mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

remove xmpp support

Browse source 
I've long considered the XMPP support in git-annex a wart.
It's nice to remove it.

(This also removes the NetMessager, which was only used for XMPP, and the
daemonstatus's desynced list (likewise).)

Existing XMPP remotes should be ignored by git-annex.

This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess 2016-11-14 14:26:20 -04:00
parent a7fd200440
commit d58148031b
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
64 changed files with 38 additions and 2827 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
Assistant.hs
View file

@ -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

6
Assistant/DaemonStatus.hs
View file

@ -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))

6
Assistant/Monad.hs
View file

@ -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

180
Assistant/NetMessager.hs
View file

@ -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]

66
Assistant/Sync.hs
View file

@ -9,8 +9,6 @@ module Assistant.Sync where
import Assistant.Common
import Assistant.Pushes
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
@ -20,7 +18,6 @@ import qualified Command.Sync
import Utility.Parallel
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Merge
import qualified Remote
import qualified Types.Remote as Remote
@ -40,7 +37,6 @@ import Types.Transfer
import Data.Time.Clock
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Concurrent
{- Syncs with remotes that may have been disconnected for a while.
@ -51,21 +47,14 @@ import Control.Concurrent
- the remotes have diverged from the local git-annex branch. Otherwise,
- it's sufficient to requeue failed transfers.
-
- XMPP remotes are also signaled that we can push to them, and we request
- they push to us. Since XMPP pushes run ansynchronously, any scan of the
- XMPP remotes has to be deferred until they're done pushing to us, so
- all XMPP remotes are marked as possibly desynced.
-
- Also handles signaling any connectRemoteNotifiers, after the syncing is
- done.
-}
reconnectRemotes :: Bool -> [Remote] -> Assistant ()
reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
reconnectRemotes :: [Remote] -> Assistant ()
reconnectRemotes [] = noop
reconnectRemotes rs = void $ do
rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
unless (null rs') $ do
modifyDaemonStatus_ $ \s -> s
{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
failedrs <- syncAction rs' (const go)
forM_ failedrs $ \r ->
whenM (liftIO $ Remote.checkAvailable False r) $
@ -73,7 +62,7 @@ reconnectRemotes notifypushes rs = void $ do
mapM_ signal $ filter (`notElem` failedrs) rs'
where
gitremotes = filter (notspecialremote . Remote.repo) rs
(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
(_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
notspecialremote r
| Git.repoIsUrl r = True
| Git.repoIsLocal r = True
@ -82,7 +71,7 @@ reconnectRemotes notifypushes rs = void $ do
sync currentbranch@(Just _, _) = do
(failedpull, diverged) <- manualPull currentbranch gitremotes
now <- liftIO getCurrentTime
failedpush <- pushToRemotes' now notifypushes gitremotes
failedpush <- pushToRemotes' now gitremotes
return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -}
sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
@ -102,9 +91,6 @@ reconnectRemotes notifypushes rs = void $ do
- as "git annex sync", except in parallel, and will co-exist with use of
- "git annex sync".
-
- After the pushes to normal git remotes, also signals XMPP clients that
- they can request an XMPP push.
-
- Avoids running possibly long-duration commands in the Annex monad, so
- as not to block other threads.
-
@ -122,27 +108,21 @@ reconnectRemotes notifypushes rs = void $ do
-
- Returns any remotes that it failed to push to.
-}
pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
pushToRemotes notifypushes remotes = do
pushToRemotes :: [Remote] -> Assistant [Remote]
pushToRemotes remotes = do
now <- liftIO getCurrentTime
let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes
syncAction remotes' (pushToRemotes' now notifypushes)
pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
pushToRemotes' now notifypushes remotes = do
syncAction remotes' (pushToRemotes' now)
pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote]
pushToRemotes' now remotes = do
(g, branch, u) <- liftAnnex $ do
Annex.Branch.commit "update"
(,,)
<$> gitRepo
<*> join Command.Sync.getCurrBranch
<*> getUUID
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
ret <- go True branch g u normalremotes
unless (null xmppremotes) $ do
shas <- liftAnnex $ map fst <$>
inRepo (Git.Ref.matchingWithHEAD
[Annex.Branch.fullname, Git.Ref.headRef])
forM_ xmppremotes $ \r -> sendNetMessage $
Pushing (getXMPPClientID r) (CanPush u shas)
return ret
where
go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
@ -152,11 +132,7 @@ pushToRemotes' now notifypushes remotes = do
(succeeded, failed) <- parallelPush g rs (push branch)
updatemap succeeded []
if null failed
then do
when notifypushes $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
return failed
then return []
else if shouldretry
then retry currbranch g u failed
else fallback branch g u failed
@ -175,9 +151,6 @@ pushToRemotes' now notifypushes remotes = do
debug ["fallback pushing to", show rs]
(succeeded, failed) <- parallelPush g rs (taggedPush u Nothing branch)
updatemap succeeded failed
when (notifypushes && (not $ null succeeded)) $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
return failed
push branch remote = Command.Sync.pushBranch remote branch
@ -195,10 +168,6 @@ parallelPush g rs a = do
{- Displays an alert while running an action that syncs with some remotes,
- and returns any remotes that it failed to sync with.
-
- XMPP remotes are handled specially; since the action can only start
- an async process for them, they are not included in the alert, but are
- still passed to the action.
-
- Readonly remotes are also hidden (to hide the web special remote).
-}
syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
@ -222,15 +191,11 @@ syncAction rs a
- remotes that it failed to pull from, and a Bool indicating
- whether the git-annex branches of the remotes and local had
- diverged before the pull.
-
- After pulling from the normal git remotes, requests pushes from any
- XMPP remotes. However, those pushes will run asynchronously, so their
- results are not included in the return data.
-}
manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
failed <- forM normalremotes $ \r -> do
g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
@ -240,9 +205,6 @@ manualPull currentbranch remotes = do
haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r currentbranch mergeConfig
u <- liftAnnex getUUID
forM_ xmppremotes $ \r ->
sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
return (catMaybes failed, haddiverged)
mergeConfig :: [Git.Merge.MergeConfig]
@ -257,7 +219,7 @@ syncRemote :: Remote -> Assistant ()
syncRemote remote = do
updateSyncRemotes
thread <- asIO $ do
reconnectRemotes False [remote]
reconnectRemotes [remote]
addScanRemotes True [remote]
void $ liftIO $ forkIO $ thread

