diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -61,6 +61,7 @@ import Annex.Branch.Transitions import qualified Annex import Annex.Hook +import Utility.FileSystemEncoding {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref @@ -436,7 +437,6 @@ g <- gitRepo let dir = gitAnnexJournalDir g (jlogf, jlogh) <- openjlog - liftIO $ fileEncoding jlogh h <- hashObjectHandle withJournalHandle $ \jh -> Git.UpdateIndex.streamUpdateIndex g diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -33,6 +33,7 @@ import Git.Index import qualified Git.Ref import Annex.Link +import Utility.FileSystemEncoding catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -52,8 +52,7 @@ associatedFilesRelative :: Key -> Annex [FilePath] associatedFilesRelative key = do mapping <- calcRepo $ gitAnnexMapping key - liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do - fileEncoding h + liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> -- Read strictly to ensure the file is closed -- before changeAssociatedFiles tries to write to it. -- (Especially needed on Windows.) @@ -68,8 +67,7 @@ let files' = transform files when (files /= files') $ modifyContent mapping $ - liftIO $ viaTmp writeFileAnyEncoding mapping $ - unlines files' + liftIO $ viaTmp writeFile mapping $ unlines files' top <- fromRepo Git.repoPath return $ map (top ) files' diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -26,6 +26,7 @@ import Types.Key import Types.GitConfig import Types.Difference +import Utility.FileSystemEncoding type Hasher = Key -> FilePath diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -37,7 +37,6 @@ let tmpfile = tmp takeFileName jfile liftIO $ do withFile tmpfile WriteMode $ \h -> do - fileEncoding h #ifdef mingw32_HOST_OS hSetNewlineMode h noNewlineTranslation #endif @@ -53,7 +52,7 @@ - changes. -} getJournalFileStale :: FilePath -> Annex (Maybe String) getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ - readFileStrictAnyEncoding $ journalFile file g + readFileStrict $ journalFile file g {- List of files that have updated content in the journal. -} getJournalledFiles :: JournalLocked -> Annex [FilePath] diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -24,6 +24,7 @@ import Git.FilePath import Annex.HashObject import Utility.FileMode +import Utility.FileSystemEncoding import qualified Data.ByteString.Lazy as L @@ -63,7 +64,6 @@ Nothing -> fallback probefilecontent f = withFile f ReadMode $ \h -> do - fileEncoding h -- The first 8k is more than enough to read; link -- files are small. s <- take 8192 <$> hGetContents h diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -63,7 +63,6 @@ gitAnnexUrlFile, gitAnnexTmpCfgFile, gitAnnexSshDir, - gitAnnexSshConfig, gitAnnexRemotesDir, gitAnnexAssistantDefaultDir, HashLevels(..), @@ -402,10 +401,6 @@ {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r "ssh" - -{- .git/annex/ssh.config is used to configure ssh. -} -gitAnnexSshConfig :: Git.Repo -> FilePath -gitAnnexSshConfig r = gitAnnexDir r "ssh.config" {- .git/annex/remotes/ is used for remote-specific state. -} gitAnnexRemotesDir :: Git.Repo -> FilePath diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -33,7 +33,7 @@ import Config import Annex.Path import Utility.Env -import Utility.Tmp +import Utility.FileSystemEncoding import Types.CleanupActions import Git.Env #ifndef mingw32_HOST_OS @@ -50,37 +50,13 @@ go (Just socketfile, params) = do prepSocket socketfile ret params - ret ps = do - overideconfigfile <- fromRepo gitAnnexSshConfig - -- We assume that the file content does not change. - -- If it did, a more expensive test would be needed. - liftIO $ unlessM (doesFileExist overideconfigfile) $ - viaTmp writeFile overideconfigfile $ unlines - -- Make old version of ssh that does - -- not know about Include ignore those - -- entries. - [ "IgnoreUnknown Include" - -- ssh expands "~" - , "Include ~/.ssh/config" - -- ssh will silently skip the file - -- if it does not exist - , "Include /etc/ssh/ssh_config" - -- Everything below this point is only - -- used if there's no setting for it in - -- the above files. - -- - -- Make sure that ssh detects stalled - -- connections. - , "ServerAliveInterval 60" - ] - return $ concat - [ ps - , [Param "-F", File overideconfigfile] - , map Param (remoteAnnexSshOptions gc) - , opts - , portParams port - , [Param "-T"] - ] + ret ps = return $ concat + [ ps + , map Param (remoteAnnexSshOptions gc) + , opts + , portParams port + , [Param "-T"] + ] {- Returns a filename to use for a ssh connection caching socket, and - parameters to enable ssh connection caching. -} diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -8,6 +8,7 @@ module Annex.VariantFile where import Annex.Common +import Utility.FileSystemEncoding import Data.Hash.MD5 diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -41,10 +41,6 @@ #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 @@ -152,11 +148,6 @@ #ifdef WITH_WEBAPP #ifdef WITH_PAIRING , assist $ pairListenerThread urlrenderer -#endif -#ifdef WITH_XMPP - , assist $ xmppClientThread urlrenderer - , assist $ xmppSendPackThread urlrenderer - , assist $ xmppReceivePackThread urlrenderer #endif #endif , assist pushThread diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -12,7 +12,6 @@ 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.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 a = do i <- addAlert $ alert { alertClass = Activity } removeAlert i `after` a - -getXMPPClientID :: Remote -> ClientID -getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r)) diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -40,8 +40,6 @@ 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 @@ , changePool :: ChangePool , repoProblemChan :: RepoProblemChan , branchChangeHandle :: BranchChangeHandle - , buddyList :: BuddyList - , netMessager :: NetMessager , remoteControl :: RemoteControl , credPairCache :: CredPairCache } @@ -88,8 +84,6 @@ <*> newChangePool <*> newRepoProblemChan <*> newBranchChangeHandle - <*> newBuddyList - <*> newNetMessager <*> newRemoteControl <*> newCredPairCache diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs deleted file mode 100644 --- a/Assistant/NetMessager.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- git-annex assistant out of band network messager interface - - - - Copyright 2012-2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE BangPatterns #-} - -module Assistant.NetMessager where - -import Assistant.Common -import Assistant.Types.NetMessager - -import Control.Concurrent.STM -import Control.Concurrent.MSampleVar -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.DList as D - -sendNetMessage :: NetMessage -> Assistant () -sendNetMessage m = - (atomically . flip writeTChan m) <<~ (netMessages . netMessager) - -waitNetMessage :: Assistant (NetMessage) -waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager) - -notifyNetMessagerRestart :: Assistant () -notifyNetMessagerRestart = - flip writeSV () <<~ (netMessagerRestart . netMessager) - -{- This can be used to get an early indication if the network has - - changed, to immediately restart a connection. However, that is not - - available on all systems, so clients also need to deal with - - restarting dropped connections in the usual way. -} -waitNetMessagerRestart :: Assistant () -waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager) - -{- Store a new important NetMessage for a client, and if an equivilant - - older message is already stored, remove it from both importantNetMessages - - and sentImportantNetMessages. -} -storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant () -storeImportantNetMessage m client matchingclient = go <<~ netMessager - where - go nm = atomically $ do - q <- takeTMVar $ importantNetMessages nm - sent <- takeTMVar $ sentImportantNetMessages nm - putTMVar (importantNetMessages nm) $ - M.alter (Just . maybe (S.singleton m) (S.insert m)) client $ - M.mapWithKey removematching q - putTMVar (sentImportantNetMessages nm) $ - M.mapWithKey removematching sent - removematching someclient s - | matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s - | otherwise = s - -{- Indicates that an important NetMessage has been sent to a client. -} -sentImportantNetMessage :: NetMessage -> ClientID -> Assistant () -sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager) - where - go v = atomically $ do - sent <- takeTMVar v - putTMVar v $ - M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent - -{- Checks for important NetMessages that have been stored for a client, and - - sent to a client. Typically the same client for both, although - - a modified or more specific client may need to be used. -} -checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage) -checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager - where - go nm = atomically $ do - stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm) - sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm) - return (fromMaybe S.empty stored, fromMaybe S.empty sent) - -{- Queues a push initiation message in the queue for the appropriate - - side of the push but only if there is not already an initiation message - - from the same client in the queue. -} -queuePushInitiation :: NetMessage -> Assistant () -queuePushInitiation msg@(Pushing clientid stage) = do - tv <- getPushInitiationQueue side - liftIO $ atomically $ do - r <- tryTakeTMVar tv - case r of - Nothing -> putTMVar tv [msg] - Just l -> do - let !l' = msg : filter differentclient l - putTMVar tv l' - where - side = pushDestinationSide stage - differentclient (Pushing cid _) = cid /= clientid - differentclient _ = True -queuePushInitiation _ = noop - -{- Waits for a push inititation message to be received, and runs - - function to select a message from the queue. -} -waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage -waitPushInitiation side selector = do - tv <- getPushInitiationQueue side - liftIO $ atomically $ do - q <- takeTMVar tv - if null q - then retry - else do - let (msg, !q') = selector q - unless (null q') $ - putTMVar tv q' - return msg - -{- Stores messages for a push into the appropriate inbox. - - - - To avoid overflow, only 1000 messages max are stored in any - - inbox, which should be far more than necessary. - - - - TODO: If we have more than 100 inboxes for different clients, - - discard old ones that are not currently being used by any push. - -} -storeInbox :: NetMessage -> Assistant () -storeInbox msg@(Pushing clientid stage) = do - inboxes <- getInboxes side - stored <- liftIO $ atomically $ do - m <- readTVar inboxes - let update = \v -> do - writeTVar inboxes $ - M.insertWith' const clientid v m - return True - case M.lookup clientid m of - Nothing -> update (1, tostore) - Just (sz, l) - | sz > 1000 -> return False - | otherwise -> - let !sz' = sz + 1 - !l' = D.append l tostore - in update (sz', l') - if stored - then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"] - else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"] - where - side = pushDestinationSide stage - tostore = D.singleton msg -storeInbox _ = noop - -{- Gets the new message for a push from its inbox. - - Blocks until a message has been received. -} -waitInbox :: ClientID -> PushSide -> Assistant (NetMessage) -waitInbox clientid side = do - inboxes <- getInboxes side - liftIO $ atomically $ do - m <- readTVar inboxes - case M.lookup clientid m of - Nothing -> retry - Just (sz, dl) - | sz < 1 -> retry - | otherwise -> do - let msg = D.head dl - let dl' = D.tail dl - let !sz' = sz - 1 - writeTVar inboxes $ - M.insertWith' const clientid (sz', dl') m - return msg - -emptyInbox :: ClientID -> PushSide -> Assistant () -emptyInbox clientid side = do - inboxes <- getInboxes side - liftIO $ atomically $ - modifyTVar' inboxes $ - M.delete clientid - -getInboxes :: PushSide -> Assistant Inboxes -getInboxes side = - getSide side . netMessagerInboxes <$> getAssistant netMessager - -getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage]) -getPushInitiationQueue side = - getSide side . netMessagerPushInitiations <$> getAssistant netMessager - -netMessagerDebug :: ClientID -> [String] -> Assistant () -netMessagerDebug clientid l = debug $ - "NetMessager" : l ++ [show $ logClientID clientid] diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -9,8 +9,6 @@ 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 Utility.Parallel import qualified Git import qualified Git.Command -import qualified Git.Ref import qualified Remote import qualified Types.Remote as Remote import qualified Remote.List as Remote @@ -39,7 +36,6 @@ import Data.Time.Clock import qualified Data.Map as M -import qualified Data.Set as S import Control.Concurrent {- Syncs with remotes that may have been disconnected for a while. @@ -50,21 +46,14 @@ - the remotes have diverged from the local git-annex branch. Otherwise, - it's sufficient to requeue failed transfers. - - - XMPP remotes are also signaled that we can push to them, and we request - - they push to us. Since XMPP pushes run ansynchronously, any scan of the - - XMPP remotes has to be deferred until they're done pushing to us, so - - all XMPP remotes are marked as possibly desynced. - - - Also handles signaling any connectRemoteNotifiers, after the syncing is - done. -} -reconnectRemotes :: Bool -> [Remote] -> Assistant () -reconnectRemotes _ [] = noop -reconnectRemotes notifypushes rs = void $ do +reconnectRemotes :: [Remote] -> Assistant () +reconnectRemotes [] = noop +reconnectRemotes rs = void $ do rs' <- liftIO $ filterM (Remote.checkAvailable True) rs unless (null rs') $ do - modifyDaemonStatus_ $ \s -> s - { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } failedrs <- syncAction rs' (const go) forM_ failedrs $ \r -> whenM (liftIO $ Remote.checkAvailable False r) $ @@ -72,7 +61,7 @@ mapM_ signal $ filter (`notElem` failedrs) rs' where gitremotes = filter (notspecialremote . Remote.repo) rs - (xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs + (_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs notspecialremote r | Git.repoIsUrl r = True | Git.repoIsLocal r = True @@ -81,7 +70,7 @@ sync currentbranch@(Just _, _) = do (failedpull, diverged) <- manualPull currentbranch gitremotes now <- liftIO getCurrentTime - failedpush <- pushToRemotes' now notifypushes gitremotes + failedpush <- pushToRemotes' now gitremotes return (nub $ failedpull ++ failedpush, diverged) {- No local branch exists yet, but we can try pulling. -} sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes @@ -101,9 +90,6 @@ - as "git annex sync", except in parallel, and will co-exist with use of - "git annex sync". - - - After the pushes to normal git remotes, also signals XMPP clients that - - they can request an XMPP push. - - - Avoids running possibly long-duration commands in the Annex monad, so - as not to block other threads. - @@ -121,27 +107,21 @@ - - Returns any remotes that it failed to push to. -} -pushToRemotes :: Bool -> [Remote] -> Assistant [Remote] -pushToRemotes notifypushes remotes = do +pushToRemotes :: [Remote] -> Assistant [Remote] +pushToRemotes remotes = do now <- liftIO getCurrentTime let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes - syncAction remotes' (pushToRemotes' now notifypushes) -pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote] -pushToRemotes' now notifypushes remotes = do + syncAction remotes' (pushToRemotes' now) +pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote] +pushToRemotes' now remotes = do (g, branch, u) <- liftAnnex $ do Annex.Branch.commit "update" (,,) <$> gitRepo <*> join Command.Sync.getCurrBranch <*> getUUID - let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes + let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes ret <- go True branch g u normalremotes - unless (null xmppremotes) $ do - shas <- liftAnnex $ map fst <$> - inRepo (Git.Ref.matchingWithHEAD - [Annex.Branch.fullname, Git.Ref.headRef]) - forM_ xmppremotes $ \r -> sendNetMessage $ - Pushing (getXMPPClientID r) (CanPush u shas) return ret where go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do @@ -151,11 +131,7 @@ (succeeded, failed) <- parallelPush g rs (push branch) updatemap succeeded [] if null failed - then do - when notifypushes $ - sendNetMessage $ NotifyPush $ - map Remote.uuid succeeded - return failed + then return [] else if shouldretry then retry currbranch g u failed else fallback branch g u failed @@ -174,9 +150,6 @@ debug ["fallback pushing to", show rs] (succeeded, failed) <- parallelPush g rs (taggedPush u Nothing branch) updatemap succeeded failed - when (notifypushes && (not $ null succeeded)) $ - sendNetMessage $ NotifyPush $ - map Remote.uuid succeeded return failed push branch remote = Command.Sync.pushBranch remote branch @@ -194,10 +167,6 @@ {- Displays an alert while running an action that syncs with some remotes, - and returns any remotes that it failed to sync with. - - - XMPP remotes are handled specially; since the action can only start - - an async process for them, they are not included in the alert, but are - - still passed to the action. - - - Readonly remotes are also hidden (to hide the web special remote). -} syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote] @@ -221,15 +190,11 @@ - remotes that it failed to pull from, and a Bool indicating - whether the git-annex branches of the remotes and local had - diverged before the pull. - - - - After pulling from the normal git remotes, requests pushes from any - - XMPP remotes. However, those pushes will run asynchronously, so their - - results are not included in the return data. -} manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool) manualPull currentbranch remotes = do g <- liftAnnex gitRepo - let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes + let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes failed <- forM normalremotes $ \r -> do g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g') @@ -239,9 +204,6 @@ haddiverged <- liftAnnex Annex.Branch.forceUpdate forM_ normalremotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig - u <- liftAnnex getUUID - forM_ xmppremotes $ \r -> - sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u) return (catMaybes failed, haddiverged) {- Start syncing a remote, using a background thread. -} @@ -249,7 +211,7 @@ syncRemote remote = do updateSyncRemotes thread <- asIO $ do - reconnectRemotes False [remote] + reconnectRemotes [remote] addScanRemotes True [remote] void $ liftIO $ forkIO $ thread diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -10,20 +10,13 @@ import Assistant.Common import Assistant.TransferQueue import Assistant.BranchChange -import Assistant.DaemonStatus -import Assistant.ScanRemotes import Utility.DirWatcher import Utility.DirWatcher.Types import qualified Annex.Branch import qualified Git import qualified Git.Branch import qualified Command.Sync -import Annex.TaggedPush -import Remote (remoteFromUUID) -import qualified Data.Set as S -import qualified Data.Text as T - {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} mergeThread :: NamedThread @@ -69,8 +62,7 @@ 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 @@ -89,22 +81,6 @@ Git.Branch.AutomaticCommit 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 diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -146,7 +146,7 @@ debug ["detected mount of", dir] rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir mapM_ (fsckNudge urlrenderer . Just) rs - reconnectRemotes True rs + reconnectRemotes rs {- Finds remotes located underneath the mount point. - diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -22,7 +22,6 @@ 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 @@ - 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 @@ sendRemoteControl LOSTNET connchange True = do debug ["detected network connection"] - notifyNetMessagerRestart handleConnection sendRemoteControl RESUME onerr e _ = do @@ -197,7 +194,7 @@ handleConnection :: Assistant () handleConnection = do liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus - reconnectRemotes True =<< networkRemotes + reconnectRemotes =<< networkRemotes {- Network remotes to sync with. -} networkRemotes :: Assistant [Remote] diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -24,7 +24,7 @@ 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 @@ -- Next, wait until at least one commit has been made void getCommits -- Now see if now's a good time to push. - void $ pushToRemotes True =<< pushTargets + void $ pushToRemotes =<< pushTargets {- We want to avoid pushing to remotes that are marked readonly. - diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -76,7 +76,7 @@ - to determine if the remote has been emptied. -} startupScan = do - reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus + reconnectRemotes =<< syncGitRemotes <$> getDaemonStatus addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus {- This is a cheap scan for failed transfers involving a remote. -} diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -26,7 +26,6 @@ import Assistant.WebApp.Configurators.AWS import Assistant.WebApp.Configurators.IA import Assistant.WebApp.Configurators.WebDAV -import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Configurators.Preferences import Assistant.WebApp.Configurators.Unused import Assistant.WebApp.Configurators.Edit @@ -37,6 +36,7 @@ import Assistant.WebApp.Control import Assistant.WebApp.OtherRepos import Assistant.WebApp.Repair +import Assistant.WebApp.Pairing import Assistant.Types.ThreadedMonad import Utility.WebApp import Utility.AuthToken @@ -83,6 +83,7 @@ <*> pure cannotrun <*> pure noannex <*> pure listenhost' + <*> newWormholePairingState setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp app' <- ifM debugEnabled diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs deleted file mode 100644 --- a/Assistant/Threads/XMPPClient.hs +++ /dev/null @@ -1,375 +0,0 @@ -{- git-annex XMPP client - - - - Copyright 2012, 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Threads.XMPPClient where - -import Assistant.Common hiding (ProtocolError) -import Assistant.XMPP -import Assistant.XMPP.Client -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.Types.Buddies -import Assistant.XMPP.Buddies -import Assistant.Sync -import Assistant.DaemonStatus -import qualified Remote -import Utility.ThreadScheduler -import Assistant.WebApp (UrlRenderer) -import Assistant.WebApp.Types hiding (liftAssistant) -import Assistant.Alert -import Assistant.Pairing -import Assistant.XMPP.Git -import Annex.UUID -import Logs.UUID -import qualified Command.Sync - -import Network.Protocol.XMPP -import Control.Concurrent -import Control.Concurrent.STM.TMVar -import Control.Concurrent.STM (atomically) -import qualified Data.Text as T -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Time.Clock -import Control.Concurrent.Async - -xmppClientThread :: UrlRenderer -> NamedThread -xmppClientThread urlrenderer = namedThread "XMPPClient" $ - restartableClient . xmppClient urlrenderer =<< getAssistant id - -{- Runs the client, handing restart events. -} -restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant () -restartableClient a = forever $ go =<< liftAnnex getXMPPCreds - where - go Nothing = waitNetMessagerRestart - go (Just creds) = do - xmppuuid <- maybe NoUUID Remote.uuid . headMaybe - . filter Remote.isXMPPRemote . syncRemotes - <$> getDaemonStatus - tid <- liftIO $ forkIO $ a creds xmppuuid - waitNetMessagerRestart - liftIO $ killThread tid - -xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO () -xmppClient urlrenderer d creds xmppuuid = - retry (runclient creds) =<< getCurrentTime - where - liftAssistant = runAssistant d - inAssistant = liftIO . liftAssistant - - {- When the client exits, it's restarted; - - if it keeps failing, back off to wait 5 minutes before - - trying it again. -} - retry client starttime = do - {- The buddy list starts empty each time - - the client connects, so that stale info - - is not retained. -} - liftAssistant $ - updateBuddyList (const noBuddies) <<~ buddyList - void client - liftAssistant $ do - modifyDaemonStatus_ $ \s -> s - { xmppClientID = Nothing } - changeCurrentlyConnected $ S.delete xmppuuid - - now <- getCurrentTime - if diffUTCTime now starttime > 300 - then do - liftAssistant $ debug ["connection lost; reconnecting"] - retry client now - else do - liftAssistant $ debug ["connection failed; will retry"] - threadDelaySeconds (Seconds 300) - retry client =<< getCurrentTime - - runclient c = liftIO $ connectXMPP c $ \jid -> do - selfjid <- bindJID jid - putStanza gitAnnexSignature - - inAssistant $ do - modifyDaemonStatus_ $ \s -> s - { xmppClientID = Just $ xmppJID creds } - changeCurrentlyConnected $ S.insert xmppuuid - debug ["connected", logJid selfjid] - - lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime - - sender <- xmppSession $ sendnotifications selfjid - receiver <- xmppSession $ receivenotifications selfjid lasttraffic - pinger <- xmppSession $ sendpings selfjid lasttraffic - {- Run all 3 threads concurrently, until - - any of them throw an exception. - - Then kill all 3 threads, and rethrow the - - exception. - - - - If this thread gets an exception, the 3 threads - - will also be killed. -} - liftIO $ pinger `concurrently` sender `concurrently` receiver - - sendnotifications selfjid = forever $ - join $ inAssistant $ relayNetMessage selfjid - receivenotifications selfjid lasttraffic = forever $ do - l <- decodeStanza selfjid <$> getStanza - void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime - inAssistant $ debug - ["received:", show $ map logXMPPEvent l] - mapM_ (handlemsg selfjid) l - sendpings selfjid lasttraffic = forever $ do - putStanza pingstanza - - startping <- liftIO getCurrentTime - liftIO $ threadDelaySeconds (Seconds 120) - t <- liftIO $ atomically $ readTMVar lasttraffic - when (t < startping) $ do - inAssistant $ debug ["ping timeout"] - error "ping timeout" - where - {- XEP-0199 says that the server will respond with either - - a ping response or an error message. Either will - - cause traffic, so good enough. -} - pingstanza = xmppPing selfjid - - handlemsg selfjid (PresenceMessage p) = do - void $ inAssistant $ - updateBuddyList (updateBuddies p) <<~ buddyList - resendImportantMessages selfjid p - handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature - handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us - handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) = - maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) - handlemsg _ (GotNetMessage m@(Pushing _ pushstage)) - | isPushNotice pushstage = inAssistant $ handlePushNotice m - | isPushInitiation pushstage = inAssistant $ queuePushInitiation m - | otherwise = inAssistant $ storeInbox m - handlemsg _ (Ignorable _) = noop - handlemsg _ (Unknown _) = noop - handlemsg _ (ProtocolError _) = noop - - resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do - let c = formatJID jid - (stored, sent) <- inAssistant $ - checkImportantNetMessages (formatJID (baseJID jid), c) - forM_ (S.toList $ S.difference stored sent) $ \msg -> do - let msg' = readdressNetMessage msg c - inAssistant $ debug - [ "sending to new client:" - , logJid jid - , show $ logNetMessage msg' - ] - join $ inAssistant $ convertNetMsg msg' selfjid - inAssistant $ sentImportantNetMessage msg c - resendImportantMessages _ _ = noop - -data XMPPEvent - = GotNetMessage NetMessage - | PresenceMessage Presence - | Ignorable ReceivedStanza - | Unknown ReceivedStanza - | ProtocolError ReceivedStanza - deriving Show - -logXMPPEvent :: XMPPEvent -> String -logXMPPEvent (GotNetMessage m) = logNetMessage m -logXMPPEvent (PresenceMessage p) = logPresence p -logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p -logXMPPEvent (Ignorable _) = "Ignorable message" -logXMPPEvent (Unknown _) = "Unknown message" -logXMPPEvent (ProtocolError _) = "Protocol error message" - -logPresence :: Presence -> String -logPresence (p@Presence { presenceFrom = Just jid }) = unwords - [ "Presence from" - , logJid jid - , show $ extractGitAnnexTag p - ] -logPresence _ = "Presence from unknown" - -logJid :: JID -> String -logJid jid = - let name = T.unpack (buddyName jid) - resource = maybe "" (T.unpack . strResource) (jidResource jid) - in take 1 name ++ show (length name) ++ "/" ++ resource - -logClient :: Client -> String -logClient (Client jid) = logJid jid - -{- Decodes an XMPP stanza into one or more events. -} -decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] -decodeStanza selfjid s@(ReceivedPresence p) - | presenceType p == PresenceError = [ProtocolError s] - | isNothing (presenceFrom p) = [Ignorable s] - | presenceFrom p == Just selfjid = [Ignorable s] - | otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p) - where - decode i - | tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ - decodePushNotification (tagValue i) - | tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence - | otherwise = [Unknown s] - {- Things sent via presence imply a presence message, - - along with their real meaning. -} - impliedp v = [PresenceMessage p, v] -decodeStanza selfjid s@(ReceivedMessage m) - | isNothing (messageFrom m) = [Ignorable s] - | messageFrom m == Just selfjid = [Ignorable s] - | messageType m == MessageError = [ProtocolError s] - | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)] -decodeStanza _ s = [Unknown s] - -{- Waits for a NetMessager message to be sent, and relays it to XMPP. - - - - Chat messages must be directed to specific clients, not a base - - account JID, due to git-annex clients using a negative presence priority. - - PairingNotification messages are always directed at specific - - clients, but Pushing messages are sometimes not, and need to be exploded - - out to specific clients. - - - - Important messages, not directed at any specific client, - - are cached to be sent later when additional clients connect. - -} -relayNetMessage :: JID -> Assistant (XMPP ()) -relayNetMessage selfjid = do - msg <- waitNetMessage - debug ["sending:", logNetMessage msg] - a1 <- handleImportant msg - a2 <- convert msg - return (a1 >> a2) - where - handleImportant msg = case parseJID =<< isImportantNetMessage msg of - Just tojid - | tojid == baseJID tojid -> do - storeImportantNetMessage msg (formatJID tojid) $ - \c -> (baseJID <$> parseJID c) == Just tojid - return $ putStanza presenceQuery - _ -> return noop - convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> - if tojid == baseJID tojid - then do - clients <- maybe [] (S.toList . buddyAssistants) - <$> getBuddy (genBuddyKey tojid) <<~ buddyList - debug ["exploded undirected message to clients", unwords $ map logClient clients] - return $ forM_ clients $ \(Client jid) -> - putStanza $ pushMessage pushstage jid selfjid - else do - debug ["to client:", logJid tojid] - return $ putStanza $ pushMessage pushstage tojid selfjid - convert msg = convertNetMsg msg selfjid - -{- Converts a NetMessage to an XMPP action. -} -convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ()) -convertNetMsg msg selfjid = convert msg - where - convert (NotifyPush us) = return $ putStanza $ pushNotification us - convert QueryPresence = return $ putStanza presenceQuery - convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do - changeBuddyPairing tojid True - return $ putStanza $ pairingNotification stage u tojid selfjid - convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> - return $ putStanza $ pushMessage pushstage tojid selfjid - -withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ()) -withOtherClient selfjid c a = case parseJID c of - Nothing -> return noop - Just tojid - | tojid == selfjid -> return noop - | otherwise -> a tojid - -withClient :: ClientID -> (JID -> XMPP ()) -> XMPP () -withClient c a = maybe noop a $ parseJID c - -{- Returns an IO action that runs a XMPP action in a separate thread, - - using a session to allow it to access the same XMPP client. -} -xmppSession :: XMPP () -> XMPP (IO ()) -xmppSession a = do - s <- getSession - return $ void $ runXMPP s a - -{- We only pull from one remote out of the set listed in the push - - notification, as an optimisation. - - - - Note that it might be possible (though very unlikely) for the push - - notification to take a while to be sent, and multiple pushes happen - - before it is sent, so it includes multiple remotes that were pushed - - to at different times. - - - - It could then be the case that the remote we choose had the earlier - - push sent to it, but then failed to get the later push, and so is not - - fully up-to-date. If that happens, the pushRetryThread will come along - - and retry the push, and we'll get another notification once it succeeds, - - and pull again. -} -pull :: [UUID] -> Assistant () -pull [] = noop -pull us = do - rs <- filter matching . syncGitRemotes <$> getDaemonStatus - debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs - pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch) - where - matching r = Remote.uuid r `S.member` s - s = S.fromList us - - pullone [] _ = noop - pullone (r:rs) branch = - unlessM (null . fst <$> manualPull branch [r]) $ - pullone rs branch - -{- PairReq from another client using our JID is automatically - - accepted. This is so pairing devices all using the same XMPP - - account works without confirmations. - - - - Also, autoaccept PairReq from the same JID of any repo we've - - already paired with, as long as the UUID in the PairReq is - - one we know about. --} -pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () -pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid - | baseJID selfjid == baseJID theirjid = autoaccept - | otherwise = do - knownjids <- mapMaybe (parseJID . getXMPPClientID) - . filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus - um <- liftAnnex uuidMap - if elem (baseJID theirjid) knownjids && M.member theiruuid um - then autoaccept - else showalert - - where - autoaccept = do - selfuuid <- liftAnnex getUUID - sendNetMessage $ - PairingNotification PairAck (formatJID theirjid) selfuuid - finishXMPPPairing theirjid theiruuid - -- Show an alert to let the user decide if they want to pair. - showalert = do - button <- mkAlertButton True (T.pack "Respond") urlrenderer $ - ConfirmXMPPPairFriendR $ - PairKey theiruuid $ formatJID theirjid - void $ addAlert $ pairRequestReceivedAlert - (T.unpack $ buddyName theirjid) - button - -{- PairAck must come from one of the buddies we are pairing with; - - don't pair with just anyone. -} -pairMsgReceived _ PairAck theiruuid _selfjid theirjid = - whenM (isBuddyPairing theirjid) $ do - changeBuddyPairing theirjid False - selfuuid <- liftAnnex getUUID - sendNetMessage $ - PairingNotification PairDone (formatJID theirjid) selfuuid - finishXMPPPairing theirjid theiruuid - -pairMsgReceived _ PairDone _theiruuid _selfjid theirjid = - changeBuddyPairing theirjid False - -isBuddyPairing :: JID -> Assistant Bool -isBuddyPairing jid = maybe False buddyPairing <$> - getBuddy (genBuddyKey jid) <<~ buddyList - -changeBuddyPairing :: JID -> Bool -> Assistant () -changeBuddyPairing jid ispairing = - updateBuddyList (M.adjust set key) <<~ buddyList - where - key = genBuddyKey jid - set b = b { buddyPairing = ispairing } diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs deleted file mode 100644 --- a/Assistant/Threads/XMPPPusher.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- git-annex XMPP pusher threads - - - - This is a pair of threads. One handles git send-pack, - - and the other git receive-pack. Each thread can be running at most - - one such operation at a time. - - - - Why not use a single thread? Consider two clients A and B. - - If both decide to run a receive-pack at the same time to the other, - - they would deadlock with only one thread. For larger numbers of - - clients, the two threads are also sufficient. - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Threads.XMPPPusher where - -import Assistant.Common -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.WebApp (UrlRenderer) -import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) -import Assistant.XMPP.Git - -import Control.Exception as E - -xmppSendPackThread :: UrlRenderer -> NamedThread -xmppSendPackThread = pusherThread "XMPPSendPack" SendPack - -xmppReceivePackThread :: UrlRenderer -> NamedThread -xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack - -pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread -pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing - where - go lastpushedto = do - msg <- waitPushInitiation side $ selectNextPush lastpushedto - debug ["started running push", logNetMessage msg] - - runpush <- asIO $ runPush checker msg - r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID))) - let successful = case r of - Right (Just _) -> True - _ -> False - - {- Empty the inbox, because stuff may have - - been left in it if the push failed. -} - let justpushedto = getclient msg - maybe noop (`emptyInbox` side) justpushedto - - debug ["finished running push", logNetMessage msg, show successful] - go $ if successful then justpushedto else lastpushedto - - checker = checkCloudRepos urlrenderer - - getclient (Pushing cid _) = Just cid - getclient _ = Nothing - -{- Select the next push to run from the queue. - - The queue cannot be empty! - - - - We prefer to select the most recently added push, because its requestor - - is more likely to still be connected. - - - - When passed the ID of a client we just pushed to, we prefer to not - - immediately push again to that same client. This avoids one client - - drowing out others. So pushes from the client we just pushed to are - - relocated to the beginning of the list, to be processed later. - -} -selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage]) -selectNextPush _ (m:[]) = (m, []) -- common case -selectNextPush _ [] = error "selectNextPush: empty list" -selectNextPush lastpushedto l = go [] l - where - go (r:ejected) [] = (r, ejected) - go rejected (m:ms) = case m of - (Pushing clientid _) - | Just clientid /= lastpushedto -> (m, rejected ++ ms) - _ -> go (m:rejected) ms - go [] [] = error "empty push queue" - diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -74,8 +74,6 @@ , std_in = CreatePipe , std_out = CreatePipe } - fileEncoding readh - fileEncoding writeh return $ Transferrer { transferrerRead = readh , transferrerWrite = writeh diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs deleted file mode 100644 --- a/Assistant/Types/Buddies.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- git-annex assistant buddies - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Assistant.Types.Buddies where - -import Annex.Common - -import qualified Data.Map as M -import Control.Concurrent.STM -import Utility.NotificationBroadcaster -import Data.Text as T - -{- For simplicity, dummy types are defined even when XMPP is disabled. -} -#ifdef WITH_XMPP -import Network.Protocol.XMPP -import Data.Set as S -import Data.Ord - -newtype Client = Client JID - deriving (Eq, Show) - -instance Ord Client where - compare = comparing show - -data Buddy = Buddy - { buddyPresent :: S.Set Client - , buddyAway :: S.Set Client - , buddyAssistants :: S.Set Client - , buddyPairing :: Bool - } -#else -data Buddy = Buddy -#endif - deriving (Eq, Show) - -data BuddyKey = BuddyKey T.Text - deriving (Eq, Ord, Show, Read) - -data PairKey = PairKey UUID T.Text - deriving (Eq, Ord, Show, Read) - -type Buddies = M.Map BuddyKey Buddy - -{- A list of buddies, and a way to notify when it changes. -} -type BuddyList = (TMVar Buddies, NotificationBroadcaster) - -noBuddies :: Buddies -noBuddies = M.empty - -newBuddyList :: IO BuddyList -newBuddyList = (,) - <$> atomically (newTMVar noBuddies) - <*> newNotificationBroadcaster - -getBuddyList :: BuddyList -> IO [Buddy] -getBuddyList (v, _) = M.elems <$> atomically (readTMVar v) - -getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy) -getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v) - -getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster -getBuddyBroadcaster (_, h) = h - -{- Applies a function to modify the buddy list, and if it's changed, - - sends notifications to any listeners. -} -updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO () -updateBuddyList a (v, caster) = do - changed <- atomically $ do - buds <- takeTMVar v - let buds' = a buds - putTMVar v buds' - return $ buds /= buds' - when changed $ - sendNotification caster diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -12,7 +12,6 @@ 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 @@ , 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 @@ , 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 @@ <*> pure [] <*> pure False <*> pure S.empty - <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster @@ -117,5 +110,4 @@ <*> newNotificationBroadcaster <*> pure Nothing <*> pure M.empty - <*> pure Nothing <*> pure M.empty diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs deleted file mode 100644 --- a/Assistant/Types/NetMessager.hs +++ /dev/null @@ -1,155 +0,0 @@ -{- git-annex assistant out of band network messager types - - - - Copyright 2012 Joey Hess - - - - 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 "" -logNetMessage (PairingNotification stage c uuid) = - show $ PairingNotification stage (logClientID c) uuid -logNetMessage m = show m - -logClientID :: ClientID -> ClientID -logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c] - -{- Things that initiate either side of a push, but do not actually send data. -} -isPushInitiation :: PushStage -> Bool -isPushInitiation (PushRequest _) = True -isPushInitiation (StartingPush _) = True -isPushInitiation _ = False - -isPushNotice :: PushStage -> Bool -isPushNotice (CanPush _ _) = True -isPushNotice _ = False - -data PushSide = SendPack | ReceivePack - deriving (Eq, Ord, Show) - -pushDestinationSide :: PushStage -> PushSide -pushDestinationSide (CanPush _ _) = ReceivePack -pushDestinationSide (PushRequest _) = SendPack -pushDestinationSide (StartingPush _) = ReceivePack -pushDestinationSide (ReceivePackOutput _ _) = SendPack -pushDestinationSide (SendPackOutput _ _) = ReceivePack -pushDestinationSide (ReceivePackDone _) = SendPack - -type SideMap a = PushSide -> a - -mkSideMap :: STM a -> IO (SideMap a) -mkSideMap gen = do - (sp, rp) <- atomically $ (,) <$> gen <*> gen - return $ lookupside sp rp - where - lookupside sp _ SendPack = sp - lookupside _ rp ReceivePack = rp - -getSide :: PushSide -> SideMap a -> a -getSide side m = m side - -type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage)) - -data NetMessager = NetMessager - -- outgoing messages - { netMessages :: TChan NetMessage - -- important messages for each client - , importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) - -- important messages that are believed to have been sent to a client - , sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) - -- write to this to restart the net messager - , netMessagerRestart :: MSampleVar () - -- queue of incoming messages that request the initiation of pushes - , netMessagerPushInitiations :: SideMap (TMVar [NetMessage]) - -- incoming messages containing data for a running - -- (or not yet started) push - , netMessagerInboxes :: SideMap Inboxes - } - -newNetMessager :: IO NetMessager -newNetMessager = NetMessager - <$> atomically newTChan - <*> atomically (newTMVar M.empty) - <*> atomically (newTMVar M.empty) - <*> newEmptySV - <*> mkSideMap newEmptyTMVar - <*> mkSideMap (newTVar M.empty) diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -5,26 +5,18 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} module Assistant.WebApp.Configurators where import Assistant.WebApp.Common import Assistant.WebApp.RepoList -#ifdef WITH_XMPP -import Assistant.XMPP.Client -#endif {- The main configuration screen. -} getConfigurationR :: Handler Html getConfigurationR = ifM inFirstRun ( redirect FirstRepositoryR , page "Configuration" (Just Configuration) $ do -#ifdef WITH_XMPP - xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds -#else - let xmppconfigured = False -#endif $(widgetFile "configurators/main") ) @@ -39,8 +31,8 @@ makeCloudRepositories :: Widget makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud") -makeXMPPConnection :: Widget -makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection") +makeWormholePairing :: Widget +makeWormholePairing = $(widgetFile "configurators/addrepository/wormholepairing") makeSshRepository :: Widget makeSshRepository = $(widgetFile "configurators/addrepository/ssh") diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -37,16 +37,8 @@ go Nothing = error "Unknown UUID" go (Just _) = a -handleXMPPRemoval :: UUID -> Handler Html -> Handler Html -handleXMPPRemoval uuid nonxmpp = do - remote <- fromMaybe (error "unknown remote") - <$> liftAnnex (Remote.remoteFromUUID uuid) - if Remote.isXMPPRemote remote - then deletionPage $ $(widgetFile "configurators/delete/xmpp") - else nonxmpp - getDeleteRepositoryR :: UUID -> Handler Html -getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do +getDeleteRepositoryR uuid = notCurrentRepo uuid $ do deletionPage $ do reponame <- liftAnnex $ Remote.prettyUUID uuid $(widgetFile "configurators/delete/start") diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -1,41 +1,41 @@ {- git-annex assistant webapp configurator for pairing - - - Copyright 2012 Joey Hess + - Copyright 2012,2016 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-} {-# LANGUAGE CPP #-} 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 +import Assistant.DaemonStatus import Assistant.Pairing.MakeRemote +import Assistant.Pairing.Network import Assistant.Ssh -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 Utility.Tor +import Utility.Su +import Assistant.WebApp.Pairing +import Assistant.Alert +import qualified Utility.MagicWormhole as Wormhole +import Assistant.MakeRemote +import Assistant.RemoteControl +import Assistant.Sync +import Assistant.WebApp.SideBar +import Command.P2P (unusedPeerRemoteName, PairingResult(..)) +import P2P.Address import Git +import Config.Files +import qualified Data.Map as M import qualified Data.Text as T #ifdef WITH_PAIRING import qualified Data.Text.Encoding as T @@ -44,85 +44,112 @@ import qualified Control.Exception as E import Control.Concurrent #endif -#ifdef WITH_XMPP -import qualified Data.Set as S -#endif +import Control.Concurrent.STM hiding (check) -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 +getStartWormholePairFriendR :: Handler Html +getStartWormholePairFriendR = startWormholePairR PairingWithFriend -noXMPPPairing :: Handler Html -noXMPPPairing = noPairing "XMPP" -#endif +getStartWormholePairSelfR :: Handler Html +getStartWormholePairSelfR = startWormholePairR PairingWithSelf -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 +startWormholePairR :: PairingWith -> Handler Html +startWormholePairR pairingwith = whenTorInstalled $ whenWormholeInstalled $ + pairPage $ do + sucommand <- liftIO $ mkSuCommand "git-annex" [Param "enable-tor"] + $(widgetFile "configurators/pairing/wormhole/start") -getRunningXMPPPairFriendR :: BuddyKey -> Handler Html -getRunningXMPPPairFriendR = sendXMPPPairRequest . Just +getPrepareWormholePairR :: PairingWith -> Handler Html +getPrepareWormholePairR pairingwith = do + enableTor + myaddrs <- liftAnnex loadP2PAddresses + remotename <- liftAnnex unusedPeerRemoteName + h <- liftAssistant $ + startWormholePairing pairingwith remotename myaddrs + i <- liftIO . addWormholePairingState h + =<< wormholePairingState <$> getYesod + redirect $ RunningWormholePairR i -getRunningXMPPPairSelfR :: Handler Html -getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing +enableTor :: Handler () +enableTor = do + gitannex <- liftIO readProgramFile + (transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing + if ok + -- Reload remotedameon so it's serving the tor hidden + -- service. + then liftAssistant $ sendRemoteControl RELOAD + else giveup $ "Failed to enable tor\n\n" ++ transcript -{- 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 +getRunningWormholePairR :: WormholePairingId -> Handler Html +getRunningWormholePairR = runningWormholePairR + +postRunningWormholePairR :: WormholePairingId -> Handler Html +postRunningWormholePairR = runningWormholePairR + +runningWormholePairR :: WormholePairingId -> Handler Html +runningWormholePairR i = go =<< getWormholePairingHandle i 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 + go Nothing = redirect StartWormholePairFriendR + go (Just h) = pairPage $ withPairingWith h $ \pairingwith -> do + ourcode <- liftIO $ getOurWormholeCode h + let codeprompt = case pairingwith of + PairingWithFriend -> "Your friend's pairing code" + PairingWithSelf -> "The other device's pairing code" + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ + areq (checkwormholecode ourcode pairingwith textField) (bfs codeprompt) Nothing + case result of + FormSuccess t -> case Wormhole.toCode (T.unpack t) of + Nothing -> giveup invalidcode + Just theircode -> finish h theircode + _ -> showform form enctype ourcode pairingwith + + showform form enctype ourcode pairingwith = + $(widgetFile "configurators/pairing/wormhole/prompt") + + checkwormholecode ourcode pairingwith = check $ \t -> + case Wormhole.toCode (T.unpack t) of + Nothing -> Left (T.pack invalidcode) + Just theircode + | theircode == ourcode -> Left $ + case pairingwith of + PairingWithSelf -> "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository." + PairingWithFriend -> "Oops -- You entered your pairing code. Enter your friend's pairing code." + | otherwise -> Right t + invalidcode = "That does not look like a valid pairing code. Try again..." + + finish h theircode = do + void $ liftIO $ sendTheirWormholeCode h theircode + res <- liftAssistant $ finishWormholePairing h + case res of + SendFailed -> giveup "Failed sending data to pair." + ReceiveFailed -> giveup "Failed receiving data from pair." + LinkFailed e -> giveup $ "Failed linking to pair: " ++ e + PairSuccess -> withRemoteName h $ \remotename -> do + r <- liftAnnex $ addRemote (return remotename) + liftAssistant $ syncRemote r + liftAssistant $ sendRemoteControl RELOAD + redirect DashboardR + +getWormholePairingHandle :: WormholePairingId -> Handler (Maybe WormholePairingHandle) +getWormholePairingHandle i = do + s <- wormholePairingState <$> getYesod + liftIO $ atomically $ M.lookup i <$> readTVar s + +whenTorInstalled :: Handler Html -> Handler Html +whenTorInstalled a = ifM (liftIO torIsInstalled) + ( a + , page "Need Tor" (Just Configuration) $ + $(widgetFile "configurators/needtor") + ) + +whenWormholeInstalled :: Handler Html -> Handler Html +whenWormholeInstalled a = ifM (liftIO Wormhole.isInstalled) + ( a + , page "Need Magic Wormhole" (Just Configuration) $ + $(widgetFile "configurators/needmagicwormhole") + ) + {- Starts local pairing. -} getStartLocalPairR :: Handler Html getStartLocalPairR = postStartLocalPairR @@ -156,41 +183,6 @@ uuid = Just $ pairUUID $ pairMsgData msg #else 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 diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs deleted file mode 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ /dev/null @@ -1,226 +0,0 @@ -{- git-annex assistant XMPP configuration - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-} -{-# LANGUAGE CPP #-} - -module Assistant.WebApp.Configurators.XMPP where - -import Assistant.WebApp.Common -import Assistant.WebApp.Notifications -import Utility.NotificationBroadcaster -#ifdef WITH_XMPP -import qualified Remote -import Assistant.XMPP.Client -import Assistant.XMPP.Buddies -import Assistant.Types.Buddies -import Assistant.NetMessager -import Assistant.Alert -import Assistant.DaemonStatus -import Assistant.WebApp.RepoList -import Assistant.WebApp.Configurators -import Assistant.XMPP -import qualified Git.Remote.Remove -import Remote.List -import Creds -#endif - -#ifdef WITH_XMPP -import Network.Protocol.XMPP -import Network -import qualified Data.Text as T -#endif - -{- When appropriate, displays an alert suggesting to configure a cloud repo - - to suppliment an XMPP remote. -} -checkCloudRepos :: UrlRenderer -> Remote -> Assistant () -#ifdef WITH_XMPP -checkCloudRepos urlrenderer r = - unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do - buddyname <- getBuddyName $ Remote.uuid r - button <- mkAlertButton True "Add a cloud repository" urlrenderer $ - NeedCloudRepoR $ Remote.uuid r - void $ addAlert $ cloudRepoNeededAlert buddyname button -#else -checkCloudRepos _ _ = noop -#endif - -#ifdef WITH_XMPP -{- Returns the name of the friend corresponding to a - - repository's UUID, but not if it's our name. -} -getBuddyName :: UUID -> Assistant (Maybe String) -getBuddyName u = go =<< getclientjid - where - go Nothing = return Nothing - go (Just myjid) = (T.unpack . buddyName <$>) - . headMaybe - . filter (\j -> baseJID j /= baseJID myjid) - . map fst - . filter (\(_, r) -> Remote.uuid r == u) - <$> getXMPPRemotes - getclientjid = maybe Nothing parseJID . xmppClientID - <$> getDaemonStatus -#endif - -getNeedCloudRepoR :: UUID -> Handler Html -#ifdef WITH_XMPP -getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do - buddyname <- liftAssistant $ getBuddyName for - $(widgetFile "configurators/xmpp/needcloudrepo") -#else -getNeedCloudRepoR _ = xmppPage $ - $(widgetFile "configurators/xmpp/disabled") -#endif - -getXMPPConfigR :: Handler Html -getXMPPConfigR = postXMPPConfigR - -postXMPPConfigR :: Handler Html -postXMPPConfigR = xmppform DashboardR - -getXMPPConfigForPairFriendR :: Handler Html -getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR - -postXMPPConfigForPairFriendR :: Handler Html -postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR - -getXMPPConfigForPairSelfR :: Handler Html -getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR - -postXMPPConfigForPairSelfR :: Handler Html -postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR - -xmppform :: Route WebApp -> Handler Html -#ifdef WITH_XMPP -xmppform next = xmppPage $ do - ((result, form), enctype) <- liftH $ do - oldcreds <- liftAnnex getXMPPCreds - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $ - creds2Form <$> oldcreds - let showform problem = $(widgetFile "configurators/xmpp") - case result of - FormSuccess f -> either (showform . Just) (liftH . storecreds) - =<< liftIO (validateForm f) - _ -> showform Nothing - where - storecreds creds = do - void $ liftAnnex $ setXMPPCreds creds - liftAssistant notifyNetMessagerRestart - redirect next -#else -xmppform _ = xmppPage $ - $(widgetFile "configurators/xmpp/disabled") -#endif - -{- Called by client to get a list of buddies. - - - - Returns a div, which will be inserted into the calling page. - -} -getBuddyListR :: NotificationId -> Handler Html -getBuddyListR nid = do - waitNotifier getBuddyListBroadcaster nid - - p <- widgetToPageContent buddyListDisplay - withUrlRenderer $ [hamlet|^{pageBody p}|] - -buddyListDisplay :: Widget -buddyListDisplay = do - autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int) -#ifdef WITH_XMPP - myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus - let isself (BuddyKey b) = Just b == myjid - buddies <- liftAssistant $ do - pairedwith <- map fst <$> getXMPPRemotes - catMaybes . map (buddySummary pairedwith) - <$> (getBuddyList <<~ buddyList) - $(widgetFile "configurators/xmpp/buddylist") -#else - noop -#endif - where - ident = "buddylist" - -#ifdef WITH_XMPP - -getXMPPRemotes :: Assistant [(JID, Remote)] -getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes - <$> getDaemonStatus - where - pair r = maybe Nothing (\jid -> Just (jid, r)) $ - parseJID $ getXMPPClientID r - -data XMPPForm = XMPPForm - { formJID :: Text - , formPassword :: Text } - -creds2Form :: XMPPCreds -> XMPPForm -creds2Form c = XMPPForm (xmppJID c) (xmppPassword c) - -xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm -xmppAForm d = XMPPForm - <$> areq jidField (bfs "Jabber address") (formJID <$> d) - <*> areq passwordField (bfs "Password") Nothing - -jidField :: MkField Text -jidField = checkBool (isJust . parseJID) bad textField - where - bad :: Text - bad = "This should look like an email address.." - -validateForm :: XMPPForm -> IO (Either String XMPPCreds) -validateForm f = do - let jid = fromMaybe (error "bad JID") $ parseJID (formJID f) - let username = fromMaybe "" (strNode <$> jidNode jid) - testXMPP $ XMPPCreds - { xmppUsername = username - , xmppPassword = formPassword f - , xmppHostname = T.unpack $ strDomain $ jidDomain jid - , xmppPort = 5222 - , xmppJID = formJID f - } - -testXMPP :: XMPPCreds -> IO (Either String XMPPCreds) -testXMPP creds = do - (good, bad) <- partition (either (const False) (const True) . snd) - <$> connectXMPP creds (const noop) - case good of - (((h, PortNumber p), _):_) -> return $ Right $ creds - { xmppHostname = h - , xmppPort = fromIntegral p - } - (((h, _), _):_) -> return $ Right $ creds - { xmppHostname = h - } - _ -> return $ Left $ intercalate "; " $ map formatlog bad - where - formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e - formatlog _ = "" - - showport (PortNumber n) = show n - showport (Service s) = s - showport (UnixSocket s) = s -#endif - -getDisconnectXMPPR :: Handler Html -getDisconnectXMPPR = do -#ifdef WITH_XMPP - rs <- filter Remote.isXMPPRemote . syncRemotes - <$> liftAssistant getDaemonStatus - liftAnnex $ do - mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs - void remoteListRefresh - removeCreds xmppCredsFile - liftAssistant $ do - updateSyncRemotes - notifyNetMessagerRestart - redirect DashboardR -#else - xmppPage $ $(widgetFile "configurators/xmpp/disabled") -#endif - -xmppPage :: Widget -> Handler Html -xmppPage = page "Jabber" (Just Configuration) diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -74,5 +74,5 @@ getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexLogFile logs <- liftIO $ listLogs logfile - logcontent <- liftIO $ concat <$> mapM readFileStrictAnyEncoding logs + logcontent <- liftIO $ concat <$> mapM readFile logs $(widgetFile "control/log") diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs --- a/Assistant/WebApp/Notifications.hs +++ b/Assistant/WebApp/Notifications.hs @@ -13,7 +13,6 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.DaemonStatus -import Assistant.Types.Buddies import Utility.NotificationBroadcaster import Utility.Yesod import Utility.AuthToken @@ -60,9 +59,6 @@ getNotifierSideBarR :: Handler RepPlain getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster -getNotifierBuddyListR :: Handler RepPlain -getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster - getNotifierRepoListR :: RepoSelector -> Handler RepPlain getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster where @@ -76,9 +72,6 @@ getAlertBroadcaster :: Assistant NotificationBroadcaster getAlertBroadcaster = alertNotifier <$> getDaemonStatus - -getBuddyListBroadcaster :: Assistant NotificationBroadcaster -getBuddyListBroadcaster = getBuddyBroadcaster <$> getAssistant buddyList getRepoListBroadcaster :: Assistant NotificationBroadcaster getRepoListBroadcaster = syncRemotesNotifier <$> getDaemonStatus diff --git a/Assistant/WebApp/Pairing.hs b/Assistant/WebApp/Pairing.hs new file mode 100644 --- /dev/null +++ b/Assistant/WebApp/Pairing.hs @@ -0,0 +1,79 @@ +{- git-annex assistant pairing + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Assistant.WebApp.Pairing where + +import Assistant.Common +import qualified Utility.MagicWormhole as Wormhole +import Command.P2P (wormholePairing, PairingResult(..)) +import P2P.Address +import Annex.Concurrent +import Git.Types + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Data.Map as M + +data PairingWith = PairingWithSelf | PairingWithFriend + deriving (Eq, Show, Read) + +type WormholePairingState = TVar (M.Map WormholePairingId WormholePairingHandle) + +type WormholePairingHandle = (PairingWith, RemoteName, MVar Wormhole.CodeObserver, MVar Wormhole.Code, Async (Annex PairingResult)) + +newtype WormholePairingId = WormholePairingId Int + deriving (Ord, Eq, Show, Read) + +newWormholePairingState :: IO WormholePairingState +newWormholePairingState = newTVarIO M.empty + +addWormholePairingState :: WormholePairingHandle -> WormholePairingState -> IO WormholePairingId +addWormholePairingState h tv = atomically $ do + m <- readTVar tv + -- use of head is safe because allids is infinite + let i = Prelude.head $ filter (`notElem` M.keys m) allids + writeTVar tv (M.insertWith' const i h m) + return i + where + allids = map WormholePairingId [1..] + +-- | Starts the wormhole pairing processes. +startWormholePairing :: PairingWith -> RemoteName -> [P2PAddress] -> Assistant WormholePairingHandle +startWormholePairing pairingwith remotename ouraddrs = do + observerrelay <- liftIO newEmptyMVar + producerrelay <- liftIO newEmptyMVar + -- wormholePairing needs to run in the Annex monad, and is a + -- long-duration action. So, don't just liftAnnex to run it; + -- fork the Annex state. + runner <- liftAnnex $ forkState $ + wormholePairing remotename ouraddrs $ \observer producer -> do + putMVar observerrelay observer + theircode <- takeMVar producerrelay + Wormhole.sendCode producer theircode + tid <- liftIO $ async runner + return (pairingwith, remotename, observerrelay, producerrelay, tid) + +-- | Call after sendTheirWormholeCode. This can take some time to return. +finishWormholePairing :: WormholePairingHandle -> Assistant PairingResult +finishWormholePairing (_, _, _, _, tid) = liftAnnex =<< liftIO (wait tid) + +-- | Waits for wormhole to produce our code. Can be called repeatedly, safely. +getOurWormholeCode :: WormholePairingHandle -> IO Wormhole.Code +getOurWormholeCode (_, _, observerrelay, _, _) = + readMVar observerrelay >>= Wormhole.waitCode + +-- | Sends their code to wormhole. If their code has already been sent, +-- avoids blocking and returns False. +sendTheirWormholeCode :: WormholePairingHandle -> Wormhole.Code -> IO Bool +sendTheirWormholeCode (_, _, _, producerrelay, _) = tryPutMVar producerrelay + +withPairingWith :: WormholePairingHandle -> (PairingWith -> a) -> a +withPairingWith (pairingwith, _, _, _, _) a = a pairingwith + +withRemoteName :: WormholePairingHandle -> (RemoteName -> a) -> a +withRemoteName (_, remotename, _, _, _) a = a remotename diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -260,7 +260,7 @@ if u == uuid then do thread <- liftAssistant $ asIO $ - reconnectRemotes True + reconnectRemotes =<< (syncRemotes <$> getDaemonStatus) void $ liftIO $ forkIO thread else maybe noop (liftAssistant . syncRemote) diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -18,7 +18,6 @@ import Assistant.Common import Assistant.Ssh import Assistant.Pairing -import Assistant.Types.Buddies import Utility.NotificationBroadcaster import Utility.AuthToken import Utility.WebApp @@ -28,6 +27,7 @@ import Build.SysConfig (packageversion) import Types.ScheduledActivity import Assistant.WebApp.RepoId +import Assistant.WebApp.Pairing import Types.Distribution import Yesod.Static @@ -49,6 +49,7 @@ , cannotRun :: Maybe String , noAnnex :: Bool , listenHost ::Maybe HostName + , wormholePairingState :: WormholePairingState } mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -166,30 +167,30 @@ toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece BuddyKey where +instance PathPiece RepoSelector where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece PairKey where +instance PathPiece ThreadName where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece RepoSelector where +instance PathPiece ScheduledActivity where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece ThreadName where +instance PathPiece RepoId where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece ScheduledActivity where +instance PathPiece GitAnnexDistribution where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece RepoId where +instance PathPiece PairingWith where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece GitAnnexDistribution where +instance PathPiece WormholePairingId where toPathPiece = pack . show fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -16,11 +16,6 @@ /config ConfigurationR GET /config/preferences PreferencesR GET POST -/config/xmpp XMPPConfigR GET POST -/config/xmpp/for/self XMPPConfigForPairSelfR GET POST -/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST -/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET -/config/xmpp/disconnect DisconnectXMPPR GET /config/needconnection ConnectionNeededR GET /config/fsck ConfigFsckR GET POST /config/fsck/preferences ConfigFsckPreferencesR POST @@ -67,13 +62,10 @@ /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/pair/wormhole/start/self StartWormholePairSelfR GET +/config/repository/pair/wormhole/start/friend StartWormholePairFriendR GET +/config/repository/pair/wormhole/prepare/#PairingWith PrepareWormholePairR GET +/config/repository/pair/wormhole/running/#WormholePairingId RunningWormholePairR GET POST /config/repository/enable/rsync/#UUID EnableRsyncR GET POST /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST @@ -102,9 +94,6 @@ /sidebar/#NotificationId SideBarR GET /notifier/sidebar NotifierSideBarR GET - -/buddylist/#NotificationId BuddyListR GET -/notifier/buddylist NotifierBuddyListR GET /repolist/#NotificationId/#RepoSelector RepoListR GET /notifier/repolist/#RepoSelector NotifierRepoListR GET diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs deleted file mode 100644 --- a/Assistant/XMPP.hs +++ /dev/null @@ -1,275 +0,0 @@ -{- core xmpp support - - - - Copyright 2012-2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE OverloadedStrings #-} - -module Assistant.XMPP where - -import Assistant.Common -import Assistant.Types.NetMessager -import Assistant.Pairing -import Git.Sha (extractSha) -import Git - -import Network.Protocol.XMPP hiding (Node) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as M -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.XML.Types -import qualified "sandi" Codec.Binary.Base64 as B64 -import Data.Bits.Utils - -{- Name of the git-annex tag, in our own XML namespace. - - (Not using a namespace URL to avoid unnecessary bloat.) -} -gitAnnexTagName :: Name -gitAnnexTagName = "{git-annex}git-annex" - -{- Creates a git-annex tag containing a particular attribute and value. -} -gitAnnexTag :: Name -> Text -> Element -gitAnnexTag attr val = gitAnnexTagContent attr val [] - -{- Also with some content. -} -gitAnnexTagContent :: Name -> Text -> [Node] -> Element -gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])] - -isGitAnnexTag :: Element -> Bool -isGitAnnexTag t = elementName t == gitAnnexTagName - -{- Things that a git-annex tag can inserted into. -} -class GitAnnexTaggable a where - insertGitAnnexTag :: a -> Element -> a - - extractGitAnnexTag :: a -> Maybe Element - - hasGitAnnexTag :: a -> Bool - hasGitAnnexTag = isJust . extractGitAnnexTag - -instance GitAnnexTaggable Message where - insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m } - extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads - -instance GitAnnexTaggable Presence where - -- always mark extended away and set presence priority to negative - insertGitAnnexTag p elt = p - { presencePayloads = extendedAway : negativePriority : elt : presencePayloads p } - extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads - -data GitAnnexTagInfo = GitAnnexTagInfo - { tagAttr :: Name - , tagValue :: Text - , tagElement :: Element - } - -type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage - -gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo -gitAnnexTagInfo v = case extractGitAnnexTag v of - {- Each git-annex tag has a single attribute. -} - Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo - <$> pure attr - <*> attributeText attr tag - <*> pure tag - _ -> Nothing - -{- A presence with a git-annex tag in it. - - Also includes a status tag, which may be visible in XMPP clients. -} -gitAnnexPresence :: Element -> Presence -gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable - where - addStatusTag p = p - { presencePayloads = status : presencePayloads p } - status = Element "status" [] [statusMessage] - statusMessage = NodeContent $ ContentText $ T.pack "git-annex" - -{- A presence with an empty git-annex tag in it, used for letting other - - clients know we're around and are a git-annex client. -} -gitAnnexSignature :: Presence -gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] [] - -{- XMPP client to server ping -} -xmppPing :: JID -> IQ -xmppPing selfjid = (emptyIQ IQGet) - { iqID = Just "c2s1" - , iqFrom = Just selfjid - , iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing - , iqPayload = Just $ Element xmppPingTagName [] [] - } - -xmppPingTagName :: Name -xmppPingTagName = "{urn:xmpp}ping" - -{- A message with a git-annex tag in it. -} -gitAnnexMessage :: Element -> JID -> JID -> Message -gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt) - { messageTo = Just tojid - , messageFrom = Just fromjid - } - -{- A notification that we've pushed to some repositories, listing their - - UUIDs. -} -pushNotification :: [UUID] -> Presence -pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification - -encodePushNotification :: [UUID] -> Text -encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID) - -decodePushNotification :: Text -> [UUID] -decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep - -uuidSep :: Text -uuidSep = "," - -{- A request for other git-annex clients to send presence. -} -presenceQuery :: Presence -presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty - -{- A notification about a stage of pairing. -} -pairingNotification :: PairStage -> UUID -> JID -> JID -> Message -pairingNotification pairstage u = gitAnnexMessage $ - gitAnnexTag pairAttr $ encodePairingNotification pairstage u - -encodePairingNotification :: PairStage -> UUID -> Text -encodePairingNotification pairstage u = T.unwords $ map T.pack - [ show pairstage - , fromUUID u - ] - -decodePairingNotification :: Decoder -decodePairingNotification m = parse . words . T.unpack . tagValue - where - parse [stage, u] = PairingNotification - <$> readish stage - <*> (formatJID <$> messageFrom m) - <*> pure (toUUID u) - parse _ = Nothing - -pushMessage :: PushStage -> JID -> JID -> Message -pushMessage = gitAnnexMessage . encode - where - encode (CanPush u shas) = - gitAnnexTag canPushAttr $ T.pack $ unwords $ - fromUUID u : map fromRef shas - encode (PushRequest u) = - gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u - encode (StartingPush u) = - gitAnnexTag startingPushAttr $ T.pack $ fromUUID u - encode (ReceivePackOutput n b) = - gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b - encode (SendPackOutput n b) = - gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b - encode (ReceivePackDone code) = - gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code - val = T.pack . show - -decodeMessage :: Message -> Maybe NetMessage -decodeMessage m = decode =<< gitAnnexTagInfo m - where - decode i = M.lookup (tagAttr i) decoders >>= rundecoder i - rundecoder i d = d m i - decoders = M.fromList $ zip - [ pairAttr - , canPushAttr - , pushRequestAttr - , startingPushAttr - , receivePackAttr - , sendPackAttr - , receivePackDoneAttr - ] - [ decodePairingNotification - , pushdecoder $ shasgen CanPush - , pushdecoder $ gen PushRequest - , pushdecoder $ gen StartingPush - , pushdecoder $ seqgen ReceivePackOutput - , pushdecoder $ seqgen SendPackOutput - , pushdecoder $ - fmap (ReceivePackDone . decodeExitCode) . readish . - T.unpack . tagValue - ] - pushdecoder a m' i = Pushing - <$> (formatJID <$> messageFrom m') - <*> a i - gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i))) - seqgen c i = do - packet <- decodeTagContent $ tagElement i - let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i - return $ c seqnum packet - shasgen c i = do - let (u:shas) = words $ T.unpack $ tagValue i - return $ c (toUUID u) (mapMaybe extractSha shas) - -decodeExitCode :: Int -> ExitCode -decodeExitCode 0 = ExitSuccess -decodeExitCode n = ExitFailure n - -encodeExitCode :: ExitCode -> Int -encodeExitCode ExitSuccess = 0 -encodeExitCode (ExitFailure n) = n - -{- Base 64 encoding a ByteString to use as the content of a tag. -} -encodeTagContent :: ByteString -> [Node] -encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b] - -decodeTagContent :: Element -> Maybe ByteString -decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s) - where - s = T.unpack $ T.concat $ elementText elt - -{- The JID without the client part. -} -baseJID :: JID -> JID -baseJID j = JID (jidNode j) (jidDomain j) Nothing - -{- An XMPP chat message with an empty body. This should not be displayed - - by clients, but can be used for communications. -} -silentMessage :: Message -silentMessage = (emptyMessage MessageChat) - { messagePayloads = [ emptybody ] } - where - emptybody = Element - { elementName = "body" - , elementAttributes = [] - , elementNodes = [] - } - -{- Add to a presence to mark its client as extended away. -} -extendedAway :: Element -extendedAway = Element "show" [] [NodeContent $ ContentText "xa"] - -{- Add to a presence to give it a negative priority. -} -negativePriority :: Element -negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"] - -pushAttr :: Name -pushAttr = "push" - -queryAttr :: Name -queryAttr = "query" - -pairAttr :: Name -pairAttr = "pair" - -canPushAttr :: Name -canPushAttr = "canpush" - -pushRequestAttr :: Name -pushRequestAttr = "pushrequest" - -startingPushAttr :: Name -startingPushAttr = "startingpush" - -receivePackAttr :: Name -receivePackAttr = "rp" - -sendPackAttr :: Name -sendPackAttr = "sp" - -receivePackDoneAttr :: Name -receivePackDoneAttr = "rpdone" - -shasAttr :: Name -shasAttr = "shas" diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs deleted file mode 100644 --- a/Assistant/XMPP/Buddies.hs +++ /dev/null @@ -1,87 +0,0 @@ -{- xmpp buddies - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.XMPP.Buddies where - -import Assistant.XMPP -import Annex.Common -import Assistant.Types.Buddies - -import Network.Protocol.XMPP -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T - -genBuddyKey :: JID -> BuddyKey -genBuddyKey j = BuddyKey $ formatJID $ baseJID j - -buddyName :: JID -> Text -buddyName j = maybe (T.pack "") strNode (jidNode j) - -ucFirst :: Text -> Text -ucFirst s = let (first, rest) = T.splitAt 1 s - in T.concat [T.toUpper first, rest] - -{- Summary of info about a buddy. - - - - If the buddy has no clients at all anymore, returns Nothing. -} -buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey) -buddySummary pairedwith b = case clients of - ((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j) - [] -> Nothing - where - away = S.null (buddyPresent b) && S.null (buddyAssistants b) - canpair = not $ S.null (buddyAssistants b) - clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b - alreadypaired j = baseJID j `elem` pairedwith - -{- Updates the buddies with XMPP presence info. -} -updateBuddies :: Presence -> Buddies -> Buddies -updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key - where - key = genBuddyKey jid - update (Just b) = Just $ applyPresence p b - update Nothing = newBuddy p -updateBuddies _ = id - -{- Creates a new buddy based on XMPP presence info. -} -newBuddy :: Presence -> Maybe Buddy -newBuddy p - | presenceType p == PresenceAvailable = go - | presenceType p == PresenceUnavailable = go - | otherwise = Nothing - where - go = make <$> presenceFrom p - make _jid = applyPresence p $ Buddy - { buddyPresent = S.empty - , buddyAway = S.empty - , buddyAssistants = S.empty - , buddyPairing = False - } - -applyPresence :: Presence -> Buddy -> Buddy -applyPresence p b = fromMaybe b $! go <$> presenceFrom p - where - go jid - | presenceType p == PresenceUnavailable = b - { buddyAway = addto $ buddyAway b - , buddyPresent = removefrom $ buddyPresent b - , buddyAssistants = removefrom $ buddyAssistants b - } - | hasGitAnnexTag p = b - { buddyAssistants = addto $ buddyAssistants b - , buddyAway = removefrom $ buddyAway b } - | presenceType p == PresenceAvailable = b - { buddyPresent = addto $ buddyPresent b - , buddyAway = removefrom $ buddyAway b - } - | otherwise = b - where - client = Client jid - removefrom = S.filter (/= client) - addto = S.insert client diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs deleted file mode 100644 --- a/Assistant/XMPP/Client.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- xmpp client support - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.XMPP.Client where - -import Assistant.Common -import Utility.SRV -import Creds - -import Network.Protocol.XMPP -import Network -import Control.Concurrent -import qualified Data.Text as T - -{- Everything we need to know to connect to an XMPP server. -} -data XMPPCreds = XMPPCreds - { xmppUsername :: T.Text - , xmppPassword :: T.Text - , xmppHostname :: HostName - , xmppPort :: Int - , xmppJID :: T.Text - } - deriving (Read, Show) - -connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP c a = case parseJID (xmppJID c) of - Nothing -> error "bad JID" - Just jid -> connectXMPP' jid c a - -{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} -connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord) - where - srvrecord = mkSRVTcp "xmpp-client" $ - T.unpack $ strDomain $ jidDomain jid - serverjid = JID Nothing (jidDomain jid) Nothing - - handlesrv [] = do - let h = xmppHostname c - let p = PortNumber $ fromIntegral $ xmppPort c - r <- run h p $ a jid - return [r] - handlesrv srvs = go [] srvs - - go l [] = return l - go l ((h,p):rest) = do - {- Try each SRV record in turn, until one connects, - - at which point the MVar will be full. -} - mv <- newEmptyMVar - r <- run h p $ do - liftIO $ putMVar mv () - a jid - ifM (isEmptyMVar mv) - ( go (r : l) rest - , return (r : l) - ) - - {- Async exceptions are let through so the XMPP thread can - - be killed. -} - run h p a' = do - r <- tryNonAsync $ - runClientError (Server serverjid h p) jid - (xmppUsername c) (xmppPassword c) (void a') - return ((h, p), r) - -{- XMPP runClient, that throws errors rather than returning an Either -} -runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a -runClientError s j u p x = either (error . show) return =<< runClient s j u p x - -getXMPPCreds :: Annex (Maybe XMPPCreds) -getXMPPCreds = parse <$> readCacheCreds xmppCredsFile - where - parse s = readish =<< s - -setXMPPCreds :: XMPPCreds -> Annex () -setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile - -xmppCredsFile :: FilePath -xmppCredsFile = "xmpp" diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs deleted file mode 100644 --- a/Assistant/XMPP/Git.hs +++ /dev/null @@ -1,381 +0,0 @@ -{- git over XMPP - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Assistant.XMPP.Git where - -import Assistant.Common -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.XMPP -import Assistant.XMPP.Buddies -import Assistant.DaemonStatus -import Assistant.Alert -import Assistant.MakeRemote -import Assistant.Sync -import qualified Command.Sync -import qualified Annex.Branch -import Annex.Path -import Annex.UUID -import Logs.UUID -import Annex.TaggedPush -import Annex.CatFile -import Config -import Git -import qualified Types.Remote as Remote -import qualified Remote as Remote -import Remote.List -import Utility.FileMode -import Utility.Shell -import Utility.Env - -import Network.Protocol.XMPP -import qualified Data.Text as T -import System.Posix.Types -import qualified System.Posix.IO -import Control.Concurrent -import System.Timeout -import qualified Data.ByteString as B -import qualified Data.Map as M - -{- Largest chunk of data to send in a single XMPP message. -} -chunkSize :: Int -chunkSize = 4096 - -{- How long to wait for an expected message before assuming the other side - - has gone away and canceling a push. - - - - This needs to be long enough to allow a message of up to 2+ times - - chunkSize to propigate up to a XMPP server, perhaps across to another - - server, and back down to us. On the other hand, other XMPP pushes can be - - delayed for running until the timeout is reached, so it should not be - - excessive. - -} -xmppTimeout :: Int -xmppTimeout = 120000000 -- 120 seconds - -finishXMPPPairing :: JID -> UUID -> Assistant () -finishXMPPPairing jid u = void $ alertWhile alert $ - makeXMPPGitRemote buddy (baseJID jid) u - where - buddy = T.unpack $ buddyName jid - alert = pairRequestAcknowledgedAlert buddy Nothing - -gitXMPPLocation :: JID -> String -gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid) - -makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool -makeXMPPGitRemote buddyname jid u = do - remote <- liftAnnex $ addRemote $ - makeGitRemote buddyname $ gitXMPPLocation jid - liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u - liftAnnex $ void remoteListRefresh - remote' <- liftAnnex $ fromMaybe (error "failed to add remote") - <$> Remote.byName (Just buddyname) - syncRemote remote' - return True - -{- Pushes over XMPP, communicating with a specific client. - - Runs an arbitrary IO action to push, which should run git-push with - - an xmpp:: url. - - - - To handle xmpp:: urls, git push will run git-remote-xmpp, which is - - injected into its PATH, and in turn runs git-annex xmppgit. The - - dataflow them becomes: - - - - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp - - | - - git receive-pack <--> xmppReceivePack <---------------> xmpp - - - - The pipe between git-annex xmppgit and us is set up and communicated - - using two environment variables, relayIn and relayOut, that are set - - to the file descriptors to use. Another, relayControl, is used to - - propigate the exit status of git receive-pack. - - - - We listen at the other end of the pipe and relay to and from XMPP. - -} -xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool -xmppPush cid gitpush = do - u <- liftAnnex getUUID - sendNetMessage $ Pushing cid (StartingPush u) - - (Fd inf, writepush) <- liftIO System.Posix.IO.createPipe - (readpush, Fd outf) <- liftIO System.Posix.IO.createPipe - (Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe - - tmpdir <- gettmpdir - installwrapper tmpdir - - environ <- liftIO getEnvironment - path <- liftIO getSearchPath - let myenviron = addEntries - [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) - , (relayIn, show inf) - , (relayOut, show outf) - , (relayControl, show controlf) - ] - environ - - inh <- liftIO $ fdToHandle readpush - outh <- liftIO $ fdToHandle writepush - controlh <- liftIO $ fdToHandle writecontrol - - t1 <- forkIO <~> toxmpp 0 inh - t2 <- forkIO <~> fromxmpp outh controlh - - {- This can take a long time to run, so avoid running it in the - - Annex monad. Also, override environment. -} - g <- liftAnnex gitRepo - r <- liftIO $ gitpush $ g { gitEnv = Just myenviron } - - liftIO $ do - mapM_ killThread [t1, t2] - mapM_ hClose [inh, outh, controlh] - mapM_ closeFd [Fd inf, Fd outf, Fd controlf] - - return r - where - toxmpp seqnum inh = do - b <- liftIO $ B.hGetSome inh chunkSize - if B.null b - then liftIO $ killThread =<< myThreadId - else do - let seqnum' = succ seqnum - sendNetMessage $ Pushing cid $ - SendPackOutput seqnum' b - toxmpp seqnum' inh - - fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg - where - handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = - liftIO $ writeChunk outh b - handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) = - liftIO $ do - hPrint controlh exitcode - hFlush controlh - handlemsg (Just _) = noop - handlemsg Nothing = do - debug ["timeout waiting for git receive-pack output via XMPP"] - -- Send a synthetic exit code to git-annex - -- xmppgit, which will exit and cause git push - -- to die. - liftIO $ do - hPrint controlh (ExitFailure 1) - hFlush controlh - killThread =<< myThreadId - - installwrapper tmpdir = liftIO $ do - createDirectoryIfMissing True tmpdir - let wrapper = tmpdir "git-remote-xmpp" - program <- programPath - writeFile wrapper $ unlines - [ shebang_local - , "exec " ++ program ++ " xmppgit" - ] - modifyFileMode wrapper $ addModes executeModes - - {- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp - - dir (ie, not on a crippled filesystem where we can't make - - the wrapper executable). -} - gettmpdir = do - v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR" - case v of - Nothing -> do - tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir - return $ tmp "xmppgit" - Just d -> return $ d "xmppgit" - -type EnvVar = String - -envVar :: String -> EnvVar -envVar s = "GIT_ANNEX_XMPPGIT_" ++ s - -relayIn :: EnvVar -relayIn = envVar "IN" - -relayOut :: EnvVar -relayOut = envVar "OUT" - -relayControl :: EnvVar -relayControl = envVar "CONTROL" - -relayHandle :: EnvVar -> IO Handle -relayHandle var = do - v <- getEnv var - case readish =<< v of - Nothing -> error $ var ++ " not set" - Just n -> fdToHandle $ Fd n - -{- Called by git-annex xmppgit. - - - - git-push is talking to us on stdin - - we're talking to git-push on stdout - - git-receive-pack is talking to us on relayIn (via XMPP) - - we're talking to git-receive-pack on relayOut (via XMPP) - - git-receive-pack's exit code will be passed to us on relayControl - -} -xmppGitRelay :: IO () -xmppGitRelay = do - flip relay stdout =<< relayHandle relayIn - relay stdin =<< relayHandle relayOut - code <- hGetLine =<< relayHandle relayControl - exitWith $ fromMaybe (ExitFailure 1) $ readish code - where - {- Is it possible to set up pipes and not need to copy the data - - ourselves? See splice(2) -} - relay fromh toh = void $ forkIO $ forever $ do - b <- B.hGetSome fromh chunkSize - when (B.null b) $ do - hClose fromh - hClose toh - killThread =<< myThreadId - writeChunk toh b - -{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating - - its exit status to XMPP. -} -xmppReceivePack :: ClientID -> Assistant Bool -xmppReceivePack cid = do - repodir <- liftAnnex $ fromRepo repoPath - let p = (proc "git" ["receive-pack", repodir]) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - } - (Just inh, Just outh, _, pid) <- liftIO $ createProcess p - readertid <- forkIO <~> relayfromxmpp inh - relaytoxmpp 0 outh - code <- liftIO $ waitForProcess pid - void $ sendNetMessage $ Pushing cid $ ReceivePackDone code - liftIO $ do - killThread readertid - hClose inh - hClose outh - return $ code == ExitSuccess - where - relaytoxmpp seqnum outh = do - b <- liftIO $ B.hGetSome outh chunkSize - -- empty is EOF, so exit - unless (B.null b) $ do - let seqnum' = succ seqnum - sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b - relaytoxmpp seqnum' outh - relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg - where - handlemsg (Just (Pushing _ (SendPackOutput _ b))) = - liftIO $ writeChunk inh b - handlemsg (Just _) = noop - handlemsg Nothing = do - debug ["timeout waiting for git send-pack output via XMPP"] - -- closing the handle will make git receive-pack exit - liftIO $ do - hClose inh - killThread =<< myThreadId - -xmppRemotes :: ClientID -> UUID -> Assistant [Remote] -xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of - Nothing -> return [] - Just jid -> do - let loc = gitXMPPLocation jid - um <- liftAnnex uuidMap - filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes - <$> getDaemonStatus - where - matching loc r = repoIsUrl r && repoLocation r == loc - knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um - -{- Returns the ClientID that it pushed to. -} -runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID) -runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) = - go =<< liftAnnex (join Command.Sync.getCurrBranch) - where - go (Just branch, _) = do - rs <- xmppRemotes cid theiruuid - liftAnnex $ Annex.Branch.commit "update" - (g, u) <- liftAnnex $ (,) - <$> gitRepo - <*> getUUID - liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g - selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus - if null rs - then return Nothing - else do - forM_ rs $ \r -> do - void $ alertWhile (syncAlert [r]) $ - xmppPush cid (taggedPush u selfjid branch r) - checkcloudrepos r - return $ Just cid - go _ = return Nothing -runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do - rs <- xmppRemotes cid theiruuid - if null rs - then return Nothing - else do - void $ alertWhile (syncAlert rs) $ - xmppReceivePack cid - mapM_ checkcloudrepos rs - return $ Just cid -runPush _ _ = return Nothing - -{- Check if any of the shas that can be pushed are ones we do not - - have. - - - - (Older clients send no shas, so when there are none, always - - request a push.) - -} -handlePushNotice :: NetMessage -> Assistant () -handlePushNotice (Pushing cid (CanPush theiruuid shas)) = - unlessM (null <$> xmppRemotes cid theiruuid) $ - if null shas - then go - else ifM (haveall shas) - ( debug ["ignoring CanPush with known shas"] - , go - ) - where - go = do - u <- liftAnnex getUUID - sendNetMessage $ Pushing cid (PushRequest u) - haveall l = liftAnnex $ not <$> anyM donthave l - donthave sha = isNothing <$> catObjectDetails sha -handlePushNotice _ = noop - -writeChunk :: Handle -> B.ByteString -> IO () -writeChunk h b = do - B.hPut h b - hFlush h - -{- Gets NetMessages for a PushSide, ensures they are in order, - - and runs an action to handle each in turn. The action will be passed - - Nothing on timeout. - - - - Does not currently reorder messages, but does ensure that any - - duplicate messages, or messages not in the sequence, are discarded. - -} -withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant () -withPushMessagesInSequence cid side a = loop 0 - where - loop seqnum = do - m <- timeout xmppTimeout <~> waitInbox cid side - let go s = a m >> loop s - let next = seqnum + 1 - case extractSequence =<< m of - Just seqnum' - | seqnum' == next -> go next - | seqnum' == 0 -> go seqnum - | seqnum' == seqnum -> do - debug ["ignoring duplicate sequence number", show seqnum] - loop seqnum - | otherwise -> do - debug ["ignoring out of order sequence number", show seqnum', "expected", show next] - loop seqnum - Nothing -> go seqnum - -extractSequence :: NetMessage -> Maybe Int -extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum -extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum -extractSequence _ = Nothing diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -10,6 +10,7 @@ import Data.Hash.MD5 import Annex.Common +import Utility.FileSystemEncoding {- Generates a keyName from an input string. Takes care of sanitizing it. - If it's not too long, the full string is used as the keyName. diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs --- a/Build/DistributionUpdate.hs +++ b/Build/DistributionUpdate.hs @@ -14,6 +14,7 @@ import Utility.UserInfo import Utility.Url import Utility.Tmp +import Utility.FileSystemEncoding import qualified Git.Construct import qualified Annex import Annex.Content @@ -50,6 +51,7 @@ main :: IO () main = do + useFileSystemEncoding version <- liftIO getChangelogVersion repodir <- getRepoDir changeWorkingDirectory repodir diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs --- a/Build/EvilSplicer.hs +++ b/Build/EvilSplicer.hs @@ -203,14 +203,13 @@ applySplices destdir imports splices@(first:_) = do let f = splicedFile first let dest = (destdir f) - lls <- map (++ "\n") . lines <$> readFileStrictAnyEncoding f + lls <- map (++ "\n") . lines <$> readFileStrict f createDirectoryIfMissing True (parentDir dest) let newcontent = concat $ addimports $ expand lls splices - oldcontent <- catchMaybeIO $ readFileStrictAnyEncoding dest + oldcontent <- catchMaybeIO $ readFileStrict dest when (oldcontent /= Just newcontent) $ do putStrLn $ "splicing " ++ f withFile dest WriteMode $ \h -> do - fileEncoding h hPutStr h newcontent hClose h where @@ -486,18 +485,8 @@ - So, we can put the semicolon at the start of every line - containing " -> " unless there's a "\ " first, or it's - all whitespace up until it. - - - - Except.. type signatures also contain " -> " sometimes starting - - a line: - - - - forall foo => - - Foo -> - - - - To avoid breaking these, look for the => on the previous line. -} - case_layout = parsecAndReplace $ do - void newline - lastline <- restOfLine + case_layout = skipfree $ parsecAndReplace $ do void newline indent1 <- many1 $ char ' ' prefix <- manyTill (noneOf "\n") (try (string "-> ")) @@ -507,9 +496,7 @@ then unexpected "lambda expression" else if null prefix then unexpected "second line of lambda" - else if "=>" `isSuffixOf` lastline - then unexpected "probably type signature" - else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> " + else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> " {- Sometimes cases themselves span multiple lines: - - Nothing @@ -520,7 +507,7 @@ - var var - -> foo -} - case_layout_multiline = parsecAndReplace $ do + case_layout_multiline = skipfree $ parsecAndReplace $ do void newline indent1 <- many1 $ char ' ' firstline <- restofline @@ -533,6 +520,11 @@ else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n" ++ indent1 ++ indent2 ++ "-> " + {- Type definitions for free monads triggers the case_* hacks, avoid. -} + skipfree f s + | "MonadFree" `isInfixOf` s = s + | otherwise = f s + {- (foo, \ -> bar) is not valid haskell, GHC. - Change to (foo, bar) - @@ -728,7 +720,9 @@ find = many $ try (Right <$> p) <|> (Left <$> anyChar) main :: IO () -main = go =<< getArgs +main = do + useFileSystemEncoding + go =<< getArgs where go (destdir:log:header:[]) = run destdir log (Just header) go (destdir:log:[]) = run destdir log Nothing diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -63,11 +63,6 @@ #ifdef WITH_DESKTOP_NOTIFY , "DesktopNotify" #endif -#ifdef WITH_XMPP - , "XMPP" -#else -#warning Building without XMPP. -#endif #ifdef WITH_CONCURRENTOUTPUT , "ConcurrentOutput" #else diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,50 @@ +git-annex (6.20170101) unstable; urgency=medium + + * XMPP support has been removed from the assistant in this release. + If your repositories used XMPP to keep in sync, that will no longer + work, and you should enable some other remote to keep them in sync. + A ssh server is one way, or use the new Tor pairing feature. + * p2p --pair makes it easy to pair repositories, over Tor, using + Magic Wormhole codes to find the other repository. + See http://git-annex.branchable.com/tips/peer_to_peer_network_with_tor/ + * webapp: The "Share with a friend" and "Share with your other devices" + pages have been changed to pair repositories using Tor and Magic Wormhole. + * metadata --batch: Fix bug when conflicting metadata changes were + made in the same batch run. + * Pass annex.web-options to wget and curl after other options, so that + eg --no-show-progress can be set by the user to disable the default + --show-progress. + * Revert ServerAliveInterval change in 6.20161111, which caused problems + with too many old versions of ssh and unusual ssh configurations. + It should have not been needed anyway since ssh is supposted to + have TCPKeepAlive enabled by default. + * Make all --batch input, as well as fromkey and registerurl stdin + be processed without requiring it to be in the current encoding. + * p2p: --link no longer takes a remote name, instead the --name + option can be used. + * Linux standalone: Improve generation of locale definition files, + supporting locales such as en_GB.UTF-8. + * rekey --force: Incorrectly marked the new key's content as being + present in the local repo even when it was not. + * enable-tor: Put tor sockets in /var/lib/tor-annex/, rather + than in /etc/tor/hidden_service/. + * enable-tor: No longer needs to be run as root. + * enable-tor: When run as a regular user, also tests a connection back to + the hidden service over tor. + * Support all common locations of the torrc file. + * Always use filesystem encoding for all file and handle reads and + writes. + * Fix build with directory-1.3. + * Debian: Suggest tor and magic-wormhole. + * Debian: Build webapp on armel. + + -- Joey Hess Sat, 31 Dec 2016 15:11:04 -0400 + git-annex (6.20161210) unstable; urgency=medium + * Linux standalone: Updated ghc to fix its "unable to decommit memory" + bug, which may have resulted in data loss when these builds were used + with Linux kernels older than 4.5. * enable-tor: New command, enables tor hidden service for P2P syncing. * p2p: New command, allows linking repositories using a P2P network. * remotedaemon: Serve tor hidden service. diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -2,11 +2,11 @@ Source: native package Files: * -Copyright: © 2010-2016 Joey Hess +Copyright: © 2010-2017 Joey Hess License: GPL-3+ Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/* -Copyright: © 2012-2016 Joey Hess +Copyright: © 2012-2017 Joey Hess © 2014 Sören Brunk License: AGPL-3+ @@ -21,7 +21,7 @@ License: BSD-2-clause Files: Utility/* -Copyright: 2012-2016 Joey Hess +Copyright: 2012-2017 Joey Hess License: BSD-2-clause Files: Utility/Gpg.hs Utility/DirWatcher* diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -48,15 +48,16 @@ -- Reads lines of batch mode input and passes to the action to handle. batchInput :: (String -> Either String a) -> (a -> Annex ()) -> Annex () -batchInput parser a = do - mp <- liftIO $ catchMaybeIO getLine - case mp of - Nothing -> return () - Just v -> do - either parseerr a (parser v) - batchInput parser a +batchInput parser a = go =<< batchLines where + go [] = return () + go (l:rest) = do + either parseerr a (parser l) + go rest parseerr s = giveup $ "Batch input parse failure: " ++ s + +batchLines :: Annex [String] +batchLines = liftIO $ lines <$> getContents -- Runs a CommandStart in batch mode. -- diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -109,10 +109,7 @@ #ifdef WITH_WEBAPP import qualified Command.WebApp #endif -#ifdef WITH_XMPP -import qualified Command.XMPPGit #endif -#endif import qualified Command.Test #ifdef WITH_TESTSUITE import qualified Command.FuzzTest @@ -217,9 +214,6 @@ , Command.Assistant.cmd #ifdef WITH_WEBAPP , Command.WebApp.cmd -#endif -#ifdef WITH_XMPP - , Command.XMPPGit.cmd #endif #endif , Command.Test.cmd testoptparser testrunner diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -27,6 +27,7 @@ import Annex.FileMatcher import Logs.Location import Utility.Metered +import Utility.FileSystemEncoding import qualified Annex.Transfer as Transfer import Annex.Quvi import qualified Utility.Quvi as Quvi diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -5,15 +5,28 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Command.EnableTor where import Command +import qualified Annex import P2P.Address +import P2P.Annex import Utility.Tor import Annex.UUID +import Config.Files +import P2P.IO +import qualified P2P.Protocol as P2P +import Utility.ThreadScheduler --- This runs as root, so avoid making any commits or initializing --- git-annex, or doing other things that create root-owned files. +import Control.Concurrent.Async +import qualified Network.Socket as S +#ifndef mingw32_HOST_OS +import Utility.Su +import System.Posix.User +#endif + cmd :: Command cmd = noCommit $ dontCheck repoExists $ command "enable-tor" SectionSetup "enable tor hidden service" @@ -22,14 +35,97 @@ seek :: CmdParams -> CommandSeek seek = withWords start +-- This runs as root, so avoid making any commits or initializing +-- git-annex, or doing other things that create root-owned files. start :: [String] -> CommandStart -start ps = case readish =<< headMaybe ps of - Nothing -> giveup "Bad params" - Just userid -> do - uuid <- getUUID - when (uuid == NoUUID) $ - giveup "This can only be run in a git-annex repository." +start os = do + uuid <- getUUID + when (uuid == NoUUID) $ + giveup "This can only be run in a git-annex repository." +#ifndef mingw32_HOST_OS + curruserid <- liftIO getEffectiveUserID + if curruserid == 0 + then case readish =<< headMaybe os of + Nothing -> giveup "Need user-id parameter." + Just userid -> go uuid userid + else do + showStart "enable-tor" "" + gitannex <- liftIO readProgramFile + let ps = [Param (cmdname cmd), Param (show curruserid)] + sucommand <- liftIO $ mkSuCommand gitannex ps + maybe noop showLongNote + (describePasswordPrompt' sucommand) + ifM (liftIO $ runSuCommand sucommand) + ( next $ next checkHiddenService + , giveup $ unwords $ + [ "Failed to run as root:" , gitannex ] ++ toCommand ps + ) +#else + go uuid 0 +#endif + where + go uuid userid = do (onionaddr, onionport) <- liftIO $ - addHiddenService userid (fromUUID uuid) + addHiddenService torAppName userid (fromUUID uuid) storeP2PAddress $ TorAnnex onionaddr onionport stop + +checkHiddenService :: CommandCleanup +checkHiddenService = bracket setup cleanup go + where + setup = do + showLongNote "Tor hidden service is configured. Checking connection to it. This may take a few minutes." + startlistener + + cleanup = liftIO . cancel + + go _ = check (150 :: Int) =<< filter istoraddr <$> loadP2PAddresses + + istoraddr (TorAnnex _ _) = True + + check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details." + check _ [] = giveup "Somehow didn't get an onion address." + check n addrs@(addr:_) = do + g <- Annex.gitRepo + -- Connect but don't bother trying to auth, + -- we just want to know if the tor circuit works. + cv <- liftIO $ tryNonAsync $ connectPeer g addr + case cv of + Left e -> do + warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.." + liftIO $ threadDelaySeconds (Seconds 2) + check (n-1) addrs + Right conn -> do + liftIO $ closeConnection conn + showLongNote "Tor hidden service is working." + return True + + -- Unless the remotedaemon is already listening on the hidden + -- service's socket, start a listener. This is only run during the + -- check, and it refuses all auth attempts. + startlistener = do + r <- Annex.gitRepo + u <- getUUID + msock <- torSocketFile + case msock of + Just sockfile -> ifM (liftIO $ haslistener sockfile) + ( liftIO $ async $ return () + , liftIO $ async $ runlistener sockfile u r + ) + Nothing -> giveup "Could not find socket file in Tor configuration!" + + runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do + let conn = P2PConnection + { connRepo = r + , connCheckAuth = const False + , connIhdl = h + , connOhdl = h + } + void $ runNetProto conn $ P2P.serveAuth u + hClose h + + haslistener sockfile = catchBoolIO $ do + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect soc (S.SockAddrUnix sockfile) + S.close soc + return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -45,7 +45,7 @@ next massAdd massAdd :: CommandPerform -massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents +massAdd = go True =<< map (separate (== ' ')) <$> batchLines where go status [] = next $ return status go status ((keyname,f):rest) | not (null keyname) && not (null f) = do diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -138,10 +138,12 @@ Just $ ToDownload f u i $ Enclosure enclosureurl Nothing -> mkquvi f i mkquvi f i = case getItemLink i of - Just link -> ifM (quviSupported link) - ( return $ Just $ ToDownload f u i $ QuviLink link - , return Nothing - ) + Just link -> do + liftIO $ print ("link", link) + ifM (quviSupported link) + ( return $ Just $ ToDownload f u i $ QuviLink link + , return Nothing + ) Nothing -> return Nothing {- Feeds change, so a feed download cannot be resumed. -} @@ -154,7 +156,7 @@ liftIO $ withTmpFile "feed" $ \f h -> do hClose h ifM (Url.download url f uo) - ( parseFeedString <$> readFileStrictAnyEncoding f + ( parseFeedString <$> readFileStrict f , return Nothing ) diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -20,6 +20,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BU import Data.Time.Clock.POSIX import Data.Aeson +import Control.Concurrent cmd :: Command cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ @@ -65,23 +66,22 @@ ) seek :: MetaDataOptions -> CommandSeek -seek o = do - now <- liftIO getPOSIXTime - case batchOption o of - NoBatch -> do - let seeker = case getSet o of - Get _ -> withFilesInGit - GetAll -> withFilesInGit - Set _ -> withFilesInGitNonRecursive - "Not recursively setting metadata. Use --force to do that." - withKeyOptions (keyOptions o) False - (startKeys now o) - (seeker $ whenAnnexed $ start now o) - (forFiles o) - Batch -> withMessageState $ \s -> case outputType s of - JSONOutput _ -> batchInput parseJSONInput $ - commandAction . startBatch now - _ -> giveup "--batch is currently only supported in --json mode" +seek o = case batchOption o of + NoBatch -> do + now <- liftIO getPOSIXTime + let seeker = case getSet o of + Get _ -> withFilesInGit + GetAll -> withFilesInGit + Set _ -> withFilesInGitNonRecursive + "Not recursively setting metadata. Use --force to do that." + withKeyOptions (keyOptions o) False + (startKeys now o) + (seeker $ whenAnnexed $ start now o) + (forFiles o) + Batch -> withMessageState $ \s -> case outputType s of + JSONOutput _ -> batchInput parseJSONInput $ + commandAction . startBatch + _ -> giveup "--batch is currently only supported in --json mode" start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart start now o file k = startKeys now o k (mkActionItem afile) @@ -150,8 +150,8 @@ (Nothing, Just f) -> Right (Left f, m) (Nothing, Nothing) -> Left "JSON input is missing either file or key" -startBatch :: POSIXTime -> (Either FilePath Key, MetaData) -> CommandStart -startBatch now (i, (MetaData m)) = case i of +startBatch :: (Either FilePath Key, MetaData) -> CommandStart +startBatch (i, (MetaData m)) = case i of Left f -> do mk <- lookupFile f case mk of @@ -169,6 +169,15 @@ , keyOptions = Nothing , batchOption = NoBatch } + now <- liftIO getPOSIXTime + -- It would be bad if two batch mode changes used exactly + -- the same timestamp, since the order of adds and removals + -- of the same metadata value would then be indeterminate. + -- To guarantee that never happens, delay 1 microsecond, + -- so the timestamp will always be different. This is + -- probably less expensive than cleaner methods, + -- such as taking from a list of increasing timestamps. + liftIO $ threadDelay 1 next $ perform now o k mkModMeta (f, s) | S.null s = DelMeta f Nothing diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -12,14 +12,21 @@ import P2P.Auth import P2P.IO import qualified P2P.Protocol as P2P -import Utility.AuthToken import Git.Types import qualified Git.Remote import qualified Git.Command import qualified Annex import Annex.UUID import Config +import Utility.AuthToken +import Utility.Tmp +import Utility.FileMode +import Utility.ThreadScheduler +import qualified Utility.MagicWormhole as Wormhole +import Control.Concurrent.Async +import qualified Data.Text as T + cmd :: Command cmd = command "p2p" SectionSetup "configure peer-2-peer links between repositories" @@ -27,26 +34,54 @@ data P2POpts = GenAddresses - | LinkRemote RemoteName + | LinkRemote + | Pair -optParser :: CmdParamsDesc -> Parser P2POpts -optParser _ = genaddresses <|> linkremote +optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName) +optParser _ = (,) + <$> (pair <|> linkremote <|> genaddresses) + <*> optional name where genaddresses = flag' GenAddresses ( long "gen-addresses" <> help "generate addresses that allow accessing this repository over P2P networks" ) - linkremote = LinkRemote <$> strOption + linkremote = flag' LinkRemote ( long "link" - <> metavar paramRemote - <> help "specify name to use for git remote" + <> help "set up a P2P link to a git remote" ) + pair = flag' Pair + ( long "pair" + <> help "pair with another repository" + ) + name = Git.Remote.makeLegalName <$> strOption + ( long "name" + <> metavar paramName + <> help "name of remote" + ) -seek :: P2POpts -> CommandSeek -seek GenAddresses = genAddresses =<< loadP2PAddresses -seek (LinkRemote name) = commandAction $ - linkRemote (Git.Remote.makeLegalName name) +seek :: (P2POpts, Maybe RemoteName) -> CommandSeek +seek (GenAddresses, _) = genAddresses =<< loadP2PAddresses +seek (LinkRemote, Just name) = commandAction $ + linkRemote name +seek (LinkRemote, Nothing) = commandAction $ + linkRemote =<< unusedPeerRemoteName +seek (Pair, Just name) = commandAction $ + startPairing name =<< loadP2PAddresses +seek (Pair, Nothing) = commandAction $ do + name <- unusedPeerRemoteName + startPairing name =<< loadP2PAddresses +unusedPeerRemoteName :: Annex RemoteName +unusedPeerRemoteName = go (1 :: Integer) =<< usednames + where + usednames = mapMaybe remoteName . remotes <$> Annex.gitRepo + go n names = do + let name = "peer" ++ show n + if name `elem` names + then go (n+1) names + else return name + -- Only addresses are output to stdout, to allow scripting. genAddresses :: [P2PAddress] -> Annex () genAddresses [] = giveup "No P2P networks are currrently available." @@ -77,24 +112,191 @@ Nothing -> do liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again." prompt - Just addr -> setup addr - setup (P2PAddressAuth addr authtoken) = do - g <- Annex.gitRepo - conn <- liftIO $ connectPeer g addr - `catchNonAsync` connerror - u <- getUUID - v <- liftIO $ runNetProto conn $ P2P.auth u authtoken - case v of - Right (Just theiruuid) -> do - ok <- inRepo $ Git.Command.runBool - [ Param "remote", Param "add" - , Param remotename - , Param (formatP2PAddress addr) - ] - when ok $ do - storeUUIDIn (remoteConfig remotename "uuid") theiruuid - storeP2PRemoteAuthToken addr authtoken - return ok - Right Nothing -> giveup "Unable to authenticate with peer. Please check the address and try again." - Left e -> giveup $ "Unable to authenticate with peer: " ++ e - connerror e = giveup $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")" + Just addr -> do + r <- setupLink remotename addr + case r of + LinkSuccess -> return True + ConnectionError e -> giveup e + AuthenticationError e -> giveup e + +startPairing :: RemoteName -> [P2PAddress] -> CommandStart +startPairing _ [] = giveup "No P2P networks are currrently available." +startPairing remotename addrs = do + showStart "p2p pair" remotename + ifM (liftIO Wormhole.isInstalled) + ( next $ performPairing remotename addrs + , giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/" + ) + +performPairing :: RemoteName -> [P2PAddress] -> CommandPerform +performPairing remotename addrs = do + -- This note is displayed mainly so when magic wormhole + -- complains about possible protocol mismatches or other problems, + -- it's clear what's doing the complaining. + showNote "using Magic Wormhole" + next $ do + showOutput + r <- wormholePairing remotename addrs ui + case r of + PairSuccess -> return True + SendFailed -> do + warning "Failed sending data to pair." + return False + ReceiveFailed -> do + warning "Failed receiving data from pair." + return False + LinkFailed e -> do + warning $ "Failed linking to pair: " ++ e + return False + where + ui observer producer = do + ourcode <- Wormhole.waitCode observer + putStrLn "" + putStrLn $ "This repository's pairing code is: " ++ + Wormhole.fromCode ourcode + putStrLn "" + theircode <- getcode ourcode + Wormhole.sendCode producer theircode + + getcode ourcode = do + putStr "Enter the other repository's pairing code: " + hFlush stdout + l <- getLine + case Wormhole.toCode l of + Just code + | code /= ourcode -> do + putStrLn "Exchanging pairing data..." + return code + | otherwise -> do + putStrLn "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository." + getcode ourcode + Nothing -> do + putStrLn "That does not look like a valiad pairing code. Try again..." + getcode ourcode + +-- We generate half of the authtoken; the pair will provide +-- the other half. +newtype HalfAuthToken = HalfAuthToken T.Text + deriving (Show) + +data PairData = PairData HalfAuthToken [P2PAddress] + deriving (Show) + +serializePairData :: PairData -> String +serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $ + T.unpack ha : map formatP2PAddress addrs + +deserializePairData :: String -> Maybe PairData +deserializePairData s = case lines s of + [] -> Nothing + (ha:l) -> do + addrs <- mapM unformatP2PAddress l + return (PairData (HalfAuthToken (T.pack ha)) addrs) + +data PairingResult + = PairSuccess + | SendFailed + | ReceiveFailed + | LinkFailed String + +wormholePairing + :: RemoteName + -> [P2PAddress] + -> (Wormhole.CodeObserver -> Wormhole.CodeProducer -> IO ()) + -> Annex PairingResult +wormholePairing remotename ouraddrs ui = do + ourhalf <- liftIO $ HalfAuthToken . fromAuthToken + <$> genAuthToken 64 + let ourpairdata = PairData ourhalf ouraddrs + + -- The magic wormhole interface only supports exchanging + -- files. Permissions of received files may allow others + -- to read them. So, set up a temp directory that only + -- we can read. + withTmpDir "pair" $ \tmp -> do + liftIO $ void $ tryIO $ modifyFileMode tmp $ + removeModes otherGroupModes + let sendf = tmp "send" + let recvf = tmp "recv" + liftIO $ writeFileProtected sendf $ + serializePairData ourpairdata + + observer <- liftIO Wormhole.mkCodeObserver + producer <- liftIO Wormhole.mkCodeProducer + void $ liftIO $ async $ ui observer producer + (sendres, recvres) <- liftIO $ + Wormhole.sendFile sendf observer [] + `concurrently` + Wormhole.receiveFile recvf producer [] + liftIO $ nukeFile sendf + if sendres /= True + then return SendFailed + else if recvres /= True + then return ReceiveFailed + else do + r <- liftIO $ tryIO $ + readFileStrict recvf + case r of + Left _e -> return ReceiveFailed + Right s -> maybe + (return ReceiveFailed) + (finishPairing 100 remotename ourhalf) + (deserializePairData s) + +-- | Allow the peer we're pairing with to authenticate to us, +-- using an authtoken constructed from the two HalfAuthTokens. +-- Connect to the peer we're pairing with, and try to link to them. +-- +-- Multiple addresses may have been received for the peer. This only +-- makes a link to one address. +-- +-- Since we're racing the peer as they do the same, the first try is likely +-- to fail to authenticate. Can retry any number of times, to avoid the +-- users needing to redo the whole process. +finishPairing :: Int -> RemoteName -> HalfAuthToken -> PairData -> Annex PairingResult +finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToken theirhalf) theiraddrs) = do + case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of + (Just ourauthtoken, Just theirauthtoken) -> do + liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++ "..." + storeP2PAuthToken ourauthtoken + go retries theiraddrs theirauthtoken + _ -> return ReceiveFailed + where + go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "." + go n [] theirauthtoken = do + liftIO $ threadDelaySeconds (Seconds 2) + liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..." + go (n-1) theiraddrs theirauthtoken + go n (addr:rest) theirauthtoken = do + r <- setupLink remotename (P2PAddressAuth addr theirauthtoken) + case r of + LinkSuccess -> return PairSuccess + _ -> go n rest theirauthtoken + +data LinkResult + = LinkSuccess + | ConnectionError String + | AuthenticationError String + +setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult +setupLink remotename (P2PAddressAuth addr authtoken) = do + g <- Annex.gitRepo + cv <- liftIO $ tryNonAsync $ connectPeer g addr + case cv of + Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")" + Right conn -> do + u <- getUUID + go =<< liftIO (runNetProto conn $ P2P.auth u authtoken) + where + go (Right (Just theiruuid)) = do + ok <- inRepo $ Git.Command.runBool + [ Param "remote", Param "add" + , Param remotename + , Param (formatP2PAddress addr) + ] + when ok $ do + storeUUIDIn (remoteConfig remotename "uuid") theiruuid + storeP2PRemoteAuthToken addr authtoken + return LinkSuccess + go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again." + go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -126,6 +126,6 @@ Database.Keys.removeAssociatedFile oldkey =<< inRepo (toTopFilePath file) ) - - logStatus newkey InfoPresent + whenM (inAnnex newkey) $ + logStatus newkey InfoPresent return True diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -35,7 +35,7 @@ start _ = giveup "specify a key and an url" massAdd :: CommandPerform -massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents +massAdd = go True =<< map (separate (== ' ')) <$> batchLines where go status [] = next $ return status go status ((keyname,u):rest) | not (null keyname) && not (null u) = do diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -56,10 +56,7 @@ -> (TransferRequest -> Annex Bool) -> Annex () runRequests readh writeh a = do - liftIO $ do - hSetBuffering readh NoBuffering - fileEncoding readh - fileEncoding writeh + liftIO $ hSetBuffering readh NoBuffering go =<< readrequests where go (d:rn:k:f:rest) = do diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -41,7 +41,7 @@ createAnnexDirectory $ parentDir f cfg <- getCfg descs <- uuidDescriptions - liftIO $ writeFileAnyEncoding f $ genCfg cfg descs + liftIO $ writeFile f $ genCfg cfg descs vicfg cfg f stop @@ -51,11 +51,11 @@ -- Allow EDITOR to be processed by the shell, so it can contain options. unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ giveup $ vi ++ " exited nonzero; aborting" - r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrictAnyEncoding f) + r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) liftIO $ nukeFile f case r of Left s -> do - liftIO $ writeFileAnyEncoding f s + liftIO $ writeFile f s vicfg curcfg f Right newcfg -> setCfg curcfg newcfg diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs deleted file mode 100644 --- a/Command/XMPPGit.hs +++ /dev/null @@ -1,48 +0,0 @@ -{- git-annex command - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Command.XMPPGit where - -import Command -import Assistant.XMPP.Git - -cmd :: Command -cmd = noCommit $ dontCheck repoExists $ - noRepo (parseparams startNoRepo) $ - command "xmppgit" SectionPlumbing "git to XMPP relay" - paramNothing (parseparams seek) - where - parseparams = withParams - -seek :: CmdParams -> CommandSeek -seek = withWords start - -start :: CmdParams -> CommandStart -start _ = do - liftIO gitRemoteHelper - liftIO xmppGitRelay - stop - -startNoRepo :: CmdParams -> IO () -startNoRepo _ = xmppGitRelay - -{- A basic implementation of the git-remote-helpers protocol. -} -gitRemoteHelper :: IO () -gitRemoteHelper = do - expect "capabilities" - respond ["connect"] - expect "connect git-receive-pack" - respond [] - where - expect s = do - gitcmd <- getLine - unless (gitcmd == s) $ - error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ gitcmd - respond l = do - mapM_ putStrLn l - putStrLn "" - hFlush stdout diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -29,7 +29,6 @@ import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.FileSystemEncoding as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Network as X diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -112,7 +112,7 @@ createDirectoryIfMissing True (takeDirectory lf) writeFile lf (lfs ++ "\n" ++ stdattr) where - readattr = liftIO . catchDefaultIO "" . readFileStrictAnyEncoding + readattr = liftIO . catchDefaultIO "" . readFileStrict stdattr = unlines [ "* filter=annex" , ".* !filter" diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -69,7 +69,7 @@ worker <- async (workerThread (T.pack db) tablename jobs) -- work around https://github.com/yesodweb/persistent/issues/474 - liftIO setConsoleEncoding + liftIO $ fileEncoding stderr return $ DbHandle worker jobs diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -37,6 +37,7 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess +import Utility.FileSystemEncoding data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -53,7 +53,6 @@ pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - fileEncoding h c <- hGetContents h return (c, checkSuccessProcess pid) where @@ -66,7 +65,6 @@ pipeReadStrict :: [CommandParam] -> Repo -> IO String pipeReadStrict params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - fileEncoding h output <- hGetContentsStrict h hClose h return output @@ -81,9 +79,7 @@ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do - fileEncoding h - hSetNewlineMode h noNewlineTranslation + adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -79,10 +79,6 @@ {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - -- We use the FileSystemEncoding when reading from git-config, - -- because it can contain arbitrary filepaths (and other strings) - -- in any encoding. - fileEncoding h val <- hGetContentsStrict h store val repo @@ -167,7 +163,6 @@ fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h val <- hGetContentsStrict h r' <- store val r return (r', val) diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -41,7 +41,6 @@ - interface does not allow batch hashing without using temp files. -} hashBlob :: HashObjectHandle -> String -> IO Sha hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do - fileEncoding tmph #ifdef mingw32_HOST_OS hSetNewlineMode tmph noNewlineTranslation #endif diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -159,7 +159,6 @@ #ifndef mingw32_HOST_OS let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo } withHandle StdinHandle createProcessSuccess p $ \h -> do - fileEncoding h hPutStr h $ intercalate "\0" $ toCommand $ getFiles action hClose h #else diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -614,4 +614,4 @@ safeReadFile :: FilePath -> IO String safeReadFile f = do allowRead f - readFileStrictAnyEncoding f + readFileStrict f diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -22,6 +22,7 @@ import Git.HashObject import Git.Types import Git.FilePath +import Utility.FileSystemEncoding {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -94,8 +95,7 @@ -- We don't know how the file is encoded, but need to -- split it into lines to union merge. Using the -- FileSystemEncoding for this is a hack, but ensures there - -- are no decoding errors. Note that this works because - -- hashObject sets fileEncoding on its write handle. + -- are no decoding errors. getcontents s = lines . encodeW8NUL . L.unpack <$> catObject h s {- Calculates a union merge between a list of refs, with contents. diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -55,7 +55,6 @@ startUpdateIndex repo = do (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) { std_in = CreatePipe } - fileEncoding h return $ UpdateIndexHandle p h where params = map Param ["update-index", "-z", "--index-info"] diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -220,8 +220,7 @@ bits = splitDirectories file writeTransferInfoFile :: TransferInfo -> FilePath -> IO () -writeTransferInfoFile info tfile = writeFileAnyEncoding tfile $ - writeTransferInfo info +writeTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info {- File format is a header line containing the startedTime and any - bytesComplete value. Followed by a newline and the associatedFile. @@ -243,7 +242,7 @@ readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo) readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ - readTransferInfo mpid <$> readFileStrictAnyEncoding tfile + readTransferInfo mpid <$> readFileStrict tfile readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo diff --git a/Logs/Unused.hs b/Logs/Unused.hs --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -66,7 +66,7 @@ writeUnusedLog :: FilePath -> UnusedLog -> Annex () writeUnusedLog prefix l = do logfile <- fromRepo $ gitAnnexUnusedLog prefix - liftIO $ viaTmp writeFileAnyEncoding logfile $ unlines $ map format $ M.toList l + liftIO $ viaTmp writeFile logfile $ unlines $ map format $ M.toList l where format (k, (i, Just t)) = show i ++ " " ++ key2file k ++ " " ++ show t format (k, (i, Nothing)) = show i ++ " " ++ key2file k @@ -76,7 +76,7 @@ f <- fromRepo $ gitAnnexUnusedLog prefix ifM (liftIO $ doesFileExist f) ( M.fromList . mapMaybe parse . lines - <$> liftIO (readFileStrictAnyEncoding f) + <$> liftIO (readFileStrict f) , return M.empty ) where diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -183,7 +183,6 @@ <$> streamHandler stderr DEBUG <*> pure preciseLogFormatter updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s]) - setConsoleEncoding {- Force output to be line buffered. This is normally the case when - it's connected to a terminal, but may not be when redirected to - a file or a pipe. -} diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,13 @@ +git-annex (6.20170101) unstable; urgency=medium + + XMPP support has been removed from the assistant in this release. + + If your repositories used XMPP to keep in sync, that will no longer + work, and you should enable some other remote to keep them in sync. + A ssh server is one way, or use the new Tor pairing feature. + + -- Joey Hess Tue, 27 Dec 2016 16:37:46 -0400 + git-annex (4.20131002) unstable; urgency=low The layout of gcrypt repositories has changed, and diff --git a/P2P/Address.hs b/P2P/Address.hs --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -90,3 +90,6 @@ p2pAddressCredsFile :: FilePath p2pAddressCredsFile = "p2paddrs" + +torAppName :: AppName +torAppName = "tor-annex" diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -5,25 +5,32 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE RankNTypes, FlexibleContexts #-} +{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-} module P2P.Annex ( RunMode(..) , P2PConnection(..) , runFullProto + , torSocketFile ) where import Annex.Common import Annex.Content import Annex.Transfer import Annex.ChangedRefs +import P2P.Address import P2P.Protocol import P2P.IO import Logs.Location import Types.NumCopies import Utility.Metered +import Utility.Tor +import Annex.UUID import Control.Monad.Free +#ifndef mingw32_HOST_OS +import System.Posix.User +#endif data RunMode = Serving UUID (Maybe ChangedRefsHandle) @@ -152,3 +159,14 @@ liftIO $ hSeek h AbsoluteSeek o b <- liftIO $ hGetContentsMetered h p' runner (sender b) + +torSocketFile :: Annex (Maybe FilePath) +torSocketFile = do + u <- getUUID + let ident = fromUUID u +#ifndef mingw32_HOST_OS + uid <- liftIO getRealUserID +#else + let uid = 0 +#endif + liftIO $ getHiddenServiceSocketFile torAppName uid ident diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -12,35 +12,33 @@ , P2PConnection(..) , connectPeer , closeConnection + , serveUnixSocket , setupHandle , runNetProto , runNet ) where +import Common import P2P.Protocol import P2P.Address -import Utility.Process import Git import Git.Command import Utility.AuthToken -import Utility.SafeCommand import Utility.SimpleProtocol -import Utility.Exception import Utility.Metered import Utility.Tor -import Utility.FileSystemEncoding +import Utility.FileMode -import Control.Monad import Control.Monad.Free import Control.Monad.IO.Class import System.Exit (ExitCode(..)) import Network.Socket -import System.IO import Control.Concurrent import Control.Concurrent.Async import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import System.Log.Logger (debugM) +import qualified Network.Socket as S -- Type of interpreters of the Proto free monad. type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Either String a) @@ -68,12 +66,39 @@ hClose (connIhdl conn) hClose (connOhdl conn) +-- Serves the protocol on a unix socket. +-- +-- The callback is run to serve a connection, and is responsible for +-- closing the Handle when done. +-- +-- Note that while the callback is running, other connections won't be +-- processed, so longterm work should be run in a separate thread by +-- the callback. +serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () +serveUnixSocket unixsocket serveconn = do + nukeFile unixsocket + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.bind soc (S.SockAddrUnix unixsocket) + -- Allow everyone to read and write to the socket, + -- so a daemon like tor, that is probably running as a different + -- de sock $ addModes + -- user, can access it. + -- + -- Connections have to authenticate to do anything, + -- so it's fine that other local users can connect to the + -- socket. + modifyFileMode unixsocket $ addModes + [groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] + S.listen soc 2 + forever $ do + (conn, _) <- S.accept soc + setupHandle conn >>= serveconn + setupHandle :: Socket -> IO Handle setupHandle s = do h <- socketToHandle s ReadWriteMode hSetBuffering h LineBuffering hSetBinaryMode h False - fileEncoding h return h -- Purposefully incomplete interpreter of Proto. diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -353,7 +353,7 @@ checkAvailable assumenetworkavailable = maybe (return assumenetworkavailable) doesDirectoryExist . localpath -{- Remotes using the XMPP transport have urls like xmpp::user@host -} +{- Old remotes using the XMPP transport have urls like xmpp::user@host -} isXMPPRemote :: Remote -> Bool isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r where diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -21,6 +21,7 @@ import Messages.Progress import Utility.Metered import Utility.Tmp +import Utility.FileSystemEncoding import Backend.URL import Annex.Perms import Annex.UUID diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -384,9 +384,6 @@ p <- propgit g basep (Just hin, Just hout, Just herr, ph) <- createProcess p `catchIO` runerr - fileEncoding hin - fileEncoding hout - fileEncoding herr stderrelay <- async $ errrelayer herr checkearlytermination =<< getProcessExitCode ph cv <- newTVarIO $ externalDefaultConfig external diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -74,12 +74,13 @@ runController ichan ochan = do h <- genTransportHandle m <- genRemoteMap h ochan - startrunning m - mapM_ (\s -> async (s h)) remoteServers - go h False m + starttransports m + serverchans <- mapM (startserver h) remoteServers + go h False m serverchans where - go h paused m = do + go h paused m serverchans = do cmd <- atomically $ readTChan ichan + broadcast cmd serverchans case cmd of RELOAD -> do h' <- updateTransportHandle h @@ -87,36 +88,42 @@ let common = M.intersection m m' let new = M.difference m' m let old = M.difference m m' - broadcast STOP old + broadcast STOP (mchans old) unless paused $ - startrunning new - go h' paused (M.union common new) + starttransports new + go h' paused (M.union common new) serverchans LOSTNET -> do -- force close all cached ssh connections -- (done here so that if there are multiple -- ssh remotes, it's only done once) liftAnnex h forceSshCleanup - broadcast LOSTNET m - go h True m + broadcast LOSTNET transportchans + go h True m serverchans PAUSE -> do - broadcast STOP m - go h True m + broadcast STOP transportchans + go h True m serverchans RESUME -> do when paused $ - startrunning m - go h False m + starttransports m + go h False m serverchans STOP -> exitSuccess -- All remaining messages are sent to -- all Transports. msg -> do - unless paused $ atomically $ - forM_ chans (`writeTChan` msg) - go h paused m + unless paused $ + broadcast msg transportchans + go h paused m serverchans where - chans = map snd (M.elems m) + transportchans = mchans m + mchans = map snd . M.elems + + startserver h server = do + c <- newTChanIO + void $ async $ server c h + return c - startrunning m = forM_ (M.elems m) startrunning' - startrunning' (transport, c) = do + starttransports m = forM_ (M.elems m) starttransports' + starttransports' (transport, c) = do -- drain any old control messages from the channel -- to avoid confusing the transport with them atomically $ drain c @@ -124,9 +131,7 @@ drain c = maybe noop (const $ drain c) =<< tryReadTChan c - broadcast msg m = atomically $ forM_ (M.elems m) send - where - send (_, c) = writeTChan c msg + broadcast msg cs = atomically $ forM_ cs $ \c -> writeTChan c msg -- Generates a map with a transport for each supported remote in the git repo, -- except those that have annex.sync = false diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs --- a/RemoteDaemon/Transport.hs +++ b/RemoteDaemon/Transport.hs @@ -26,5 +26,5 @@ , (torAnnexScheme, RemoteDaemon.Transport.Tor.transport) ] -remoteServers :: [TransportHandle -> IO ()] +remoteServers :: [Server] remoteServers = [RemoteDaemon.Transport.Tor.server] diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -13,8 +13,6 @@ import Annex.ChangedRefs import RemoteDaemon.Types import RemoteDaemon.Common -import Utility.Tor -import Utility.FileMode import Utility.AuthToken import P2P.Protocol as P2P import P2P.IO @@ -27,48 +25,57 @@ import Git import Git.Command -import System.PosixCompat.User import Control.Concurrent import System.Log.Logger (debugM) import Control.Concurrent.STM import Control.Concurrent.STM.TBMQueue import Control.Concurrent.Async -import qualified Network.Socket as S -- Run tor hidden service. -server :: TransportHandle -> IO () -server th@(TransportHandle (LocalRepo r) _) = do - u <- liftAnnex th getUUID - - q <- newTBMQueueIO maxConnections - replicateM_ maxConnections $ - forkIO $ forever $ serveClient th u r q +server :: Server +server ichan th@(TransportHandle (LocalRepo r) _) = go + where + go = checkstartservice >>= handlecontrol - uid <- getRealUserID - let ident = fromUUID u - let sock = hiddenServiceSocketFile uid ident - nukeFile sock - soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol - S.bind soc (S.SockAddrUnix sock) - -- Allow everyone to read and write to the socket; tor is probably - -- running as a different user. Connections have to authenticate - -- to do anything, so it's fine that other local users can connect. - modifyFileMode sock $ addModes - [groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] - S.listen soc 2 - debugM "remotedaemon" "Tor hidden service running" - forever $ do - (conn, _) <- S.accept soc - h <- setupHandle conn - ok <- atomically $ ifM (isFullTBMQueue q) - ( return False - , do - writeTBMQueue q h + checkstartservice = do + u <- liftAnnex th getUUID + msock <- liftAnnex th torSocketFile + case msock of + Nothing -> do + debugM "remotedaemon" "Tor hidden service not enabled" + return False + Just sock -> do + void $ async $ startservice sock u return True - ) - unless ok $ do - hClose h - warningIO "dropped Tor connection, too busy" + + startservice sock u = do + q <- newTBMQueueIO maxConnections + replicateM_ maxConnections $ + forkIO $ forever $ serveClient th u r q + + debugM "remotedaemon" "Tor hidden service running" + serveUnixSocket sock $ \conn -> do + ok <- atomically $ ifM (isFullTBMQueue q) + ( return False + , do + writeTBMQueue q conn + return True + ) + unless ok $ do + hClose conn + warningIO "dropped Tor connection, too busy" + + handlecontrol servicerunning = do + msg <- atomically $ readTChan ichan + case msg of + -- On reload, the configuration may have changed to + -- enable the tor hidden service. If it was not + -- enabled before, start it, + RELOAD | not servicerunning -> go + -- We can ignore all other messages; no need + -- to restart the hidden service when the network + -- changes as tor takes care of all that. + _ -> handlecontrol servicerunning -- How many clients to serve at a time, maximum. This is to avoid DOS attacks. maxConnections :: Int diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs --- a/RemoteDaemon/Types.hs +++ b/RemoteDaemon/Types.hs @@ -28,6 +28,10 @@ -- from a Chan, and emits others to another Chan. type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> TChan Consumed -> TChan Emitted -> IO () +-- A server for a Transport consumes some messages from a Chan in +-- order to learn about network changes, reloads, etc. +type Server = TChan Consumed -> TransportHandle -> IO () + data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig newtype LocalRepo = LocalRepo Git.Repo diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -95,6 +95,7 @@ import qualified Utility.ThreadScheduler import qualified Utility.Base64 import qualified Utility.Tmp +import qualified Utility.FileSystemEncoding import qualified Command.Uninit import qualified CmdLine.GitAnnex as GitAnnex #ifndef mingw32_HOST_OS @@ -1675,7 +1676,8 @@ - calculated correctly for files in subdirs. -} unlessM (unlockedFiles <$> getTestMode) $ do git_annex "sync" [] @? "sync failed" - l <- annexeval $ decodeBS <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") + l <- annexeval $ Utility.FileSystemEncoding.decodeBS + <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) createDirectory "dir2" diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -47,10 +47,10 @@ rawMode to return $ CoProcessState pid to from s where - rawMode h = do - fileEncoding h #ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation + rawMode h = hSetNewlineMode h noNewlineTranslation +#else + rawMode _ = return () #endif stop :: CoProcessHandle -> IO () diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs --- a/Utility/ExternalSHA.hs +++ b/Utility/ExternalSHA.hs @@ -14,7 +14,6 @@ import Utility.SafeCommand import Utility.Process -import Utility.FileSystemEncoding import Utility.Misc import Utility.Exception @@ -30,7 +29,6 @@ Left _ -> Left (command ++ " failed") where readsha args = withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h output <- hGetContentsStrict h hClose h return output diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2016 Joey Hess - - License: BSD-2-clause -} @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( + useFileSystemEncoding, fileEncoding, withFilePath, md5FilePath, @@ -19,7 +20,6 @@ encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -39,17 +39,35 @@ import Utility.Exception -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} +useFileSystemEncoding :: IO () +useFileSystemEncoding = do +#ifndef mingw32_HOST_OS + e <- Encoding.getFileSystemEncoding +#else + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 +#endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e + fileEncoding :: Handle -> IO () #ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} fileEncoding h = hSetEncoding h Encoding.utf8 #endif @@ -165,10 +183,3 @@ else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif - -{- This avoids ghc's output layer crashing on invalid encoded characters in - - filenames when printing them out. -} -setConsoleEncoding :: IO () -setConsoleEncoding = do - fileEncoding stdout - fileEncoding stderr diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -47,9 +47,8 @@ -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] query opts = - withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do - fileEncoding h - parse <$> hGetContentsStrict h + withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ + parse <$$> hGetContentsStrict where p = proc "lsof" ("-F0can" : opts) diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs new file mode 100644 --- /dev/null +++ b/Utility/MagicWormhole.hs @@ -0,0 +1,160 @@ +{- Magic Wormhole integration + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.MagicWormhole ( + Code, + mkCode, + toCode, + fromCode, + validCode, + CodeObserver, + CodeProducer, + mkCodeObserver, + mkCodeProducer, + waitCode, + sendCode, + WormHoleParams, + sendFile, + receiveFile, + isInstalled, +) where + +import Utility.Process +import Utility.SafeCommand +import Utility.Monad +import Utility.Misc +import Utility.Env +import Utility.Path + +import System.IO +import System.Exit +import Control.Concurrent +import Control.Exception +import Data.Char +import Data.List +import Control.Applicative +import Prelude + +-- | A Magic Wormhole code. +newtype Code = Code String + deriving (Eq, Show) + +-- | Smart constructor for Code +mkCode :: String -> Maybe Code +mkCode s + | validCode s = Just (Code s) + | otherwise = Nothing + +-- | Tries to fix up some common mistakes in a homan-entered code. +toCode :: String -> Maybe Code +toCode s = mkCode $ intercalate "-" $ words s + +fromCode :: Code -> String +fromCode (Code s) = s + +-- | Codes have the form number-word-word and may contain 2 or more words. +validCode :: String -> Bool +validCode s = + let (n, r) = separate (== '-') s + (w1, w2) = separate (== '-') r + in and + [ not (null n) + , all isDigit n + , not (null w1) + , not (null w2) + , not $ any isSpace s + ] + +newtype CodeObserver = CodeObserver (MVar Code) + +newtype CodeProducer = CodeProducer (MVar Code) + +mkCodeObserver :: IO CodeObserver +mkCodeObserver = CodeObserver <$> newEmptyMVar + +mkCodeProducer :: IO CodeProducer +mkCodeProducer = CodeProducer <$> newEmptyMVar + +waitCode :: CodeObserver -> IO Code +waitCode (CodeObserver o) = readMVar o + +sendCode :: CodeProducer -> Code -> IO () +sendCode (CodeProducer p) = putMVar p + +type WormHoleParams = [CommandParam] + +-- | Sends a file. Once the send is underway, and the Code has been +-- generated, it will be sent to the CodeObserver. (This may not happen, +-- eg if there's a network problem). +-- +-- Currently this has to parse the output of wormhole to find the code. +-- To make this as robust as possible, avoids looking for any particular +-- output strings, and only looks for the form of a wormhole code +-- (number-word-word). +-- +-- Note that, if the filename looks like "foo 1-wormhole-code bar", when +-- that is output by wormhole, it will look like it's output a wormhole code. +-- +-- A request to make the code available in machine-parsable form is here: +-- https://github.com/warner/magic-wormhole/issues/104 +sendFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool +sendFile f (CodeObserver observer) ps = do + -- Work around stupid stdout buffering behavior of python. + -- See https://github.com/warner/magic-wormhole/issues/108 + environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment + runWormHoleProcess p { env = Just environ} $ \_hin hout -> + findcode =<< words <$> hGetContents hout + where + p = wormHoleProcess (Param "send" : ps ++ [File f]) + findcode [] = return False + findcode (w:ws) = case mkCode w of + Just code -> do + putMVar observer code + return True + Nothing -> findcode ws + +-- | Receives a file. Once the receive is under way, the Code will be +-- read from the CodeProducer, and fed to wormhole on stdin. +receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool +receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do + Code c <- readMVar producer + hPutStrLn hin c + hFlush hin + return True + where + p = wormHoleProcess $ + [ Param "receive" + , Param "--accept-file" + , Param "--output-file" + , File f + ] ++ ps + +wormHoleProcess :: WormHoleParams -> CreateProcess +wormHoleProcess = proc "wormhole" . toCommand + +runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> IO Bool) -> IO Bool +runWormHoleProcess p consumer = + bracketOnError setup (\v -> cleanup v <&&> return False) go + where + setup = do + (Just hin, Just hout, Nothing, pid) + <- createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + return (hin, hout, pid) + cleanup (hin, hout, pid) = do + r <- waitForProcess pid + hClose hin + hClose hout + return $ case r of + ExitSuccess -> True + ExitFailure _ -> False + go h@(hin, hout, _) = consumer hin hout <&&> cleanup h + +isInstalled :: IO Bool +isInstalled = inPath "wormhole" diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -10,9 +10,6 @@ module Utility.Misc where -import Utility.FileSystemEncoding -import Utility.Monad - import System.IO import Control.Monad import Foreign @@ -34,20 +31,6 @@ {- A version of readFile that is not lazy. -} readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s - -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content {- Like break, but the item matching the condition is not included - in the second result list. diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs --- a/Utility/Quvi.hs +++ b/Utility/Quvi.hs @@ -153,11 +153,8 @@ httponly Quvi04 = [Param "-c", Param "http"] httponly _ = [] -- No way to do it with 0.9? -{- Both versions of quvi will output utf-8 encoded data even when - - the locale doesn't support it. -} readQuvi :: [String] -> IO String readQuvi ps = withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h r <- hGetContentsStrict h hClose h return r diff --git a/Utility/Shell.hs b/Utility/Shell.hs --- a/Utility/Shell.hs +++ b/Utility/Shell.hs @@ -15,6 +15,7 @@ import Utility.FileSystemEncoding import Utility.Exception import Utility.PartialPrelude +import Utility.Applicative #endif #ifdef mingw32_HOST_OS @@ -48,9 +49,8 @@ #ifndef mingw32_HOST_OS defcmd #else - l <- catchDefaultIO Nothing $ withFile f ReadMode $ \h -> do - fileEncoding h - headMaybe . lines <$> hGetContents h + l <- catchDefaultIO Nothing $ withFile f ReadMode $ + headMaybe . lines <$$> hGetContents case l of Just ('#':'!':rest) -> case words rest of [] -> defcmd diff --git a/Utility/Su.hs b/Utility/Su.hs new file mode 100644 --- /dev/null +++ b/Utility/Su.hs @@ -0,0 +1,102 @@ +{- su to root + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Su where + +import Common +import Utility.Env + +#ifndef mingw32_HOST_OS +import System.Posix.Terminal +#endif + +data WhosePassword + = RootPassword + | UserPassword + | SomePassword + -- ^ may be user or root; su program should indicate which + deriving (Show) + +data PasswordPrompt + = WillPromptPassword WhosePassword + | MayPromptPassword WhosePassword + | NoPromptPassword + deriving (Show) + +describePasswordPrompt :: PasswordPrompt -> Maybe String +describePasswordPrompt (WillPromptPassword whose) = Just $ + "You will be prompted for " ++ describeWhosePassword whose ++ " password" +describePasswordPrompt (MayPromptPassword whose) = Just $ + "You may be prompted for " ++ describeWhosePassword whose ++ " password" +describePasswordPrompt NoPromptPassword = Nothing + +describeWhosePassword :: WhosePassword -> String +describeWhosePassword RootPassword = "root's" +describeWhosePassword UserPassword = "your" +describeWhosePassword SomePassword = "a" + +data SuCommand = SuCommand PasswordPrompt String [CommandParam] + deriving (Show) + +describePasswordPrompt' :: Maybe SuCommand -> Maybe String +describePasswordPrompt' (Just (SuCommand p _ _)) = describePasswordPrompt p +describePasswordPrompt' Nothing = Nothing + +runSuCommand :: (Maybe SuCommand) -> IO Bool +runSuCommand (Just (SuCommand _ cmd ps)) = boolSystem cmd ps +runSuCommand Nothing = return False + +-- Generates a SuCommand that runs a command as root, fairly portably. +-- +-- Does not use sudo commands if something else is available, because +-- the user may not be in sudoers and we couldn't differentiate between +-- that and the command failing. Although, some commands like gksu +-- decide based on the system's configuration whether sudo should be used. +mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand) +#ifndef mingw32_HOST_OS +mkSuCommand cmd ps = firstM (\(SuCommand _ p _) -> inPath p) =<< selectcmds + where + selectcmds = ifM (inx <||> (not <$> atconsole)) + ( return (graphicalcmds ++ consolecmds) + , return consolecmds + ) + + inx = isJust <$> getEnv "DISPLAY" + atconsole = queryTerminal stdInput + + -- These will only work when the user is logged into a desktop. + graphicalcmds = + [ SuCommand (MayPromptPassword SomePassword) "gksu" + [Param shellcmd] + , SuCommand (MayPromptPassword SomePassword) "kdesu" + [Param shellcmd] + -- Available in Debian's menu package; knows about lots of + -- ways to gain root. + , SuCommand (MayPromptPassword SomePassword) "su-to-root" + [Param "-X", Param "-c", Param shellcmd] + -- OSX native way to run a command as root, prompts in GUI + , SuCommand (WillPromptPassword RootPassword) "osascript" + [Param "-e", Param ("do shell script \"" ++ shellcmd ++ "\" with administrator privileges")] + ] + + -- These will only work when run in a console. + consolecmds = + [ SuCommand (WillPromptPassword RootPassword) "su" + [Param "-c", Param shellcmd] + , SuCommand (MayPromptPassword UserPassword) "sudo" + ([Param cmd] ++ ps) + , SuCommand (MayPromptPassword SomePassword) "su-to-root" + [Param "-c", Param shellcmd] + ] + + shellcmd = unwords $ map shellEscape (cmd:toCommand ps) +#else +-- For windows, we assume the user has administrator access. +mkSuCommand cmd ps = return $ Just $ SuCommand NoPromptPassword cmd ps +#endif diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -25,8 +25,12 @@ type OnionSocket = FilePath +-- | A unique identifier for a hidden service. type UniqueIdent = String +-- | Name of application that is providing a hidden service. +type AppName = String + connectHiddenService :: OnionAddress -> OnionPort -> IO Socket connectHiddenService (OnionAddress address) port = do (s, _) <- socksConnect torsockconf socksaddr @@ -48,10 +52,10 @@ -- -- If there is already a hidden service for the specified unique -- identifier, returns its information without making any changes. -addHiddenService :: UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) -addHiddenService uid ident = do - prepHiddenServiceSocketDir uid ident - ls <- lines <$> readFile torrc +addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) +addHiddenService appname uid ident = do + prepHiddenServiceSocketDir appname uid ident + ls <- lines <$> (readFile =<< findTorrc) let portssocks = mapMaybe (parseportsock . separate isSpace) ls case filter (\(_, s) -> s == sockfile) portssocks of ((p, _s):_) -> waithiddenservice 1 p @@ -59,10 +63,11 @@ highports <- R.getStdRandom mkhighports let newport = Prelude.head $ filter (`notElem` map fst portssocks) highports + torrc <- findTorrc writeFile torrc $ unlines $ ls ++ [ "" - , "HiddenServiceDir " ++ hiddenServiceDir uid ident + , "HiddenServiceDir " ++ hiddenServiceDir appname uid ident , "HiddenServicePort " ++ show newport ++ " unix:" ++ sockfile ] @@ -70,7 +75,7 @@ -- service and generate the hostname file for it. reloaded <- anyM (uncurry boolSystem) [ ("systemctl", [Param "reload", Param "tor"]) - , ("sefvice", [Param "tor", Param "reload"]) + , ("service", [Param "tor", Param "reload"]) ] unless reloaded $ giveup "failed to reload tor, perhaps the tor service is not running" @@ -81,7 +86,7 @@ return (p, drop 1 (dropWhile (/= ':') l)) parseportsock _ = Nothing - sockfile = hiddenServiceSocketFile uid ident + sockfile = hiddenServiceSocketFile appname uid ident -- An infinite random list of high ports. mkhighports g = @@ -91,7 +96,7 @@ waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice n p = do - v <- tryIO $ readFile $ hiddenServiceHostnameFile uid ident + v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident case v of Right s | ".onion\n" `isSuffixOf` s -> return (OnionAddress (takeWhile (/= '\n') s), p) @@ -101,44 +106,72 @@ -- | A hidden service directory to use. -- --- The "hs" is used in the name to prevent too long a path name, --- which could present problems for socketFile. -hiddenServiceDir :: UserID -> UniqueIdent -> FilePath -hiddenServiceDir uid ident = libDir "hs_" ++ show uid ++ "_" ++ ident +-- Has to be inside the torLibDir so tor can create it. +-- +-- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it. +hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath +hiddenServiceDir appname uid ident = torLibDir appname ++ "_" ++ show uid ++ "_" ++ ident -hiddenServiceHostnameFile :: UserID -> UniqueIdent -> FilePath -hiddenServiceHostnameFile uid ident = hiddenServiceDir uid ident "hostname" +hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath +hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident "hostname" -- | Location of the socket for a hidden service. -- -- This has to be a location that tor can read from, and that the user --- can write to. Tor is often prevented by apparmor from reading --- from many locations. Putting it in /etc is a FHS violation, but it's the --- simplest and most robust choice until http://bugs.debian.org/846275 is --- dealt with. +-- can write to. Since torLibDir is locked down, it can't go in there. -- -- Note that some unix systems limit socket paths to 92 bytes long. -- That should not be a problem if the UniqueIdent is around the length of --- a UUID. -hiddenServiceSocketFile :: UserID -> UniqueIdent -> FilePath -hiddenServiceSocketFile uid ident = etcDir "hidden_services" show uid ++ "_" ++ ident "s" +-- a UUID, and the AppName is short. +hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath +hiddenServiceSocketFile appname uid ident = varLibDir appname show uid ++ "_" ++ ident "s" +-- | Parse torrc, to get the socket file used for a hidden service with +-- the specified UniqueIdent. +getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath) +getHiddenServiceSocketFile _appname uid ident = + parse . map words . lines <$> catchDefaultIO "" (readFile =<< findTorrc) + where + parse [] = Nothing + parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest) + | "unix:" `isPrefixOf` hsaddr && hasident hsdir = + Just (drop (length "unix:") hsaddr) + | otherwise = parse rest + parse (_:rest) = parse rest + + -- Don't look for AppName in the hsdir, because it didn't used to + -- be included. + hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir + -- | Sets up the directory for the socketFile, with appropriate -- permissions. Must run as root. -prepHiddenServiceSocketDir :: UserID -> UniqueIdent -> IO () -prepHiddenServiceSocketDir uid ident = do +prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () +prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d setOwnerAndGroup d uid (-1) modifyFileMode d $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where - d = takeDirectory $ hiddenServiceSocketFile uid ident + d = takeDirectory $ hiddenServiceSocketFile appname uid ident -torrc :: FilePath -torrc = "/etc/tor/torrc" +-- | Finds the system's torrc file, in any of the typical locations of it. +-- Returns the first found. If there is no system torrc file, defaults to +-- /etc/tor/torrc. +findTorrc :: IO FilePath +findTorrc = fromMaybe "/etc/tor/torrc" <$> firstM doesFileExist + -- Debian + [ "/etc/tor/torrc" + -- Some systems put it here instead. + , "/etc/torrc" + -- Default when installed from source + , "/usr/local/etc/tor/torrc" + ] -libDir :: FilePath -libDir = "/var/lib/tor" +torLibDir :: FilePath +torLibDir = "/var/lib/tor" -etcDir :: FilePath -etcDir = "/etc/tor" +varLibDir :: FilePath +varLibDir = "/var/lib" + +torIsInstalled :: IO Bool +torIsInstalled = inPath "tor" diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -110,6 +110,7 @@ checkBoth url expected_size uo = do v <- check url expected_size uo return (fst v && snd v) + check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) check url expected_size = go <$$> getUrlInfo url where @@ -303,7 +304,7 @@ - it was asked to write to a file elsewhere. -} go cmd opts = withTmpDir "downloadurl" $ \tmp -> do absfile <- absPath file - let ps = addUserAgent uo $ reqParams uo++opts++[File absfile, File url] + let ps = addUserAgent uo $ opts++reqParams uo++[File absfile, File url] boolSystem' cmd ps $ \p -> p { cwd = Just tmp } quietopt s diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -84,7 +84,6 @@ -- disable buggy sloworis attack prevention code webAppSettings :: Settings - webAppSettings = setTimeout halfhour defaultSettings where halfhour = 30 * 60 diff --git a/doc/git-annex-enable-tor.mdwn b/doc/git-annex-enable-tor.mdwn --- a/doc/git-annex-enable-tor.mdwn +++ b/doc/git-annex-enable-tor.mdwn @@ -4,14 +4,18 @@ # SYNOPSIS +git annex enable-tor + sudo git annex enable-tor $(id -u) # DESCRIPTION This command enables a tor hidden service for git-annex. -It has to be run by root, since it modifies `/etc/tor/torrc`. -Pass it your user id number, as output by `id -u` +It modifies `/etc/tor/torrc` to register the hidden service. If run as a +normal user, it will try to use sudo/su/etc to get root access to modify +that file. If you run it as root, pass it your non-root user id number, +as output by `id -u` After this command is run, `git annex remotedaemon` can be run to serve the tor hidden service, and then `git-annex p2p --gen-address` can be run to diff --git a/doc/git-annex-p2p.mdwn b/doc/git-annex-p2p.mdwn --- a/doc/git-annex-p2p.mdwn +++ b/doc/git-annex-p2p.mdwn @@ -16,20 +16,46 @@ # OPTIONS +* `--pair` + + Run this in two repositories to pair them together over the P2P network. + + This will print out a code phrase, like "3-mango-elephant", and + will prompt for you to enter the code phrase from the other repository. + + Once code phrases have been exchanged, the two repositories will + be paired. A git remote will be created for the other repository, + with a name like "peer1". + + This uses [Magic Wormhole](https://github.com/warner/magic-wormhole) + to verify the code phrases and securely communicate the P2P addresses of + the repositories, so you will need it installed on both computers that are + being paired. + * `--gen-address` Generates addresses that can be used to access this git-annex repository over the available P2P networks. The address or addresses is output to - stdout. + stdout. + + Note that anyone who knows these addresses can access your + repository over the P2P networks. -* `--link remotename` +* `--link` - Sets up a git remote with the specified remotename that is accessed over - a P2P network. + Sets up a git remote that is accessed over a P2P network. This will prompt for an address to be entered; you should paste in the address that was generated by --gen-address in the remote repository. + Defaults to making the git remote be named "peer1", "peer2", + etc. This can be overridden with the `--name` option. + +* `--name` + + Specify a name to use when setting up a git remote with `--link` + or `--pair`. + # SEE ALSO [[git-annex]](1) @@ -37,6 +63,8 @@ [[git-annex-enable-tor]](1) [[git-annex-remotedaemon]](1) + +wormhole(1) # AUTHOR diff --git a/doc/git-annex-xmppgit.mdwn b/doc/git-annex-xmppgit.mdwn deleted file mode 100644 --- a/doc/git-annex-xmppgit.mdwn +++ /dev/null @@ -1,23 +0,0 @@ -# NAME - -git-annex xmppgit - git to XMPP relay - -# SYNOPSIS - -git annex xmppgit - -# DESCRIPTION - -This command is used internally by the assistant to perform git pulls over XMPP. - -# SEE ALSO - -[[git-annex]](1) - -[[git-annex-assistant]](1) - -# AUTHOR - -Joey Hess - -Warning: Automatically converted into a man page by mdwn2man. Edit with care. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -385,12 +385,6 @@ See [[git-annex-repair]](1) for details. -* `remotedaemon` - - Persistent communication with remotes. - - See [[git-annex-remotedaemon]](1) for details. - * `p2p` Configure peer-2-Peer links between repositories. @@ -670,13 +664,12 @@ See [[git-annex-smudge]](1) for details. -* `xmppgit` +* `remotedaemon` - This command is used internally by the assistant to perform git pulls - over XMPP. - - See [[git-annex-xmppgit]](1) for details. + Detects when network remotes have received git pushes and fetches from them. + See [[git-annex-remotedaemon]](1) for details. + # TESTING COMMANDS * `test` @@ -1307,11 +1300,6 @@ Used to identify tahoe special remotes. Points to the configuration directory for tahoe. - -* `remote..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..gcrypt` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20161210 +Version: 6.20170101 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -137,7 +137,6 @@ doc/git-annex-watch.mdwn doc/git-annex-webapp.mdwn doc/git-annex-whereis.mdwn - doc/git-annex-xmppgit.mdwn doc/git-remote-tor-annex.mdwn doc/logo.svg doc/logo_16x16.png @@ -198,13 +197,9 @@ templates/configurators/enablewebdav.hamlet templates/configurators/pairing/local/inprogress.hamlet templates/configurators/pairing/local/prompt.hamlet + templates/configurators/pairing/wormhole/prompt.hamlet + templates/configurators/pairing/wormhole/start.hamlet templates/configurators/pairing/disabled.hamlet - templates/configurators/pairing/xmpp/self/retry.hamlet - templates/configurators/pairing/xmpp/self/prompt.hamlet - templates/configurators/pairing/xmpp/friend/prompt.hamlet - templates/configurators/pairing/xmpp/friend/confirm.hamlet - templates/configurators/pairing/xmpp/end.hamlet - templates/configurators/xmpp.hamlet templates/configurators/addglacier.hamlet templates/configurators/fsck.cassius templates/configurators/edit/nonannexremote.hamlet @@ -226,19 +221,20 @@ templates/configurators/addrepository/archive.hamlet templates/configurators/addrepository/cloud.hamlet templates/configurators/addrepository/connection.hamlet - templates/configurators/addrepository/xmppconnection.hamlet templates/configurators/addrepository/ssh.hamlet templates/configurators/addrepository/misc.hamlet + templates/configurators/addrepository/wormholepairing.hamlet templates/configurators/rsync.net/add.hamlet templates/configurators/rsync.net/encrypt.hamlet templates/configurators/gitlab.com/add.hamlet templates/configurators/needgcrypt.hamlet + templates/configurators/needtor.hamlet + templates/configurators/needmagicwormhole.hamlet templates/configurators/enabledirectory.hamlet templates/configurators/fsck/status.hamlet templates/configurators/fsck/form.hamlet templates/configurators/fsck/preferencesform.hamlet templates/configurators/fsck/formcontent.hamlet - templates/configurators/delete/xmpp.hamlet templates/configurators/delete/finished.hamlet templates/configurators/delete/start.hamlet templates/configurators/delete/currentrepository.hamlet @@ -246,9 +242,6 @@ templates/configurators/adddrive.hamlet templates/configurators/preferences.hamlet templates/configurators/addia.hamlet - templates/configurators/xmpp/buddylist.hamlet - templates/configurators/xmpp/disabled.hamlet - templates/configurators/xmpp/needcloudrepo.hamlet templates/configurators/enableaws.hamlet templates/configurators/addrepository.hamlet templates/actionbutton.hamlet @@ -308,9 +301,6 @@ Flag Dbus Description: Enable dbus support -Flag XMPP - Description: Enable notifications using XMPP - source-repository head type: git location: git://git-annex.branchable.com/ @@ -481,11 +471,6 @@ Build-Depends: network-multicast, network-info CPP-Options: -DWITH_PAIRING - if flag(XMPP) - if (! os(windows)) - Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4), xml-types - CPP-Options: -DWITH_XMPP - if flag(TorrentParser) Build-Depends: torrent (>= 10000.0.0) CPP-Options: -DWITH_TORRENTPARSER @@ -580,7 +565,6 @@ Assistant.MakeRemote Assistant.Monad Assistant.NamedThread - Assistant.NetMessager Assistant.Pairing Assistant.Pairing.MakeRemote Assistant.Pairing.Network @@ -613,20 +597,16 @@ Assistant.Threads.Upgrader Assistant.Threads.Watcher Assistant.Threads.WebApp - Assistant.Threads.XMPPClient - Assistant.Threads.XMPPPusher Assistant.TransferQueue Assistant.TransferSlots Assistant.TransferrerPool Assistant.Types.Alert Assistant.Types.BranchChange - Assistant.Types.Buddies Assistant.Types.Changes Assistant.Types.Commits Assistant.Types.CredPairCache Assistant.Types.DaemonStatus Assistant.Types.NamedThread - Assistant.Types.NetMessager Assistant.Types.Pushes Assistant.Types.RemoteControl Assistant.Types.RepoProblem @@ -654,7 +634,6 @@ Assistant.WebApp.Configurators.Unused Assistant.WebApp.Configurators.Upgrade Assistant.WebApp.Configurators.WebDAV - Assistant.WebApp.Configurators.XMPP Assistant.WebApp.Control Assistant.WebApp.DashBoard Assistant.WebApp.Documentation @@ -664,15 +643,12 @@ Assistant.WebApp.Notifications Assistant.WebApp.OtherRepos Assistant.WebApp.Page + Assistant.WebApp.Pairing Assistant.WebApp.Repair Assistant.WebApp.RepoId Assistant.WebApp.RepoList Assistant.WebApp.SideBar Assistant.WebApp.Types - Assistant.XMPP - Assistant.XMPP.Buddies - Assistant.XMPP.Client - Assistant.XMPP.Git Backend Backend.Hash Backend.URL @@ -812,7 +788,6 @@ Command.Watch Command.WebApp Command.Whereis - Command.XMPPGit Common Config Config.Cost @@ -1044,6 +1019,7 @@ Utility.LockPool.Windows Utility.LogFile Utility.Lsof + Utility.MagicWormhole Utility.Matcher Utility.Metered Utility.Misc @@ -1071,6 +1047,7 @@ Utility.Shell Utility.SimpleProtocol Utility.SshConfig + Utility.Su Utility.SystemDirectory Utility.TList Utility.Tense diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -15,6 +15,7 @@ import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteTorAnnex import qualified Test +import Utility.FileSystemEncoding #ifdef mingw32_HOST_OS import Utility.UserInfo @@ -23,6 +24,7 @@ main :: IO () main = withSocketsDo $ do + useFileSystemEncoding ps <- getArgs #ifdef mingw32_HOST_OS winEnv diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,6 @@ webapp: true magicmime: false dbus: false - xmpp: false android: false androidsplice: false packages: diff --git a/templates/configurators/addrepository/connection.hamlet b/templates/configurators/addrepository/connection.hamlet --- a/templates/configurators/addrepository/connection.hamlet +++ b/templates/configurators/addrepository/connection.hamlet @@ -1,3 +1,3 @@ -^{makeXMPPConnection} - ^{makeSshRepository} + +^{makeWormholePairing} diff --git a/templates/configurators/addrepository/misc.hamlet b/templates/configurators/addrepository/misc.hamlet --- a/templates/configurators/addrepository/misc.hamlet +++ b/templates/configurators/addrepository/misc.hamlet @@ -8,7 +8,7 @@ SneakerNet # between computers. -^{makeXMPPConnection} +^{makeWormholePairing}

