diff options
64 files changed, 38 insertions, 2827 deletions
diff --git a/Assistant.hs b/Assistant.hs index 4dab6f162c..ea9967610c 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -41,10 +41,6 @@ import Assistant.Threads.WebApp #ifdef WITH_PAIRING import Assistant.Threads.PairListener #endif -#ifdef WITH_XMPP -import Assistant.Threads.XMPPClient -import Assistant.Threads.XMPPPusher -#endif #else import Assistant.Types.UrlRenderer #endif @@ -153,11 +149,6 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = #ifdef WITH_PAIRING , assist $ pairListenerThread urlrenderer #endif -#ifdef WITH_XMPP - , assist $ xmppClientThread urlrenderer - , assist $ xmppSendPackThread urlrenderer - , assist $ xmppReceivePackThread urlrenderer -#endif #endif , assist pushThread , assist pushRetryThread diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 6e11b923e4..ce5f01e278 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -12,7 +12,6 @@ module Assistant.DaemonStatus where import Assistant.Common import Assistant.Alert.Utility import Utility.Tmp -import Assistant.Types.NetMessager import Utility.NotificationBroadcaster import Types.Transfer import Logs.Transfer @@ -20,14 +19,12 @@ import Logs.Trust import Logs.TimeStamp import qualified Remote import qualified Types.Remote as Remote -import qualified Git import Control.Concurrent.STM import System.Posix.Types import Data.Time.Clock.POSIX import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.Text as T getDaemonStatus :: Assistant DaemonStatus getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle @@ -264,6 +261,3 @@ alertDuring :: Alert -> Assistant a -> Assistant a alertDuring alert a = do i <- addAlert $ alert { alertClass = Activity } removeAlert i `after` a - -getXMPPClientID :: Remote -> ClientID -getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r)) diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 5662209c94..e529839155 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -40,8 +40,6 @@ import Assistant.Types.BranchChange import Assistant.Types.Commits import Assistant.Types.Changes import Assistant.Types.RepoProblem -import Assistant.Types.Buddies -import Assistant.Types.NetMessager import Assistant.Types.ThreadName import Assistant.Types.RemoteControl import Assistant.Types.CredPairCache @@ -68,8 +66,6 @@ data AssistantData = AssistantData , changePool :: ChangePool , repoProblemChan :: RepoProblemChan , branchChangeHandle :: BranchChangeHandle - , buddyList :: BuddyList - , netMessager :: NetMessager , remoteControl :: RemoteControl , credPairCache :: CredPairCache } @@ -88,8 +84,6 @@ newAssistantData st dstatus = AssistantData <*> newChangePool <*> newRepoProblemChan <*> newBranchChangeHandle - <*> newBuddyList - <*> newNetMessager <*> newRemoteControl <*> newCredPairCache diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs deleted file mode 100644 index dd18111415..0000000000 --- a/Assistant/NetMessager.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- git-annex assistant out of band network messager interface - - - - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE BangPatterns #-} - -module Assistant.NetMessager where - -import Assistant.Common -import Assistant.Types.NetMessager - -import Control.Concurrent.STM -import Control.Concurrent.MSampleVar -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.DList as D - -sendNetMessage :: NetMessage -> Assistant () -sendNetMessage m = - (atomically . flip writeTChan m) <<~ (netMessages . netMessager) - -waitNetMessage :: Assistant (NetMessage) -waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager) - -notifyNetMessagerRestart :: Assistant () -notifyNetMessagerRestart = - flip writeSV () <<~ (netMessagerRestart . netMessager) - -{- This can be used to get an early indication if the network has - - changed, to immediately restart a connection. However, that is not - - available on all systems, so clients also need to deal with - - restarting dropped connections in the usual way. -} -waitNetMessagerRestart :: Assistant () -waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager) - -{- Store a new important NetMessage for a client, and if an equivilant - - older message is already stored, remove it from both importantNetMessages - - and sentImportantNetMessages. -} -storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant () -storeImportantNetMessage m client matchingclient = go <<~ netMessager - where - go nm = atomically $ do - q <- takeTMVar $ importantNetMessages nm - sent <- takeTMVar $ sentImportantNetMessages nm - putTMVar (importantNetMessages nm) $ - M.alter (Just . maybe (S.singleton m) (S.insert m)) client $ - M.mapWithKey removematching q - putTMVar (sentImportantNetMessages nm) $ - M.mapWithKey removematching sent - removematching someclient s - | matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s - | otherwise = s - -{- Indicates that an important NetMessage has been sent to a client. -} -sentImportantNetMessage :: NetMessage -> ClientID -> Assistant () -sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager) - where - go v = atomically $ do - sent <- takeTMVar v - putTMVar v $ - M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent - -{- Checks for important NetMessages that have been stored for a client, and - - sent to a client. Typically the same client for both, although - - a modified or more specific client may need to be used. -} -checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage) -checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager - where - go nm = atomically $ do - stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm) - sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm) - return (fromMaybe S.empty stored, fromMaybe S.empty sent) - -{- Queues a push initiation message in the queue for the appropriate - - side of the push but only if there is not already an initiation message - - from the same client in the queue. -} -queuePushInitiation :: NetMessage -> Assistant () -queuePushInitiation msg@(Pushing clientid stage) = do - tv <- getPushInitiationQueue side - liftIO $ atomically $ do - r <- tryTakeTMVar tv - case r of - Nothing -> putTMVar tv [msg] - Just l -> do - let !l' = msg : filter differentclient l - putTMVar tv l' - where - side = pushDestinationSide stage - differentclient (Pushing cid _) = cid /= clientid - differentclient _ = True -queuePushInitiation _ = noop - -{- Waits for a push inititation message to be received, and runs - - function to select a message from the queue. -} -waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage -waitPushInitiation side selector = do - tv <- getPushInitiationQueue side - liftIO $ atomically $ do - q <- takeTMVar tv - if null q - then retry - else do - let (msg, !q') = selector q - unless (null q') $ - putTMVar tv q' - return msg - -{- Stores messages for a push into the appropriate inbox. - - - - To avoid overflow, only 1000 messages max are stored in any - - inbox, which should be far more than necessary. - - - - TODO: If we have more than 100 inboxes for different clients, - - discard old ones that are not currently being used by any push. - -} -storeInbox :: NetMessage -> Assistant () -storeInbox msg@(Pushing clientid stage) = do - inboxes <- getInboxes side - stored <- liftIO $ atomically $ do - m <- readTVar inboxes - let update = \v -> do - writeTVar inboxes $ - M.insertWith' const clientid v m - return True - case M.lookup clientid m of - Nothing -> update (1, tostore) - Just (sz, l) - | sz > 1000 -> return False - | otherwise -> - let !sz' = sz + 1 - !l' = D.append l tostore - in update (sz', l') - if stored - then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"] - else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"] - where - side = pushDestinationSide stage - tostore = D.singleton msg -storeInbox _ = noop - -{- Gets the new message for a push from its inbox. - - Blocks until a message has been received. -} -waitInbox :: ClientID -> PushSide -> Assistant (NetMessage) -waitInbox clientid side = do - inboxes <- getInboxes side - liftIO $ atomically $ do - m <- readTVar inboxes - case M.lookup clientid m of - Nothing -> retry - Just (sz, dl) - | sz < 1 -> retry - | otherwise -> do - let msg = D.head dl - let dl' = D.tail dl - let !sz' = sz - 1 - writeTVar inboxes $ - M.insertWith' const clientid (sz', dl') m - return msg - -emptyInbox :: ClientID -> PushSide -> Assistant () -emptyInbox clientid side = do - inboxes <- getInboxes side - liftIO $ atomically $ - modifyTVar' inboxes $ - M.delete clientid - -getInboxes :: PushSide -> Assistant Inboxes -getInboxes side = - getSide side . netMessagerInboxes <$> getAssistant netMessager - -getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage]) -getPushInitiationQueue side = - getSide side . netMessagerPushInitiations <$> getAssistant netMessager - -netMessagerDebug :: ClientID -> [String] -> Assistant () -netMessagerDebug clientid l = debug $ - "NetMessager" : l ++ [show $ logClientID clientid] diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 9b9e7ebe5e..e46910ccd7 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -9,8 +9,6 @@ module Assistant.Sync where import Assistant.Common import Assistant.Pushes -import Assistant.NetMessager -import Assistant.Types.NetMessager import Assistant.Alert import Assistant.Alert.Utility import Assistant.DaemonStatus @@ -20,7 +18,6 @@ import qualified Command.Sync import Utility.Parallel import qualified Git import qualified Git.Command -import qualified Git.Ref import qualified Git.Merge import qualified Remote import qualified Types.Remote as Remote @@ -40,7 +37,6 @@ import Types.Transfer import Data.Time.Clock import qualified Data.Map as M -import qualified Data.Set as S import Control.Concurrent {- Syncs with remotes that may have been disconnected for a while. @@ -51,21 +47,14 @@ import Control.Concurrent - the remotes have diverged from the local git-annex branch. Otherwise, - it's sufficient to requeue failed transfers. - - - XMPP remotes are also signaled that we can push to them, and we request - - they push to us. Since XMPP pushes run ansynchronously, any scan of the - - XMPP remotes has to be deferred until they're done pushing to us, so - - all XMPP remotes are marked as possibly desynced. - - - Also handles signaling any connectRemoteNotifiers, after the syncing is - done. -} -reconnectRemotes :: Bool -> [Remote] -> Assistant () -reconnectRemotes _ [] = noop -reconnectRemotes notifypushes rs = void $ do +reconnectRemotes :: [Remote] -> Assistant () +reconnectRemotes [] = noop +reconnectRemotes rs = void $ do rs' <- liftIO $ filterM (Remote.checkAvailable True) rs unless (null rs') $ do - modifyDaemonStatus_ $ \s -> s - { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } failedrs <- syncAction rs' (const go) forM_ failedrs $ \r -> whenM (liftIO $ Remote.checkAvailable False r) $ @@ -73,7 +62,7 @@ reconnectRemotes notifypushes rs = void $ do mapM_ signal $ filter (`notElem` failedrs) rs' where gitremotes = filter (notspecialremote . Remote.repo) rs - (xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs + (_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs notspecialremote r | Git.repoIsUrl r = True | Git.repoIsLocal r = True @@ -82,7 +71,7 @@ reconnectRemotes notifypushes rs = void $ do sync currentbranch@(Just _, _) = do (failedpull, diverged) <- manualPull currentbranch gitremotes now <- liftIO getCurrentTime - failedpush <- pushToRemotes' now notifypushes gitremotes + failedpush <- pushToRemotes' now gitremotes return (nub $ failedpull ++ failedpush, diverged) {- No local branch exists yet, but we can try pulling. -} sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes @@ -102,9 +91,6 @@ reconnectRemotes notifypushes rs = void $ do - as "git annex sync", except in parallel, and will co-exist with use of - "git annex sync". - - - After the pushes to normal git remotes, also signals XMPP clients that - - they can request an XMPP push. - - - Avoids running possibly long-duration commands in the Annex monad, so - as not to block other threads. - @@ -122,27 +108,21 @@ reconnectRemotes notifypushes rs = void $ do - - Returns any remotes that it failed to push to. -} -pushToRemotes :: Bool -> [Remote] -> Assistant [Remote] -pushToRemotes notifypushes remotes = do +pushToRemotes :: [Remote] -> Assistant [Remote] +pushToRemotes remotes = do now <- liftIO getCurrentTime let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes - syncAction remotes' (pushToRemotes' now notifypushes) -pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote] -pushToRemotes' now notifypushes remotes = do + syncAction remotes' (pushToRemotes' now) +pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote] +pushToRemotes' now remotes = do (g, branch, u) <- liftAnnex $ do Annex.Branch.commit "update" (,,) <$> gitRepo <*> join Command.Sync.getCurrBranch <*> getUUID - let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes + let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes ret <- go True branch g u normalremotes - unless (null xmppremotes) $ do - shas <- liftAnnex $ map fst <$> - inRepo (Git.Ref.matchingWithHEAD - [Annex.Branch.fullname, Git.Ref.headRef]) - forM_ xmppremotes $ \r -> sendNetMessage $ - Pushing (getXMPPClientID r) (CanPush u shas) return ret where go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do @@ -152,11 +132,7 @@ pushToRemotes' now notifypushes remotes = do (succeeded, failed) <- parallelPush g rs (push branch) updatemap succeeded [] if null failed - then do - when notifypushes $ - sendNetMessage $ NotifyPush $ - map Remote.uuid succeeded - return failed + then return [] else if shouldretry then retry currbranch g u failed else fallback branch g u failed @@ -175,9 +151,6 @@ pushToRemotes' now notifypushes remotes = do debug ["fallback pushing to", show rs] (succeeded, failed) <- parallelPush g rs (taggedPush u Nothing branch) updatemap succeeded failed - when (notifypushes && (not $ null succeeded)) $ - sendNetMessage $ NotifyPush $ - map Remote.uuid succeeded return failed push branch remote = Command.Sync.pushBranch remote branch @@ -195,10 +168,6 @@ parallelPush g rs a = do {- Displays an alert while running an action that syncs with some remotes, - and returns any remotes that it failed to sync with. - - - XMPP remotes are handled specially; since the action can only start - - an async process for them, they are not included in the alert, but are - - still passed to the action. - - - Readonly remotes are also hidden (to hide the web special remote). -} syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote] @@ -222,15 +191,11 @@ syncAction rs a - remotes that it failed to pull from, and a Bool indicating - whether the git-annex branches of the remotes and local had - diverged before the pull. - - - - After pulling from the normal git remotes, requests pushes from any - - XMPP remotes. However, those pushes will run asynchronously, so their - - results are not included in the return data. -} manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool) manualPull currentbranch remotes = do g <- liftAnnex gitRepo - let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes + let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes failed <- forM normalremotes $ \r -> do g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g') @@ -240,9 +205,6 @@ manualPull currentbranch remotes = do haddiverged <- liftAnnex Annex.Branch.forceUpdate forM_ normalremotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch mergeConfig - u <- liftAnnex getUUID - forM_ xmppremotes $ \r -> - sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u) return (catMaybes failed, haddiverged) mergeConfig :: [Git.Merge.MergeConfig] @@ -257,7 +219,7 @@ syncRemote :: Remote -> Assistant () syncRemote remote = do updateSyncRemotes thread <- asIO $ do - reconnectRemotes False [remote] + reconnectRemotes [remote] addScanRemotes True [remote] void $ liftIO $ forkIO $ thread diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 521e5bda6b..c38c2f3755 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -10,8 +10,6 @@ module Assistant.Threads.Merger where import Assistant.Common import Assistant.TransferQueue import Assistant.BranchChange -import Assistant.DaemonStatus -import Assistant.ScanRemotes import Assistant.Sync import Utility.DirWatcher import Utility.DirWatcher.Types @@ -19,11 +17,6 @@ import qualified Annex.Branch import qualified Git import qualified Git.Branch import qualified Command.Sync -import Annex.TaggedPush -import Remote (remoteFromUUID) - -import qualified Data.Set as S -import qualified Data.Text as T {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} @@ -70,8 +63,7 @@ onChange file branchChanged diverged <- liftAnnex Annex.Branch.forceUpdate when diverged $ - unlessM handleDesynced $ - queueDeferredDownloads "retrying deferred download" Later + queueDeferredDownloads "retrying deferred download" Later | "/synced/" `isInfixOf` file = mergecurrent =<< liftAnnex (join Command.Sync.getCurrBranch) | otherwise = noop @@ -91,22 +83,6 @@ onChange file changedbranch mergecurrent _ = noop - handleDesynced = case fromTaggedBranch changedbranch of - Nothing -> return False - Just (u, info) -> do - mr <- liftAnnex $ remoteFromUUID u - case mr of - Nothing -> return False - Just r -> do - s <- desynced <$> getDaemonStatus - if S.member u s || Just (T.unpack $ getXMPPClientID r) == info - then do - modifyDaemonStatus_ $ \st -> st - { desynced = S.delete u s } - addScanRemotes True [r] - return True - else return False - equivBranches :: Git.Ref -> Git.Ref -> Bool equivBranches x y = base x == base y where diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index a741b731dc..bd8d0e6149 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -146,7 +146,7 @@ handleMount urlrenderer dir = do debug ["detected mount of", dir] rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir mapM_ (fsckNudge urlrenderer . Just) rs - reconnectRemotes True rs + reconnectRemotes rs {- Finds remotes located underneath the mount point. - diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 52f8db4741..4dc8721b1e 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -22,7 +22,6 @@ import Assistant.RemoteControl import Utility.DBus import DBus.Client import DBus -import Assistant.NetMessager #else #ifdef linux_HOST_OS #warning Building without dbus support; will poll for network connection changes @@ -44,9 +43,8 @@ netWatcherThread = thread noop - while (despite the local network staying up), are synced with - periodically. - - - Note that it does not call notifyNetMessagerRestart, or - - signal the RemoteControl, because it doesn't know that the - - network has changed. + - Note that it does not signal the RemoteControl, because it doesn't + - know that the network has changed. -} netWatcherFallbackThread :: NamedThread netWatcherFallbackThread = namedThread "NetWatcherFallback" $ @@ -76,7 +74,6 @@ dbusThread = do sendRemoteControl LOSTNET connchange True = do debug ["detected network connection"] - notifyNetMessagerRestart handleConnection sendRemoteControl RESUME onerr e _ = do @@ -197,7 +194,7 @@ listenWicdConnections client setconnected = do handleConnection :: Assistant () handleConnection = do liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus - reconnectRemotes True =<< networkRemotes + reconnectRemotes =<< networkRemotes {- Network remotes to sync with. -} networkRemotes :: Assistant [Remote] diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 35989ed48a..5b4055885f 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -24,7 +24,7 @@ pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do topush <- getFailedPushesBefore (fromIntegral halfhour) unless (null topush) $ do debug ["retrying", show (length topush), "failed pushes"] - void $ pushToRemotes True topush + void $ pushToRemotes topush where halfhour = 1800 @@ -35,7 +35,7 @@ pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do -- Next, wait until at least one commit has been made void getCommits -- Now see if now's a good time to push. - void $ pushToRemotes True =<< pushTargets + void $ pushToRemotes =<< pushTargets {- We want to avoid pushing to remotes that are marked readonly. - diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 10aed20b04..a55a3496e5 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -76,7 +76,7 @@ transferScannerThread urlrenderer = namedThread "TransferScanner" $ do - to determine if the remote has been emptied. -} startupScan = do - reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus + reconnectRemotes =<< syncGitRemotes <$> getDaemonStatus addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus {- This is a cheap scan for failed transfers involving a remote. -} diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 58effdc1c0..5cc6895955 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -26,7 +26,6 @@ import Assistant.WebApp.Configurators.Pairing import Assistant.WebApp.Configurators.AWS import Assistant.WebApp.Configurators.IA import Assistant.WebApp.Configurators.WebDAV -import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Configurators.Preferences import Assistant.WebApp.Configurators.Unused import Assistant.WebApp.Configurators.Edit diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs deleted file mode 100644 index 2b68ecbe11..0000000000 --- a/Assistant/Threads/XMPPClient.hs +++ /dev/null @@ -1,375 +0,0 @@ -{- git-annex XMPP client - - - - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Threads.XMPPClient where - -import Assistant.Common hiding (ProtocolError) -import Assistant.XMPP -import Assistant.XMPP.Client -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.Types.Buddies -import Assistant.XMPP.Buddies -import Assistant.Sync -import Assistant.DaemonStatus -import qualified Remote -import Utility.ThreadScheduler -import Assistant.WebApp (UrlRenderer) -import Assistant.WebApp.Types hiding (liftAssistant) -import Assistant.Alert -import Assistant.Pairing -import Assistant.XMPP.Git -import Annex.UUID -import Logs.UUID -import qualified Command.Sync - -import Network.Protocol.XMPP -import Control.Concurrent -import Control.Concurrent.STM.TMVar -import Control.Concurrent.STM (atomically) -import qualified Data.Text as T -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Time.Clock -import Control.Concurrent.Async - -xmppClientThread :: UrlRenderer -> NamedThread -xmppClientThread urlrenderer = namedThread "XMPPClient" $ - restartableClient . xmppClient urlrenderer =<< getAssistant id - -{- Runs the client, handing restart events. -} -restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant () -restartableClient a = forever $ go =<< liftAnnex getXMPPCreds - where - go Nothing = waitNetMessagerRestart - go (Just creds) = do - xmppuuid <- maybe NoUUID Remote.uuid . headMaybe - . filter Remote.isXMPPRemote . syncRemotes - <$> getDaemonStatus - tid <- liftIO $ forkIO $ a creds xmppuuid - waitNetMessagerRestart - liftIO $ killThread tid - -xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO () -xmppClient urlrenderer d creds xmppuuid = - retry (runclient creds) =<< getCurrentTime - where - liftAssistant = runAssistant d - inAssistant = liftIO . liftAssistant - - {- When the client exits, it's restarted; - - if it keeps failing, back off to wait 5 minutes before - - trying it again. -} - retry client starttime = do - {- The buddy list starts empty each time - - the client connects, so that stale info - - is not retained. -} - liftAssistant $ - updateBuddyList (const noBuddies) <<~ buddyList - void client - liftAssistant $ do - modifyDaemonStatus_ $ \s -> s - { xmppClientID = Nothing } - changeCurrentlyConnected $ S.delete xmppuuid - - now <- getCurrentTime - if diffUTCTime now starttime > 300 - then do - liftAssistant $ debug ["connection lost; reconnecting"] - retry client now - else do - liftAssistant $ debug ["connection failed; will retry"] - threadDelaySeconds (Seconds 300) - retry client =<< getCurrentTime - - runclient c = liftIO $ connectXMPP c $ \jid -> do - selfjid <- bindJID jid - putStanza gitAnnexSignature - - inAssistant $ do - modifyDaemonStatus_ $ \s -> s - { xmppClientID = Just $ xmppJID creds } - changeCurrentlyConnected $ S.insert xmppuuid - debug ["connected", logJid selfjid] - - lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime - - sender <- xmppSession $ sendnotifications selfjid - receiver <- xmppSession $ receivenotifications selfjid lasttraffic - pinger <- xmppSession $ sendpings selfjid lasttraffic - {- Run all 3 threads concurrently, until - - any of them throw an exception. - - Then kill all 3 threads, and rethrow the - - exception. - - - - If this thread gets an exception, the 3 threads - - will also be killed. -} - liftIO $ pinger `concurrently` sender `concurrently` receiver - - sendnotifications selfjid = forever $ - join $ inAssistant $ relayNetMessage selfjid - receivenotifications selfjid lasttraffic = forever $ do - l <- decodeStanza selfjid <$> getStanza - void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime - inAssistant $ debug - ["received:", show $ map logXMPPEvent l] - mapM_ (handlemsg selfjid) l - sendpings selfjid lasttraffic = forever $ do - putStanza pingstanza - - startping <- liftIO getCurrentTime - liftIO $ threadDelaySeconds (Seconds 120) - t <- liftIO $ atomically $ readTMVar lasttraffic - when (t < startping) $ do - inAssistant $ debug ["ping timeout"] - error "ping timeout" - where - {- XEP-0199 says that the server will respond with either - - a ping response or an error message. Either will - - cause traffic, so good enough. -} - pingstanza = xmppPing selfjid - - handlemsg selfjid (PresenceMessage p) = do - void $ inAssistant $ - updateBuddyList (updateBuddies p) <<~ buddyList - resendImportantMessages selfjid p - handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature - handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us - handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) = - maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) - handlemsg _ (GotNetMessage m@(Pushing _ pushstage)) - | isPushNotice pushstage = inAssistant $ handlePushNotice m - | isPushInitiation pushstage = inAssistant $ queuePushInitiation m - | otherwise = inAssistant $ storeInbox m - handlemsg _ (Ignorable _) = noop - handlemsg _ (Unknown _) = noop - handlemsg _ (ProtocolError _) = noop - - resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do - let c = formatJID jid - (stored, sent) <- inAssistant $ - checkImportantNetMessages (formatJID (baseJID jid), c) - forM_ (S.toList $ S.difference stored sent) $ \msg -> do - let msg' = readdressNetMessage msg c - inAssistant $ debug - [ "sending to new client:" - , logJid jid - , show $ logNetMessage msg' - ] - join $ inAssistant $ convertNetMsg msg' selfjid - inAssistant $ sentImportantNetMessage msg c - resendImportantMessages _ _ = noop - -data XMPPEvent - = GotNetMessage NetMessage - | PresenceMessage Presence - | Ignorable ReceivedStanza - | Unknown ReceivedStanza - | ProtocolError ReceivedStanza - deriving Show - -logXMPPEvent :: XMPPEvent -> String -logXMPPEvent (GotNetMessage m) = logNetMessage m -logXMPPEvent (PresenceMessage p) = logPresence p -logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p -logXMPPEvent (Ignorable _) = "Ignorable message" -logXMPPEvent (Unknown _) = "Unknown message" -logXMPPEvent (ProtocolError _) = "Protocol error message" - -logPresence :: Presence -> String -logPresence (p@Presence { presenceFrom = Just jid }) = unwords - [ "Presence from" - , logJid jid - , show $ extractGitAnnexTag p - ] -logPresence _ = "Presence from unknown" - -logJid :: JID -> String -logJid jid = - let name = T.unpack (buddyName jid) - resource = maybe "" (T.unpack . strResource) (jidResource jid) - in take 1 name ++ show (length name) ++ "/" ++ resource - -logClient :: Client -> String -logClient (Client jid) = logJid jid - -{- Decodes an XMPP stanza into one or more events. -} -decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] -decodeStanza selfjid s@(ReceivedPresence p) - | presenceType p == PresenceError = [ProtocolError s] - | isNothing (presenceFrom p) = [Ignorable s] - | presenceFrom p == Just selfjid = [Ignorable s] - | otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p) - where - decode i - | tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ - decodePushNotification (tagValue i) - | tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence - | otherwise = [Unknown s] - {- Things sent via presence imply a presence message, - - along with their real meaning. -} - impliedp v = [PresenceMessage p, v] -decodeStanza selfjid s@(ReceivedMessage m) - | isNothing (messageFrom m) = [Ignorable s] - | messageFrom m == Just selfjid = [Ignorable s] - | messageType m == MessageError = [ProtocolError s] - | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)] -decodeStanza _ s = [Unknown s] - -{- Waits for a NetMessager message to be sent, and relays it to XMPP. - - - - Chat messages must be directed to specific clients, not a base - - account JID, due to git-annex clients using a negative presence priority. - - PairingNotification messages are always directed at specific - - clients, but Pushing messages are sometimes not, and need to be exploded - - out to specific clients. - - - - Important messages, not directed at any specific client, - - are cached to be sent later when additional clients connect. - -} -relayNetMessage :: JID -> Assistant (XMPP ()) -relayNetMessage selfjid = do - msg <- waitNetMessage - debug ["sending:", logNetMessage msg] - a1 <- handleImportant msg - a2 <- convert msg - return (a1 >> a2) - where - handleImportant msg = case parseJID =<< isImportantNetMessage msg of - Just tojid - | tojid == baseJID tojid -> do - storeImportantNetMessage msg (formatJID tojid) $ - \c -> (baseJID <$> parseJID c) == Just tojid - return $ putStanza presenceQuery - _ -> return noop - convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> - if tojid == baseJID tojid - then do - clients <- maybe [] (S.toList . buddyAssistants) - <$> getBuddy (genBuddyKey tojid) <<~ buddyList - debug ["exploded undirected message to clients", unwords $ map logClient clients] - return $ forM_ clients $ \(Client jid) -> - putStanza $ pushMessage pushstage jid selfjid - else do - debug ["to client:", logJid tojid] - return $ putStanza $ pushMessage pushstage tojid selfjid - convert msg = convertNetMsg msg selfjid - -{- Converts a NetMessage to an XMPP action. -} -convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ()) -convertNetMsg msg selfjid = convert msg - where - convert (NotifyPush us) = return $ putStanza $ pushNotification us - convert QueryPresence = return $ putStanza presenceQuery - convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do - changeBuddyPairing tojid True - return $ putStanza $ pairingNotification stage u tojid selfjid - convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> - return $ putStanza $ pushMessage pushstage tojid selfjid - -withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ()) -withOtherClient selfjid c a = case parseJID c of - Nothing -> return noop - Just tojid - | tojid == selfjid -> return noop - | otherwise -> a tojid - -withClient :: ClientID -> (JID -> XMPP ()) -> XMPP () -withClient c a = maybe noop a $ parseJID c - -{- Returns an IO action that runs a XMPP action in a separate thread, - - using a session to allow it to access the same XMPP client. -} -xmppSession :: XMPP () -> XMPP (IO ()) -xmppSession a = do - s <- getSession - return $ void $ runXMPP s a - -{- We only pull from one remote out of the set listed in the push - - notification, as an optimisation. - - - - Note that it might be possible (though very unlikely) for the push - - notification to take a while to be sent, and multiple pushes happen - - before it is sent, so it includes multiple remotes that were pushed - - to at different times. - - - - It could then be the case that the remote we choose had the earlier - - push sent to it, but then failed to get the later push, and so is not - - fully up-to-date. If that happens, the pushRetryThread will come along - - and retry the push, and we'll get another notification once it succeeds, - - and pull again. -} -pull :: [UUID] -> Assistant () -pull [] = noop -pull us = do - rs <- filter matching . syncGitRemotes <$> getDaemonStatus - debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs - pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch) - where - matching r = Remote.uuid r `S.member` s - s = S.fromList us - - pullone [] _ = noop - pullone (r:rs) branch = - unlessM (null . fst <$> manualPull branch [r]) $ - pullone rs branch - -{- PairReq from another client using our JID is automatically - - accepted. This is so pairing devices all using the same XMPP - - account works without confirmations. - - - - Also, autoaccept PairReq from the same JID of any repo we've - - already paired with, as long as the UUID in the PairReq is - - one we know about. --} -pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () -pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid - | baseJID selfjid == baseJID theirjid = autoaccept - | otherwise = do - knownjids <- mapMaybe (parseJID . getXMPPClientID) - . filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus - um <- liftAnnex uuidMap - if elem (baseJID theirjid) knownjids && M.member theiruuid um - then autoaccept - else showalert - - where - autoaccept = do - selfuuid <- liftAnnex getUUID - sendNetMessage $ - PairingNotification PairAck (formatJID theirjid) selfuuid - finishXMPPPairing theirjid theiruuid - -- Show an alert to let the user decide if they want to pair. - showalert = do - button <- mkAlertButton True (T.pack "Respond") urlrenderer $ - ConfirmXMPPPairFriendR $ - PairKey theiruuid $ formatJID theirjid - void $ addAlert $ pairRequestReceivedAlert - (T.unpack $ buddyName theirjid) - button - -{- PairAck must come from one of the buddies we are pairing with; - - don't pair with just anyone. -} -pairMsgReceived _ PairAck theiruuid _selfjid theirjid = - whenM (isBuddyPairing theirjid) $ do - changeBuddyPairing theirjid False - selfuuid <- liftAnnex getUUID - sendNetMessage $ - PairingNotification PairDone (formatJID theirjid) selfuuid - finishXMPPPairing theirjid theiruuid - -pairMsgReceived _ PairDone _theiruuid _selfjid theirjid = - changeBuddyPairing theirjid False - -isBuddyPairing :: JID -> Assistant Bool -isBuddyPairing jid = maybe False buddyPairing <$> - getBuddy (genBuddyKey jid) <<~ buddyList - -changeBuddyPairing :: JID -> Bool -> Assistant () -changeBuddyPairing jid ispairing = - updateBuddyList (M.adjust set key) <<~ buddyList - where - key = genBuddyKey jid - set b = b { buddyPairing = ispairing } diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs deleted file mode 100644 index bff17356d7..0000000000 --- a/Assistant/Threads/XMPPPusher.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- git-annex XMPP pusher threads - - - - This is a pair of threads. One handles git send-pack, - - and the other git receive-pack. Each thread can be running at most - - one such operation at a time. - - - - Why not use a single thread? Consider two clients A and B. - - If both decide to run a receive-pack at the same time to the other, - - they would deadlock with only one thread. For larger numbers of - - clients, the two threads are also sufficient. - - - - Copyright 2013 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Threads.XMPPPusher where - -import Assistant.Common -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.WebApp (UrlRenderer) -import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) -import Assistant.XMPP.Git - -import Control.Exception as E - -xmppSendPackThread :: UrlRenderer -> NamedThread -xmppSendPackThread = pusherThread "XMPPSendPack" SendPack - -xmppReceivePackThread :: UrlRenderer -> NamedThread -xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack - -pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread -pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing - where - go lastpushedto = do - msg <- waitPushInitiation side $ selectNextPush lastpushedto - debug ["started running push", logNetMessage msg] - - runpush <- asIO $ runPush checker msg - r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID))) - let successful = case r of - Right (Just _) -> True - _ -> False - - {- Empty the inbox, because stuff may have - - been left in it if the push failed. -} - let justpushedto = getclient msg - maybe noop (`emptyInbox` side) justpushedto - - debug ["finished running push", logNetMessage msg, show successful] - go $ if successful then justpushedto else lastpushedto - - checker = checkCloudRepos urlrenderer - - getclient (Pushing cid _) = Just cid - getclient _ = Nothing - -{- Select the next push to run from the queue. - - The queue cannot be empty! - - - - We prefer to select the most recently added push, because its requestor - - is more likely to still be connected. - - - - When passed the ID of a client we just pushed to, we prefer to not - - immediately push again to that same client. This avoids one client - - drowing out others. So pushes from the client we just pushed to are - - relocated to the beginning of the list, to be processed later. - -} -selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage]) -selectNextPush _ (m:[]) = (m, []) -- common case -selectNextPush _ [] = error "selectNextPush: empty list" -selectNextPush lastpushedto l = go [] l - where - go (r:ejected) [] = (r, ejected) - go rejected (m:ms) = case m of - (Pushing clientid _) - | Just clientid /= lastpushedto -> (m, rejected ++ ms) - _ -> go (m:rejected) ms - go [] [] = error "empty push queue" - diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs deleted file mode 100644 index 432440d2e6..0000000000 --- a/Assistant/Types/Buddies.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- git-annex assistant buddies - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Assistant.Types.Buddies where - -import Annex.Common - -import qualified Data.Map as M -import Control.Concurrent.STM -import Utility.NotificationBroadcaster -import Data.Text as T - -{- For simplicity, dummy types are defined even when XMPP is disabled. -} -#ifdef WITH_XMPP -import Network.Protocol.XMPP -import Data.Set as S -import Data.Ord - -newtype Client = Client JID - deriving (Eq, Show) - -instance Ord Client where - compare = comparing show - -data Buddy = Buddy - { buddyPresent :: S.Set Client - , buddyAway :: S.Set Client - , buddyAssistants :: S.Set Client - , buddyPairing :: Bool - } -#else -data Buddy = Buddy -#endif - deriving (Eq, Show) - -data BuddyKey = BuddyKey T.Text - deriving (Eq, Ord, Show, Read) - -data PairKey = PairKey UUID T.Text - deriving (Eq, Ord, Show, Read) - -type Buddies = M.Map BuddyKey Buddy - -{- A list of buddies, and a way to notify when it changes. -} -type BuddyList = (TMVar Buddies, NotificationBroadcaster) - -noBuddies :: Buddies -noBuddies = M.empty - -newBuddyList :: IO BuddyList -newBuddyList = (,) - <$> atomically (newTMVar noBuddies) - <*> newNotificationBroadcaster - -getBuddyList :: BuddyList -> IO [Buddy] -getBuddyList (v, _) = M.elems <$> atomically (readTMVar v) - -getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy) -getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v) - -getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster -getBuddyBroadcaster (_, h) = h - -{- Applies a function to modify the buddy list, and if it's changed, - - sends notifications to any listeners. -} -updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO () -updateBuddyList a (v, caster) = do - changed <- atomically $ do - buds <- takeTMVar v - let buds' = a buds - putTMVar v buds' - return $ buds /= buds' - when changed $ - sendNotification caster diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 0e52d3477c..08e98d98e1 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -12,7 +12,6 @@ import Assistant.Pairing import Utility.NotificationBroadcaster import Types.Transfer import Assistant.Types.ThreadName -import Assistant.Types.NetMessager import Assistant.Types.Alert import Utility.Url @@ -54,8 +53,6 @@ data DaemonStatus = DaemonStatus , syncingToCloudRemote :: Bool -- Set of uuids of remotes that are currently connected. , currentlyConnectedRemotes :: S.Set UUID - -- List of uuids of remotes that we may have gotten out of sync with. - , desynced :: S.Set UUID -- Pairing request that is in progress. , pairingInProgress :: Maybe PairingInProgress -- Broadcasts notifications about all changes to the DaemonStatus. @@ -77,9 +74,6 @@ data DaemonStatus = DaemonStatus , globalRedirUrl :: Maybe URLString -- Actions to run after a Key is transferred. , transferHook :: M.Map Key (Transfer -> IO ()) - -- When the XMPP client is connected, this will contain the XMPP - -- address. - , xmppClientID :: Maybe ClientID -- MVars to signal when a remote gets connected. , connectRemoteNotifiers :: M.Map UUID [MVar ()] } @@ -105,7 +99,6 @@ newDaemonStatus = DaemonStatus <*> pure [] <*> pure False <*> pure S.empty - <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster @@ -117,5 +110,4 @@ newDaemonStatus = DaemonStatus <*> newNotificationBroadcaster <*> pure Nothing <*> pure M.empty - <*> pure Nothing <*> pure M.empty diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs deleted file mode 100644 index da6682233b..0000000000 --- a/Assistant/Types/NetMessager.hs +++ /dev/null @@ -1,155 +0,0 @@ -{- git-annex assistant out of band network messager types - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Types.NetMessager where - -import Annex.Common -import Assistant.Pairing -import Git.Types - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.DList as D -import Control.Concurrent.STM -import Control.Concurrent.MSampleVar -import Data.ByteString (ByteString) -import Data.Text (Text) - -{- Messages that can be sent out of band by a network messager. -} -data NetMessage - -- indicate that pushes have been made to the repos with these uuids - = NotifyPush [UUID] - -- requests other clients to inform us of their presence - | QueryPresence - -- notification about a stage in the pairing process, - -- involving a client, and a UUID. - | PairingNotification PairStage ClientID UUID - -- used for git push over the network messager - | Pushing ClientID PushStage - deriving (Eq, Ord, Show) - -{- Something used to identify the client, or clients to send the message to. -} -type ClientID = Text - -data PushStage - -- indicates that we have data to push over the out of band network - = CanPush UUID [Sha] - -- request that a git push be sent over the out of band network - | PushRequest UUID - -- indicates that a push is starting - | StartingPush UUID - -- a chunk of output of git receive-pack - | ReceivePackOutput SequenceNum ByteString - -- a chuck of output of git send-pack - | SendPackOutput SequenceNum ByteString - -- sent when git receive-pack exits, with its exit code - | ReceivePackDone ExitCode - deriving (Eq, Ord, Show) - -{- A sequence number. Incremented by one per packet in a sequence, - - starting with 1 for the first packet. 0 means sequence numbers are - - not being used. -} -type SequenceNum = Int - -{- NetMessages that are important (and small), and should be stored to be - - resent when new clients are seen. -} -isImportantNetMessage :: NetMessage -> Maybe ClientID -isImportantNetMessage (Pushing c (CanPush _ _)) = Just c -isImportantNetMessage (Pushing c (PushRequest _)) = Just c -isImportantNetMessage _ = Nothing - -{- Checks if two important NetMessages are equivilant. - - That is to say, assuming they were sent to the same client, - - would it do the same thing for one as for the other? -} -equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool -equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True -equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True -equivilantImportantNetMessages _ _ = False - -readdressNetMessage :: NetMessage -> ClientID -> NetMessage -readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid -readdressNetMessage (Pushing _ stage) c = Pushing c stage -readdressNetMessage m _ = m - -{- Convert a NetMessage to something that can be logged. -} -logNetMessage :: NetMessage -> String -logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $ - case stage of - ReceivePackOutput n _ -> ReceivePackOutput n elided - SendPackOutput n _ -> SendPackOutput n elided - s -> s - where - elided = T.encodeUtf8 $ T.pack "<elided>" -logNetMessage (PairingNotification stage c uuid) = - show $ PairingNotification stage (logClientID c) uuid -logNetMessage m = show m - -logClientID :: ClientID -> ClientID -logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c] - -{- Things that initiate either side of a push, but do not actually send data. -} -isPushInitiation :: PushStage -> Bool -isPushInitiation (PushRequest _) = True -isPushInitiation (StartingPush _) = True -isPushInitiation _ = False - -isPushNotice :: PushStage -> Bool -isPushNotice (CanPush _ _) = True -isPushNotice _ = False - -data PushSide = SendPack | ReceivePack - deriving (Eq, Ord, Show) - -pushDestinationSide :: PushStage -> PushSide -pushDestinationSide (CanPush _ _) = ReceivePack -pushDestinationSide (PushRequest _) = SendPack -pushDestinationSide (StartingPush _) = ReceivePack -pushDestinationSide (ReceivePackOutput _ _) = SendPack -pushDestinationSide (SendPackOutput _ _) = ReceivePack -pushDestinationSide (ReceivePackDone _) = SendPack - -type SideMap a = PushSide -> a - -mkSideMap :: STM a -> IO (SideMap a) -mkSideMap gen = do - (sp, rp) <- atomically $ (,) <$> gen <*> gen - return $ lookupside sp rp - where - lookupside sp _ SendPack = sp - lookupside _ rp ReceivePack = rp - -getSide :: PushSide -> SideMap a -> a -getSide side m = m side - -type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage)) - -data NetMessager = NetMessager - -- outgoing messages - { netMessages :: TChan NetMessage - -- important messages for each client - , importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) - -- important messages that are believed to have been sent to a client - , sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) - -- write to this to restart the net messager - , netMessagerRestart :: MSampleVar () - -- queue of incoming messages that request the initiation of pushes - , netMessagerPushInitiations :: SideMap (TMVar [NetMessage]) - -- incoming messages containing data for a running - -- (or not yet started) push - , netMessagerInboxes :: SideMap Inboxes - } - -newNetMessager :: IO NetMessager -newNetMessager = NetMessager - <$> atomically newTChan - <*> atomically (newTMVar M.empty) - <*> atomically (newTMVar M.empty) - <*> newEmptySV - <*> mkSideMap newEmptyTMVar - <*> mkSideMap (newTVar M.empty) diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 6810165e20..f1ffeaec91 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -5,26 +5,18 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.Configurators where import Assistant.WebApp.Common import Assistant.WebApp.RepoList -#ifdef WITH_XMPP -import Assistant.XMPP.Client -#endif {- The main configuration screen. -} getConfigurationR :: Handler Html getConfigurationR = ifM inFirstRun ( redirect FirstRepositoryR , page "Configuration" (Just Configuration) $ do -#ifdef WITH_XMPP - xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds -#else - let xmppconfigured = False -#endif $(widgetFile "configurators/main") ) @@ -39,9 +31,6 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc") makeCloudRepositories :: Widget makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud") -makeXMPPConnection :: Widget -makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection") - makeSshRepository :: Widget makeSshRepository = $(widgetFile "configurators/addrepository/ssh") diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 149b403bbd..7239447ef0 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -37,16 +37,8 @@ notCurrentRepo uuid a = do go Nothing = error "Unknown UUID" go (Just _) = a -handleXMPPRemoval :: UUID -> Handler Html -> Handler Html -handleXMPPRemoval uuid nonxmpp = do - remote <- fromMaybe (error "unknown remote") - <$> liftAnnex (Remote.remoteFromUUID uuid) - if Remote.isXMPPRemote remote - then deletionPage $ $(widgetFile "configurators/delete/xmpp") - else nonxmpp - getDeleteRepositoryR :: UUID -> Handler Html -getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do +getDeleteRepositoryR uuid = notCurrentRepo uuid $ do deletionPage $ do reponame <- liftAnnex $ Remote.prettyUUID uuid $(widgetFile "configurators/delete/start") diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 9b6de6c135..913bd474e5 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators.Pairing where import Assistant.Pairing import Assistant.WebApp.Common -import Assistant.Types.Buddies import Annex.UUID #ifdef WITH_PAIRING import Assistant.Pairing.Network @@ -22,17 +21,6 @@ import Assistant.Alert import Assistant.DaemonStatus import Utility.Verifiable #endif -#ifdef WITH_XMPP -import Assistant.XMPP.Client -import Assistant.XMPP.Buddies -import Assistant.XMPP.Git -import Network.Protocol.XMPP -import Assistant.Types.NetMessager -import Assistant.NetMessager -import Assistant.WebApp.RepoList -import Assistant.WebApp.Configurators -import Assistant.WebApp.Configurators.XMPP -#endif import Utility.UserInfo import Git @@ -44,84 +32,6 @@ import Data.Char import qualified Control.Exception as E import Control.Concurrent #endif -#ifdef WITH_XMPP -import qualified Data.Set as S -#endif - -getStartXMPPPairFriendR :: Handler Html -#ifdef WITH_XMPP -getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds) - ( do - {- Ask buddies to send presence info, to get - - the buddy list populated. -} - liftAssistant $ sendNetMessage QueryPresence - pairPage $ - $(widgetFile "configurators/pairing/xmpp/friend/prompt") - , do - -- go get XMPP configured, then come back - redirect XMPPConfigForPairFriendR - ) -#else -getStartXMPPPairFriendR = noXMPPPairing - -noXMPPPairing :: Handler Html -noXMPPPairing = noPairing "XMPP" -#endif - -getStartXMPPPairSelfR :: Handler Html -#ifdef WITH_XMPP -getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds - where - go Nothing = do - -- go get XMPP configured, then come back - redirect XMPPConfigForPairSelfR - go (Just creds) = do - {- Ask buddies to send presence info, to get - - the buddy list populated. -} - liftAssistant $ sendNetMessage QueryPresence - let account = xmppJID creds - pairPage $ - $(widgetFile "configurators/pairing/xmpp/self/prompt") -#else -getStartXMPPPairSelfR = noXMPPPairing -#endif - -getRunningXMPPPairFriendR :: BuddyKey -> Handler Html -getRunningXMPPPairFriendR = sendXMPPPairRequest . Just - -getRunningXMPPPairSelfR :: Handler Html -getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing - -{- Sends a XMPP pair request, to a buddy or to self. -} -sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html -#ifdef WITH_XMPP -sendXMPPPairRequest mbid = do - bid <- maybe getself return mbid - buddy <- liftAssistant $ getBuddy bid <<~ buddyList - go $ S.toList . buddyAssistants <$> buddy - where - go (Just (clients@((Client exemplar):_))) = do - u <- liftAnnex getUUID - liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $ - PairingNotification PairReq (formatJID c) u - xmppPairStatus True $ - if selfpair then Nothing else Just exemplar - go _ - {- Nudge the user to turn on their other device. -} - | selfpair = do - liftAssistant $ sendNetMessage QueryPresence - pairPage $ - $(widgetFile "configurators/pairing/xmpp/self/retry") - {- Buddy could have logged out, etc. - - Go back to buddy list. -} - | otherwise = redirect StartXMPPPairFriendR - selfpair = isNothing mbid - getself = maybe (error "XMPP not configured") - (return . BuddyKey . xmppJID) - =<< liftAnnex getXMPPCreds -#else -sendXMPPPairRequest _ = noXMPPPairing -#endif {- Starts local pairing. -} getStartLocalPairR :: Handler Html @@ -158,41 +68,6 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do postFinishLocalPairR _ = noLocalPairing #endif -getConfirmXMPPPairFriendR :: PairKey -> Handler Html -#ifdef WITH_XMPP -getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of - Nothing -> error "bad JID" - Just theirjid -> pairPage $ do - let name = buddyName theirjid - $(widgetFile "configurators/pairing/xmpp/friend/confirm") -#else -getConfirmXMPPPairFriendR _ = noXMPPPairing -#endif - -getFinishXMPPPairFriendR :: PairKey -> Handler Html -#ifdef WITH_XMPP -getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of - Nothing -> error "bad JID" - Just theirjid -> do - selfuuid <- liftAnnex getUUID - liftAssistant $ do - sendNetMessage $ - PairingNotification PairAck (formatJID theirjid) selfuuid - finishXMPPPairing theirjid theiruuid - xmppPairStatus False $ Just theirjid -#else -getFinishXMPPPairFriendR _ = noXMPPPairing -#endif - -{- Displays a page indicating pairing status and - - prompting to set up cloud repositories. -} -#ifdef WITH_XMPP -xmppPairStatus :: Bool -> Maybe JID -> Handler Html -xmppPairStatus inprogress theirjid = pairPage $ do - let friend = buddyName <$> theirjid - $(widgetFile "configurators/pairing/xmpp/end") -#endif - getRunningLocalPairR :: SecretReminder -> Handler Html #ifdef WITH_PAIRING getRunningLocalPairR s = pairPage $ do diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs deleted file mode 100644 index 6075f1c2c4..0000000000 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ /dev/null @@ -1,226 +0,0 @@ -{- git-annex assistant XMPP configuration - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-} -{-# LANGUAGE CPP #-} - -module Assistant.WebApp.Configurators.XMPP where - -import Assistant.WebApp.Common -import Assistant.WebApp.Notifications -import Utility.NotificationBroadcaster -#ifdef WITH_XMPP -import qualified Remote -import Assistant.XMPP.Client -import Assistant.XMPP.Buddies -import Assistant.Types.Buddies -import Assistant.NetMessager -import Assistant.Alert -import Assistant.DaemonStatus -import Assistant.WebApp.RepoList -import Assistant.WebApp.Configurators -import Assistant.XMPP -import qualified Git.Remote.Remove -import Remote.List -import Creds -#endif - -#ifdef WITH_XMPP -import Network.Protocol.XMPP -import Network -import qualified Data.Text as T -#endif - -{- When appropriate, displays an alert suggesting to configure a cloud repo - - to suppliment an XMPP remote. -} -checkCloudRepos :: UrlRenderer -> Remote -> Assistant () -#ifdef WITH_XMPP -checkCloudRepos urlrenderer r = - unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do - buddyname <- getBuddyName $ Remote.uuid r - button <- mkAlertButton True "Add a cloud repository" urlrenderer $ - NeedCloudRepoR $ Remote.uuid r - void $ addAlert $ cloudRepoNeededAlert buddyname button -#else -checkCloudRepos _ _ = noop -#endif - -#ifdef WITH_XMPP -{- Returns the name of the friend corresponding to a - - repository's UUID, but not if it's our name. -} -getBuddyName :: UUID -> Assistant (Maybe String) -getBuddyName u = go =<< getclientjid - where - go Nothing = return Nothing - go (Just myjid) = (T.unpack . buddyName <$>) - . headMaybe - . filter (\j -> baseJID j /= baseJID myjid) - . map fst - . filter (\(_, r) -> Remote.uuid r == u) - <$> getXMPPRemotes - getclientjid = maybe Nothing parseJID . xmppClientID - <$> getDaemonStatus -#endif - -getNeedCloudRepoR :: UUID -> Handler Html -#ifdef WITH_XMPP -getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do - buddyname <- liftAssistant $ getBuddyName for - $(widgetFile "configurators/xmpp/needcloudrepo") -#else -getNeedCloudRepoR _ = xmppPage $ - $(widgetFile "configurators/xmpp/disabled") -#endif - -getXMPPConfigR :: Handler Html -getXMPPConfigR = postXMPPConfigR - -postXMPPConfigR :: Handler Html -postXMPPConfigR = xmppform DashboardR - -getXMPPConfigForPairFriendR :: Handler Html -getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR - -postXMPPConfigForPairFriendR :: Handler Html -postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR - -getXMPPConfigForPairSelfR :: Handler Html -getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR - -postXMPPConfigForPairSelfR :: Handler Html -postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR - -xmppform :: Route WebApp -> Handler Html -#ifdef WITH_XMPP -xmppform next = xmppPage $ do - ((result, form), enctype) <- liftH $ do - oldcreds <- liftAnnex getXMPPCreds - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $ - creds2Form <$> oldcreds - let showform problem = $(widgetFile "configurators/xmpp") - case result of - FormSuccess f -> either (showform . Just) (liftH . storecreds) - =<< liftIO (validateForm f) - _ -> showform Nothing - where - storecreds creds = do - void $ liftAnnex $ setXMPPCreds creds - liftAssistant notifyNetMessagerRestart - redirect next -#else -xmppform _ = xmppPage $ - $(widgetFile "configurators/xmpp/disabled") -#endif - -{- Called by client to get a list of buddies. - - - - Returns a div, which will be inserted into the calling page. - -} -getBuddyListR :: NotificationId -> Handler Html -getBuddyListR nid = do - waitNotifier getBuddyListBroadcaster nid - - p <- widgetToPageContent buddyListDisplay - withUrlRenderer $ [hamlet|^{pageBody p}|] - -buddyListDisplay :: Widget -buddyListDisplay = do - autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int) -#ifdef WITH_XMPP - myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus - let isself (BuddyKey b) = Just b == myjid - buddies <- liftAssistant $ do - pairedwith <- map fst <$> getXMPPRemotes - catMaybes . map (buddySummary pairedwith) - <$> (getBuddyList <<~ buddyList) - $(widgetFile "configurators/xmpp/buddylist") -#else - noop -#endif - where - ident = "buddylist" - -#ifdef WITH_XMPP - -getXMPPRemotes :: Assistant [(JID, Remote)] -getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes - <$> getDaemonStatus - where - pair r = maybe Nothing (\jid -> Just (jid, r)) $ - parseJID $ getXMPPClientID r - -data XMPPForm = XMPPForm - { formJID :: Text - , formPassword :: Text } - -creds2Form :: XMPPCreds -> XMPPForm -creds2Form c = XMPPForm (xmppJID c) (xmppPassword c) - -xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm -xmppAForm d = XMPPForm - <$> areq jidField (bfs "Jabber address") (formJID <$> d) - <*> areq passwordField (bfs "Password") Nothing - -jidField :: MkField Text -jidField = checkBool (isJust . parseJID) bad textField - where - bad :: Text - bad = "This should look like an email address.." - -validateForm :: XMPPForm -> IO (Either String XMPPCreds) -validateForm f = do - let jid = fromMaybe (error "bad JID") $ parseJID (formJID f) - let username = fromMaybe "" (strNode <$> jidNode jid) - testXMPP $ XMPPCreds - { xmppUsername = username - , xmppPassword = formPassword f - , xmppHostname = T.unpack $ strDomain $ jidDomain jid - , xmppPort = 5222 - , xmppJID = formJID f - } - -testXMPP :: XMPPCreds -> IO (Either String XMPPCreds) -testXMPP creds = do - (good, bad) <- partition (either (const False) (const True) . snd) - <$> connectXMPP creds (const noop) - case good of - (((h, PortNumber p), _):_) -> return $ Right $ creds - { xmppHostname = h - , xmppPort = fromIntegral p - } - (((h, _), _):_) -> return $ Right $ creds - { xmppHostname = h - } - _ -> return $ Left $ intercalate "; " $ map formatlog bad - where - formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e - formatlog _ = "" - - showport (PortNumber n) = show n - showport (Service s) = s - showport (UnixSocket s) = s -#endif - -getDisconnectXMPPR :: Handler Html -getDisconnectXMPPR = do -#ifdef WITH_XMPP - rs <- filter Remote.isXMPPRemote . syncRemotes - <$> liftAssistant getDaemonStatus - liftAnnex $ do - mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs - void remoteListRefresh - removeCreds xmppCredsFile - liftAssistant $ do - updateSyncRemotes - notifyNetMessagerRestart - redirect DashboardR -#else - xmppPage $ $(widgetFile "configurators/xmpp/disabled") -#endif - -xmppPage :: Widget -> Handler Html -xmppPage = page "Jabber" (Just Configuration) diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs index 8d4a86cc7b..71d7cf9170 100644 --- a/Assistant/WebApp/Notifications.hs +++ b/Assistant/WebApp/Notifications.hs @@ -13,7 +13,6 @@ import Assistant.Common import Assistant.WebApp import Assistant.WebApp.Types import Assistant.DaemonStatus -import Assistant.Types.Buddies import Utility.NotificationBroadcaster import Utility.Yesod import Utility.WebApp @@ -60,9 +59,6 @@ getNotifierTransfersR = notifierUrl TransfersR getTransferBroadcaster getNotifierSideBarR :: Handler RepPlain getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster -getNotifierBuddyListR :: Handler RepPlain -getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster - getNotifierRepoListR :: RepoSelector -> Handler RepPlain getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster where @@ -77,9 +73,6 @@ getTransferBroadcaster = transferNotifier <$> getDaemonStatus getAlertBroadcaster :: Assistant NotificationBroadcaster getAlertBroadcaster = alertNotifier <$> getDaemonStatus -getBuddyListBroadcaster :: Assistant NotificationBroadcaster -getBuddyListBroadcaster = getBuddyBroadcaster <$> getAssistant buddyList - getRepoListBroadcaster :: Assistant NotificationBroadcaster getRepoListBroadcaster = syncRemotesNotifier <$> getDaemonStatus diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 5e4251de64..b01e5e8d27 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -260,7 +260,7 @@ getSyncNowRepositoryR uuid = do if u == uuid then do thread <- liftAssistant $ asIO $ - reconnectRemotes True + reconnectRemotes =<< (syncRemotes <$> getDaemonStatus) void $ liftIO $ forkIO thread else maybe noop (liftAssistant . syncRemote) diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index 1ab0fa306f..497d5eafba 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -15,7 +15,6 @@ module Assistant.WebApp.Types where import Assistant.Common import Assistant.Ssh import Assistant.Pairing -import Assistant.Types.Buddies import Utility.NotificationBroadcaster import Utility.WebApp import Utility.Yesod @@ -162,14 +161,6 @@ instance PathPiece UUID where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece BuddyKey where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece PairKey where - toPathPiece = pack . show - fromPathPiece = readish . unpack - instance PathPiece RepoSelector where toPathPiece = pack . show fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index ae2565ab5c..3016ac393f 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -16,11 +16,6 @@ /config ConfigurationR GET /config/preferences PreferencesR GET POST -/config/xmpp XMPPConfigR GET POST -/config/xmpp/for/self XMPPConfigForPairSelfR GET POST -/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST -/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET -/config/xmpp/disconnect DisconnectXMPPR GET /config/needconnection ConnectionNeededR GET /config/fsck ConfigFsckR GET POST /config/fsck/preferences ConfigFsckPreferencesR POST @@ -67,14 +62,6 @@ /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST -/config/repository/pair/xmpp/self/start StartXMPPPairSelfR GET -/config/repository/pair/xmpp/self/running RunningXMPPPairSelfR GET - -/config/repository/pair/xmpp/friend/start StartXMPPPairFriendR GET -/config/repository/pair/xmpp/friend/running/#BuddyKey RunningXMPPPairFriendR GET -/config/repository/pair/xmpp/friend/accept/#PairKey ConfirmXMPPPairFriendR GET -/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET - /config/repository/enable/rsync/#UUID EnableRsyncR GET POST /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST /config/repository/enable/directory/#UUID EnableDirectoryR GET @@ -103,9 +90,6 @@ /sidebar/#NotificationId SideBarR GET /notifier/sidebar NotifierSideBarR GET -/buddylist/#NotificationId BuddyListR GET -/notifier/buddylist NotifierBuddyListR GET - /repolist/#NotificationId/#RepoSelector RepoListR GET /notifier/repolist/#RepoSelector NotifierRepoListR GET diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs deleted file mode 100644 index 52cd319392..0000000000 --- a/Assistant/XMPP.hs +++ /dev/null @@ -1,275 +0,0 @@ -{- core xmpp support - - - - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE OverloadedStrings #-} - -module Assistant.XMPP where - -import Assistant.Common -import Assistant.Types.NetMessager -import Assistant.Pairing -import Git.Sha (extractSha) -import Git - -import Network.Protocol.XMPP hiding (Node) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as M -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.XML.Types -import qualified "sandi" Codec.Binary.Base64 as B64 -import Data.Bits.Utils - -{- Name of the git-annex tag, in our own XML namespace. - - (Not using a namespace URL to avoid unnecessary bloat.) -} -gitAnnexTagName :: Name -gitAnnexTagName = "{git-annex}git-annex" - -{- Creates a git-annex tag containing a particular attribute and value. -} -gitAnnexTag :: Name -> Text -> Element -gitAnnexTag attr val = gitAnnexTagContent attr val [] - -{- Also with some content. -} -gitAnnexTagContent :: Name -> Text -> [Node] -> Element -gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])] - -isGitAnnexTag :: Element -> Bool -isGitAnnexTag t = elementName t == gitAnnexTagName - -{- Things that a git-annex tag can inserted into. -} -class GitAnnexTaggable a where - insertGitAnnexTag :: a -> Element -> a - - extractGitAnnexTag :: a -> Maybe Element - - hasGitAnnexTag :: a -> Bool - hasGitAnnexTag = isJust . extractGitAnnexTag - -instance GitAnnexTaggable Message where - insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m } - extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads - -instance GitAnnexTaggable Presence where - -- always mark extended away and set presence priority to negative - insertGitAnnexTag p elt = p - { presencePayloads = extendedAway : negativePriority : elt : presencePayloads p } - extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads - -data GitAnnexTagInfo = GitAnnexTagInfo - { tagAttr :: Name - , tagValue :: Text - , tagElement :: Element - } - -type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage - -gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo -gitAnnexTagInfo v = case extractGitAnnexTag v of - {- Each git-annex tag has a single attribute. -} - Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo - <$> pure attr - <*> attributeText attr tag - <*> pure tag - _ -> Nothing - -{- A presence with a git-annex tag in it. - - Also includes a status tag, which may be visible in XMPP clients. -} -gitAnnexPresence :: Element -> Presence -gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable - where - addStatusTag p = p - { presencePayloads = status : presencePayloads p } - status = Element "status" [] [statusMessage] - statusMessage = NodeContent $ ContentText $ T.pack "git-annex" - -{- A presence with an empty git-annex tag in it, used for letting other - - clients know we're around and are a git-annex client. -} -gitAnnexSignature :: Presence -gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] [] - -{- XMPP client to server ping -} -xmppPing :: JID -> IQ -xmppPing selfjid = (emptyIQ IQGet) - { iqID = Just "c2s1" - , iqFrom = Just selfjid - , iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing - , iqPayload = Just $ Element xmppPingTagName [] [] - } - -xmppPingTagName :: Name -xmppPingTagName = "{urn:xmpp}ping" - -{- A message with a git-annex tag in it. -} -gitAnnexMessage :: Element -> JID -> JID -> Message -gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt) - { messageTo = Just tojid - , messageFrom = Just fromjid - } - -{- A notification that we've pushed to some repositories, listing their - - UUIDs. -} -pushNotification :: [UUID] -> Presence -pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification - -encodePushNotification :: [UUID] -> Text -encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID) - -decodePushNotification :: Text -> [UUID] -decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep - -uuidSep :: Text -uuidSep = "," - -{- A request for other git-annex clients to send presence. -} -presenceQuery :: Presence -presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty - -{- A notification about a stage of pairing. -} -pairingNotification :: PairStage -> UUID -> JID -> JID -> Message -pairingNotification pairstage u = gitAnnexMessage $ - gitAnnexTag pairAttr $ encodePairingNotification pairstage u - -encodePairingNotification :: PairStage -> UUID -> Text -encodePairingNotification pairstage u = T.unwords $ map T.pack - [ show pairstage - , fromUUID u - ] - -decodePairingNotification :: Decoder -decodePairingNotification m = parse . words . T.unpack . tagValue - where - parse [stage, u] = PairingNotification - <$> readish stage - <*> (formatJID <$> messageFrom m) - <*> pure (toUUID u) - parse _ = Nothing - -pushMessage :: PushStage -> JID -> JID -> Message -pushMessage = gitAnnexMessage . encode - where - encode (CanPush u shas) = - gitAnnexTag canPushAttr $ T.pack $ unwords $ - fromUUID u : map fromRef shas - encode (PushRequest u) = - gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u - encode (StartingPush u) = - gitAnnexTag startingPushAttr $ T.pack $ fromUUID u - encode (ReceivePackOutput n b) = - gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b - encode (SendPackOutput n b) = - gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b - encode (ReceivePackDone code) = - gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code - val = T.pack . show - -decodeMessage :: Message -> Maybe NetMessage -decodeMessage m = decode =<< gitAnnexTagInfo m - where - decode i = M.lookup (tagAttr i) decoders >>= rundecoder i - rundecoder i d = d m i - decoders = M.fromList $ zip - [ pairAttr - , canPushAttr - , pushRequestAttr - , startingPushAttr - , receivePackAttr - , sendPackAttr - , receivePackDoneAttr - ] - [ decodePairingNotification - , pushdecoder $ shasgen CanPush - , pushdecoder $ gen PushRequest - , pushdecoder $ gen StartingPush - , pushdecoder $ seqgen ReceivePackOutput - , pushdecoder $ seqgen SendPackOutput - , pushdecoder $ - fmap (ReceivePackDone . decodeExitCode) . readish . - T.unpack . tagValue - ] - pushdecoder a m' i = Pushing - <$> (formatJID <$> messageFrom m') - <*> a i - gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i))) - seqgen c i = do - packet <- decodeTagContent $ tagElement i - let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i - return $ c seqnum packet - shasgen c i = do - let (u:shas) = words $ T.unpack $ tagValue i - return $ c (toUUID u) (mapMaybe extractSha shas) - -decodeExitCode :: Int -> ExitCode -decodeExitCode 0 = ExitSuccess -decodeExitCode n = ExitFailure n - -encodeExitCode :: ExitCode -> Int -encodeExitCode ExitSuccess = 0 -encodeExitCode (ExitFailure n) = n - -{- Base 64 encoding a ByteString to use as the content of a tag. -} -encodeTagContent :: ByteString -> [Node] -encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b] - -decodeTagContent :: Element -> Maybe ByteString -decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s) - where - s = T.unpack $ T.concat $ elementText elt - -{- The JID without the client part. -} -baseJID :: JID -> JID -baseJID j = JID (jidNode j) (jidDomain j) Nothing - -{- An XMPP chat message with an empty body. This should not be displayed - - by clients, but can be used for communications. -} -silentMessage :: Message -silentMessage = (emptyMessage MessageChat) - { messagePayloads = [ emptybody ] } - where - emptybody = Element - { elementName = "body" - , elementAttributes = [] - , elementNodes = [] - } - -{- Add to a presence to mark its client as extended away. -} -extendedAway :: Element -extendedAway = Element "show" [] [NodeContent $ ContentText "xa"] - -{- Add to a presence to give it a negative priority. -} -negativePriority :: Element -negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"] - -pushAttr :: Name -pushAttr = "push" - -queryAttr :: Name -queryAttr = "query" - -pairAttr :: Name -pairAttr = "pair" - -canPushAttr :: Name -canPushAttr = "canpush" - -pushRequestAttr :: Name -pushRequestAttr = "pushrequest" - -startingPushAttr :: Name -startingPushAttr = "startingpush" - -receivePackAttr :: Name -receivePackAttr = "rp" - -sendPackAttr :: Name -sendPackAttr = "sp" - -receivePackDoneAttr :: Name -receivePackDoneAttr = "rpdone" - -shasAttr :: Name -shasAttr = "shas" diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs deleted file mode 100644 index 77eb3202f3..0000000000 --- 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 6d09d32e68..0000000000 --- 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 612e0f2c54..0000000000 --- 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 diff --git a/BuildFlags.hs b/BuildFlags.hs index 3a737589f2..68dfabbe86 100644 --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -63,11 +63,6 @@ buildFlags = filter (not . null) #ifdef WITH_DESKTOP_NOTIFY , "DesktopNotify" #endif -#ifdef WITH_XMPP - , "XMPP" -#else -#warning Building without XMPP. -#endif #ifdef WITH_CONCURRENTOUTPUT , "ConcurrentOutput" #else diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index e989f3f438..a5913e9e02 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -106,9 +106,6 @@ import qualified Command.Assistant #ifdef WITH_WEBAPP import qualified Command.WebApp #endif -#ifdef WITH_XMPP -import qualified Command.XMPPGit -#endif import qualified Command.RemoteDaemon #endif import qualified Command.Test @@ -213,9 +210,6 @@ cmds testoptparser testrunner = #ifdef WITH_WEBAPP , Command.WebApp.cmd #endif -#ifdef WITH_XMPP - , Command.XMPPGit.cmd -#endif , Command.RemoteDaemon.cmd #endif , Command.Test.cmd testoptparser testrunner diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs deleted file mode 100644 index 0a7178df80..0000000000 --- a/Command/XMPPGit.hs +++ /dev/null @@ -1,48 +0,0 @@ -{- git-annex command - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Command.XMPPGit where - -import Command -import Assistant.XMPP.Git - -cmd :: Command -cmd = noCommit $ dontCheck repoExists $ - noRepo (parseparams startNoRepo) $ - command "xmppgit" SectionPlumbing "git to XMPP relay" - paramNothing (parseparams seek) - where - parseparams = withParams - -seek :: CmdParams -> CommandSeek -seek = withWords start - -start :: CmdParams -> CommandStart -start _ = do - liftIO gitRemoteHelper - liftIO xmppGitRelay - stop - -startNoRepo :: CmdParams -> IO () -startNoRepo _ = xmppGitRelay - -{- A basic implementation of the git-remote-helpers protocol. -} -gitRemoteHelper :: IO () -gitRemoteHelper = do - expect "capabilities" - respond ["connect"] - expect "connect git-receive-pack" - respond [] - where - expect s = do - gitcmd <- getLine - unless (gitcmd == s) $ - error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ gitcmd - respond l = do - mapM_ putStrLn l - putStrLn "" - hFlush stdout @@ -280,7 +280,7 @@ dist/caballog: git-annex.cabal # TODO should be possible to derive this from caballog. hdevtools: hdevtools --stop-server || true - hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -DWITH_XMPP -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports + hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports distributionupdate: git pull diff --git a/debian/control b/debian/control index ec77a2946e..ea33eccab7 100644 --- a/debian/control +++ b/debian/control @@ -59,9 +59,6 @@ Build-Depends: libghc-network-multicast-dev, libghc-network-info-dev [linux-any kfreebsd-any], libghc-safesemaphore-dev, - libghc-network-protocol-xmpp-dev (>= 0.4.3-1+b1), - libghc-gnutls-dev (>= 0.1.4), - libghc-xml-types-dev, libghc-async-dev, libghc-monad-logger-dev, libghc-feed-dev (>= 0.3.9.2), diff --git a/doc/assistant.mdwn b/doc/assistant.mdwn index 2ed35d6df8..f625ebeedc 100644 --- a/doc/assistant.mdwn +++ b/doc/assistant.mdwn @@ -24,8 +24,6 @@ instructions. * Or perhaps you want to share files between computers in different locations, like home and work? Follow the [[remote_sharing_walkthrough]]. -* Want to share a synchronised folder with a friend? - Follow the [[share_with_a_friend_walkthrough]]. * Want to archive data to a drive or the cloud? Follow the [[archival_walkthrough]]. diff --git a/doc/assistant/share_with_a_friend_walkthrough.mdwn b/doc/assistant/share_with_a_friend_walkthrough.mdwn deleted file mode 100644 index 38544d1110..0000000000 --- a/doc/assistant/share_with_a_friend_walkthrough.mdwn +++ /dev/null @@ -1,58 +0,0 @@ -Want to share all the files in your repository with a friend? - -Let's suppose you use Google Mail, and so does your friend, and you -sometimes also chat in Google Talk. The git-annex assistant will -use your Google account to share with your friend. (This actually -works with any Jabber account you use, not just Google Talk.) - -Start by opening up your git annex dashboard. - -[[!img local_pairing_walkthrough/addrepository.png alt="Add another repository button"]] - -`*click*` - -[[!img pairing.png alt="Share with a friend"]] - -`*click*` - -[[!img xmpp.png alt="Configuring Jabber account"]] - -Fill that out, and git-annex will be able to show you a list of your -friends. - -[[!img buddylist.png alt="Buddy list"]] - -This list will refresh as friends log on and off, so you can -leave it open in a tab until a friend is available to start pairing. - -(If your friend is not using git-annex yet, now's a great time to spread -the word!) - -Once you click on "Start Pairing", your friend will see this pop up -on their git annex dashboard. - -[[!img xmppalert.png alt="Pair request"]] - -Once your friend clicks on that, your repositories will be paired. - -### But, wait, there's one more step... - -Despite the repositories being paired now, you and your friend can't yet -quite share files. You'll start to see your friend's files show up in your -git-annex folder, but you won't be able to open them yet. - -What you need to do now is set up a repository out there in the cloud, -that both you and your friend can access. This will be used to transfer -files between the two of you. - -At the end of the pairing process, a number of cloud providers are -suggested, and the git-annex assistant makes it easy to configure one of -them. Once you or your friend sets it up, it'll show up in the other -one's list of repositories: - -[[!img repolist.png alt="Repository list"]] - -The final step is to share the login information for the cloud repository -with your friend, so they can enable it too. - -With that complete, you'll be able to open your friend's files! diff --git a/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png b/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png Binary files differdeleted file mode 100644 index 5e2d562895..0000000000 --- a/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png +++ /dev/null diff --git a/doc/bugs/assistant_-_GTalk_collision.mdwn b/doc/bugs/assistant_-_GTalk_collision.mdwn index b814166ae0..a950dcdbcb 100644 --- a/doc/bugs/assistant_-_GTalk_collision.mdwn +++ b/doc/bugs/assistant_-_GTalk_collision.mdwn @@ -15,3 +15,5 @@ I expect to remain invisible, but I get the following warning: "Oops! You are no Syncing between the repositories works ok. [[!tag /design/assistant]] + +> [[done]]; xmpp support has been removed. --[[Joey]] diff --git a/doc/bugs/problems_with_android_and_xmpp.mdwn b/doc/bugs/problems_with_android_and_xmpp.mdwn index 0b05c94bb2..73ceab7b32 100644 --- a/doc/bugs/problems_with_android_and_xmpp.mdwn +++ b/doc/bugs/problems_with_android_and_xmpp.mdwn @@ -80,3 +80,5 @@ fatal: The remote end hung up unexpectedly [2014-02-13 13:18:25 CET] XMPPClient: to client: d6/tigase-14134 """]] + +> [[done]]; xmpp support has been removed --[[Joey]] diff --git a/doc/git-annex-xmppgit.mdwn b/doc/git-annex-xmppgit.mdwn deleted file mode 100644 index 76ae81cb41..0000000000 --- a/doc/git-annex-xmppgit.mdwn +++ /dev/null @@ -1,23 +0,0 @@ -# NAME - -git-annex xmppgit - git to XMPP relay - -# SYNOPSIS - -git annex xmppgit - -# DESCRIPTION - -This command is used internally by the assistant to perform git pulls over XMPP. - -# SEE ALSO - -[[git-annex]](1) - -[[git-annex-assistant]](1) - -# AUTHOR - -Joey Hess <id@joeyh.name> - -Warning: Automatically converted into a man page by mdwn2man. Edit with care. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 955f67629f..d71076087b 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -658,13 +658,6 @@ subdirectories). See [[git-annex-remotedaemon]](1) for details. -* `xmppgit` - - This command is used internally by the assistant to perform git pulls - over XMPP. - - See [[git-annex-xmppgit]](1) for details. - # TESTING COMMANDS * `test` @@ -1296,11 +1289,6 @@ Here are all the supported configuration settings. Used to identify tahoe special remotes. Points to the configuration directory for tahoe. -* `remote.<name>.annex-xmppaddress` - - Used to identify the XMPP address of a Jabber buddy. - Normally this is set up by the git-annex assistant when pairing over XMPP. - * `remote.<name>.gcrypt` Used to identify gcrypt special remotes. diff --git a/doc/special_remotes/xmpp.mdwn b/doc/special_remotes/xmpp.mdwn index 0f1c93b253..0144a4243c 100644 --- a/doc/special_remotes/xmpp.mdwn +++ b/doc/special_remotes/xmpp.mdwn @@ -1,39 +1,4 @@ -XMPP (Jabber) is used by the [[assistant]] as a git remote. This is, -technically not a git-annex special remote (large files are not transferred -over XMPP; only git commits are sent). - -Typically XMPP will be set up using the web app, but here's how a manual -set up could be accomplished: - -1. xmpp login credentials need to be stored in `.git/annex/creds/xmpp`. - Obviously this file should be mode 600. An example file: - - XMPPCreds {xmppUsername = "joeyhess", xmppPassword = "xxxx", xmppHostname = "xmpp.l.google.com.", xmppPort = 5222, xmppJID = "joeyhess@gmail.com"} - -2. A git remote is created using a special url, of the form `xmpp::user@host` - For the above example, it would be `url = xmpp::joeyhess@gmail.com` - -3. The uuid of one of the other clients using XMPP should be configured - using the `annex.uuid` setting, the same as is set up for other remotes. - -With the above configuration, the [[assistant]] will use xmpp remotes much as -any other git remote. Since XMPP requires a client that is continually running -to see incoming pushes, the XMPP remote cannot be used with git at the -command line. - -## XMPP server support status -[[!table data=""" -Provider|Status|Type|Notes -[[Gmail|http://gmail.com]]|Working|?|Google Apps: [setup your SRV records](http://www.olark.com/gtalk/check_srv) or configure `.git/annex/creds/xmpp` manually -[[Coderollers|http://www.coderollers.com/xmpp-server/]]|Working|[[Openfire|http://www.igniterealtime.org/projects/openfire/]] -[[jabber.me|http://jabber.me/]]|Working|[[Tigase|http://www.tigase.org/]] -[[xmpp.ru.net|https://www.xmpp.ru.net]]|Working|[[jabberd2|http://jabberd2.org/]] -[[jabber.org|http://jabber.org]]|Working|[[Isode M-Link|http://www.isode.com/products/m-link.html]] --|Working|[[Prosody|http://prosody.im/]]|No providers tested. --|Working|[[Metronome|http://www.lightwitch.org/]]|No providers tested. --|[[Failing|http://git-annex.branchable.com/forum/XMPP_authentication_failure/]]|ejabberd|[[Authentication bug|https://support.process-one.net/browse/EJAB-1632]]: Fixed in debian unstable (>= 2.1.10-5) and stable (>=2.1.10-4+deb7u1) --|[[Failing|http://git-annex.branchable.com/forum/XMPP_authentication_failure/#comment-4ce5aeabd12ca3016290b3d8255f6ef1]]|jabberd14|No further information -"""]] -List of providers: [[http://xmpp.net/]] - -See also: [[xmpp_protocol_design_notes|design/assistant/xmpp]] +XMPP (Jabber) used to be able to be used by the [[assistant]] as a git remote. +This never worked very well, and it was not entirely secure, since the XMPP +server saw the contents of git pushes without encryption. So, XMPP support +has been removed. diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn index 4606f7f403..d45e9a8215 100644 --- a/doc/todo/windows_support.mdwn +++ b/doc/todo/windows_support.mdwn @@ -21,8 +21,6 @@ Seems like this would need Windows 10. Workaround: Put your git-annex repo in `C:\annex` or some similar short path if possible. -* XMPP library not yet built. (See below.) - * Local pairing seems to fail, after acking on Linux box, it stalls. (Also, of course, the Windows box is unlikely to have a ssh server, so only pairing with a !Windows box will work.) @@ -88,42 +86,3 @@ seems unreliable/broken on Windows. it and files can be transferred to it and back * Does stopping in progress transfers work in the webapp? -## trying to build XMPP - -Lots of library deps: - -1. gsasl-$LATEST.zip from <http://josefsson.org/gnutls4win/> (includes - gnuidn and gnutls) -2. pkg-config from - <http://sourceforge.net/projects/pkgconfiglite/files/latest/download?source=files> -3. libxml2 from mingw: - <http://sourceforge.net/projects/mingw/files/MSYS/Extension/libxml2/libxml2-2.7.6-1/> - both the -dll and the -dev -3. Extract all the above into the Haskell platform's mingw directory. Note - that pkg-config needs to be moved out of a named subdirectory. -4. Run in DOS prompt (not cygwin!): cabal install network-protocol-xmpp - -Current FAIL: - -<pre> -Loading package gnutls-0.1.5 ... ghc.exe: internal error: Misaligned section: 18206e5b - (GHC version 7.6.3 for i386_unknown_mingw32) - Please report this as a GHC bug: - http://www.haskell.org/ghc/reportabug -</pre> - -<https://ghc.haskell.org/trac/ghc/ticket/8830> - -Note: This only happens in the TH link stage. So building w/o the webapp -works with XMPP. - -Options: - -1. Use EvilSplicer, building first without XMPP library, but with its UI, - and a second time without TH, but with the XMPP library. Partially done - on the `winsplicehack` branch, but requires building patched versions - of lots of yesod dependency chain to export modules referenced by TH - splices, like had to be done on Android. Horrible pain. Ugly as hell. -2. Make a helper program with the XMPP support in it, that does not use TH. -3. Swich to a different XMPP client library, like - <http://hackage.haskell.org/package/pontarius-xmpp> diff --git a/doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn b/doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn index 96552eecca..83f75bb936 100644 --- a/doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn +++ b/doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn @@ -5,3 +5,5 @@ Currently XMPP fails if you use a google apps account. Since the domain provided Same goes for webdav support. If i have my own webdav server somewhere on the internet there is no way to set it up in the assistant. [[!tag /design/assistant]] + +> [[done]]; xmpp support has been removed --[[Joey]] diff --git a/doc/todo/xmpp_removal.mdwn b/doc/todo/xmpp_removal.mdwn index 9eb0407804..26d4529400 100644 --- a/doc/todo/xmpp_removal.mdwn +++ b/doc/todo/xmpp_removal.mdwn @@ -23,3 +23,5 @@ notably the stack build. It's never worked on Windows. Next step is probably to default the flag to false by default, except for in a few builds like the Debian package and standalone builds. + +> [[done]] diff --git a/git-annex.cabal b/git-annex.cabal index 65abc8d32d..6f9d75ca00 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -135,7 +135,6 @@ Extra-Source-Files: doc/git-annex-watch.mdwn doc/git-annex-webapp.mdwn doc/git-annex-whereis.mdwn - doc/git-annex-xmppgit.mdwn doc/logo.svg doc/logo_16x16.png Build/mdwn2man @@ -196,12 +195,6 @@ Extra-Source-Files: templates/configurators/pairing/local/inprogress.hamlet templates/configurators/pairing/local/prompt.hamlet templates/configurators/pairing/disabled.hamlet - templates/configurators/pairing/xmpp/self/retry.hamlet - templates/configurators/pairing/xmpp/self/prompt.hamlet - templates/configurators/pairing/xmpp/friend/prompt.hamlet - templates/configurators/pairing/xmpp/friend/confirm.hamlet - templates/configurators/pairing/xmpp/end.hamlet - templates/configurators/xmpp.hamlet templates/configurators/addglacier.hamlet templates/configurators/fsck.cassius templates/configurators/edit/nonannexremote.hamlet @@ -223,7 +216,6 @@ Extra-Source-Files: templates/configurators/addrepository/archive.hamlet templates/configurators/addrepository/cloud.hamlet templates/configurators/addrepository/connection.hamlet - templates/configurators/addrepository/xmppconnection.hamlet templates/configurators/addrepository/ssh.hamlet templates/configurators/addrepository/misc.hamlet templates/configurators/rsync.net/add.hamlet @@ -235,7 +227,6 @@ Extra-Source-Files: templates/configurators/fsck/form.hamlet templates/configurators/fsck/preferencesform.hamlet templates/configurators/fsck/formcontent.hamlet - templates/configurators/delete/xmpp.hamlet templates/configurators/delete/finished.hamlet templates/configurators/delete/start.hamlet templates/configurators/delete/currentrepository.hamlet @@ -243,9 +234,6 @@ Extra-Source-Files: templates/configurators/adddrive.hamlet templates/configurators/preferences.hamlet templates/configurators/addia.hamlet - templates/configurators/xmpp/buddylist.hamlet - templates/configurators/xmpp/disabled.hamlet - templates/configurators/xmpp/needcloudrepo.hamlet templates/configurators/enableaws.hamlet templates/configurators/addrepository.hamlet templates/actionbutton.hamlet @@ -305,9 +293,6 @@ Flag Cryptonite Flag Dbus Description: Enable dbus support -Flag XMPP - Description: Enable notifications using XMPP - source-repository head type: git location: git://git-annex.branchable.com/ @@ -479,11 +464,6 @@ Executable git-annex Build-Depends: network-multicast, network-info CPP-Options: -DWITH_PAIRING - if flag(XMPP) - if (! os(windows)) - Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4), xml-types - CPP-Options: -DWITH_XMPP - if flag(TorrentParser) Build-Depends: torrent (>= 10000.0.0) CPP-Options: -DWITH_TORRENTPARSER @@ -577,7 +557,6 @@ Executable git-annex Assistant.MakeRemote Assistant.Monad Assistant.NamedThread - Assistant.NetMessager Assistant.Pairing Assistant.Pairing.MakeRemote Assistant.Pairing.Network @@ -610,20 +589,16 @@ Executable git-annex Assistant.Threads.Upgrader Assistant.Threads.Watcher Assistant.Threads.WebApp - Assistant.Threads.XMPPClient - Assistant.Threads.XMPPPusher Assistant.TransferQueue Assistant.TransferSlots Assistant.TransferrerPool Assistant.Types.Alert Assistant.Types.BranchChange - Assistant.Types.Buddies Assistant.Types.Changes Assistant.Types.Commits Assistant.Types.CredPairCache Assistant.Types.DaemonStatus Assistant.Types.NamedThread - Assistant.Types.NetMessager Assistant.Types.Pushes Assistant.Types.RemoteControl Assistant.Types.RepoProblem @@ -651,7 +626,6 @@ Executable git-annex Assistant.WebApp.Configurators.Unused Assistant.WebApp.Configurators.Upgrade Assistant.WebApp.Configurators.WebDAV - Assistant.WebApp.Configurators.XMPP Assistant.WebApp.Control Assistant.WebApp.DashBoard Assistant.WebApp.Documentation @@ -666,10 +640,6 @@ Executable git-annex Assistant.WebApp.RepoList Assistant.WebApp.SideBar Assistant.WebApp.Types - Assistant.XMPP - Assistant.XMPP.Buddies - Assistant.XMPP.Client - Assistant.XMPP.Git Backend Backend.Hash Backend.URL @@ -806,7 +776,6 @@ Executable git-annex Command.Watch Command.WebApp Command.Whereis - Command.XMPPGit Common Config Config.Cost diff --git a/stack.yaml b/stack.yaml index 59abff99db..13d5126967 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,6 @@ flags: webapp: true magicmime: false dbus: false - xmpp: false android: false androidsplice: false packages: diff --git a/standalone/android/cabal.config b/standalone/android/cabal.config index dd57db47e3..f61fe9a0b9 100644 --- a/standalone/android/cabal.config +++ b/standalone/android/cabal.config @@ -111,7 +111,6 @@ constraints: unix installed, network-conduit ==1.1.0, network-info ==0.2.0.5, network-multicast ==0.0.10, - network-protocol-xmpp ==0.4.6, network-uri ==2.6.0.1, optparse-applicative ==0.11.0.2, parallel ==3.2.0.4, diff --git a/standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch b/standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch deleted file mode 100644 index ff9d8f2458..0000000000 --- a/standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch +++ /dev/null @@ -1,50 +0,0 @@ -From afdec6c9e66211a0ac8419fffe191b059d1fd00c Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sun, 22 Sep 2013 17:24:33 +0000 -Subject: [PATCH] fix build with new base - ---- - Data/Text/IDN/IDNA.chs | 1 + - Data/Text/IDN/Punycode.chs | 1 + - Data/Text/IDN/StringPrep.chs | 1 + - 3 files changed, 3 insertions(+) - -diff --git a/Data/Text/IDN/IDNA.chs b/Data/Text/IDN/IDNA.chs -index ed29ee4..dbb4ba5 100644 ---- a/Data/Text/IDN/IDNA.chs -+++ b/Data/Text/IDN/IDNA.chs -@@ -31,6 +31,7 @@ import Foreign - import Foreign.C - - import Data.Text.IDN.Internal -+import System.IO.Unsafe - - #include <idna.h> - #include <idn-free.h> -diff --git a/Data/Text/IDN/Punycode.chs b/Data/Text/IDN/Punycode.chs -index 24b5fa6..4e62555 100644 ---- a/Data/Text/IDN/Punycode.chs -+++ b/Data/Text/IDN/Punycode.chs -@@ -32,6 +32,7 @@ import Data.List (unfoldr) - import qualified Data.ByteString as B - import qualified Data.Text as T - -+import System.IO.Unsafe - import Foreign - import Foreign.C - -diff --git a/Data/Text/IDN/StringPrep.chs b/Data/Text/IDN/StringPrep.chs -index 752dc9e..5e9fd84 100644 ---- a/Data/Text/IDN/StringPrep.chs -+++ b/Data/Text/IDN/StringPrep.chs -@@ -39,6 +39,7 @@ import qualified Data.ByteString as B - import qualified Data.Text as T - import qualified Data.Text.Encoding as TE - -+import System.IO.Unsafe - import Foreign - import Foreign.C - --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch b/standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch deleted file mode 100644 index 6f75da240a..0000000000 --- a/standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch +++ /dev/null @@ -1,43 +0,0 @@ -From 311aab1ae9d7a653edfbec1351f548b98de85c4b Mon Sep 17 00:00:00 2001 -From: androidbuilder <androidbuilder@example.com> -Date: Mon, 26 May 2014 21:54:18 +0000 -Subject: [PATCH] hack gnutls to link on android - -This uses a hardcoded path to the library, which includes the -arm-linux-androideabi-4.8 part. Will need to be changed when that changes.. - -Have to list all the libraries that gnutls depends on, pkgconfig depends -seems not to be working. ---- - gnutls.cabal | 9 +++++---- - 1 file changed, 5 insertions(+), 4 deletions(-) - -diff --git a/gnutls.cabal b/gnutls.cabal -index 5bfe687..61db23f 100644 ---- a/gnutls.cabal -+++ b/gnutls.cabal -@@ -31,16 +31,17 @@ source-repository this - library - hs-source-dirs: lib - ghc-options: -Wall -O2 -+ LD-Options: -L /home/builder/.ghc/android-14/arm-linux-androideabi-4.8/sysroot/usr/lib/ -+ -+ extra-libraries: gnutls nettle hogweed gmp z -+ pkgconfig-depends: gnutls - - build-depends: - base >= 4.0 && < 5.0 -- , bytestring >= 0.9 -+ , bytestring >= 0.10.3.0 - , transformers >= 0.2 - , monads-tf >= 0.1 && < 0.2 - -- extra-libraries: gnutls -- pkgconfig-depends: gnutls -- - exposed-modules: - Network.Protocol.TLS.GNU - --- -1.7.10.4 - diff --git a/standalone/android/install-haskell-packages b/standalone/android/install-haskell-packages index 0e6b8cba45..7d79d0b801 100755 --- a/standalone/android/install-haskell-packages +++ b/standalone/android/install-haskell-packages @@ -111,10 +111,7 @@ EOF patched DAV patched yesod-static patched dns - patched gnutls patched unbounded-delays - patched gnuidn - patched network-protocol-xmpp patched uuid cd .. diff --git a/templates/configurators/addrepository/connection.hamlet b/templates/configurators/addrepository/connection.hamlet index fc111b0653..43444abf62 100644 --- a/templates/configurators/addrepository/connection.hamlet +++ b/templates/configurators/addrepository/connection.hamlet @@ -1,3 +1 @@ -^{makeXMPPConnection} - ^{makeSshRepository} diff --git a/templates/configurators/addrepository/misc.hamlet b/templates/configurators/addrepository/misc.hamlet index f9e89360ad..96d1c58bf2 100644 --- a/templates/configurators/addrepository/misc.hamlet +++ b/templates/configurators/addrepository/misc.hamlet @@ -8,8 +8,6 @@ <a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> # between computers. -^{makeXMPPConnection} - <h3> <a href="@{StartLocalPairR}"> <span .glyphicon .glyphicon-plus-sign> diff --git a/templates/configurators/addrepository/xmppconnection.hamlet b/templates/configurators/addrepository/xmppconnection.hamlet deleted file mode 100644 index 34e87ed83d..0000000000 --- a/templates/configurators/addrepository/xmppconnection.hamlet +++ /dev/null @@ -1,13 +0,0 @@ -<h3> - <a href="@{StartXMPPPairSelfR}"> - <span .glyphicon .glyphicon-plus-sign> - \ Share with your other devices -<p> - Keep files in sync between your devices running git-annex. - -<h3> - <a href="@{StartXMPPPairFriendR}"> - <span .glyphicon .glyphicon-plus-sign> - \ Share with a friend -<p> - Combine your repository with a friend's repository, and share your files. diff --git a/templates/configurators/delete/xmpp.hamlet b/templates/configurators/delete/xmpp.hamlet deleted file mode 100644 index 92e3e6eb9b..0000000000 --- a/templates/configurators/delete/xmpp.hamlet +++ /dev/null @@ -1,12 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Disconnecting from Jabber - <p> - This won't delete the repository or repositories at the other end - of the Jabber connection, but it will disconnect from them, and stop - using Jabber. - <p> - <a .btn .btn-primary href="@{DisconnectXMPPR}"> - <span .glyphicon .glyphicon-minus> - \ Disconnect diff --git a/templates/configurators/main.hamlet b/templates/configurators/main.hamlet index dec5ad8048..339b92713b 100644 --- a/templates/configurators/main.hamlet +++ b/templates/configurators/main.hamlet @@ -27,16 +27,3 @@ Unused files <p> Configure what to do with old and deleted files. - <div .row> - <div .col-sm-4> - <h3> - <a href="@{XMPPConfigR}"> - Jabber account - $if xmppconfigured - <p> - Your jabber account is set up, and will be used to keep # - in touch with remote devices, and with your friends. - $else - <p> - Keep in touch with remote devices, and with your friends, # - by configuring a jabber account. diff --git a/templates/configurators/pairing/xmpp/end.hamlet b/templates/configurators/pairing/xmpp/end.hamlet deleted file mode 100644 index 68bf948160..0000000000 --- a/templates/configurators/pairing/xmpp/end.hamlet +++ /dev/null @@ -1,33 +0,0 @@ -<div .col-sm-9> - <div .content-box> - $if inprogress - <h2> - Pair request sent ... - <p> - $maybe name <- friend - A pair request has been sent to #{name}. Now it's up to them # - to accept it and finish pairing. - $nothing - A pair request has been sent to all other devices that # - have been configured to use your jabber account. # - It will be answered automatically by any devices that see it. - $else - Pair request accepted. - <h2> - Configure a shared cloud repository - $maybe name <- friend - <p> - ☂ To share files with #{name}, you'll need a repository in # - the cloud, that you both can access. - $nothing - <p> - ☂ To share files with your other devices, when they're not # - nearby, you'll need a repository in the cloud. - <p> - Make sure that your other devices are configured to access a # - cloud repository, and that the same repository is enabled here # - too. - ^{cloudRepoList} - <h2> - Add a cloud repository - ^{makeCloudRepositories} diff --git a/templates/configurators/pairing/xmpp/friend/confirm.hamlet b/templates/configurators/pairing/xmpp/friend/confirm.hamlet deleted file mode 100644 index 68ed9f6c2f..0000000000 --- a/templates/configurators/pairing/xmpp/friend/confirm.hamlet +++ /dev/null @@ -1,12 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Pair request received from #{name} - <p> - Pairing with #{name} will combine your two git annex # - repositories into one, allowing you to share files. - <p> - <a .btn .btn-primary .btn-lg href="@{FinishXMPPPairFriendR pairkey}"> - Accept pair request - <a .btn .btn-default .btn-lg href="@{DashboardR}"> - No thanks diff --git a/templates/configurators/pairing/xmpp/friend/prompt.hamlet b/templates/configurators/pairing/xmpp/friend/prompt.hamlet deleted file mode 100644 index 3410cb1285..0000000000 --- a/templates/configurators/pairing/xmpp/friend/prompt.hamlet +++ /dev/null @@ -1,13 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Share with a friend - <p> - You can combine your repository with a friend's repository # - to share your files. Your repositories will automatically be kept in # - sync. Only do this if you want your friend to see all the files # - in this repository! - <p> - Here are the friends currently available via your Jabber account. - <p> - ^{buddyListDisplay} diff --git a/templates/configurators/pairing/xmpp/self/prompt.hamlet b/templates/configurators/pairing/xmpp/self/prompt.hamlet deleted file mode 100644 index ec14e3596f..0000000000 --- a/templates/configurators/pairing/xmpp/self/prompt.hamlet +++ /dev/null @@ -1,21 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Sharing with your other devices - <p> - If you have multiple devices, all running git-annex, and using # - your Jabber account #{account}, you can configure them to share # - your files between themselves. - <p> - For example, you can have a computer at home, one at work, and a # - laptop, and their repositories will automatically be kept in sync. - <p> - Make sure your other devices are online and configured to use # - your Jabber account before continuing. Note that <b>all</b> # - repositories configured to use the same Jabber account will be # - combined together when you do this. - <p> - <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}"> - Start sharing with my other devices # - <a .btn .btn-default .btn-lg href="@{DashboardR}"> - Cancel diff --git a/templates/configurators/pairing/xmpp/self/retry.hamlet b/templates/configurators/pairing/xmpp/self/retry.hamlet deleted file mode 100644 index 8e6cacf7de..0000000000 --- a/templates/configurators/pairing/xmpp/self/retry.hamlet +++ /dev/null @@ -1,12 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Unable to get in touch with any other devices. - <p> - Make sure your other devices are online and configured to use # - your Jabber account before continuing. - <p> - <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}"> - Start sharing with my other devices # - <a .btn .btn-default .btn-lg href="@{DashboardR}"> - Cancel diff --git a/templates/configurators/xmpp.hamlet b/templates/configurators/xmpp.hamlet deleted file mode 100644 index 86269603a6..0000000000 --- a/templates/configurators/xmpp.hamlet +++ /dev/null @@ -1,43 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Configuring jabber account - <p> - A jabber account is used to communicate between # - devices that are not in direct contact. # - It can also be used to pair up with a friend's repository, if desired. - <p> - It's fine to reuse an existing jabber account; git-annex won't # - post any messages to it. - <p> - $maybe msg <- problem - <span .glyphicon .glyphicon-warning-sign> - \ Unable to connect to the Jabber server. # - Maybe you entered the wrong password? (Error message: #{msg}) - $nothing - <span .glyphicon .glyphicon-user> - \ If you have a Gmail account, you can use # - Google Talk. Just enter your full Gmail address # - <small>(<tt>you@gmail.com</tt>)</small> # - and password below. - <p> - <form method="post" .form-horizontal enctype=#{enctype}> - <fieldset> - ^{form} - ^{webAppFormAuthToken} - <div .form-group> - <div .col-sm-10 .col-sm-offset-2> - <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');"> - Use this account - \ - <a .btn .btn-default href="@{DisconnectXMPPR}"> - Stop using this account -<div .modal .fade #workingmodal> - <div .modal-dialog> - <div .modal-content> - <div .modal-header> - <h3> - Testing account ... - <div .modal-body> - <p> - Testing jabber account. This could take a minute. diff --git a/templates/configurators/xmpp/buddylist.hamlet b/templates/configurators/xmpp/buddylist.hamlet deleted file mode 100644 index 069f78ff4d..0000000000 --- a/templates/configurators/xmpp/buddylist.hamlet +++ /dev/null @@ -1,40 +0,0 @@ -<div ##{ident}> - <table .table> - <tbody> - $if null buddies - <tr> - <td> - $if isNothing myjid - Not connected to the jabber server. Check your network connection ... - $else - Searching... - $else - $forall (name, away, canpair, paired, buddyid) <- buddies - <tr> - <td> - $if isself buddyid - <span .glyphicon .glyphicon-star> # - <span :away:.text-muted> - your other devices - $else - <span .glyphicon .glyphicon-user> # - <span :away:.text-muted> - #{name} - <td> - $if away - <span .text-muted> - away - $else - $if paired - <span .label .label-success> - paired - $else - $if canpair - $if isself buddyid - <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairSelfR}"> - Start pairing - $else - <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairFriendR buddyid}"> - Start pairing - $else - not using git-annex diff --git a/templates/configurators/xmpp/disabled.hamlet b/templates/configurators/xmpp/disabled.hamlet deleted file mode 100644 index 75c46dee1c..0000000000 --- a/templates/configurators/xmpp/disabled.hamlet +++ /dev/null @@ -1,6 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - Jabber not supported - <p> - This build of git-annex does not support Jabber. Sorry! diff --git a/templates/configurators/xmpp/needcloudrepo.hamlet b/templates/configurators/xmpp/needcloudrepo.hamlet deleted file mode 100644 index ff4d4367e9..0000000000 --- a/templates/configurators/xmpp/needcloudrepo.hamlet +++ /dev/null @@ -1,18 +0,0 @@ -<div .col-sm-9> - <div .content-box> - <h2> - ☂ Configure a shared cloud repository - $maybe name <- buddyname - <p> - You and #{name} have combined your repositores. But you can't open # - each other's files yet. To start sharing files with #{name}, # - you need a repository in the cloud, that you both can access. - $nothing - <p> - You've combined the repositories on two or more of your devices. # - But files are not flowing yet. To start sharing files # - between your devices, you should set up a repository in the cloud. - ^{cloudRepoList} - <h2> - Add a cloud repository - ^{makeCloudRepositories} |