26
Assistant/Threads/Merger.hs
View file

@ -10,8 +10,6 @@ module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.Sync
import Utility.DirWatcher
import Utility.DirWatcher.Types
@ -19,11 +17,6 @@ import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import qualified Command.Sync
import Annex.TaggedPush
import Remote (remoteFromUUID)
import qualified Data.Set as S
import qualified Data.Text as T
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
@ -70,8 +63,7 @@ onChange file
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate
when diverged $
unlessM handleDesynced $
queueDeferredDownloads "retrying deferred download" Later
queueDeferredDownloads "retrying deferred download" Later
| "/synced/" `isInfixOf` file =
mergecurrent =<< liftAnnex (join Command.Sync.getCurrBranch)
| otherwise = noop
@ -91,22 +83,6 @@ onChange file
changedbranch
mergecurrent _ = noop
handleDesynced = case fromTaggedBranch changedbranch of
Nothing -> return False
Just (u, info) -> do
mr <- liftAnnex $ remoteFromUUID u
case mr of
Nothing -> return False
Just r -> do
s <- desynced <$> getDaemonStatus
if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
then do
modifyDaemonStatus_ $ \st -> st
{ desynced = S.delete u s }
addScanRemotes True [r]
return True
else return False
equivBranches :: Git.Ref -> Git.Ref -> Bool
equivBranches x y = base x == base y
where

2
Assistant/Threads/MountWatcher.hs
View file

@ -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.
-

9
Assistant/Threads/NetWatcher.hs
View file

@ -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]

4
Assistant/Threads/Pusher.hs
View file

@ -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.
-

2
Assistant/Threads/TransferScanner.hs
View file

@ -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. -}

1
Assistant/Threads/WebApp.hs
View file

@ -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

375
Assistant/Threads/XMPPClient.hs
View file

@ -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 }

82
Assistant/Threads/XMPPPusher.hs
View file

@ -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"

80
Assistant/Types/Buddies.hs
View file

@ -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

8
Assistant/Types/DaemonStatus.hs
View file

@ -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

155
Assistant/Types/NetMessager.hs
View file

@ -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)

13
Assistant/WebApp/Configurators.hs
View file

@ -5,26 +5,18 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators where
import Assistant.WebApp.Common
import Assistant.WebApp.RepoList
#ifdef WITH_XMPP
import Assistant.XMPP.Client
#endif
{- The main configuration screen. -}
getConfigurationR :: Handler Html
getConfigurationR = ifM inFirstRun
( redirect FirstRepositoryR
, page "Configuration" (Just Configuration) $ do
#ifdef WITH_XMPP
xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds
#else
let xmppconfigured = False
#endif
$(widgetFile "configurators/main")
)
@ -39,9 +31,6 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
makeCloudRepositories :: Widget
makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
makeXMPPConnection :: Widget
makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection")
makeSshRepository :: Widget
makeSshRepository = $(widgetFile "configurators/addrepository/ssh")

10
Assistant/WebApp/Configurators/Delete.hs
View file

@ -37,16 +37,8 @@ notCurrentRepo uuid a = do
go Nothing = error "Unknown UUID"
go (Just _) = a
handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
handleXMPPRemoval uuid nonxmpp = do
remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
if Remote.isXMPPRemote remote
then deletionPage $ $(widgetFile "configurators/delete/xmpp")
else nonxmpp
getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
getDeleteRepositoryR uuid = notCurrentRepo uuid $ do
deletionPage $ do
reponame <- liftAnnex $ Remote.prettyUUID uuid
$(widgetFile "configurators/delete/start")

125
Assistant/WebApp/Configurators/Pairing.hs
View file

