diff options
Diffstat (limited to 'Assistant/XMPP')
| -rw-r--r-- | Assistant/XMPP/Buddies.hs | 87 | ||||
| -rw-r--r-- | Assistant/XMPP/Client.hs | 83 | ||||
| -rw-r--r-- | Assistant/XMPP/Git.hs | 381 |
3 files changed, 0 insertions, 551 deletions
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs deleted file mode 100644 index 77eb3202f..000000000 --- a/Assistant/XMPP/Buddies.hs +++ /dev/null @@ -1,87 +0,0 @@ -{- xmpp buddies - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.XMPP.Buddies where - -import Assistant.XMPP -import Annex.Common -import Assistant.Types.Buddies - -import Network.Protocol.XMPP -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T - -genBuddyKey :: JID -> BuddyKey -genBuddyKey j = BuddyKey $ formatJID $ baseJID j - -buddyName :: JID -> Text -buddyName j = maybe (T.pack "") strNode (jidNode j) - -ucFirst :: Text -> Text -ucFirst s = let (first, rest) = T.splitAt 1 s - in T.concat [T.toUpper first, rest] - -{- Summary of info about a buddy. - - - - If the buddy has no clients at all anymore, returns Nothing. -} -buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey) -buddySummary pairedwith b = case clients of - ((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j) - [] -> Nothing - where - away = S.null (buddyPresent b) && S.null (buddyAssistants b) - canpair = not $ S.null (buddyAssistants b) - clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b - alreadypaired j = baseJID j `elem` pairedwith - -{- Updates the buddies with XMPP presence info. -} -updateBuddies :: Presence -> Buddies -> Buddies -updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key - where - key = genBuddyKey jid - update (Just b) = Just $ applyPresence p b - update Nothing = newBuddy p -updateBuddies _ = id - -{- Creates a new buddy based on XMPP presence info. -} -newBuddy :: Presence -> Maybe Buddy -newBuddy p - | presenceType p == PresenceAvailable = go - | presenceType p == PresenceUnavailable = go - | otherwise = Nothing - where - go = make <$> presenceFrom p - make _jid = applyPresence p $ Buddy - { buddyPresent = S.empty - , buddyAway = S.empty - , buddyAssistants = S.empty - , buddyPairing = False - } - -applyPresence :: Presence -> Buddy -> Buddy -applyPresence p b = fromMaybe b $! go <$> presenceFrom p - where - go jid - | presenceType p == PresenceUnavailable = b - { buddyAway = addto $ buddyAway b - , buddyPresent = removefrom $ buddyPresent b - , buddyAssistants = removefrom $ buddyAssistants b - } - | hasGitAnnexTag p = b - { buddyAssistants = addto $ buddyAssistants b - , buddyAway = removefrom $ buddyAway b } - | presenceType p == PresenceAvailable = b - { buddyPresent = addto $ buddyPresent b - , buddyAway = removefrom $ buddyAway b - } - | otherwise = b - where - client = Client jid - removefrom = S.filter (/= client) - addto = S.insert client diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs deleted file mode 100644 index 6d09d32e6..000000000 --- a/Assistant/XMPP/Client.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- xmpp client support - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.XMPP.Client where - -import Assistant.Common -import Utility.SRV -import Creds - -import Network.Protocol.XMPP -import Network -import Control.Concurrent -import qualified Data.Text as T - -{- Everything we need to know to connect to an XMPP server. -} -data XMPPCreds = XMPPCreds - { xmppUsername :: T.Text - , xmppPassword :: T.Text - , xmppHostname :: HostName - , xmppPort :: Int - , xmppJID :: T.Text - } - deriving (Read, Show) - -connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP c a = case parseJID (xmppJID c) of - Nothing -> error "bad JID" - Just jid -> connectXMPP' jid c a - -{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} -connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord) - where - srvrecord = mkSRVTcp "xmpp-client" $ - T.unpack $ strDomain $ jidDomain jid - serverjid = JID Nothing (jidDomain jid) Nothing - - handlesrv [] = do - let h = xmppHostname c - let p = PortNumber $ fromIntegral $ xmppPort c - r <- run h p $ a jid - return [r] - handlesrv srvs = go [] srvs - - go l [] = return l - go l ((h,p):rest) = do - {- Try each SRV record in turn, until one connects, - - at which point the MVar will be full. -} - mv <- newEmptyMVar - r <- run h p $ do - liftIO $ putMVar mv () - a jid - ifM (isEmptyMVar mv) - ( go (r : l) rest - , return (r : l) - ) - - {- Async exceptions are let through so the XMPP thread can - - be killed. -} - run h p a' = do - r <- tryNonAsync $ - runClientError (Server serverjid h p) jid - (xmppUsername c) (xmppPassword c) (void a') - return ((h, p), r) - -{- XMPP runClient, that throws errors rather than returning an Either -} -runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a -runClientError s j u p x = either (error . show) return =<< runClient s j u p x - -getXMPPCreds :: Annex (Maybe XMPPCreds) -getXMPPCreds = parse <$> readCacheCreds xmppCredsFile - where - parse s = readish =<< s - -setXMPPCreds :: XMPPCreds -> Annex () -setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile - -xmppCredsFile :: FilePath -xmppCredsFile = "xmpp" diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs deleted file mode 100644 index 612e0f2c5..000000000 --- a/Assistant/XMPP/Git.hs +++ /dev/null @@ -1,381 +0,0 @@ -{- git over XMPP - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Assistant.XMPP.Git where - -import Assistant.Common -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.XMPP -import Assistant.XMPP.Buddies -import Assistant.DaemonStatus -import Assistant.Alert -import Assistant.MakeRemote -import Assistant.Sync -import qualified Command.Sync -import qualified Annex.Branch -import Annex.Path -import Annex.UUID -import Logs.UUID -import Annex.TaggedPush -import Annex.CatFile -import Config -import Git -import qualified Types.Remote as Remote -import qualified Remote as Remote -import Remote.List -import Utility.FileMode -import Utility.Shell -import Utility.Env - -import Network.Protocol.XMPP -import qualified Data.Text as T -import System.Posix.Types -import qualified System.Posix.IO -import Control.Concurrent -import System.Timeout -import qualified Data.ByteString as B -import qualified Data.Map as M - -{- Largest chunk of data to send in a single XMPP message. -} -chunkSize :: Int -chunkSize = 4096 - -{- How long to wait for an expected message before assuming the other side - - has gone away and canceling a push. - - - - This needs to be long enough to allow a message of up to 2+ times - - chunkSize to propigate up to a XMPP server, perhaps across to another - - server, and back down to us. On the other hand, other XMPP pushes can be - - delayed for running until the timeout is reached, so it should not be - - excessive. - -} -xmppTimeout :: Int -xmppTimeout = 120000000 -- 120 seconds - -finishXMPPPairing :: JID -> UUID -> Assistant () -finishXMPPPairing jid u = void $ alertWhile alert $ - makeXMPPGitRemote buddy (baseJID jid) u - where - buddy = T.unpack $ buddyName jid - alert = pairRequestAcknowledgedAlert buddy Nothing - -gitXMPPLocation :: JID -> String -gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid) - -makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool -makeXMPPGitRemote buddyname jid u = do - remote <- liftAnnex $ addRemote $ - makeGitRemote buddyname $ gitXMPPLocation jid - liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u - liftAnnex $ void remoteListRefresh - remote' <- liftAnnex $ fromMaybe (error "failed to add remote") - <$> Remote.byName (Just buddyname) - syncRemote remote' - return True - -{- Pushes over XMPP, communicating with a specific client. - - Runs an arbitrary IO action to push, which should run git-push with - - an xmpp:: url. - - - - To handle xmpp:: urls, git push will run git-remote-xmpp, which is - - injected into its PATH, and in turn runs git-annex xmppgit. The - - dataflow them becomes: - - - - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp - - | - - git receive-pack <--> xmppReceivePack <---------------> xmpp - - - - The pipe between git-annex xmppgit and us is set up and communicated - - using two environment variables, relayIn and relayOut, that are set - - to the file descriptors to use. Another, relayControl, is used to - - propigate the exit status of git receive-pack. - - - - We listen at the other end of the pipe and relay to and from XMPP. - -} -xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool -xmppPush cid gitpush = do - u <- liftAnnex getUUID - sendNetMessage $ Pushing cid (StartingPush u) - - (Fd inf, writepush) <- liftIO System.Posix.IO.createPipe - (readpush, Fd outf) <- liftIO System.Posix.IO.createPipe - (Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe - - tmpdir <- gettmpdir - installwrapper tmpdir - - environ <- liftIO getEnvironment - path <- liftIO getSearchPath - let myenviron = addEntries - [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) - , (relayIn, show inf) - , (relayOut, show outf) - , (relayControl, show controlf) - ] - environ - - inh <- liftIO $ fdToHandle readpush - outh <- liftIO $ fdToHandle writepush - controlh <- liftIO $ fdToHandle writecontrol - - t1 <- forkIO <~> toxmpp 0 inh - t2 <- forkIO <~> fromxmpp outh controlh - - {- This can take a long time to run, so avoid running it in the - - Annex monad. Also, override environment. -} - g <- liftAnnex gitRepo - r <- liftIO $ gitpush $ g { gitEnv = Just myenviron } - - liftIO $ do - mapM_ killThread [t1, t2] - mapM_ hClose [inh, outh, controlh] - mapM_ closeFd [Fd inf, Fd outf, Fd controlf] - - return r - where - toxmpp seqnum inh = do - b <- liftIO $ B.hGetSome inh chunkSize - if B.null b - then liftIO $ killThread =<< myThreadId - else do - let seqnum' = succ seqnum - sendNetMessage $ Pushing cid $ - SendPackOutput seqnum' b - toxmpp seqnum' inh - - fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg - where - handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = - liftIO $ writeChunk outh b - handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) = - liftIO $ do - hPrint controlh exitcode - hFlush controlh - handlemsg (Just _) = noop - handlemsg Nothing = do - debug ["timeout waiting for git receive-pack output via XMPP"] - -- Send a synthetic exit code to git-annex - -- xmppgit, which will exit and cause git push - -- to die. - liftIO $ do - hPrint controlh (ExitFailure 1) - hFlush controlh - killThread =<< myThreadId - - installwrapper tmpdir = liftIO $ do - createDirectoryIfMissing True tmpdir - let wrapper = tmpdir </> "git-remote-xmpp" - program <- programPath - writeFile wrapper $ unlines - [ shebang_local - , "exec " ++ program ++ " xmppgit" - ] - modifyFileMode wrapper $ addModes executeModes - - {- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp - - dir (ie, not on a crippled filesystem where we can't make - - the wrapper executable). -} - gettmpdir = do - v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR" - case v of - Nothing -> do - tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir - return $ tmp </> "xmppgit" - Just d -> return $ d </> "xmppgit" - -type EnvVar = String - -envVar :: String -> EnvVar -envVar s = "GIT_ANNEX_XMPPGIT_" ++ s - -relayIn :: EnvVar -relayIn = envVar "IN" - -relayOut :: EnvVar -relayOut = envVar "OUT" - -relayControl :: EnvVar -relayControl = envVar "CONTROL" - -relayHandle :: EnvVar -> IO Handle -relayHandle var = do - v <- getEnv var - case readish =<< v of - Nothing -> error $ var ++ " not set" - Just n -> fdToHandle $ Fd n - -{- Called by git-annex xmppgit. - - - - git-push is talking to us on stdin - - we're talking to git-push on stdout - - git-receive-pack is talking to us on relayIn (via XMPP) - - we're talking to git-receive-pack on relayOut (via XMPP) - - git-receive-pack's exit code will be passed to us on relayControl - -} -xmppGitRelay :: IO () -xmppGitRelay = do - flip relay stdout =<< relayHandle relayIn - relay stdin =<< relayHandle relayOut - code <- hGetLine =<< relayHandle relayControl - exitWith $ fromMaybe (ExitFailure 1) $ readish code - where - {- Is it possible to set up pipes and not need to copy the data - - ourselves? See splice(2) -} - relay fromh toh = void $ forkIO $ forever $ do - b <- B.hGetSome fromh chunkSize - when (B.null b) $ do - hClose fromh - hClose toh - killThread =<< myThreadId - writeChunk toh b - -{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating - - its exit status to XMPP. -} -xmppReceivePack :: ClientID -> Assistant Bool -xmppReceivePack cid = do - repodir <- liftAnnex $ fromRepo repoPath - let p = (proc "git" ["receive-pack", repodir]) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - } - (Just inh, Just outh, _, pid) <- liftIO $ createProcess p - readertid <- forkIO <~> relayfromxmpp inh - relaytoxmpp 0 outh - code <- liftIO $ waitForProcess pid - void $ sendNetMessage $ Pushing cid $ ReceivePackDone code - liftIO $ do - killThread readertid - hClose inh - hClose outh - return $ code == ExitSuccess - where - relaytoxmpp seqnum outh = do - b <- liftIO $ B.hGetSome outh chunkSize - -- empty is EOF, so exit - unless (B.null b) $ do - let seqnum' = succ seqnum - sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b - relaytoxmpp seqnum' outh - relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg - where - handlemsg (Just (Pushing _ (SendPackOutput _ b))) = - liftIO $ writeChunk inh b - handlemsg (Just _) = noop - handlemsg Nothing = do - debug ["timeout waiting for git send-pack output via XMPP"] - -- closing the handle will make git receive-pack exit - liftIO $ do - hClose inh - killThread =<< myThreadId - -xmppRemotes :: ClientID -> UUID -> Assistant [Remote] -xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of - Nothing -> return [] - Just jid -> do - let loc = gitXMPPLocation jid - um <- liftAnnex uuidMap - filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes - <$> getDaemonStatus - where - matching loc r = repoIsUrl r && repoLocation r == loc - knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um - -{- Returns the ClientID that it pushed to. -} -runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID) -runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) = - go =<< liftAnnex (join Command.Sync.getCurrBranch) - where - go (Just branch, _) = do - rs <- xmppRemotes cid theiruuid - liftAnnex $ Annex.Branch.commit "update" - (g, u) <- liftAnnex $ (,) - <$> gitRepo - <*> getUUID - liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g - selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus - if null rs - then return Nothing - else do - forM_ rs $ \r -> do - void $ alertWhile (syncAlert [r]) $ - xmppPush cid (taggedPush u selfjid branch r) - checkcloudrepos r - return $ Just cid - go _ = return Nothing -runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do - rs <- xmppRemotes cid theiruuid - if null rs - then return Nothing - else do - void $ alertWhile (syncAlert rs) $ - xmppReceivePack cid - mapM_ checkcloudrepos rs - return $ Just cid -runPush _ _ = return Nothing - -{- Check if any of the shas that can be pushed are ones we do not - - have. - - - - (Older clients send no shas, so when there are none, always - - request a push.) - -} -handlePushNotice :: NetMessage -> Assistant () -handlePushNotice (Pushing cid (CanPush theiruuid shas)) = - unlessM (null <$> xmppRemotes cid theiruuid) $ - if null shas - then go - else ifM (haveall shas) - ( debug ["ignoring CanPush with known shas"] - , go - ) - where - go = do - u <- liftAnnex getUUID - sendNetMessage $ Pushing cid (PushRequest u) - haveall l = liftAnnex $ not <$> anyM donthave l - donthave sha = isNothing <$> catObjectDetails sha -handlePushNotice _ = noop - -writeChunk :: Handle -> B.ByteString -> IO () -writeChunk h b = do - B.hPut h b - hFlush h - -{- Gets NetMessages for a PushSide, ensures they are in order, - - and runs an action to handle each in turn. The action will be passed - - Nothing on timeout. - - - - Does not currently reorder messages, but does ensure that any - - duplicate messages, or messages not in the sequence, are discarded. - -} -withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant () -withPushMessagesInSequence cid side a = loop 0 - where - loop seqnum = do - m <- timeout xmppTimeout <~> waitInbox cid side - let go s = a m >> loop s - let next = seqnum + 1 - case extractSequence =<< m of - Just seqnum' - | seqnum' == next -> go next - | seqnum' == 0 -> go seqnum - | seqnum' == seqnum -> do - debug ["ignoring duplicate sequence number", show seqnum] - loop seqnum - | otherwise -> do - debug ["ignoring out of order sequence number", show seqnum', "expected", show next] - loop seqnum - Nothing -> go seqnum - -extractSequence :: NetMessage -> Maybe Int -extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum -extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum -extractSequence _ = Nothing |