diff --git a/templates/configurators/addrepository/wormholepairing.hamlet b/templates/configurators/addrepository/wormholepairing.hamlet new file mode 100644 --- /dev/null +++ b/templates/configurators/addrepository/wormholepairing.hamlet @@ -0,0 +1,13 @@ +

+ + + \ Share with your other devices +

+ Keep files in sync between your devices running git-annex. + +

+ + + \ Share with a friend +

+ Combine your repository with a friend's repository, and share your files. diff --git a/templates/configurators/addrepository/xmppconnection.hamlet b/templates/configurators/addrepository/xmppconnection.hamlet deleted file mode 100644 --- a/templates/configurators/addrepository/xmppconnection.hamlet +++ /dev/null @@ -1,13 +0,0 @@ -

- - - \ Share with your other devices -

- Keep files in sync between your devices running git-annex. - -

- - - \ Share with a friend -

- Combine your repository with a friend's repository, and share your files. diff --git a/templates/configurators/delete/xmpp.hamlet b/templates/configurators/delete/xmpp.hamlet deleted file mode 100644 --- a/templates/configurators/delete/xmpp.hamlet +++ /dev/null @@ -1,12 +0,0 @@ -

-
-

- Disconnecting from Jabber -

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

- - - \ Disconnect diff --git a/templates/configurators/main.hamlet b/templates/configurators/main.hamlet --- a/templates/configurators/main.hamlet +++ b/templates/configurators/main.hamlet @@ -27,16 +27,3 @@ Unused files