@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators.Pairing where
import Assistant.Pairing
import Assistant.WebApp.Common
import Assistant.Types.Buddies
import Annex.UUID
#ifdef WITH_PAIRING
import Assistant.Pairing.Network
@ -22,17 +21,6 @@ import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
#endif
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.XMPP.Git
import Network.Protocol.XMPP
import Assistant.Types.NetMessager
import Assistant.NetMessager
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.XMPP
#endif
import Utility.UserInfo
import Git
@ -44,84 +32,6 @@ import Data.Char
import qualified Control.Exception as E
import Control.Concurrent
#endif
#ifdef WITH_XMPP
import qualified Data.Set as S
#endif
getStartXMPPPairFriendR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
( do
{- Ask buddies to send presence info, to get
- the buddy list populated. -}
liftAssistant $ sendNetMessage QueryPresence
pairPage $
$(widgetFile "configurators/pairing/xmpp/friend/prompt")
, do
-- go get XMPP configured, then come back
redirect XMPPConfigForPairFriendR
)
#else
getStartXMPPPairFriendR = noXMPPPairing
noXMPPPairing :: Handler Html
noXMPPPairing = noPairing "XMPP"
#endif
getStartXMPPPairSelfR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
where
go Nothing = do
-- go get XMPP configured, then come back
redirect XMPPConfigForPairSelfR
go (Just creds) = do
{- Ask buddies to send presence info, to get
- the buddy list populated. -}
liftAssistant $ sendNetMessage QueryPresence
let account = xmppJID creds
pairPage $
$(widgetFile "configurators/pairing/xmpp/self/prompt")
#else
getStartXMPPPairSelfR = noXMPPPairing
#endif
getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
getRunningXMPPPairSelfR :: Handler Html
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
{- Sends a XMPP pair request, to a buddy or to self. -}
sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
#ifdef WITH_XMPP
sendXMPPPairRequest mbid = do
bid <- maybe getself return mbid
buddy <- liftAssistant $ getBuddy bid <<~ buddyList
go $ S.toList . buddyAssistants <$> buddy
where
go (Just (clients@((Client exemplar):_))) = do
u <- liftAnnex getUUID
liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
PairingNotification PairReq (formatJID c) u
xmppPairStatus True $
if selfpair then Nothing else Just exemplar
go _
{- Nudge the user to turn on their other device. -}
| selfpair = do
liftAssistant $ sendNetMessage QueryPresence
pairPage $
$(widgetFile "configurators/pairing/xmpp/self/retry")
{- Buddy could have logged out, etc.
- Go back to buddy list. -}
| otherwise = redirect StartXMPPPairFriendR
selfpair = isNothing mbid
getself = maybe (error "XMPP not configured")
(return . BuddyKey . xmppJID)
=<< liftAnnex getXMPPCreds
#else
sendXMPPPairRequest _ = noXMPPPairing
#endif
{- Starts local pairing. -}
getStartLocalPairR :: Handler Html
@ -158,41 +68,6 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
postFinishLocalPairR _ = noLocalPairing
#endif
getConfirmXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
Nothing -> error "bad JID"
Just theirjid -> pairPage $ do
let name = buddyName theirjid
$(widgetFile "configurators/pairing/xmpp/friend/confirm")
#else
getConfirmXMPPPairFriendR _ = noXMPPPairing
#endif
getFinishXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
Nothing -> error "bad JID"
Just theirjid -> do
selfuuid <- liftAnnex getUUID
liftAssistant $ do
sendNetMessage $
PairingNotification PairAck (formatJID theirjid) selfuuid
finishXMPPPairing theirjid theiruuid
xmppPairStatus False $ Just theirjid
#else
getFinishXMPPPairFriendR _ = noXMPPPairing
#endif
{- Displays a page indicating pairing status and
- prompting to set up cloud repositories. -}
#ifdef WITH_XMPP
xmppPairStatus :: Bool -> Maybe JID -> Handler Html
xmppPairStatus inprogress theirjid = pairPage $ do
let friend = buddyName <$> theirjid
$(widgetFile "configurators/pairing/xmpp/end")
#endif
getRunningLocalPairR :: SecretReminder -> Handler Html
#ifdef WITH_PAIRING
getRunningLocalPairR s = pairPage $ do

226
Assistant/WebApp/Configurators/XMPP.hs
View file

