summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-12-28 12:26:16 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-12-28 12:26:16 -0400
commit900c29071ad6b342be4eea00439fc355503ecbd2 (patch)
treed35adcadd1f063f1ae5b7205e82b845f18c8dd5f
parent7a15547943bf87131b13804c9337eec59f9b9350 (diff)
parent68f5d56115c2e4011b9a9be7c2585c1fe43f4957 (diff)
Merge branch 'no-xmpp'
-rw-r--r--Assistant.hs9
-rw-r--r--Assistant/DaemonStatus.hs6
-rw-r--r--Assistant/Monad.hs6
-rw-r--r--Assistant/NetMessager.hs180
-rw-r--r--Assistant/Sync.hs66
-rw-r--r--Assistant/Threads/Merger.hs26
-rw-r--r--Assistant/Threads/MountWatcher.hs2
-rw-r--r--Assistant/Threads/NetWatcher.hs9
-rw-r--r--Assistant/Threads/Pusher.hs4
-rw-r--r--Assistant/Threads/TransferScanner.hs2
-rw-r--r--Assistant/Threads/WebApp.hs3
-rw-r--r--Assistant/Threads/XMPPClient.hs375
-rw-r--r--Assistant/Threads/XMPPPusher.hs82
-rw-r--r--Assistant/Types/Buddies.hs80
-rw-r--r--Assistant/Types/DaemonStatus.hs8
-rw-r--r--Assistant/Types/NetMessager.hs155
-rw-r--r--Assistant/XMPP.hs275
-rw-r--r--Assistant/XMPP/Buddies.hs87
-rw-r--r--Assistant/XMPP/Client.hs83
-rw-r--r--Assistant/XMPP/Git.hs381
-rw-r--r--BuildFlags.hs5
-rw-r--r--CHANGELOG10
-rw-r--r--COPYRIGHT6
-rw-r--r--CmdLine/GitAnnex.hs6
-rw-r--r--Command/P2P.hs4
-rw-r--r--Command/XMPPGit.hs48
-rw-r--r--Makefile2
-rw-r--r--NEWS10
-rw-r--r--RemoteDaemon/Core.hs49
-rw-r--r--RemoteDaemon/Transport.hs2
-rw-r--r--RemoteDaemon/Transport/Tor.hs38
-rw-r--r--RemoteDaemon/Types.hs4
-rw-r--r--Utility/MagicWormhole.hs4
-rw-r--r--Utility/Tor.hs3
-rw-r--r--Utility/WebApp.hs1
-rw-r--r--debian/control3
-rw-r--r--doc/assistant.mdwn7
-rw-r--r--doc/assistant/local_pairing_walkthrough.mdwn4
-rw-r--r--doc/assistant/release_notes.mdwn8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_1_e0187b0a926904b363065ab0f850f0b2._comment10
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_2_dabcbc9aaf0bdb82716f5a5d55807a21._comment8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_4_978fab3cd165b4ca245e32fc48cf0970._comment8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_4_d7e879f7b098964040df2e27a18eda72._comment18
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_5_00852736d47c05772b15c5ff54ae7da7._comment8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_6_770c4f1802fc40d76bbaf7783bb3b4ac._comment14
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_7_61c1f5b00381b2fa891a8578267881ab._comment8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_8_35e00cd10e89ae4bcc66af7dadf6bb5c._comment8
-rw-r--r--doc/assistant/remote_sharing_walkthrough/comment_9_c900e4ef49388826c87cadef4235c073._comment8
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough.mdwn58
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough/buddylist.pngbin5114 -> 0 bytes
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough/comment_1_c87889721e3a7e52ac1ed3752fa7db46._comment8
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough/repolist.pngbin8525 -> 0 bytes
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough/xmppalert.pngbin4070 -> 0 bytes
-rw-r--r--doc/bugs/assistant_-_GTalk_collision.mdwn2
-rw-r--r--doc/bugs/problems_with_android_and_xmpp.mdwn2
-rw-r--r--doc/git-annex-xmppgit.mdwn23
-rw-r--r--doc/git-annex.mdwn20
-rw-r--r--doc/special_remotes/xmpp.mdwn43
-rw-r--r--doc/tips/peer_to_peer_network_with_tor.mdwn4
-rw-r--r--doc/todo/windows_support.mdwn41
-rw-r--r--doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn2
-rw-r--r--doc/todo/xmpp_removal.mdwn2
-rw-r--r--doc/videos/git-annex_assistant_remote_sharing.mdwn6
-rw-r--r--git-annex.cabal37
-rw-r--r--stack.yaml1
-rw-r--r--standalone/android/cabal.config1
-rw-r--r--standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch50
-rw-r--r--standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch43
-rwxr-xr-xstandalone/android/install-haskell-packages3
69 files changed, 171 insertions, 2318 deletions
diff --git a/Assistant.hs b/Assistant.hs
index 4dab6f162..ea9967610 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 6e11b923e..ce5f01e27 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 5662209c9..e52983915 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 dd1811141..000000000
--- 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 ff34c0656..702f1e98f 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 Remote
import qualified Types.Remote as Remote
import qualified Remote.List as Remote
@@ -39,7 +36,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.
@@ -50,21 +46,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) $
@@ -72,7 +61,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
@@ -81,7 +70,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
@@ -101,9 +90,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.
-
@@ -121,27 +107,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
@@ -151,11 +131,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
@@ -174,9 +150,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
@@ -194,10 +167,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]
@@ -221,15 +190,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')
@@ -239,9 +204,6 @@ manualPull currentbranch remotes = do
haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig
- u <- liftAnnex getUUID
- forM_ xmppremotes $ \r ->
- sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
return (catMaybes failed, haddiverged)
{- Start syncing a remote, using a background thread. -}
@@ -249,7 +211,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 ce0dfbcb4..0bb37e664 100644
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -10,19 +10,12 @@ module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
import Utility.DirWatcher
import Utility.DirWatcher.Types
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. -}
@@ -69,8 +62,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
@@ -90,22 +82,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 a741b731d..bd8d0e614 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 52f8db474..4dc8721b1 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 35989ed48..5b4055885 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 10aed20b0..a55a3496e 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 a5cd38504..dfb631bc6 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
@@ -37,6 +36,7 @@ import Assistant.WebApp.Documentation
import Assistant.WebApp.Control
import Assistant.WebApp.OtherRepos
import Assistant.WebApp.Repair
+import Assistant.WebApp.Pairing
import Assistant.Types.ThreadedMonad
import Utility.WebApp
import Utility.AuthToken
@@ -83,6 +83,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
<*> pure cannotrun
<*> pure noannex
<*> pure listenhost'
+ <*> newWormholePairingState
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp
app' <- ifM debugEnabled
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
deleted file mode 100644
index 2b68ecbe1..000000000
--- 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 bff17356d..000000000
--- 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 432440d2e..000000000
--- 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 0e52d3477..08e98d98e 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 da6682233..000000000
--- 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/XMPP.hs b/Assistant/XMPP.hs
deleted file mode 100644
index 52cd31939..000000000
--- 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 77eb3202f..000000000
--- a/Assistant/XMPP/Buddies.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{- xmpp buddies
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.XMPP.Buddies where
-
-import Assistant.XMPP
-import Annex.Common
-import Assistant.Types.Buddies
-
-import Network.Protocol.XMPP
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-
-genBuddyKey :: JID -> BuddyKey
-genBuddyKey j = BuddyKey $ formatJID $ baseJID j
-
-buddyName :: JID -> Text
-buddyName j = maybe (T.pack "") strNode (jidNode j)
-
-ucFirst :: Text -> Text
-ucFirst s = let (first, rest) = T.splitAt 1 s
- in T.concat [T.toUpper first, rest]
-
-{- Summary of info about a buddy.
- -
- - If the buddy has no clients at all anymore, returns Nothing. -}
-buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey)
-buddySummary pairedwith b = case clients of
- ((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j)
- [] -> Nothing
- where
- away = S.null (buddyPresent b) && S.null (buddyAssistants b)
- canpair = not $ S.null (buddyAssistants b)
- clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b
- alreadypaired j = baseJID j `elem` pairedwith
-
-{- Updates the buddies with XMPP presence info. -}
-updateBuddies :: Presence -> Buddies -> Buddies
-updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
- where
- key = genBuddyKey jid
- update (Just b) = Just $ applyPresence p b
- update Nothing = newBuddy p
-updateBuddies _ = id
-
-{- Creates a new buddy based on XMPP presence info. -}
-newBuddy :: Presence -> Maybe Buddy
-newBuddy p
- | presenceType p == PresenceAvailable = go
- | presenceType p == PresenceUnavailable = go
- | otherwise = Nothing
- where
- go = make <$> presenceFrom p
- make _jid = applyPresence p $ Buddy
- { buddyPresent = S.empty
- , buddyAway = S.empty
- , buddyAssistants = S.empty
- , buddyPairing = False
- }
-
-applyPresence :: Presence -> Buddy -> Buddy
-applyPresence p b = fromMaybe b $! go <$> presenceFrom p
- where
- go jid
- | presenceType p == PresenceUnavailable = b
- { buddyAway = addto $ buddyAway b
- , buddyPresent = removefrom $ buddyPresent b
- , buddyAssistants = removefrom $ buddyAssistants b
- }
- | hasGitAnnexTag p = b
- { buddyAssistants = addto $ buddyAssistants b
- , buddyAway = removefrom $ buddyAway b }
- | presenceType p == PresenceAvailable = b
- { buddyPresent = addto $ buddyPresent b
- , buddyAway = removefrom $ buddyAway b
- }
- | otherwise = b
- where
- client = Client jid
- removefrom = S.filter (/= client)
- addto = S.insert client
diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs
deleted file mode 100644
index 6d09d32e6..000000000
--- a/Assistant/XMPP/Client.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{- xmpp client support
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.XMPP.Client where
-
-import Assistant.Common
-import Utility.SRV
-import Creds
-
-import Network.Protocol.XMPP
-import Network
-import Control.Concurrent
-import qualified Data.Text as T
-
-{- Everything we need to know to connect to an XMPP server. -}
-data XMPPCreds = XMPPCreds
- { xmppUsername :: T.Text
- , xmppPassword :: T.Text
- , xmppHostname :: HostName
- , xmppPort :: Int
- , xmppJID :: T.Text
- }
- deriving (Read, Show)
-
-connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
-connectXMPP c a = case parseJID (xmppJID c) of
- Nothing -> error "bad JID"
- Just jid -> connectXMPP' jid c a
-
-{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
-connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
-connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord)
- where
- srvrecord = mkSRVTcp "xmpp-client" $
- T.unpack $ strDomain $ jidDomain jid
- serverjid = JID Nothing (jidDomain jid) Nothing
-
- handlesrv [] = do
- let h = xmppHostname c
- let p = PortNumber $ fromIntegral $ xmppPort c
- r <- run h p $ a jid
- return [r]
- handlesrv srvs = go [] srvs
-
- go l [] = return l
- go l ((h,p):rest) = do
- {- Try each SRV record in turn, until one connects,
- - at which point the MVar will be full. -}
- mv <- newEmptyMVar
- r <- run h p $ do
- liftIO $ putMVar mv ()
- a jid
- ifM (isEmptyMVar mv)
- ( go (r : l) rest
- , return (r : l)
- )
-
- {- Async exceptions are let through so the XMPP thread can
- - be killed. -}
- run h p a' = do
- r <- tryNonAsync $
- runClientError (Server serverjid h p) jid
- (xmppUsername c) (xmppPassword c) (void a')
- return ((h, p), r)
-
-{- XMPP runClient, that throws errors rather than returning an Either -}
-runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
-runClientError s j u p x = either (error . show) return =<< runClient s j u p x
-
-getXMPPCreds :: Annex (Maybe XMPPCreds)
-getXMPPCreds = parse <$> readCacheCreds xmppCredsFile
- where
- parse s = readish =<< s
-
-setXMPPCreds :: XMPPCreds -> Annex ()
-setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile
-
-xmppCredsFile :: FilePath
-xmppCredsFile = "xmpp"
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
deleted file mode 100644
index 612e0f2c5..000000000
--- a/Assistant/XMPP/Git.hs
+++ /dev/null
@@ -1,381 +0,0 @@
-{- git over XMPP
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE CPP #-}
-
-module Assistant.XMPP.Git where
-
-import Assistant.Common
-import Assistant.NetMessager
-import Assistant.Types.NetMessager
-import Assistant.XMPP
-import Assistant.XMPP.Buddies
-import Assistant.DaemonStatus
-import Assistant.Alert
-import Assistant.MakeRemote
-import Assistant.Sync
-import qualified Command.Sync
-import qualified Annex.Branch
-import Annex.Path
-import Annex.UUID
-import Logs.UUID
-import Annex.TaggedPush
-import Annex.CatFile
-import Config
-import Git
-import qualified Types.Remote as Remote
-import qualified Remote as Remote
-import Remote.List
-import Utility.FileMode
-import Utility.Shell
-import Utility.Env
-
-import Network.Protocol.XMPP
-import qualified Data.Text as T
-import System.Posix.Types
-import qualified System.Posix.IO
-import Control.Concurrent
-import System.Timeout
-import qualified Data.ByteString as B
-import qualified Data.Map as M
-
-{- Largest chunk of data to send in a single XMPP message. -}
-chunkSize :: Int
-chunkSize = 4096
-
-{- How long to wait for an expected message before assuming the other side
- - has gone away and canceling a push.
- -
- - This needs to be long enough to allow a message of up to 2+ times
- - chunkSize to propigate up to a XMPP server, perhaps across to another
- - server, and back down to us. On the other hand, other XMPP pushes can be
- - delayed for running until the timeout is reached, so it should not be
- - excessive.
- -}
-xmppTimeout :: Int
-xmppTimeout = 120000000 -- 120 seconds
-
-finishXMPPPairing :: JID -> UUID -> Assistant ()
-finishXMPPPairing jid u = void $ alertWhile alert $
- makeXMPPGitRemote buddy (baseJID jid) u
- where
- buddy = T.unpack $ buddyName jid
- alert = pairRequestAcknowledgedAlert buddy Nothing
-
-gitXMPPLocation :: JID -> String
-gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)
-
-makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
-makeXMPPGitRemote buddyname jid u = do
- remote <- liftAnnex $ addRemote $
- makeGitRemote buddyname $ gitXMPPLocation jid
- liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u
- liftAnnex $ void remoteListRefresh
- remote' <- liftAnnex $ fromMaybe (error "failed to add remote")
- <$> Remote.byName (Just buddyname)
- syncRemote remote'
- return True
-
-{- Pushes over XMPP, communicating with a specific client.
- - Runs an arbitrary IO action to push, which should run git-push with
- - an xmpp:: url.
- -
- - To handle xmpp:: urls, git push will run git-remote-xmpp, which is
- - injected into its PATH, and in turn runs git-annex xmppgit. The
- - dataflow them becomes:
- -
- - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
- - |
- - git receive-pack <--> xmppReceivePack <---------------> xmpp
- -
- - The pipe between git-annex xmppgit and us is set up and communicated
- - using two environment variables, relayIn and relayOut, that are set
- - to the file descriptors to use. Another, relayControl, is used to
- - propigate the exit status of git receive-pack.
- -
- - We listen at the other end of the pipe and relay to and from XMPP.
- -}
-xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
-xmppPush cid gitpush = do
- u <- liftAnnex getUUID
- sendNetMessage $ Pushing cid (StartingPush u)
-
- (Fd inf, writepush) <- liftIO System.Posix.IO.createPipe
- (readpush, Fd outf) <- liftIO System.Posix.IO.createPipe
- (Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe
-
- tmpdir <- gettmpdir
- installwrapper tmpdir
-
- environ <- liftIO getEnvironment
- path <- liftIO getSearchPath
- let myenviron = addEntries
- [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
- , (relayIn, show inf)
- , (relayOut, show outf)
- , (relayControl, show controlf)
- ]
- environ
-
- inh <- liftIO $ fdToHandle readpush
- outh <- liftIO $ fdToHandle writepush
- controlh <- liftIO $ fdToHandle writecontrol
-
- t1 <- forkIO <~> toxmpp 0 inh
- t2 <- forkIO <~> fromxmpp outh controlh
-
- {- This can take a long time to run, so avoid running it in the
- - Annex monad. Also, override environment. -}
- g <- liftAnnex gitRepo
- r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }
-
- liftIO $ do
- mapM_ killThread [t1, t2]
- mapM_ hClose [inh, outh, controlh]
- mapM_ closeFd [Fd inf, Fd outf, Fd controlf]
-
- return r
- where
- toxmpp seqnum inh = do
- b <- liftIO $ B.hGetSome inh chunkSize
- if B.null b
- then liftIO $ killThread =<< myThreadId
- else do
- let seqnum' = succ seqnum
- sendNetMessage $ Pushing cid $
- SendPackOutput seqnum' b
- toxmpp seqnum' inh
-
- fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg
- where
- handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) =
- liftIO $ writeChunk outh b
- handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) =
- liftIO $ do
- hPrint controlh exitcode
- hFlush controlh
- handlemsg (Just _) = noop
- handlemsg Nothing = do
- debug ["timeout waiting for git receive-pack output via XMPP"]
- -- Send a synthetic exit code to git-annex
- -- xmppgit, which will exit and cause git push
- -- to die.
- liftIO $ do
- hPrint controlh (ExitFailure 1)
- hFlush controlh
- killThread =<< myThreadId
-
- installwrapper tmpdir = liftIO $ do
- createDirectoryIfMissing True tmpdir
- let wrapper = tmpdir </> "git-remote-xmpp"
- program <- programPath
- writeFile wrapper $ unlines
- [ shebang_local
- , "exec " ++ program ++ " xmppgit"
- ]
- modifyFileMode wrapper $ addModes executeModes
-
- {- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp
- - dir (ie, not on a crippled filesystem where we can't make
- - the wrapper executable). -}
- gettmpdir = do
- v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
- case v of
- Nothing -> do
- tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir
- return $ tmp </> "xmppgit"
- Just d -> return $ d </> "xmppgit"
-
-type EnvVar = String
-
-envVar :: String -> EnvVar
-envVar s = "GIT_ANNEX_XMPPGIT_" ++ s
-
-relayIn :: EnvVar
-relayIn = envVar "IN"
-
-relayOut :: EnvVar
-relayOut = envVar "OUT"
-
-relayControl :: EnvVar
-relayControl = envVar "CONTROL"
-
-relayHandle :: EnvVar -> IO Handle
-relayHandle var = do
- v <- getEnv var
- case readish =<< v of
- Nothing -> error $ var ++ " not set"
- Just n -> fdToHandle $ Fd n
-
-{- Called by git-annex xmppgit.
- -
- - git-push is talking to us on stdin
- - we're talking to git-push on stdout
- - git-receive-pack is talking to us on relayIn (via XMPP)
- - we're talking to git-receive-pack on relayOut (via XMPP)
- - git-receive-pack's exit code will be passed to us on relayControl
- -}
-xmppGitRelay :: IO ()
-xmppGitRelay = do
- flip relay stdout =<< relayHandle relayIn
- relay stdin =<< relayHandle relayOut
- code <- hGetLine =<< relayHandle relayControl
- exitWith $ fromMaybe (ExitFailure 1) $ readish code
- where
- {- Is it possible to set up pipes and not need to copy the data
- - ourselves? See splice(2) -}
- relay fromh toh = void $ forkIO $ forever $ do
- b <- B.hGetSome fromh chunkSize
- when (B.null b) $ do
- hClose fromh
- hClose toh
- killThread =<< myThreadId
- writeChunk toh b
-
-{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
- - its exit status to XMPP. -}
-xmppReceivePack :: ClientID -> Assistant Bool
-xmppReceivePack cid = do
- repodir <- liftAnnex $ fromRepo repoPath
- let p = (proc "git" ["receive-pack", repodir])
- { std_in = CreatePipe
- , std_out = CreatePipe
- , std_err = Inherit
- }
- (Just inh, Just outh, _, pid) <- liftIO $ createProcess p
- readertid <- forkIO <~> relayfromxmpp inh
- relaytoxmpp 0 outh
- code <- liftIO $ waitForProcess pid
- void $ sendNetMessage $ Pushing cid $ ReceivePackDone code
- liftIO $ do
- killThread readertid
- hClose inh
- hClose outh
- return $ code == ExitSuccess
- where
- relaytoxmpp seqnum outh = do
- b <- liftIO $ B.hGetSome outh chunkSize
- -- empty is EOF, so exit
- unless (B.null b) $ do
- let seqnum' = succ seqnum
- sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b
- relaytoxmpp seqnum' outh
- relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg
- where
- handlemsg (Just (Pushing _ (SendPackOutput _ b))) =
- liftIO $ writeChunk inh b
- handlemsg (Just _) = noop
- handlemsg Nothing = do
- debug ["timeout waiting for git send-pack output via XMPP"]
- -- closing the handle will make git receive-pack exit
- liftIO $ do
- hClose inh
- killThread =<< myThreadId
-
-xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
-xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
- Nothing -> return []
- Just jid -> do
- let loc = gitXMPPLocation jid
- um <- liftAnnex uuidMap
- filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes
- <$> getDaemonStatus
- where
- matching loc r = repoIsUrl r && repoLocation r == loc
- knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
-
-{- Returns the ClientID that it pushed to. -}
-runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
-runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
- go =<< liftAnnex (join Command.Sync.getCurrBranch)
- where
- go (Just branch, _) = do
- rs <- xmppRemotes cid theiruuid
- liftAnnex $ Annex.Branch.commit "update"
- (g, u) <- liftAnnex $ (,)
- <$> gitRepo
- <*> getUUID
- liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g
- selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
- if null rs
- then return Nothing
- else do
- forM_ rs $ \r -> do
- void $ alertWhile (syncAlert [r]) $
- xmppPush cid (taggedPush u selfjid branch r)
- checkcloudrepos r
- return $ Just cid
- go _ = return Nothing
-runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
- rs <- xmppRemotes cid theiruuid
- if null rs
- then return Nothing
- else do
- void $ alertWhile (syncAlert rs) $
- xmppReceivePack cid
- mapM_ checkcloudrepos rs
- return $ Just cid
-runPush _ _ = return Nothing
-
-{- Check if any of the shas that can be pushed are ones we do not
- - have.
- -
- - (Older clients send no shas, so when there are none, always
- - request a push.)
- -}
-handlePushNotice :: NetMessage -> Assistant ()
-handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
- unlessM (null <$> xmppRemotes cid theiruuid) $
- if null shas
- then go
- else ifM (haveall shas)
- ( debug ["ignoring CanPush with known shas"]
- , go
- )
- where
- go = do
- u <- liftAnnex getUUID
- sendNetMessage $ Pushing cid (PushRequest u)
- haveall l = liftAnnex $ not <$> anyM donthave l
- donthave sha = isNothing <$> catObjectDetails sha
-handlePushNotice _ = noop
-
-writeChunk :: Handle -> B.ByteString -> IO ()
-writeChunk h b = do
- B.hPut h b
- hFlush h
-
-{- Gets NetMessages for a PushSide, ensures they are in order,
- - and runs an action to handle each in turn. The action will be passed
- - Nothing on timeout.
- -
- - Does not currently reorder messages, but does ensure that any
- - duplicate messages, or messages not in the sequence, are discarded.
- -}
-withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()
-withPushMessagesInSequence cid side a = loop 0
- where
- loop seqnum = do
- m <- timeout xmppTimeout <~> waitInbox cid side
- let go s = a m >> loop s
- let next = seqnum + 1
- case extractSequence =<< m of
- Just seqnum'
- | seqnum' == next -> go next
- | seqnum' == 0 -> go seqnum
- | seqnum' == seqnum -> do
- debug ["ignoring duplicate sequence number", show seqnum]
- loop seqnum
- | otherwise -> do
- debug ["ignoring out of order sequence number", show seqnum', "expected", show next]
- loop seqnum
- Nothing -> go seqnum
-
-extractSequence :: NetMessage -> Maybe Int
-extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum
-extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum
-extractSequence _ = Nothing
diff --git a/BuildFlags.hs b/BuildFlags.hs
index 3a737589f..68dfabbe8 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/CHANGELOG b/CHANGELOG
index 7a0ca2eb2..985b9965c 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,7 +1,13 @@
-git-annex (6.20161211) UNRELEASED; urgency=medium
+git-annex (6.20170101) UNRELEASED; urgency=medium
- * p2p --pair makes it easy to pair repositories over P2P, using
+ * XMPP support has been removed from the assistant in this release.
+ If your repositories used XMPP to keep in sync, that will no longer
+ work, and you should enable some other remote to keep them in sync.
+ A ssh server is one way, or use the new Tor pairing feature.
+ * p2p --pair makes it easy to pair repositories, using
Magic Wormhole codes to find the other repository.
+ * webapp: The "Share with a friend" and "Share with your other devices"
+ pages have been changed to pair repositories using Tor and Magic Wormhole.
* metadata --batch: Fix bug when conflicting metadata changes were
made in the same batch run.
* Pass annex.web-options to wget and curl after other options, so that
diff --git a/COPYRIGHT b/COPYRIGHT
index b7e3e402d..8f677610d 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -2,11 +2,11 @@ Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
Source: native package
Files: *
-Copyright: © 2010-2016 Joey Hess <id@joeyh.name>
+Copyright: © 2010-2017 Joey Hess <id@joeyh.name>
License: GPL-3+
Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*
-Copyright: © 2012-2016 Joey Hess <id@joeyh.name>
+Copyright: © 2012-2017 Joey Hess <id@joeyh.name>
© 2014 Sören Brunk
License: AGPL-3+
@@ -21,7 +21,7 @@ Copyright: 2011 Bas van Dijk & Roel van Dijk
License: BSD-2-clause
Files: Utility/*
-Copyright: 2012-2016 Joey Hess <id@joeyh.name>
+Copyright: 2012-2017 Joey Hess <id@joeyh.name>
License: BSD-2-clause
Files: Utility/Gpg.hs Utility/DirWatcher*
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs
index a12366b74..394bd173b 100644
--- a/CmdLine/GitAnnex.hs
+++ b/CmdLine/GitAnnex.hs
@@ -109,9 +109,6 @@ import qualified Command.Assistant
#ifdef WITH_WEBAPP
import qualified Command.WebApp
#endif
-#ifdef WITH_XMPP
-import qualified Command.XMPPGit
-#endif
#endif
import qualified Command.Test
#ifdef WITH_TESTSUITE
@@ -218,9 +215,6 @@ cmds testoptparser testrunner =
#ifdef WITH_WEBAPP
, Command.WebApp.cmd
#endif
-#ifdef WITH_XMPP
- , Command.XMPPGit.cmd
-#endif
#endif
, Command.Test.cmd testoptparser testrunner
#ifdef WITH_TESTSUITE
diff --git a/Command/P2P.hs b/Command/P2P.hs
index 4ba3e43d5..b70e3e2b7 100644
--- a/Command/P2P.hs
+++ b/Command/P2P.hs
@@ -168,10 +168,10 @@ performPairing remotename addrs = do
putStrLn "Exchanging pairing data..."
return code
| otherwise -> do
- putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository."
+ putStrLn "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository."
getcode ourcode
Nothing -> do
- putStrLn "That does not look like a valid code. Try again..."
+ putStrLn "That does not look like a valiad pairing code. Try again..."
getcode ourcode
-- We generate half of the authtoken; the pair will provide
diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs
deleted file mode 100644
index 0a7178df8..000000000
--- 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
diff --git a/Makefile b/Makefile
index 56e725db2..2b9fabb51 100644
--- a/Makefile
+++ b/Makefile
@@ -283,7 +283,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/NEWS b/NEWS
index 1266bae20..0e3db783f 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,13 @@
+git-annex (6.20170101) unstable; urgency=low
+
+ XMPP support has been removed from the assistant in this release.
+
+ If your repositories used XMPP to keep in sync, that will no longer
+ work, and you should enable some other remote to keep them in sync.
+ A ssh server is one way, or use the new Tor pairing feature.
+
+ -- Joey Hess <id@joeyh.name> Tue, 27 Dec 2016 16:37:46 -0400
+
git-annex (4.20131002) unstable; urgency=low
The layout of gcrypt repositories has changed, and
diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index 2166c2b7a..a3e4e6400 100644
--- a/RemoteDaemon/Core.hs
+++ b/RemoteDaemon/Core.hs
@@ -74,12 +74,13 @@ runController :: TChan Consumed -> TChan Emitted -> IO ()
runController ichan ochan = do
h <- genTransportHandle
m <- genRemoteMap h ochan
- startrunning m
- mapM_ (\s -> async (s h)) remoteServers
- go h False m
+ starttransports m
+ serverchans <- mapM (startserver h) remoteServers
+ go h False m serverchans
where
- go h paused m = do
+ go h paused m serverchans = do
cmd <- atomically $ readTChan ichan
+ broadcast cmd serverchans
case cmd of
RELOAD -> do
h' <- updateTransportHandle h
@@ -87,36 +88,42 @@ runController ichan ochan = do
let common = M.intersection m m'
let new = M.difference m' m
let old = M.difference m m'
- broadcast STOP old
+ broadcast STOP (mchans old)
unless paused $
- startrunning new
- go h' paused (M.union common new)
+ starttransports new
+ go h' paused (M.union common new) serverchans
LOSTNET -> do
-- force close all cached ssh connections
-- (done here so that if there are multiple
-- ssh remotes, it's only done once)
liftAnnex h forceSshCleanup
- broadcast LOSTNET m
- go h True m
+ broadcast LOSTNET transportchans
+ go h True m serverchans
PAUSE -> do
- broadcast STOP m
- go h True m
+ broadcast STOP transportchans
+ go h True m serverchans
RESUME -> do
when paused $
- startrunning m
- go h False m
+ starttransports m
+ go h False m serverchans
STOP -> exitSuccess
-- All remaining messages are sent to
-- all Transports.
msg -> do
- unless paused $ atomically $
- forM_ chans (`writeTChan` msg)
- go h paused m
+ unless paused $
+ broadcast msg transportchans
+ go h paused m serverchans
where
- chans = map snd (M.elems m)
+ transportchans = mchans m
+ mchans = map snd . M.elems
+
+ startserver h server = do
+ c <- newTChanIO
+ void $ async $ server c h
+ return c
- startrunning m = forM_ (M.elems m) startrunning'
- startrunning' (transport, c) = do
+ starttransports m = forM_ (M.elems m) starttransports'
+ starttransports' (transport, c) = do
-- drain any old control messages from the channel
-- to avoid confusing the transport with them
atomically $ drain c
@@ -124,9 +131,7 @@ runController ichan ochan = do
drain c = maybe noop (const $ drain c) =<< tryReadTChan c
- broadcast msg m = atomically $ forM_ (M.elems m) send
- where
- send (_, c) = writeTChan c msg
+ broadcast msg cs = atomically $ forM_ cs $ \c -> writeTChan c msg
-- Generates a map with a transport for each supported remote in the git repo,
-- except those that have annex.sync = false
diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs
index 053973424..231173a76 100644
--- a/RemoteDaemon/Transport.hs
+++ b/RemoteDaemon/Transport.hs
@@ -26,5 +26,5 @@ remoteTransports = M.fromList
, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport)
]
-remoteServers :: [TransportHandle -> IO ()]
+remoteServers :: [Server]
remoteServers = [RemoteDaemon.Transport.Tor.server]
diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs
index e7d3794d6..2a2ceccca 100644
--- a/RemoteDaemon/Transport/Tor.hs
+++ b/RemoteDaemon/Transport/Tor.hs
@@ -34,14 +34,25 @@ import Control.Concurrent.STM.TBMQueue
import Control.Concurrent.Async
-- Run tor hidden service.
-server :: TransportHandle -> IO ()
-server th@(TransportHandle (LocalRepo r) _) = do
- u <- liftAnnex th getUUID
- uid <- getRealUserID
- let ident = fromUUID u
- go u =<< getHiddenServiceSocketFile torAppName uid ident
+server :: Server
+server ichan th@(TransportHandle (LocalRepo r) _) = go
where
- go u (Just sock) = do
+ go = checkstartservice >>= handlecontrol
+
+ checkstartservice = do
+ u <- liftAnnex th getUUID
+ uid <- getRealUserID
+ let ident = fromUUID u
+ msock <- getHiddenServiceSocketFile torAppName uid ident
+ case msock of
+ Nothing -> do
+ debugM "remotedaemon" "Tor hidden service not enabled"
+ return False
+ Just sock -> do
+ void $ async $ startservice sock u
+ return True
+
+ startservice sock u = do
q <- newTBMQueueIO maxConnections
replicateM_ maxConnections $
forkIO $ forever $ serveClient th u r q
@@ -57,7 +68,18 @@ server th@(TransportHandle (LocalRepo r) _) = do
unless ok $ do
hClose conn
warningIO "dropped Tor connection, too busy"
- go _ Nothing = debugM "remotedaemon" "Tor hidden service not enabled"
+
+ handlecontrol servicerunning = do
+ msg <- atomically $ readTChan ichan
+ case msg of
+ -- On reload, the configuration may have changed to
+ -- enable the tor hidden service. If it was not
+ -- enabled before, start it,
+ RELOAD | not servicerunning -> go
+ -- We can ignore all other messages; no need
+ -- to restart the hidden service when the network
+ -- changes as tor takes care of all that.
+ _ -> handlecontrol servicerunning
-- How many clients to serve at a time, maximum. This is to avoid DOS attacks.
maxConnections :: Int
diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs
index c0d74e038..bc0fc1c0e 100644
--- a/RemoteDaemon/Types.hs
+++ b/RemoteDaemon/Types.hs
@@ -28,6 +28,10 @@ newtype RemoteURI = RemoteURI URI
-- from a Chan, and emits others to another Chan.
type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> TChan Consumed -> TChan Emitted -> IO ()
+-- A server for a Transport consumes some messages from a Chan in
+-- order to learn about network changes, reloads, etc.
+type Server = TChan Consumed -> TransportHandle -> IO ()
+
data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig
newtype LocalRepo = LocalRepo Git.Repo
diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs
index e217dcdca..3743f352c 100644
--- a/Utility/MagicWormhole.hs
+++ b/Utility/MagicWormhole.hs
@@ -78,7 +78,7 @@ mkCodeProducer :: IO CodeProducer
mkCodeProducer = CodeProducer <$> newEmptyMVar
waitCode :: CodeObserver -> IO Code
-waitCode (CodeObserver o) = takeMVar o
+waitCode (CodeObserver o) = readMVar o
sendCode :: CodeProducer -> Code -> IO ()
sendCode (CodeProducer p) = putMVar p
@@ -119,7 +119,7 @@ sendFile f (CodeObserver observer) ps = do
-- read from the CodeProducer, and fed to wormhole on stdin.
receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do
- Code c <- takeMVar producer
+ Code c <- readMVar producer
hPutStrLn hin c
hFlush hin
return True
diff --git a/Utility/Tor.hs b/Utility/Tor.hs
index 4e7c0ef43..37fbabd40 100644
--- a/Utility/Tor.hs
+++ b/Utility/Tor.hs
@@ -161,3 +161,6 @@ torLibDir = "/var/lib/tor"
varLibDir :: FilePath
varLibDir = "/var/lib"
+
+torIsInstalled :: IO Bool
+torIsInstalled = inPath "tor"
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index a90772b10..a00a5caf2 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -84,7 +84,6 @@ fixSockAddr addr = addr
-- disable buggy sloworis attack prevention code
webAppSettings :: Settings
-
webAppSettings = setTimeout halfhour defaultSettings
where
halfhour = 30 * 60
diff --git a/debian/control b/debian/control
index b64f3e3be..ee2813e9e 100644
--- a/debian/control
+++ b/debian/control
@@ -60,9 +60,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-free-dev,
diff --git a/doc/assistant.mdwn b/doc/assistant.mdwn
index 2ed35d6df..36d4f52f8 100644
--- a/doc/assistant.mdwn
+++ b/doc/assistant.mdwn
@@ -21,11 +21,8 @@ instructions.
* [[Android documentation|/Android]]
* Want to make two nearby computers share the same synchronised folder?
Follow the [[local_pairing_walkthrough]].
-* 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 share files 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/local_pairing_walkthrough.mdwn b/doc/assistant/local_pairing_walkthrough.mdwn
index f6282ec28..c0a760ef5 100644
--- a/doc/assistant/local_pairing_walkthrough.mdwn
+++ b/doc/assistant/local_pairing_walkthrough.mdwn
@@ -76,8 +76,8 @@ computers are on the same network. If you go on a trip, any files you
edit will not be visible to your friend until you get back.
To get around this, you'll often also want to set up
-[[jabber_pairing|share_with_a_friend_walkthrough]], and a server
-in the cloud, which they can use to exchange files while away.
+[[tor_pairing|share_with_a_friend_walkthrough]] too,
+which they can use to exchange files while away.
And also, you can pair with as many other computers as you like, not just
one!
diff --git a/doc/assistant/release_notes.mdwn b/doc/assistant/release_notes.mdwn
index 52749dda7..6c7c432de 100644
--- a/doc/assistant/release_notes.mdwn
+++ b/doc/assistant/release_notes.mdwn
@@ -1,3 +1,11 @@
+## version 6.20170101
+
+XMPP support has been removed from the assistant in this release.
+
+If your repositories used XMPP to keep in sync, that will no longer
+work, and you should enable some other remote to keep them in sync.
+A ssh server is one way, or use the new Tor pairing feature.
+
## version 5.20140421
This release begins to deprecate XMPP support. In particular, if you use
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_1_e0187b0a926904b363065ab0f850f0b2._comment b/doc/assistant/remote_sharing_walkthrough/comment_1_e0187b0a926904b363065ab0f850f0b2._comment
deleted file mode 100644
index cac5295a7..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_1_e0187b0a926904b363065ab0f850f0b2._comment
+++ /dev/null
@@ -1,10 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmG4rlD9k1ezNkYZ8jDbITrycUmHV-P8Qs"
- nickname="Jeroen"
- subject="Synced vs. unsynced"
- date="2013-07-29T18:07:45Z"
- content="""
-I've noticed that it is also possible to add an existing annex folder on a remote server without using syncing. Are there any dangers in doing this?
-
-Could you explain what syncing does and when it is needed? Thanks.
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_2_dabcbc9aaf0bdb82716f5a5d55807a21._comment b/doc/assistant/remote_sharing_walkthrough/comment_2_dabcbc9aaf0bdb82716f5a5d55807a21._comment
deleted file mode 100644
index b99d9e22b..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_2_dabcbc9aaf0bdb82716f5a5d55807a21._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="4.154.0.21"
- subject="comment 2"
- date="2013-07-30T18:08:38Z"
- content="""
-I'm afraid I don't quite understand the question.
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_4_978fab3cd165b4ca245e32fc48cf0970._comment b/doc/assistant/remote_sharing_walkthrough/comment_4_978fab3cd165b4ca245e32fc48cf0970._comment
deleted file mode 100644
index ab0b19160..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_4_978fab3cd165b4ca245e32fc48cf0970._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="209.250.56.246"
- subject="comment 4"
- date="2013-11-12T18:18:16Z"
- content="""
-You can easily use a removable drive as a transfer repository to sync two computers that have no network connection. Just use the webapp to add the drive on one computer. The drive will be set up as a transfer repository by default. The webapp will automatically start copying all your files to it. Then you can disconnect the drive, bring it to the other computer, and repeat the process. Everything from the first computer will then sync over from the drive to the second computer. And repeat moving the drive back and forth to keep things in sync.
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_4_d7e879f7b098964040df2e27a18eda72._comment b/doc/assistant/remote_sharing_walkthrough/comment_4_d7e879f7b098964040df2e27a18eda72._comment
deleted file mode 100644
index 71f57e9b3..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_4_d7e879f7b098964040df2e27a18eda72._comment
+++ /dev/null
@@ -1,18 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmkXtBdMgE1d9nCz2iBc4f85xh4izZ_auU"
- nickname="Ulrich"
- subject="Using a portable drive as another transfer device?"
- date="2013-11-12T16:52:12Z"
- content="""
-I try to understand how to setup git-annex for the following use case:
-
-Two computers, that are paired via remote sharing, using some cloud repository for transfer, and a local NAS for backups.
-
-These two computers are sometimes in the same network, sometimes in different networks, and sometimes even without network at all. From what I read, it should be possible to bypass the cloud when these two machines are on the same network, which sounds great.
-
-Would it be possible to use a portable drive as \"another link\" between these two computers that can be used to sync them even if there is no network between them?
-
-And as you write, if the pairing has been set up manually, then everything is fine - so could it be that it is really easy and only necessary to setup the git-annex on the local drive as an additional remote on both (or only one?) machine?
-
-thanks for any insight!
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_5_00852736d47c05772b15c5ff54ae7da7._comment b/doc/assistant/remote_sharing_walkthrough/comment_5_00852736d47c05772b15c5ff54ae7da7._comment
deleted file mode 100644
index a66fcd098..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_5_00852736d47c05772b15c5ff54ae7da7._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawmkXtBdMgE1d9nCz2iBc4f85xh4izZ_auU"
- nickname="Ulrich"
- subject="Using a portable drive as another transfer device? – cool."
- date="2013-11-14T19:05:56Z"
- content="""
-Thanks - I was hoping that it is that easy. I'll try that as soon as I have a working version of the latest git-annex (trying to build with brew for Mac OS X 10.9, but without success so far).
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_6_770c4f1802fc40d76bbaf7783bb3b4ac._comment b/doc/assistant/remote_sharing_walkthrough/comment_6_770c4f1802fc40d76bbaf7783bb3b4ac._comment
deleted file mode 100644
index 69ae139b2..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_6_770c4f1802fc40d76bbaf7783bb3b4ac._comment
+++ /dev/null
@@ -1,14 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="88.182.182.135"
- subject="git-assistant and transfer repository"
- date="2014-03-16T17:05:43Z"
- content="""
-In your comment http://git-annex.branchable.com/assistant/remote_sharing_walkthrough/#comment-f97efe1d05c0101232684b4e4edc4866, you describe a way to synchronize two devices using an intermediate USB drive configured as a \"transfer repository\".
-
-I understand that in that case, the USB drive can only be used as a \"transmitter\", in a git repository form, not as a copy of the files structure. This means the files contained by the USB drive cannot be accessed without git/git-annnex.
-
-Is there a way to use the USB drive as a \"client repository\" in order to allow synchronization, as described earlier, but also as a simple copy of the files, in order to access them from any device (opening them with windows in a cyber coffee for example).
-
-Thanks
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_7_61c1f5b00381b2fa891a8578267881ab._comment b/doc/assistant/remote_sharing_walkthrough/comment_7_61c1f5b00381b2fa891a8578267881ab._comment
deleted file mode 100644
index e34a462da..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_7_61c1f5b00381b2fa891a8578267881ab._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="http://joeyh.name/"
- ip="209.250.56.154"
- subject="comment 7"
- date="2014-03-17T19:50:48Z"
- content="""
-@severo the web app does not support setting up that use case. However, you can make a non-bare clone of your repository onto a removable drive, and if you do the assistant will use it just the same as if you'd set up a removable drive using the webapp. Note that you will need to run `git annex sync` inside that repository in order to update the tree it displays.
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_8_35e00cd10e89ae4bcc66af7dadf6bb5c._comment b/doc/assistant/remote_sharing_walkthrough/comment_8_35e00cd10e89ae4bcc66af7dadf6bb5c._comment
deleted file mode 100644
index 994d969e6..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_8_35e00cd10e89ae4bcc66af7dadf6bb5c._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="95.152.107.168"
- subject="comment 8"
- date="2014-03-18T10:06:50Z"
- content="""
-Thansk @joeyh.name for your answer. Do you think this feature could be integrated into the git-annex assistant ?
-"""]]
diff --git a/doc/assistant/remote_sharing_walkthrough/comment_9_c900e4ef49388826c87cadef4235c073._comment b/doc/assistant/remote_sharing_walkthrough/comment_9_c900e4ef49388826c87cadef4235c073._comment
deleted file mode 100644
index 1766fcf63..000000000
--- a/doc/assistant/remote_sharing_walkthrough/comment_9_c900e4ef49388826c87cadef4235c073._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="severo"
- ip="95.152.107.168"
- subject="comment 9"
- date="2014-03-18T11:16:19Z"
- content="""
-Some explanations in French on how to do: http://seenthis.net/messages/237648#message238202
-"""]]
diff --git a/doc/assistant/share_with_a_friend_walkthrough.mdwn b/doc/assistant/share_with_a_friend_walkthrough.mdwn
index 38544d111..e820a6862 100644
--- a/doc/assistant/share_with_a_friend_walkthrough.mdwn
+++ b/doc/assistant/share_with_a_friend_walkthrough.mdwn
@@ -1,9 +1,10 @@
-Want to share all the files in your repository with a friend?
+Want to share all the files in your repository securely 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.)
+This connects to your friend's repository using
+[Tor](https://torproject.org/). Both you and your friend will need to
+install [Tor](https://torproject.org/) and
+[Magic Wormhole](https://github.com/warner/magic-wormhole), and then both
+follow these steps to connect your repositories.
Start by opening up your git annex dashboard.
@@ -15,44 +16,21 @@ Start by opening up your git annex dashboard.
`*click*`
-[[!img xmpp.png alt="Configuring Jabber account"]]
+[[!img enabletor.png alt="Enabling tor hidden service"]]
-Fill that out, and git-annex will be able to show you a list of your
-friends.
+You will probably be prompted to enter a password, to configure Tor.
+(Depending on how your system is configured, this may be the root password,
+or your user account's password.)
-[[!img buddylist.png alt="Buddy list"]]
+[[!img wormholepairing.png alt="Pairing with a friend form"]]
-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.
+A pairing code will be generated. Tell it to your friend. Ask them
+for their pairing code, and enter it in the form.
-(If your friend is not using git-annex yet, now's a great time to spread
-the word!)
+Once you've exchanged pairing codes, your repositories will be connected
+over Tor. They will begin to sync files back and forth, which can take a
+while since Tor is not super-fast.
-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!
+See [[tips/peer_to_peer_network_with_tor]] for more details.
diff --git a/doc/assistant/share_with_a_friend_walkthrough/buddylist.png b/doc/assistant/share_with_a_friend_walkthrough/buddylist.png
deleted file mode 100644
index ce3d61a96..000000000
--- a/doc/assistant/share_with_a_friend_walkthrough/buddylist.png
+++ /dev/null
Binary files differ
diff --git a/doc/assistant/share_with_a_friend_walkthrough/comment_1_c87889721e3a7e52ac1ed3752fa7db46._comment b/doc/assistant/share_with_a_friend_walkthrough/comment_1_c87889721e3a7e52ac1ed3752fa7db46._comment
deleted file mode 100644
index 527ac9ce8..000000000
--- a/doc/assistant/share_with_a_friend_walkthrough/comment_1_c87889721e3a7e52ac1ed3752fa7db46._comment
+++ /dev/null
@@ -1,8 +0,0 @@
-[[!comment format=mdwn
- username="https://www.google.com/accounts/o8/id?id=AItOawl6RDLuI2b2fHkTRseVQGUNjcQ2qUrOaE0"
- nickname="Фёдор"
- subject="comment 1"
- date="2014-05-25T15:10:34Z"
- content="""
-Do we need a cloud repository just to bypass NAT? I understand it can't share files within Jabber, but it just looks unpolished. Maybe some punching techniques might be handy, pwnat for example.
-"""]]
diff --git a/doc/assistant/share_with_a_friend_walkthrough/repolist.png b/doc/assistant/share_with_a_friend_walkthrough/repolist.png
deleted file mode 100644
index 409da4aa4..000000000
--- a/doc/assistant/share_with_a_friend_walkthrough/repolist.png
+++ /dev/null
Binary files differ
diff --git a/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png b/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png
deleted file mode 100644
index 5e2d56289..000000000
--- a/doc/assistant/share_with_a_friend_walkthrough/xmppalert.png
+++ /dev/null
Binary files differ
diff --git a/doc/bugs/assistant_-_GTalk_collision.mdwn b/doc/bugs/assistant_-_GTalk_collision.mdwn
index b814166ae..a950dcdbc 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 0b05c94bb..73ceab7b3 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 76ae81cb4..000000000
--- 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 d0cc31019..ca1ac3620 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -385,12 +385,6 @@ subdirectories).
See [[git-annex-repair]](1) for details.
-* `remotedaemon`
-
- Persistent communication with remotes.
-
- See [[git-annex-remotedaemon]](1) for details.
-
* `p2p`
Configure peer-2-Peer links between repositories.
@@ -670,12 +664,11 @@ subdirectories).
See [[git-annex-smudge]](1) for details.
-* `xmppgit`
+* `remotedaemon`
- This command is used internally by the assistant to perform git pulls
- over XMPP.
-
- See [[git-annex-xmppgit]](1) for details.
+ Detects when network remotes have received git pushes and fetches from them.
+
+ See [[git-annex-remotedaemon]](1) for details.
# TESTING COMMANDS
@@ -1308,11 +1301,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 0f1c93b25..3e9d66a1f 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. Use [[tor]] instead.
diff --git a/doc/tips/peer_to_peer_network_with_tor.mdwn b/doc/tips/peer_to_peer_network_with_tor.mdwn
index 0fdc34625..f825c7f89 100644
--- a/doc/tips/peer_to_peer_network_with_tor.mdwn
+++ b/doc/tips/peer_to_peer_network_with_tor.mdwn
@@ -21,6 +21,10 @@ connect them together over Tor so they share their contents. Or, you and a
friend want to connect your repositories together. Pairing is an easy way
to accomplish this.
+(The instructions below use the command line. If you or your friend would
+rather avoid using the command line, follow the
+[[share_with_a_friend_walkthrough]].)
+
In each git-annex repository, run these commands:
git annex enable-tor
diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn
index 4606f7f40..d45e9a821 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 96552eecc..83f75bb93 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 c517c33f9..373c16ca1 100644
--- a/doc/todo/xmpp_removal.mdwn
+++ b/doc/todo/xmpp_removal.mdwn
@@ -25,3 +25,5 @@ The [[no-xmpp]] branch is ready for merging.
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/doc/videos/git-annex_assistant_remote_sharing.mdwn b/doc/videos/git-annex_assistant_remote_sharing.mdwn
deleted file mode 100644
index 6d9a97e8e..000000000
--- a/doc/videos/git-annex_assistant_remote_sharing.mdwn
+++ /dev/null
@@ -1,6 +0,0 @@
-<video controls width=400>
-<source src="https://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">
-</video><br>
-A <a href="https://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">6 minute screencast</a>
-showing how to share files between your computers in different locations,
-such as home and work.
diff --git a/git-annex.cabal b/git-annex.cabal
index 81a6ac3ad..b58f40e32 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -137,7 +137,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/git-remote-tor-annex.mdwn
doc/logo.svg
doc/logo_16x16.png
@@ -198,13 +197,9 @@ Extra-Source-Files:
templates/configurators/enablewebdav.hamlet
templates/configurators/pairing/local/inprogress.hamlet
templates/configurators/pairing/local/prompt.hamlet
+ templates/configurators/pairing/wormhole/prompt.hamlet
+ templates/configurators/pairing/wormhole/start.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
@@ -226,19 +221,20 @@ 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/addrepository/wormholepairing.hamlet
templates/configurators/rsync.net/add.hamlet
templates/configurators/rsync.net/encrypt.hamlet
templates/configurators/gitlab.com/add.hamlet
templates/configurators/needgcrypt.hamlet
+ templates/configurators/needtor.hamlet
+ templates/configurators/needmagicwormhole.hamlet
templates/configurators/enabledirectory.hamlet
templates/configurators/fsck/status.hamlet
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
@@ -246,9 +242,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
@@ -308,9 +301,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/
@@ -481,11 +471,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
@@ -580,7 +565,6 @@ Executable git-annex
Assistant.MakeRemote
Assistant.Monad
Assistant.NamedThread
- Assistant.NetMessager
Assistant.Pairing
Assistant.Pairing.MakeRemote
Assistant.Pairing.Network
@@ -613,20 +597,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
@@ -654,7 +634,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
@@ -664,15 +643,12 @@ Executable git-annex
Assistant.WebApp.Notifications
Assistant.WebApp.OtherRepos
Assistant.WebApp.Page
+ Assistant.WebApp.Pairing
Assistant.WebApp.Repair
Assistant.WebApp.RepoId
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
@@ -812,7 +788,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 59abff99d..13d512696 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 dd57db47e..f61fe9a0b 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 ff9d8f245..000000000
--- 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 6f75da240..000000000
--- 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 0e6b8cba4..7d79d0b80 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 ..