Configure what to do with old and deleted files. -

-
-

- - Jabber account - $if xmppconfigured -

- Your jabber account is set up, and will be used to keep # - in touch with remote devices, and with your friends. - $else -

- Keep in touch with remote devices, and with your friends, # - by configuring a jabber account. diff --git a/templates/configurators/needmagicwormhole.hamlet b/templates/configurators/needmagicwormhole.hamlet new file mode 100644 --- /dev/null +++ b/templates/configurators/needmagicwormhole.hamlet @@ -0,0 +1,11 @@ +

+
+

+ Need Magic Wormhole +

+ You need to install # + + Magic Wormhole +

+ + Retry diff --git a/templates/configurators/needtor.hamlet b/templates/configurators/needtor.hamlet new file mode 100644 --- /dev/null +++ b/templates/configurators/needtor.hamlet @@ -0,0 +1,11 @@ +

+
+

+ Need Tor +

+ You need to install # + + Tor +

+ + Retry diff --git a/templates/configurators/pairing/wormhole/prompt.hamlet b/templates/configurators/pairing/wormhole/prompt.hamlet new file mode 100644 --- /dev/null +++ b/templates/configurators/pairing/wormhole/prompt.hamlet @@ -0,0 +1,59 @@ +

+
+

+ $case pairingwith + $of PairingWithSelf + Pairing your devices + $of PairingWithFriend + Pairing with a friend +

+ Pairing will connect two git-annex repositories using # + Tor, # + allowing files to be shared between them. +

+ $case pairingwith + $of PairingWithSelf + This device's # + $of PairingWithFriend + Your repository's # + pairing code is: #{Wormhole.fromCode ourcode} +

+ $case pairingwith + $of PairingWithSelf + Enter that code into the device you want to pair with. # + $of PairingWithFriend + Tell that code to your friend. # +

+

+
+ ^{form} + ^{webAppFormAuthToken} +
+
+