@ -1,226 +0,0 @@
{- git-annex assistant XMPP configuration
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp.Common
import Assistant.WebApp.Notifications
import Utility.NotificationBroadcaster
#ifdef WITH_XMPP
import qualified Remote
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.Types.Buddies
import Assistant.NetMessager
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
import qualified Git.Remote.Remove
import Remote.List
import Creds
#endif
#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Network
import qualified Data.Text as T
#endif
{- When appropriate, displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
#ifdef WITH_XMPP
checkCloudRepos urlrenderer r =
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
buddyname <- getBuddyName $ Remote.uuid r
button <- mkAlertButton True "Add a cloud repository" urlrenderer $
NeedCloudRepoR $ Remote.uuid r
void $ addAlert $ cloudRepoNeededAlert buddyname button
#else
checkCloudRepos _ _ = noop
#endif
#ifdef WITH_XMPP
{- Returns the name of the friend corresponding to a
- repository's UUID, but not if it's our name. -}
getBuddyName :: UUID -> Assistant (Maybe String)
getBuddyName u = go =<< getclientjid
where
go Nothing = return Nothing
go (Just myjid) = (T.unpack . buddyName <$>)
. headMaybe
. filter (\j -> baseJID j /= baseJID myjid)
. map fst
. filter (\(_, r) -> Remote.uuid r == u)
<$> getXMPPRemotes
getclientjid = maybe Nothing parseJID . xmppClientID
<$> getDaemonStatus
#endif
getNeedCloudRepoR :: UUID -> Handler Html
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- liftAssistant $ getBuddyName for
$(widgetFile "configurators/xmpp/needcloudrepo")
#else
getNeedCloudRepoR _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
getXMPPConfigR :: Handler Html
getXMPPConfigR = postXMPPConfigR
postXMPPConfigR :: Handler Html
postXMPPConfigR = xmppform DashboardR
getXMPPConfigForPairFriendR :: Handler Html
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
postXMPPConfigForPairFriendR :: Handler Html
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
getXMPPConfigForPairSelfR :: Handler Html
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
postXMPPConfigForPairSelfR :: Handler Html
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
xmppform :: Route WebApp -> Handler Html
#ifdef WITH_XMPP
xmppform next = xmppPage $ do
((result, form), enctype) <- liftH $ do
oldcreds <- liftAnnex getXMPPCreds
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp")
case result of
FormSuccess f -> either (showform . Just) (liftH . storecreds)
=<< liftIO (validateForm f)
_ -> showform Nothing
where
storecreds creds = do
void $ liftAnnex $ setXMPPCreds creds
liftAssistant notifyNetMessagerRestart
redirect next
#else
xmppform _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
{- Called by client to get a list of buddies.
-
- Returns a div, which will be inserted into the calling page.
-}
getBuddyListR :: NotificationId -> Handler Html
getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid
p <- widgetToPageContent buddyListDisplay
withUrlRenderer $ [hamlet|^{pageBody p}|]
buddyListDisplay :: Widget
buddyListDisplay = do
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
let isself (BuddyKey b) = Just b == myjid
buddies <- liftAssistant $ do
pairedwith <- map fst <$> getXMPPRemotes
catMaybes . map (buddySummary pairedwith)
<$> (getBuddyList <<~ buddyList)
$(widgetFile "configurators/xmpp/buddylist")
#else
noop
#endif
where
ident = "buddylist"
#ifdef WITH_XMPP
getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
<$> getDaemonStatus
where
pair r = maybe Nothing (\jid -> Just (jid, r)) $
parseJID $ getXMPPClientID r
data XMPPForm = XMPPForm
{ formJID :: Text
, formPassword :: Text }
creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
xmppAForm d = XMPPForm
<$> areq jidField (bfs "Jabber address") (formJID <$> d)
<*> areq passwordField (bfs "Password") Nothing
jidField :: MkField Text
jidField = checkBool (isJust . parseJID) bad textField
where
bad :: Text
bad = "This should look like an email address.."
validateForm :: XMPPForm -> IO (Either String XMPPCreds)
validateForm f = do
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
let username = fromMaybe "" (strNode <$> jidNode jid)
testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
, xmppPort = 5222
, xmppJID = formJID f
}
testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
testXMPP creds = do
(good, bad) <- partition (either (const False) (const True) . snd)
<$> connectXMPP creds (const noop)
case good of
(((h, PortNumber p), _):_) -> return $ Right $ creds
{ xmppHostname = h
, xmppPort = fromIntegral p
}
(((h, _), _):_) -> return $ Right $ creds
{ xmppHostname = h
}
_ -> return $ Left $ intercalate "; " $ map formatlog bad
where
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
formatlog _ = ""
showport (PortNumber n) = show n
showport (Service s) = s
showport (UnixSocket s) = s
#endif
getDisconnectXMPPR :: Handler Html
getDisconnectXMPPR = do
#ifdef WITH_XMPP
rs <- filter Remote.isXMPPRemote . syncRemotes
<$> liftAssistant getDaemonStatus
liftAnnex $ do
mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs
void remoteListRefresh
removeCreds xmppCredsFile
liftAssistant $ do
updateSyncRemotes
notifyNetMessagerRestart
redirect DashboardR
#else
xmppPage $ $(widgetFile "configurators/xmpp/disabled")
#endif
xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)

7
Assistant/WebApp/Notifications.hs
View file

@ -13,7 +13,6 @@ import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.DaemonStatus
import Assistant.Types.Buddies
import Utility.NotificationBroadcaster
import Utility.Yesod
import Utility.WebApp
@ -60,9 +59,6 @@ getNotifierTransfersR = notifierUrl TransfersR getTransferBroadcaster
getNotifierSideBarR :: Handler RepPlain
getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster
getNotifierBuddyListR :: Handler RepPlain
getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster
getNotifierRepoListR :: RepoSelector -> Handler RepPlain
getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
where
@ -77,9 +73,6 @@ getTransferBroadcaster = transferNotifier <$> getDaemonStatus
getAlertBroadcaster :: Assistant NotificationBroadcaster
getAlertBroadcaster = alertNotifier <$> getDaemonStatus
getBuddyListBroadcaster :: Assistant NotificationBroadcaster
getBuddyListBroadcaster = getBuddyBroadcaster <$> getAssistant buddyList
getRepoListBroadcaster :: Assistant NotificationBroadcaster
getRepoListBroadcaster = syncRemotesNotifier <$> getDaemonStatus

2
Assistant/WebApp/RepoList.hs
View file

@ -260,7 +260,7 @@ getSyncNowRepositoryR uuid = do
if u == uuid
then do
thread <- liftAssistant $ asIO $
reconnectRemotes True
reconnectRemotes
=<< (syncRemotes <$> getDaemonStatus)
void $ liftIO $ forkIO thread
else maybe noop (liftAssistant . syncRemote)

9
Assistant/WebApp/Types.hs
View file

@ -15,7 +15,6 @@ module Assistant.WebApp.Types where
import Assistant.Common
import Assistant.Ssh
import Assistant.Pairing
import Assistant.Types.Buddies
import Utility.NotificationBroadcaster
import Utility.WebApp
import Utility.Yesod
@ -162,14 +161,6 @@ instance PathPiece UUID where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece BuddyKey where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece PairKey where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece RepoSelector where
toPathPiece = pack . show
fromPathPiece = readish . unpack

16
Assistant/WebApp/routes
View file

@ -16,11 +16,6 @@
/config ConfigurationR GET
/config/preferences PreferencesR GET POST
/config/xmpp XMPPConfigR GET POST
/config/xmpp/for/self XMPPConfigForPairSelfR GET POST
/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
/config/xmpp/disconnect DisconnectXMPPR GET
/config/needconnection ConnectionNeededR GET
/config/fsck ConfigFsckR GET POST
/config/fsck/preferences ConfigFsckPreferencesR POST
@ -67,14 +62,6 @@
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
/config/repository/pair/xmpp/self/start StartXMPPPairSelfR GET
/config/repository/pair/xmpp/self/running RunningXMPPPairSelfR GET
/config/repository/pair/xmpp/friend/start StartXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/running/#BuddyKey RunningXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/accept/#PairKey ConfirmXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET
/config/repository/enable/rsync/#UUID EnableRsyncR GET POST
/config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST
/config/repository/enable/directory/#UUID EnableDirectoryR GET
@ -103,9 +90,6 @@
/sidebar/#NotificationId SideBarR GET
/notifier/sidebar NotifierSideBarR GET
/buddylist/#NotificationId BuddyListR GET
/notifier/buddylist NotifierBuddyListR GET
/repolist/#NotificationId/#RepoSelector RepoListR GET
/notifier/repolist/#RepoSelector NotifierRepoListR GET

275
Assistant/XMPP.hs
View file

@ -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"

87
Assistant/XMPP/Buddies.hs
View file

@ -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

83
Assistant/XMPP/Client.hs
View file

@ -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"

381
Assistant/XMPP/Git.hs
View file

@ -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

5
BuildFlags.hs
View file

@ -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

6
CmdLine/GitAnnex.hs
View file

@ -106,9 +106,6 @@ import qualified Command.Assistant
#ifdef WITH_WEBAPP
import qualified Command.WebApp
#endif
#ifdef WITH_XMPP
import qualified Command.XMPPGit
#endif
import qualified Command.RemoteDaemon
#endif
import qualified Command.Test
@ -212,9 +209,6 @@ cmds testoptparser testrunner =
, Command.Assistant.cmd
#ifdef WITH_WEBAPP
, Command.WebApp.cmd
#endif
#ifdef WITH_XMPP
, Command.XMPPGit.cmd
#endif
, Command.RemoteDaemon.cmd
#endif

48
Command/XMPPGit.hs
View file

@ -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

2
Makefile
View file

@ -280,7 +280,7 @@ dist/caballog: git-annex.cabal
# TODO should be possible to derive this from caballog.
hdevtools:
hdevtools --stop-server || true
hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -DWITH_XMPP -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports
hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports
distributionupdate:
git pull

3
debian/control vendored
View file

@ -59,9 +59,6 @@ Build-Depends:
libghc-network-multicast-dev,
libghc-network-info-dev [linux-any kfreebsd-any],
libghc-safesemaphore-dev,
libghc-network-protocol-xmpp-dev (>= 0.4.3-1+b1),
libghc-gnutls-dev (>= 0.1.4),
libghc-xml-types-dev,
libghc-async-dev,
libghc-monad-logger-dev,
libghc-feed-dev (>= 0.3.9.2),

2
doc/assistant.mdwn
View file

@ -24,8 +24,6 @@ instructions.
* Or perhaps you want to share files between computers in different
locations, like home and work?
Follow the [[remote_sharing_walkthrough]].
* Want to share a synchronised folder with a friend?
Follow the [[share_with_a_friend_walkthrough]].
* Want to archive data to a drive or the cloud?
Follow the [[archival_walkthrough]].

58
doc/assistant/share_with_a_friend_walkthrough.mdwn
View file

@ -1,58 +0,0 @@
Want to share all the files in your repository with a friend?
Let's suppose you use Google Mail, and so does your friend, and you
sometimes also chat in Google Talk. The git-annex assistant will
use your Google account to share with your friend. (This actually
works with any Jabber account you use, not just Google Talk.)
Start by opening up your git annex dashboard.
[[!img local_pairing_walkthrough/addrepository.png alt="Add another repository button"]]
`*click*`
[[!img pairing.png alt="Share with a friend"]]
`*click*`
[[!img xmpp.png alt="Configuring Jabber account"]]
Fill that out, and git-annex will be able to show you a list of your
friends.
[[!img buddylist.png alt="Buddy list"]]
This list will refresh as friends log on and off, so you can
leave it open in a tab until a friend is available to start pairing.
(If your friend is not using git-annex yet, now's a great time to spread
the word!)
Once you click on "Start Pairing", your friend will see this pop up
on their git annex dashboard.
[[!img xmppalert.png alt="Pair request"]]
Once your friend clicks on that, your repositories will be paired.
### But, wait, there's one more step...
Despite the repositories being paired now, you and your friend can't yet
quite share files. You'll start to see your friend's files show up in your
git-annex folder, but you won't be able to open them yet.
What you need to do now is set up a repository out there in the cloud,
that both you and your friend can access. This will be used to transfer
files between the two of you.
At the end of the pairing process, a number of cloud providers are
suggested, and the git-annex assistant makes it easy to configure one of
them. Once you or your friend sets it up, it'll show up in the other
one's list of repositories:
[[!img repolist.png alt="Repository list"]]
The final step is to share the login information for the cloud repository
with your friend, so they can enable it too.
With that complete, you'll be able to open your friend's files!

BIN
doc/assistant/share_with_a_friend_walkthrough/xmppalert.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 4 KiB

2
doc/bugs/assistant_-_GTalk_collision.mdwn
View file

@ -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]]

2
doc/bugs/problems_with_android_and_xmpp.mdwn
View file

@ -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]]

23
doc/git-annex-xmppgit.mdwn
View file

@ -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.

12
doc/git-annex.mdwn
View file

@ -658,13 +658,6 @@ subdirectories).
See [[git-annex-remotedaemon]](1) for details.
* `xmppgit`
This command is used internally by the assistant to perform git pulls
over XMPP.
See [[git-annex-xmppgit]](1) for details.
# TESTING COMMANDS
* `test`
@ -1296,11 +1289,6 @@ Here are all the supported configuration settings.
Used to identify tahoe special remotes.
Points to the configuration directory for tahoe.
* `remote.<name>.annex-xmppaddress`
Used to identify the XMPP address of a Jabber buddy.
Normally this is set up by the git-annex assistant when pairing over XMPP.
* `remote.<name>.gcrypt`
Used to identify gcrypt special remotes.

43
doc/special_remotes/xmpp.mdwn
View file

@ -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.

41
doc/todo/windows_support.mdwn
View file

@ -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>

2
doc/todo/wishlist__58___Advanced_settings_for_xmpp_and_webdav.mdwn
View file

@ -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]]

2
doc/todo/xmpp_removal.mdwn
View file

@ -23,3 +23,5 @@ notably the stack build. It's never worked on Windows.
Next step is probably to default the flag to false by default,
except for in a few builds like the Debian package and standalone builds.
> [[done]]

31
git-annex.cabal
View file

@ -135,7 +135,6 @@ Extra-Source-Files:
doc/git-annex-watch.mdwn
doc/git-annex-webapp.mdwn
doc/git-annex-whereis.mdwn
doc/git-annex-xmppgit.mdwn
doc/logo.svg
doc/logo_16x16.png
Build/mdwn2man
@ -196,12 +195,6 @@ Extra-Source-Files:
templates/configurators/pairing/local/inprogress.hamlet
templates/configurators/pairing/local/prompt.hamlet
templates/configurators/pairing/disabled.hamlet
templates/configurators/pairing/xmpp/self/retry.hamlet
templates/configurators/pairing/xmpp/self/prompt.hamlet
templates/configurators/pairing/xmpp/friend/prompt.hamlet
templates/configurators/pairing/xmpp/friend/confirm.hamlet
templates/configurators/pairing/xmpp/end.hamlet
templates/configurators/xmpp.hamlet
templates/configurators/addglacier.hamlet
templates/configurators/fsck.cassius
templates/configurators/edit/nonannexremote.hamlet
@ -223,7 +216,6 @@ Extra-Source-Files:
templates/configurators/addrepository/archive.hamlet
templates/configurators/addrepository/cloud.hamlet
templates/configurators/addrepository/connection.hamlet
templates/configurators/addrepository/xmppconnection.hamlet
templates/configurators/addrepository/ssh.hamlet
templates/configurators/addrepository/misc.hamlet
templates/configurators/rsync.net/add.hamlet
@ -235,7 +227,6 @@ Extra-Source-Files:
templates/configurators/fsck/form.hamlet
templates/configurators/fsck/preferencesform.hamlet
templates/configurators/fsck/formcontent.hamlet
templates/configurators/delete/xmpp.hamlet
templates/configurators/delete/finished.hamlet
templates/configurators/delete/start.hamlet
templates/configurators/delete/currentrepository.hamlet
@ -243,9 +234,6 @@ Extra-Source-Files:
templates/configurators/adddrive.hamlet
templates/configurators/preferences.hamlet
templates/configurators/addia.hamlet
templates/configurators/xmpp/buddylist.hamlet
templates/configurators/xmpp/disabled.hamlet
templates/configurators/xmpp/needcloudrepo.hamlet
templates/configurators/enableaws.hamlet
templates/configurators/addrepository.hamlet
templates/actionbutton.hamlet
@ -305,9 +293,6 @@ Flag Cryptonite
Flag Dbus
Description: Enable dbus support
Flag XMPP
Description: Enable notifications using XMPP
source-repository head
type: git
location: git://git-annex.branchable.com/
@ -479,11 +464,6 @@ Executable git-annex
Build-Depends: network-multicast, network-info
CPP-Options: -DWITH_PAIRING
if flag(XMPP)
if (! os(windows))
Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4), xml-types
CPP-Options: -DWITH_XMPP
if flag(TorrentParser)
Build-Depends: torrent (>= 10000.0.0)
CPP-Options: -DWITH_TORRENTPARSER
@ -577,7 +557,6 @@ Executable git-annex
Assistant.MakeRemote
Assistant.Monad
Assistant.NamedThread
Assistant.NetMessager
Assistant.Pairing
Assistant.Pairing.MakeRemote
Assistant.Pairing.Network
@ -610,20 +589,16 @@ Executable git-annex
Assistant.Threads.Upgrader
Assistant.Threads.Watcher
Assistant.Threads.WebApp
Assistant.Threads.XMPPClient
Assistant.Threads.XMPPPusher
Assistant.TransferQueue
Assistant.TransferSlots
Assistant.TransferrerPool
Assistant.Types.Alert
Assistant.Types.BranchChange
Assistant.Types.Buddies
Assistant.Types.Changes
Assistant.Types.Commits
Assistant.Types.CredPairCache
Assistant.Types.DaemonStatus
Assistant.Types.NamedThread
Assistant.Types.NetMessager
Assistant.Types.Pushes
Assistant.Types.RemoteControl
Assistant.Types.RepoProblem
@ -651,7 +626,6 @@ Executable git-annex
Assistant.WebApp.Configurators.Unused
Assistant.WebApp.Configurators.Upgrade
Assistant.WebApp.Configurators.WebDAV
Assistant.WebApp.Configurators.XMPP
Assistant.WebApp.Control
Assistant.WebApp.DashBoard
Assistant.WebApp.Documentation
@ -666,10 +640,6 @@ Executable git-annex
Assistant.WebApp.RepoList
Assistant.WebApp.SideBar
Assistant.WebApp.Types
Assistant.XMPP
Assistant.XMPP.Buddies
Assistant.XMPP.Client
Assistant.XMPP.Git
Backend
Backend.Hash
Backend.URL
@ -806,7 +776,6 @@ Executable git-annex
Command.Watch
Command.WebApp
Command.Whereis
Command.XMPPGit
Common
Config
Config.Cost

1
stack.yaml
View file

@ -13,7 +13,6 @@ flags:
webapp: true
magicmime: false
dbus: false
xmpp: false
android: false
androidsplice: false
packages:

1
standalone/android/cabal.config
View file

@ -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,

50
standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch
View file

@ -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

43
standalone/android/haskell-patches/gnutls_0.1.4-0001-statically-link-with-gnutls.patch
View file

@ -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

3
standalone/android/install-haskell-packages
View file

@ -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 ..

2
templates/configurators/addrepository/connection.hamlet
View file

@ -1,3 +1 @@
^{makeXMPPConnection}
^{makeSshRepository}

2
templates/configurators/addrepository/misc.hamlet
View file

@ -8,8 +8,6 @@
<a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> #
between computers.
^{makeXMPPConnection}
<h3>
<a href="@{StartLocalPairR}">
<span .glyphicon .glyphicon-plus-sign>

13
templates/configurators/addrepository/xmppconnection.hamlet
View file

@ -1,13 +0,0 @@
<h3>
<a href="@{StartXMPPPairSelfR}">
<span .glyphicon .glyphicon-plus-sign>
\ Share with your other devices
<p>
Keep files in sync between your devices running git-annex.
<h3>
<a href="@{StartXMPPPairFriendR}">
<span .glyphicon .glyphicon-plus-sign>
\ Share with a friend
<p>
Combine your repository with a friend's repository, and share your files.

12
templates/configurators/delete/xmpp.hamlet
View file

@ -1,12 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Disconnecting from Jabber
<p>
This won't delete the repository or repositories at the other end
of the Jabber connection, but it will disconnect from them, and stop
using Jabber.
<p>
<a .btn .btn-primary href="@{DisconnectXMPPR}">
<span .glyphicon .glyphicon-minus>
\ Disconnect

13
templates/configurators/main.hamlet
View file

@ -27,16 +27,3 @@
Unused files
<p>
Configure what to do with old and deleted files.
<div .row>
<div .col-sm-4>
<h3>
<a href="@{XMPPConfigR}">
Jabber account
$if xmppconfigured
<p>
Your jabber account is set up, and will be used to keep #
in touch with remote devices, and with your friends.
$else
<p>
Keep in touch with remote devices, and with your friends, #
by configuring a jabber account.

33
templates/configurators/pairing/xmpp/end.hamlet
View file

@ -1,33 +0,0 @@
<div .col-sm-9>
<div .content-box>
$if inprogress
<h2>
Pair request sent ...
<p>
$maybe name <- friend
A pair request has been sent to #{name}. Now it's up to them #
to accept it and finish pairing.
$nothing
A pair request has been sent to all other devices that #
have been configured to use your jabber account. #
It will be answered automatically by any devices that see it.
$else
Pair request accepted.
<h2>
Configure a shared cloud repository
$maybe name <- friend
<p>
&#9730; To share files with #{name}, you'll need a repository in #
the cloud, that you both can access.
$nothing
<p>
&#9730; To share files with your other devices, when they're not #
nearby, you'll need a repository in the cloud.
<p>
Make sure that your other devices are configured to access a #
cloud repository, and that the same repository is enabled here #
too.
^{cloudRepoList}
<h2>
Add a cloud repository
^{makeCloudRepositories}

12
templates/configurators/pairing/xmpp/friend/confirm.hamlet
View file

@ -1,12 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Pair request received from #{name}
<p>
Pairing with #{name} will combine your two git annex #
repositories into one, allowing you to share files.
<p>
<a .btn .btn-primary .btn-lg href="@{FinishXMPPPairFriendR pairkey}">
Accept pair request
<a .btn .btn-default .btn-lg href="@{DashboardR}">
No thanks

13
templates/configurators/pairing/xmpp/friend/prompt.hamlet
View file

@ -1,13 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Share with a friend
<p>
You can combine your repository with a friend's repository #
to share your files. Your repositories will automatically be kept in #
sync. Only do this if you want your friend to see all the files #
in this repository!
<p>
Here are the friends currently available via your Jabber account.
<p>
^{buddyListDisplay}

21
templates/configurators/pairing/xmpp/self/prompt.hamlet
View file

@ -1,21 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Sharing with your other devices
<p>
If you have multiple devices, all running git-annex, and using #
your Jabber account #{account}, you can configure them to share #
your files between themselves.
<p>
For example, you can have a computer at home, one at work, and a #
laptop, and their repositories will automatically be kept in sync.
<p>
Make sure your other devices are online and configured to use #
your Jabber account before continuing. Note that <b>all</b> #
repositories configured to use the same Jabber account will be #
combined together when you do this.
<p>
<a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">
Start sharing with my other devices #
<a .btn .btn-default .btn-lg href="@{DashboardR}">
Cancel

12
templates/configurators/pairing/xmpp/self/retry.hamlet
View file

@ -1,12 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Unable to get in touch with any other devices.
<p>
Make sure your other devices are online and configured to use #
your Jabber account before continuing.
<p>
<a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">
Start sharing with my other devices #
<a .btn .btn-default .btn-lg href="@{DashboardR}">
Cancel

43
templates/configurators/xmpp.hamlet
View file

@ -1,43 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Configuring jabber account
<p>
A jabber account is used to communicate between #
devices that are not in direct contact. #
It can also be used to pair up with a friend's repository, if desired.
<p>
It's fine to reuse an existing jabber account; git-annex won't #
post any messages to it.
<p>
$maybe msg <- problem
<span .glyphicon .glyphicon-warning-sign>
\ Unable to connect to the Jabber server. #
Maybe you entered the wrong password? (Error message: #{msg})
$nothing
<span .glyphicon .glyphicon-user>
\ If you have a Gmail account, you can use #
Google Talk. Just enter your full Gmail address #
<small>(<tt>you@gmail.com</tt>)</small> #
and password below.
<p>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}
<div .form-group>
<div .col-sm-10 .col-sm-offset-2>
<button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
Use this account
\
<a .btn .btn-default href="@{DisconnectXMPPR}">
Stop using this account
<div .modal .fade #workingmodal>
<div .modal-dialog>
<div .modal-content>
<div .modal-header>
<h3>
Testing account ...
<div .modal-body>
<p>
Testing jabber account. This could take a minute.

40
templates/configurators/xmpp/buddylist.hamlet
View file

@ -1,40 +0,0 @@
<div ##{ident}>
<table .table>
<tbody>
$if null buddies
<tr>
<td>
$if isNothing myjid
Not connected to the jabber server. Check your network connection ...
$else
Searching...
$else
$forall (name, away, canpair, paired, buddyid) <- buddies
<tr>
<td>
$if isself buddyid
<span .glyphicon .glyphicon-star> #
<span :away:.text-muted>
your other devices
$else
<span .glyphicon .glyphicon-user> #
<span :away:.text-muted>
#{name}
<td>
$if away
<span .text-muted>
away
$else
$if paired
<span .label .label-success>
paired
$else
$if canpair
$if isself buddyid
<a .btn .btn-primary .btn-sm href="@{RunningXMPPPairSelfR}">
Start pairing
$else
<a .btn .btn-primary .btn-sm href="@{RunningXMPPPairFriendR buddyid}">
Start pairing
$else
not using git-annex

6
templates/configurators/xmpp/disabled.hamlet
View file

@ -1,6 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
Jabber not supported
<p>
This build of git-annex does not support Jabber. Sorry!

18
templates/configurators/xmpp/needcloudrepo.hamlet
View file

@ -1,18 +0,0 @@
<div .col-sm-9>
<div .content-box>
<h2>
&#9730; Configure a shared cloud repository
$maybe name <- buddyname
<p>
You and #{name} have combined your repositores. But you can't open #
each other's files yet. To start sharing files with #{name}, #
you need a repository in the cloud, that you both can access.
$nothing
<p>
You've combined the repositories on two or more of your devices. #
But files are not flowing yet. To start sharing files #
between your devices, you should set up a repository in the cloud.
^{cloudRepoList}
<h2>
Add a cloud repository
^{makeCloudRepositories}