packages feed

git-annex 6.20161210 → 6.20170101

raw patch · 125 files changed

+1410/−2920 lines, 125 filesdep −gnutlsdep −network-protocol-xmppdep −xml-types

Dependencies removed: gnutls, network-protocol-xmpp, xml-types

Files

Annex/Branch.hs view
@@ -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
Annex/CatFile.hs view
@@ -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
Annex/Content/Direct.hs view
@@ -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'
Annex/DirHashes.hs view
@@ -26,6 +26,7 @@ import Types.Key import Types.GitConfig import Types.Difference+import Utility.FileSystemEncoding  type Hasher = Key -> FilePath
Annex/Journal.hs view
@@ -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]
Annex/Link.hs view
@@ -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
Annex/Locations.hs view
@@ -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
Annex/Ssh.hs view
@@ -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. -}
Annex/VariantFile.hs view
@@ -8,6 +8,7 @@ module Annex.VariantFile where  import Annex.Common+import Utility.FileSystemEncoding  import Data.Hash.MD5
Assistant.hs view
@@ -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
Assistant/DaemonStatus.hs view
@@ -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))
Assistant/Monad.hs view
@@ -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
− Assistant/NetMessager.hs 
@@ -1,180 +0,0 @@-{- git-annex assistant out of band network messager interface- -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE BangPatterns #-}--module Assistant.NetMessager where--import Assistant.Common-import Assistant.Types.NetMessager--import Control.Concurrent.STM-import Control.Concurrent.MSampleVar-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.DList as D--sendNetMessage :: NetMessage -> Assistant ()-sendNetMessage m = -	(atomically . flip writeTChan m) <<~ (netMessages . netMessager)--waitNetMessage :: Assistant (NetMessage)-waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)--notifyNetMessagerRestart :: Assistant ()-notifyNetMessagerRestart =-	flip writeSV () <<~ (netMessagerRestart . netMessager)--{- This can be used to get an early indication if the network has- - changed, to immediately restart a connection. However, that is not- - available on all systems, so clients also need to deal with- - restarting dropped connections in the usual way. -}-waitNetMessagerRestart :: Assistant ()-waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)--{- Store a new important NetMessage for a client, and if an equivilant- - older message is already stored, remove it from both importantNetMessages- - and sentImportantNetMessages. -}-storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()-storeImportantNetMessage m client matchingclient = go <<~ netMessager-  where-	go nm = atomically $ do-		q <- takeTMVar $ importantNetMessages nm-		sent <- takeTMVar $ sentImportantNetMessages nm-		putTMVar (importantNetMessages nm) $-			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $-				M.mapWithKey removematching q-		putTMVar (sentImportantNetMessages nm) $-			M.mapWithKey removematching sent-	removematching someclient s-		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s-		| otherwise = s--{- Indicates that an important NetMessage has been sent to a client. -}-sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()-sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)-  where-	go v = atomically $ do-		sent <- takeTMVar v-		putTMVar v $-			M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent--{- Checks for important NetMessages that have been stored for a client, and- - sent to a client. Typically the same client for both, although - - a modified or more specific client may need to be used. -}-checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)-checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager-  where-	go nm = atomically $ do-		stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)-		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)-		return (fromMaybe S.empty stored, fromMaybe S.empty sent)--{- Queues a push initiation message in the queue for the appropriate- - side of the push but only if there is not already an initiation message- - from the same client in the queue. -}-queuePushInitiation :: NetMessage -> Assistant ()-queuePushInitiation msg@(Pushing clientid stage) = do-	tv <- getPushInitiationQueue side-	liftIO $ atomically $ do-		r <- tryTakeTMVar tv-		case r of-			Nothing -> putTMVar tv [msg]-			Just l -> do-				let !l' = msg : filter differentclient l-				putTMVar tv l'-  where-	side = pushDestinationSide stage-	differentclient (Pushing cid _) = cid /= clientid-	differentclient _ = True-queuePushInitiation _ = noop--{- Waits for a push inititation message to be received, and runs- - function to select a message from the queue. -}-waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage-waitPushInitiation side selector = do-	tv <- getPushInitiationQueue side-	liftIO $ atomically $ do-		q <- takeTMVar tv-		if null q-			then retry-			else do-				let (msg, !q') = selector q-				unless (null q') $-					putTMVar tv q'-				return msg--{- Stores messages for a push into the appropriate inbox.- -- - To avoid overflow, only 1000 messages max are stored in any- - inbox, which should be far more than necessary.- -- - TODO: If we have more than 100 inboxes for different clients,- - discard old ones that are not currently being used by any push.- -}-storeInbox :: NetMessage -> Assistant ()-storeInbox msg@(Pushing clientid stage) = do-	inboxes <- getInboxes side-	stored <- liftIO $ atomically $ do-		m <- readTVar inboxes-		let update = \v -> do-			writeTVar inboxes $-				M.insertWith' const clientid v m-			return True-		case M.lookup clientid m of-			Nothing -> update (1, tostore)-			Just (sz, l)-				| sz > 1000 -> return False-				| otherwise ->-					let !sz' = sz + 1-					    !l' = D.append l tostore-					in update (sz', l')-	if stored-		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]-		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]-  where-	side = pushDestinationSide stage-	tostore = D.singleton msg-storeInbox _ = noop--{- Gets the new message for a push from its inbox.- - Blocks until a message has been received. -}-waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)-waitInbox clientid side = do-	inboxes <- getInboxes side-	liftIO $ atomically $ do-		m <- readTVar inboxes-		case M.lookup clientid m of-			Nothing -> retry-			Just (sz, dl)-				| sz < 1 -> retry-				| otherwise -> do-					let msg = D.head dl-					let dl' = D.tail dl-					let !sz' = sz - 1-					writeTVar inboxes $-						M.insertWith' const clientid (sz', dl') m-					return msg--emptyInbox :: ClientID -> PushSide -> Assistant ()-emptyInbox clientid side = do-	inboxes <- getInboxes side-	liftIO $ atomically $-		modifyTVar' inboxes $-			M.delete clientid-	-getInboxes :: PushSide -> Assistant Inboxes-getInboxes side =-	getSide side . netMessagerInboxes <$> getAssistant netMessager--getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])-getPushInitiationQueue side =-	getSide side . netMessagerPushInitiations <$> getAssistant netMessager--netMessagerDebug :: ClientID -> [String] -> Assistant ()-netMessagerDebug clientid l = debug $-	"NetMessager" : l ++ [show $ logClientID clientid]
Assistant/Sync.hs view
@@ -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
Assistant/Threads/Merger.hs view
@@ -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
Assistant/Threads/MountWatcher.hs view
@@ -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.  -
Assistant/Threads/NetWatcher.hs view
@@ -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]
Assistant/Threads/Pusher.hs view
@@ -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.  -
Assistant/Threads/TransferScanner.hs view
@@ -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. -}
Assistant/Threads/WebApp.hs view
@@ -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
− Assistant/Threads/XMPPClient.hs 
@@ -1,375 +0,0 @@-{- git-annex XMPP client- -- - Copyright 2012, 2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Assistant.Threads.XMPPClient where--import Assistant.Common hiding (ProtocolError)-import Assistant.XMPP-import Assistant.XMPP.Client-import Assistant.NetMessager-import Assistant.Types.NetMessager-import Assistant.Types.Buddies-import Assistant.XMPP.Buddies-import Assistant.Sync-import Assistant.DaemonStatus-import qualified Remote-import Utility.ThreadScheduler-import Assistant.WebApp (UrlRenderer)-import Assistant.WebApp.Types hiding (liftAssistant)-import Assistant.Alert-import Assistant.Pairing-import Assistant.XMPP.Git-import Annex.UUID-import Logs.UUID-import qualified Command.Sync--import Network.Protocol.XMPP-import Control.Concurrent-import Control.Concurrent.STM.TMVar-import Control.Concurrent.STM (atomically)-import qualified Data.Text as T-import qualified Data.Set as S-import qualified Data.Map as M-import Data.Time.Clock-import Control.Concurrent.Async--xmppClientThread :: UrlRenderer -> NamedThread-xmppClientThread urlrenderer = namedThread "XMPPClient" $-	restartableClient . xmppClient urlrenderer =<< getAssistant id--{- Runs the client, handing restart events. -}-restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()-restartableClient a = forever $ go =<< liftAnnex getXMPPCreds-  where-	go Nothing = waitNetMessagerRestart-	go (Just creds) = do-		xmppuuid <- maybe NoUUID Remote.uuid . headMaybe -			. filter Remote.isXMPPRemote . syncRemotes-			<$> getDaemonStatus-		tid <- liftIO $ forkIO $ a creds xmppuuid-		waitNetMessagerRestart-		liftIO $ killThread tid--xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()-xmppClient urlrenderer d creds xmppuuid =-	retry (runclient creds) =<< getCurrentTime-  where-	liftAssistant = runAssistant d-	inAssistant = liftIO . liftAssistant--	{- When the client exits, it's restarted;-	 - if it keeps failing, back off to wait 5 minutes before-	 - trying it again. -}-	retry client starttime = do-		{- The buddy list starts empty each time-		 - the client connects, so that stale info-		 - is not retained. -}-		liftAssistant $-			updateBuddyList (const noBuddies) <<~ buddyList-		void client-		liftAssistant $ do-			modifyDaemonStatus_ $ \s -> s-				{ xmppClientID = Nothing }-			changeCurrentlyConnected $ S.delete xmppuuid-			-		now <- getCurrentTime-		if diffUTCTime now starttime > 300-			then do-				liftAssistant $ debug ["connection lost; reconnecting"]-				retry client now-			else do-				liftAssistant $ debug ["connection failed; will retry"]-				threadDelaySeconds (Seconds 300)-				retry client =<< getCurrentTime--	runclient c = liftIO $ connectXMPP c $ \jid -> do-		selfjid <- bindJID jid-		putStanza gitAnnexSignature--		inAssistant $ do-			modifyDaemonStatus_ $ \s -> s-				{ xmppClientID = Just $ xmppJID creds }-			changeCurrentlyConnected $ S.insert xmppuuid-			debug ["connected", logJid selfjid]--		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime--		sender <- xmppSession $ sendnotifications selfjid-		receiver <- xmppSession $ receivenotifications selfjid lasttraffic-		pinger <- xmppSession $ sendpings selfjid lasttraffic-		{- Run all 3 threads concurrently, until-		 - any of them throw an exception.-		 - Then kill all 3 threads, and rethrow the-		 - exception.-		 --		 - If this thread gets an exception, the 3 threads-		 - will also be killed. -}-		liftIO $ pinger `concurrently` sender `concurrently` receiver--	sendnotifications selfjid = forever $-		join $ inAssistant $ relayNetMessage selfjid-	receivenotifications selfjid lasttraffic = forever $ do-		l <- decodeStanza selfjid <$> getStanza-		void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime-		inAssistant $ debug-			["received:", show $ map logXMPPEvent l]-		mapM_ (handlemsg selfjid) l-	sendpings selfjid lasttraffic = forever $ do-		putStanza pingstanza--		startping <- liftIO getCurrentTime-		liftIO $ threadDelaySeconds (Seconds 120)-		t <- liftIO $ atomically $ readTMVar lasttraffic-		when (t < startping) $ do-			inAssistant $ debug ["ping timeout"]-			error "ping timeout"-	  where-		{- XEP-0199 says that the server will respond with either-		 - a ping response or an error message. Either will-		 - cause traffic, so good enough. -}-		pingstanza = xmppPing selfjid--	handlemsg selfjid (PresenceMessage p) = do-		void $ inAssistant $ -			updateBuddyList (updateBuddies p) <<~ buddyList-		resendImportantMessages selfjid p-	handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature-	handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us-	handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) =-		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)-	handlemsg _ (GotNetMessage m@(Pushing _ pushstage))-		| isPushNotice pushstage = inAssistant $ handlePushNotice m-		| isPushInitiation pushstage = inAssistant $ queuePushInitiation m-		| otherwise = inAssistant $ storeInbox m-	handlemsg _ (Ignorable _) = noop-	handlemsg _ (Unknown _) = noop-	handlemsg _ (ProtocolError _) = noop--	resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do-		let c = formatJID jid-		(stored, sent) <- inAssistant $-			checkImportantNetMessages (formatJID (baseJID jid), c)-		forM_ (S.toList $ S.difference stored sent) $ \msg -> do-			let msg' = readdressNetMessage msg c-			inAssistant $ debug-				[ "sending to new client:"-				, logJid jid-				, show $ logNetMessage msg'-				]-			join $ inAssistant $ convertNetMsg msg' selfjid-			inAssistant $ sentImportantNetMessage msg c-	resendImportantMessages _ _ = noop--data XMPPEvent-	= GotNetMessage NetMessage-	| PresenceMessage Presence-	| Ignorable ReceivedStanza-	| Unknown ReceivedStanza-	| ProtocolError ReceivedStanza-	deriving Show--logXMPPEvent :: XMPPEvent -> String-logXMPPEvent (GotNetMessage m) = logNetMessage m-logXMPPEvent (PresenceMessage p) = logPresence p-logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p-logXMPPEvent (Ignorable _) = "Ignorable message"-logXMPPEvent (Unknown _) = "Unknown message"-logXMPPEvent (ProtocolError _) = "Protocol error message"--logPresence :: Presence -> String-logPresence (p@Presence { presenceFrom = Just jid }) = unwords-	[ "Presence from"-	, logJid jid-	, show $ extractGitAnnexTag p-	]-logPresence _ = "Presence from unknown"--logJid :: JID -> String-logJid jid =-	let name = T.unpack (buddyName jid)-	    resource = maybe "" (T.unpack . strResource) (jidResource jid)-	in take 1 name ++ show (length name) ++ "/" ++ resource--logClient :: Client -> String-logClient (Client jid) = logJid jid--{- Decodes an XMPP stanza into one or more events. -}-decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]-decodeStanza selfjid s@(ReceivedPresence p)-	| presenceType p == PresenceError = [ProtocolError s]-	| isNothing (presenceFrom p) = [Ignorable s]-	| presenceFrom p == Just selfjid = [Ignorable s]-	| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)-  where-	decode i-		| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $-			decodePushNotification (tagValue i)-		| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence-		| otherwise = [Unknown s]-	{- Things sent via presence imply a presence message,-	 - along with their real meaning. -}-	impliedp v = [PresenceMessage p, v]-decodeStanza selfjid s@(ReceivedMessage m)-	| isNothing (messageFrom m) = [Ignorable s]-	| messageFrom m == Just selfjid = [Ignorable s]-	| messageType m == MessageError = [ProtocolError s]-	| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]-decodeStanza _ s = [Unknown s]--{- Waits for a NetMessager message to be sent, and relays it to XMPP.- -- - Chat messages must be directed to specific clients, not a base- - account JID, due to git-annex clients using a negative presence priority.- - PairingNotification messages are always directed at specific- - clients, but Pushing messages are sometimes not, and need to be exploded- - out to specific clients.- -- - Important messages, not directed at any specific client, - - are cached to be sent later when additional clients connect.- -}-relayNetMessage :: JID -> Assistant (XMPP ())-relayNetMessage selfjid = do-	msg <- waitNetMessage-	debug ["sending:", logNetMessage msg]-	a1 <- handleImportant msg-	a2 <- convert msg-	return (a1 >> a2)-  where-	handleImportant msg = case parseJID =<< isImportantNetMessage msg of-		Just tojid-			| tojid == baseJID tojid -> do-				storeImportantNetMessage msg (formatJID tojid) $-					\c -> (baseJID <$> parseJID c) == Just tojid-				return $ putStanza presenceQuery-		_ -> return noop-	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->-		if tojid == baseJID tojid-			then do-				clients <- maybe [] (S.toList . buddyAssistants)-					<$> getBuddy (genBuddyKey tojid) <<~ buddyList-				debug ["exploded undirected message to clients", unwords $ map logClient clients]-				return $ forM_ clients $ \(Client jid) ->-					putStanza $ pushMessage pushstage jid selfjid-			else do-				debug ["to client:", logJid tojid]-				return $ putStanza $ pushMessage pushstage tojid selfjid-	convert msg = convertNetMsg msg selfjid--{- Converts a NetMessage to an XMPP action. -}-convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())-convertNetMsg msg selfjid = convert msg-  where-	convert (NotifyPush us) = return $ putStanza $ pushNotification us-	convert QueryPresence = return $ putStanza presenceQuery-	convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do-		changeBuddyPairing tojid True-		return $ putStanza $ pairingNotification stage u tojid selfjid-	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->-		return $ putStanza $  pushMessage pushstage tojid selfjid--withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ())-withOtherClient selfjid c a = case parseJID c of-	Nothing -> return noop-	Just tojid-		| tojid == selfjid -> return noop-		| otherwise -> a tojid--withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()-withClient c a = maybe noop a $ parseJID c--{- Returns an IO action that runs a XMPP action in a separate thread,- - using a session to allow it to access the same XMPP client. -}-xmppSession :: XMPP () -> XMPP (IO ())-xmppSession a = do-	s <- getSession-	return $ void $ runXMPP s a--{- We only pull from one remote out of the set listed in the push- - notification, as an optimisation.- -- - Note that it might be possible (though very unlikely) for the push- - notification to take a while to be sent, and multiple pushes happen- - before it is sent, so it includes multiple remotes that were pushed- - to at different times. - -- - It could then be the case that the remote we choose had the earlier- - push sent to it, but then failed to get the later push, and so is not- - fully up-to-date. If that happens, the pushRetryThread will come along- - and retry the push, and we'll get another notification once it succeeds,- - and pull again. -}-pull :: [UUID] -> Assistant ()-pull [] = noop-pull us = do-	rs <- filter matching . syncGitRemotes <$> getDaemonStatus-	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs-	pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch)-  where-	matching r = Remote.uuid r `S.member` s-	s = S.fromList us--	pullone [] _ = noop-	pullone (r:rs) branch =-		unlessM (null . fst <$> manualPull branch [r]) $-			pullone rs branch--{- PairReq from another client using our JID is automatically- - accepted. This is so pairing devices all using the same XMPP- - account works without confirmations.- -- - Also, autoaccept PairReq from the same JID of any repo we've- - already paired with, as long as the UUID in the PairReq is- - one we know about.--}-pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()-pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid-	| baseJID selfjid == baseJID theirjid = autoaccept-	| otherwise = do-		knownjids <- mapMaybe (parseJID . getXMPPClientID)-			. filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus-		um <- liftAnnex uuidMap-		if elem (baseJID theirjid) knownjids && M.member theiruuid um-			then autoaccept-			else showalert--  where-	autoaccept = do-		selfuuid <- liftAnnex getUUID-		sendNetMessage $-			PairingNotification PairAck (formatJID theirjid) selfuuid-		finishXMPPPairing theirjid theiruuid-	-- Show an alert to let the user decide if they want to pair.-	showalert = do-		button <- mkAlertButton True (T.pack "Respond") urlrenderer $-			ConfirmXMPPPairFriendR $-				PairKey theiruuid $ formatJID theirjid-		void $ addAlert $ pairRequestReceivedAlert-			(T.unpack $ buddyName theirjid)-			button--{- PairAck must come from one of the buddies we are pairing with;- - don't pair with just anyone. -}-pairMsgReceived _ PairAck theiruuid _selfjid theirjid =-	whenM (isBuddyPairing theirjid) $ do-		changeBuddyPairing theirjid False-		selfuuid <- liftAnnex getUUID-		sendNetMessage $-			PairingNotification PairDone (formatJID theirjid) selfuuid-		finishXMPPPairing theirjid theiruuid--pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =-	changeBuddyPairing theirjid False--isBuddyPairing :: JID -> Assistant Bool-isBuddyPairing jid = maybe False buddyPairing <$> -	getBuddy (genBuddyKey jid) <<~ buddyList--changeBuddyPairing :: JID -> Bool -> Assistant ()-changeBuddyPairing jid ispairing =-	updateBuddyList (M.adjust set key) <<~ buddyList-  where-	key = genBuddyKey jid-	set b = b { buddyPairing = ispairing }
− Assistant/Threads/XMPPPusher.hs 
@@ -1,82 +0,0 @@-{- git-annex XMPP pusher threads- -- - This is a pair of threads. One handles git send-pack,- - and the other git receive-pack. Each thread can be running at most- - one such operation at a time.- -- - Why not use a single thread? Consider two clients A and B.- - If both decide to run a receive-pack at the same time to the other,- - they would deadlock with only one thread. For larger numbers of- - clients, the two threads are also sufficient.- -- - Copyright 2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Assistant.Threads.XMPPPusher where--import Assistant.Common-import Assistant.NetMessager-import Assistant.Types.NetMessager-import Assistant.WebApp (UrlRenderer)-import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)-import Assistant.XMPP.Git--import Control.Exception as E--xmppSendPackThread :: UrlRenderer -> NamedThread-xmppSendPackThread = pusherThread "XMPPSendPack" SendPack--xmppReceivePackThread :: UrlRenderer -> NamedThread-xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack--pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread-pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing-  where-	go lastpushedto = do-		msg <- waitPushInitiation side $ selectNextPush lastpushedto-		debug ["started running push", logNetMessage msg]--		runpush <- asIO $ runPush checker msg-		r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID)))-		let successful = case r of-			Right (Just _) -> True-			_ -> False--		{- Empty the inbox, because stuff may have-		 - been left in it if the push failed. -}-		let justpushedto = getclient msg-		maybe noop (`emptyInbox` side) justpushedto--		debug ["finished running push", logNetMessage msg, show successful]-		go $ if successful then justpushedto else lastpushedto-	-	checker = checkCloudRepos urlrenderer--	getclient (Pushing cid _) = Just cid-	getclient _ = Nothing--{- Select the next push to run from the queue.- - The queue cannot be empty!- -- - We prefer to select the most recently added push, because its requestor- - is more likely to still be connected.- -- - When passed the ID of a client we just pushed to, we prefer to not- - immediately push again to that same client. This avoids one client - - drowing out others. So pushes from the client we just pushed to are - - relocated to the beginning of the list, to be processed later.- -}-selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage])-selectNextPush _ (m:[]) = (m, []) -- common case-selectNextPush _ [] = error "selectNextPush: empty list"-selectNextPush lastpushedto l = go [] l-  where-	go (r:ejected) [] = (r, ejected)-	go rejected (m:ms) = case m of-		(Pushing clientid _)-			| Just clientid /= lastpushedto -> (m, rejected ++ ms)-		_ -> go (m:rejected) ms-	go [] [] = error "empty push queue"-
Assistant/TransferrerPool.hs view
@@ -74,8 +74,6 @@ 		, std_in = CreatePipe 		, std_out = CreatePipe 		}-	fileEncoding readh-	fileEncoding writeh 	return $ Transferrer 		{ transferrerRead = readh 		, transferrerWrite = writeh
− Assistant/Types/Buddies.hs 
@@ -1,80 +0,0 @@-{- git-annex assistant buddies- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE CPP #-}--module Assistant.Types.Buddies where--import Annex.Common--import qualified Data.Map as M-import Control.Concurrent.STM-import Utility.NotificationBroadcaster-import Data.Text as T--{- For simplicity, dummy types are defined even when XMPP is disabled. -}-#ifdef WITH_XMPP-import Network.Protocol.XMPP-import Data.Set as S-import Data.Ord--newtype Client = Client JID-	deriving (Eq, Show)--instance Ord Client where-	compare = comparing show--data Buddy = Buddy-	{ buddyPresent :: S.Set Client-	, buddyAway :: S.Set Client-	, buddyAssistants :: S.Set Client-	, buddyPairing :: Bool-	}-#else-data Buddy = Buddy-#endif-	deriving (Eq, Show)--data BuddyKey = BuddyKey T.Text-	deriving (Eq, Ord, Show, Read)--data PairKey = PairKey UUID T.Text-	deriving (Eq, Ord, Show, Read)--type Buddies = M.Map BuddyKey Buddy--{- A list of buddies, and a way to notify when it changes. -}-type BuddyList = (TMVar Buddies, NotificationBroadcaster)--noBuddies :: Buddies-noBuddies = M.empty--newBuddyList :: IO BuddyList-newBuddyList = (,)-	<$> atomically (newTMVar noBuddies)-	<*> newNotificationBroadcaster--getBuddyList :: BuddyList -> IO [Buddy]-getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)--getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)-getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)--getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster-getBuddyBroadcaster (_, h) = h--{- Applies a function to modify the buddy list, and if it's changed,- - sends notifications to any listeners. -}-updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()-updateBuddyList a (v, caster) = do-	changed <- atomically $ do-		buds <- takeTMVar v-		let buds' = a buds-		putTMVar v buds'-		return $ buds /= buds'-	when changed $-		sendNotification caster
Assistant/Types/DaemonStatus.hs view
@@ -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
− Assistant/Types/NetMessager.hs 
@@ -1,155 +0,0 @@-{- git-annex assistant out of band network messager types- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Assistant.Types.NetMessager where--import Annex.Common-import Assistant.Pairing-import Git.Types--import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.DList as D-import Control.Concurrent.STM-import Control.Concurrent.MSampleVar-import Data.ByteString (ByteString)-import Data.Text (Text)--{- Messages that can be sent out of band by a network messager. -}-data NetMessage -	-- indicate that pushes have been made to the repos with these uuids-	= NotifyPush [UUID]-	-- requests other clients to inform us of their presence-	| QueryPresence-	-- notification about a stage in the pairing process,-	-- involving a client, and a UUID.-	| PairingNotification PairStage ClientID UUID-	-- used for git push over the network messager-	| Pushing ClientID PushStage-	deriving (Eq, Ord, Show)--{- Something used to identify the client, or clients to send the message to. -}-type ClientID = Text--data PushStage-	-- indicates that we have data to push over the out of band network-	= CanPush UUID [Sha]-	-- request that a git push be sent over the out of band network-	| PushRequest UUID-	-- indicates that a push is starting-	| StartingPush UUID-	-- a chunk of output of git receive-pack-	| ReceivePackOutput SequenceNum ByteString-	-- a chuck of output of git send-pack-	| SendPackOutput SequenceNum ByteString-	-- sent when git receive-pack exits, with its exit code-	| ReceivePackDone ExitCode-	deriving (Eq, Ord, Show)--{- A sequence number. Incremented by one per packet in a sequence,- - starting with 1 for the first packet. 0 means sequence numbers are- - not being used. -}-type SequenceNum = Int--{- NetMessages that are important (and small), and should be stored to be- - resent when new clients are seen. -}-isImportantNetMessage :: NetMessage -> Maybe ClientID-isImportantNetMessage (Pushing c (CanPush _ _)) = Just c-isImportantNetMessage (Pushing c (PushRequest _)) = Just c-isImportantNetMessage _ = Nothing--{- Checks if two important NetMessages are equivilant.- - That is to say, assuming they were sent to the same client,- - would it do the same thing for one as for the other? -}-equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool-equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True-equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True-equivilantImportantNetMessages _ _ = False--readdressNetMessage :: NetMessage -> ClientID -> NetMessage-readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid-readdressNetMessage (Pushing _ stage) c = Pushing c stage-readdressNetMessage m _ = m--{- Convert a NetMessage to something that can be logged. -}-logNetMessage :: NetMessage -> String-logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $-	case stage of-		ReceivePackOutput n _ -> ReceivePackOutput n elided-		SendPackOutput n _ -> SendPackOutput n elided-		s -> s-  where-	elided = T.encodeUtf8 $ T.pack "<elided>"-logNetMessage (PairingNotification stage c uuid) =-	show $ PairingNotification stage (logClientID c) uuid-logNetMessage m = show m--logClientID :: ClientID -> ClientID-logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]--{- Things that initiate either side of a push, but do not actually send data. -}-isPushInitiation :: PushStage -> Bool-isPushInitiation (PushRequest _) = True-isPushInitiation (StartingPush _) = True-isPushInitiation _ = False--isPushNotice :: PushStage -> Bool-isPushNotice (CanPush _ _) = True-isPushNotice _ = False--data PushSide = SendPack | ReceivePack-	deriving (Eq, Ord, Show)--pushDestinationSide :: PushStage -> PushSide-pushDestinationSide (CanPush _ _) = ReceivePack-pushDestinationSide (PushRequest _) = SendPack-pushDestinationSide (StartingPush _) = ReceivePack-pushDestinationSide (ReceivePackOutput _ _) = SendPack-pushDestinationSide (SendPackOutput _ _) = ReceivePack-pushDestinationSide (ReceivePackDone _) = SendPack--type SideMap a = PushSide -> a--mkSideMap :: STM a -> IO (SideMap a)-mkSideMap gen = do-	(sp, rp) <- atomically $ (,) <$> gen <*> gen-	return $ lookupside sp rp-  where-	lookupside sp _ SendPack = sp-	lookupside _ rp ReceivePack = rp--getSide :: PushSide -> SideMap a -> a-getSide side m = m side--type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))--data NetMessager = NetMessager-	-- outgoing messages-	{ netMessages :: TChan NetMessage-	-- important messages for each client-	, importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))-	-- important messages that are believed to have been sent to a client-	, sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))-	-- write to this to restart the net messager-	, netMessagerRestart :: MSampleVar ()-	-- queue of incoming messages that request the initiation of pushes-	, netMessagerPushInitiations :: SideMap (TMVar [NetMessage])-	-- incoming messages containing data for a running-	-- (or not yet started) push-	, netMessagerInboxes :: SideMap Inboxes-	}--newNetMessager :: IO NetMessager-newNetMessager = NetMessager-	<$> atomically newTChan-	<*> atomically (newTMVar M.empty)-	<*> atomically (newTMVar M.empty)-	<*> newEmptySV-	<*> mkSideMap newEmptyTMVar-	<*> mkSideMap (newTVar M.empty)
Assistant/WebApp/Configurators.hs view
@@ -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")
Assistant/WebApp/Configurators/Delete.hs view
@@ -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")
Assistant/WebApp/Configurators/Pairing.hs view
@@ -1,41 +1,41 @@ {- git-annex assistant webapp configurator for pairing  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012,2016 Joey Hess <id@joeyh.name>  -  - 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
− Assistant/WebApp/Configurators/XMPP.hs 
@@ -1,226 +0,0 @@-{- git-annex assistant XMPP configuration- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}-{-# LANGUAGE CPP #-}--module Assistant.WebApp.Configurators.XMPP where--import Assistant.WebApp.Common-import Assistant.WebApp.Notifications-import Utility.NotificationBroadcaster-#ifdef WITH_XMPP-import qualified Remote-import Assistant.XMPP.Client-import Assistant.XMPP.Buddies-import Assistant.Types.Buddies-import Assistant.NetMessager-import Assistant.Alert-import Assistant.DaemonStatus-import Assistant.WebApp.RepoList-import Assistant.WebApp.Configurators-import Assistant.XMPP-import qualified Git.Remote.Remove-import Remote.List-import Creds-#endif--#ifdef WITH_XMPP-import Network.Protocol.XMPP-import Network-import qualified Data.Text as T-#endif--{- When appropriate, displays an alert suggesting to configure a cloud repo- - to suppliment an XMPP remote. -}-checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()-#ifdef WITH_XMPP-checkCloudRepos urlrenderer r =-	unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do-		buddyname <- getBuddyName $ Remote.uuid r-		button <- mkAlertButton True "Add a cloud repository" urlrenderer $-			NeedCloudRepoR $ Remote.uuid r-		void $ addAlert $ cloudRepoNeededAlert buddyname button-#else-checkCloudRepos _ _ = noop-#endif--#ifdef WITH_XMPP-{- Returns the name of the friend corresponding to a- - repository's UUID, but not if it's our name. -}-getBuddyName :: UUID -> Assistant (Maybe String)-getBuddyName u = go =<< getclientjid-  where-	go Nothing = return Nothing-	go (Just myjid) = (T.unpack . buddyName <$>)-		. headMaybe -		. filter (\j -> baseJID j /= baseJID myjid)-		. map fst-		. filter (\(_, r) -> Remote.uuid r == u)-		<$> getXMPPRemotes-	getclientjid = maybe Nothing parseJID . xmppClientID-		<$> getDaemonStatus-#endif--getNeedCloudRepoR :: UUID -> Handler Html-#ifdef WITH_XMPP-getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do-	buddyname <- liftAssistant $ getBuddyName for-	$(widgetFile "configurators/xmpp/needcloudrepo")-#else-getNeedCloudRepoR _ = xmppPage $-	$(widgetFile "configurators/xmpp/disabled")-#endif--getXMPPConfigR :: Handler Html-getXMPPConfigR = postXMPPConfigR--postXMPPConfigR :: Handler Html-postXMPPConfigR = xmppform DashboardR--getXMPPConfigForPairFriendR :: Handler Html-getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR--postXMPPConfigForPairFriendR :: Handler Html-postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR--getXMPPConfigForPairSelfR :: Handler Html-getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR--postXMPPConfigForPairSelfR :: Handler Html-postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR--xmppform :: Route WebApp -> Handler Html-#ifdef WITH_XMPP-xmppform next = xmppPage $ do-	((result, form), enctype) <- liftH $ do-		oldcreds <- liftAnnex getXMPPCreds-		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $-			creds2Form <$> oldcreds-	let showform problem = $(widgetFile "configurators/xmpp")-	case result of-		FormSuccess f -> either (showform . Just) (liftH . storecreds)-			=<< liftIO (validateForm f)-		_ -> showform Nothing-  where-	storecreds creds = do-		void $ liftAnnex $ setXMPPCreds creds-		liftAssistant notifyNetMessagerRestart-		redirect next-#else-xmppform _ = xmppPage $-	$(widgetFile "configurators/xmpp/disabled")-#endif--{- Called by client to get a list of buddies.- -- - Returns a div, which will be inserted into the calling page.- -}-getBuddyListR :: NotificationId -> Handler Html-getBuddyListR nid = do-	waitNotifier getBuddyListBroadcaster nid--	p <- widgetToPageContent buddyListDisplay-	withUrlRenderer $ [hamlet|^{pageBody p}|]--buddyListDisplay :: Widget-buddyListDisplay = do-	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)-#ifdef WITH_XMPP-	myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus-	let isself (BuddyKey b) = Just b == myjid-	buddies <- liftAssistant $ do-		pairedwith <- map fst <$> getXMPPRemotes-		catMaybes . map (buddySummary pairedwith)-			<$> (getBuddyList <<~ buddyList)-	$(widgetFile "configurators/xmpp/buddylist")-#else-	noop-#endif-  where-	ident = "buddylist"--#ifdef WITH_XMPP--getXMPPRemotes :: Assistant [(JID, Remote)]-getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes-	<$> getDaemonStatus-  where-	pair r = maybe Nothing (\jid -> Just (jid, r)) $-		parseJID $ getXMPPClientID r--data XMPPForm = XMPPForm-	{ formJID :: Text-	, formPassword :: Text }--creds2Form :: XMPPCreds -> XMPPForm-creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)--xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm-xmppAForm d = XMPPForm-	<$> areq jidField (bfs "Jabber address") (formJID <$> d)-	<*> areq passwordField (bfs "Password") Nothing--jidField :: MkField Text-jidField = checkBool (isJust . parseJID) bad textField-  where-	bad :: Text-	bad = "This should look like an email address.."--validateForm :: XMPPForm -> IO (Either String XMPPCreds)-validateForm f = do-	let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)-	let username = fromMaybe "" (strNode <$> jidNode jid)-	testXMPP $ XMPPCreds-		{ xmppUsername = username-		, xmppPassword = formPassword f-		, xmppHostname = T.unpack $ strDomain $ jidDomain jid-		, xmppPort = 5222-		, xmppJID = formJID f-		}--testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)-testXMPP creds = do-	(good, bad) <- partition (either (const False) (const True) . snd) -		<$> connectXMPP creds (const noop)-	case good of-		(((h, PortNumber p), _):_) -> return $ Right $ creds-			{ xmppHostname = h-			, xmppPort = fromIntegral p-			}-		(((h, _), _):_) -> return $ Right $ creds-			{ xmppHostname = h-			}-		_ -> return $ Left $ intercalate "; " $ map formatlog bad-  where-	formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e-	formatlog _ = ""--	showport (PortNumber n) = show n-	showport (Service s) = s-	showport (UnixSocket s) = s-#endif--getDisconnectXMPPR :: Handler Html-getDisconnectXMPPR = do-#ifdef WITH_XMPP-	rs <- filter Remote.isXMPPRemote . syncRemotes-		<$> liftAssistant getDaemonStatus-	liftAnnex $ do-		mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs-		void remoteListRefresh-		removeCreds xmppCredsFile-	liftAssistant $ do-		updateSyncRemotes-		notifyNetMessagerRestart-	redirect DashboardR-#else-	xmppPage $ $(widgetFile "configurators/xmpp/disabled")-#endif--xmppPage :: Widget -> Handler Html-xmppPage = page "Jabber" (Just Configuration)
Assistant/WebApp/Control.hs view
@@ -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")
Assistant/WebApp/Notifications.hs view
@@ -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
+ Assistant/WebApp/Pairing.hs view
@@ -0,0 +1,79 @@+{- git-annex assistant pairing+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - 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
Assistant/WebApp/RepoList.hs view
@@ -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)
Assistant/WebApp/Types.hs view
@@ -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
Assistant/WebApp/routes view
@@ -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
− Assistant/XMPP.hs 
@@ -1,275 +0,0 @@-{- core xmpp support- -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE OverloadedStrings #-}--module Assistant.XMPP where--import Assistant.Common-import Assistant.Types.NetMessager-import Assistant.Pairing-import Git.Sha (extractSha)-import Git--import Network.Protocol.XMPP hiding (Node)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Map as M-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.XML.Types-import qualified "sandi" Codec.Binary.Base64 as B64-import Data.Bits.Utils--{- Name of the git-annex tag, in our own XML namespace.- - (Not using a namespace URL to avoid unnecessary bloat.) -}-gitAnnexTagName :: Name-gitAnnexTagName  = "{git-annex}git-annex"--{- Creates a git-annex tag containing a particular attribute and value. -}-gitAnnexTag :: Name -> Text -> Element-gitAnnexTag attr val = gitAnnexTagContent attr val []--{- Also with some content. -}-gitAnnexTagContent :: Name -> Text -> [Node] -> Element-gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]--isGitAnnexTag :: Element -> Bool-isGitAnnexTag t = elementName t == gitAnnexTagName--{- Things that a git-annex tag can inserted into. -}-class GitAnnexTaggable a where-	insertGitAnnexTag :: a -> Element -> a--	extractGitAnnexTag :: a -> Maybe Element--	hasGitAnnexTag :: a -> Bool-	hasGitAnnexTag = isJust . extractGitAnnexTag--instance GitAnnexTaggable Message where-	insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m }-	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads--instance GitAnnexTaggable Presence where-	-- always mark extended away and set presence priority to negative-	insertGitAnnexTag p elt = p-		{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }-	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads--data GitAnnexTagInfo = GitAnnexTagInfo-	{ tagAttr :: Name-	, tagValue :: Text-	, tagElement :: Element-	}--type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage--gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo-gitAnnexTagInfo v = case extractGitAnnexTag v of-	{- Each git-annex tag has a single attribute. -}-	Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo-		<$> pure attr-		<*> attributeText attr tag-		<*> pure tag-	_ -> Nothing--{- A presence with a git-annex tag in it.- - Also includes a status tag, which may be visible in XMPP clients. -}-gitAnnexPresence :: Element -> Presence-gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable-  where-	addStatusTag p = p-		{ presencePayloads = status : presencePayloads p }-	status = Element "status" [] [statusMessage]-	statusMessage = NodeContent $ ContentText $ T.pack "git-annex"--{- A presence with an empty git-annex tag in it, used for letting other- - clients know we're around and are a git-annex client. -}-gitAnnexSignature :: Presence-gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []--{- XMPP client to server ping -}-xmppPing :: JID -> IQ-xmppPing selfjid = (emptyIQ IQGet)-	{ iqID = Just "c2s1"-	, iqFrom = Just selfjid-	, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing-	, iqPayload = Just $ Element xmppPingTagName [] []-	}--xmppPingTagName :: Name-xmppPingTagName = "{urn:xmpp}ping"--{- A message with a git-annex tag in it. -}-gitAnnexMessage :: Element -> JID -> JID -> Message-gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)-	{ messageTo = Just tojid-	, messageFrom = Just fromjid-	}--{- A notification that we've pushed to some repositories, listing their- - UUIDs. -}-pushNotification :: [UUID] -> Presence-pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification--encodePushNotification :: [UUID] -> Text-encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)--decodePushNotification :: Text -> [UUID]-decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep--uuidSep :: Text-uuidSep = ","--{- A request for other git-annex clients to send presence. -}-presenceQuery :: Presence-presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty--{- A notification about a stage of pairing. -}-pairingNotification :: PairStage -> UUID -> JID -> JID -> Message-pairingNotification pairstage u = gitAnnexMessage $ -	gitAnnexTag pairAttr $ encodePairingNotification pairstage u--encodePairingNotification :: PairStage -> UUID -> Text-encodePairingNotification pairstage u = T.unwords $ map T.pack-	[ show pairstage-	, fromUUID u-	]--decodePairingNotification :: Decoder-decodePairingNotification m = parse . words . T.unpack . tagValue-  where-	parse [stage, u] = PairingNotification-		<$> readish stage-		<*> (formatJID <$> messageFrom m)-		<*> pure (toUUID u)-	parse _ = Nothing--pushMessage :: PushStage -> JID -> JID -> Message-pushMessage = gitAnnexMessage . encode-  where-	encode (CanPush u shas) =-		gitAnnexTag canPushAttr $ T.pack $ unwords $-			fromUUID u : map fromRef shas-	encode (PushRequest u) =-		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u-	encode (StartingPush u) =-		gitAnnexTag startingPushAttr $ T.pack $ fromUUID u-	encode (ReceivePackOutput n b) = -		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b-	encode (SendPackOutput n b) =-		gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b-	encode (ReceivePackDone code) =-		gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code-	val = T.pack . show--decodeMessage :: Message -> Maybe NetMessage-decodeMessage m = decode =<< gitAnnexTagInfo m-  where-	decode i = M.lookup (tagAttr i) decoders >>= rundecoder i-	rundecoder i d = d m i-	decoders = M.fromList $ zip-		[ pairAttr-		, canPushAttr-		, pushRequestAttr-		, startingPushAttr-		, receivePackAttr-		, sendPackAttr-		, receivePackDoneAttr-		]-		[ decodePairingNotification-		, pushdecoder $ shasgen CanPush-		, pushdecoder $ gen PushRequest-		, pushdecoder $ gen StartingPush-		, pushdecoder $ seqgen ReceivePackOutput-		, pushdecoder $ seqgen SendPackOutput-		, pushdecoder $-			fmap (ReceivePackDone . decodeExitCode) . readish .-				T.unpack . tagValue-		]-	pushdecoder a m' i = Pushing-		<$> (formatJID <$> messageFrom m')-		<*> a i-	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))-	seqgen c i = do-		packet <- decodeTagContent $ tagElement i-		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i-		return $ c seqnum packet-	shasgen c i = do-		let (u:shas) = words $ T.unpack $ tagValue i-		return $ c (toUUID u) (mapMaybe extractSha shas)--decodeExitCode :: Int -> ExitCode-decodeExitCode 0 = ExitSuccess-decodeExitCode n = ExitFailure n-	-encodeExitCode :: ExitCode -> Int-encodeExitCode ExitSuccess = 0-encodeExitCode (ExitFailure n) = n--{- Base 64 encoding a ByteString to use as the content of a tag. -}-encodeTagContent :: ByteString -> [Node]-encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b]--decodeTagContent :: Element -> Maybe ByteString-decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s)-  where-	s = T.unpack $ T.concat $ elementText elt--{- The JID without the client part. -}-baseJID :: JID -> JID-baseJID j = JID (jidNode j) (jidDomain j) Nothing--{- An XMPP chat message with an empty body. This should not be displayed- - by clients, but can be used for communications. -}-silentMessage :: Message-silentMessage = (emptyMessage MessageChat)-	{ messagePayloads = [ emptybody ] }-  where-	emptybody = Element-		{ elementName = "body"-		, elementAttributes = []-		, elementNodes = []-		}--{- Add to a presence to mark its client as extended away. -}-extendedAway :: Element-extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]--{- Add to a presence to give it a negative priority. -}-negativePriority :: Element-negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]--pushAttr :: Name-pushAttr = "push"--queryAttr :: Name-queryAttr = "query"--pairAttr :: Name-pairAttr = "pair"--canPushAttr :: Name-canPushAttr = "canpush"--pushRequestAttr :: Name-pushRequestAttr = "pushrequest"--startingPushAttr :: Name-startingPushAttr = "startingpush"--receivePackAttr :: Name-receivePackAttr = "rp"--sendPackAttr :: Name-sendPackAttr = "sp"--receivePackDoneAttr :: Name-receivePackDoneAttr = "rpdone"--shasAttr :: Name-shasAttr = "shas"
− Assistant/XMPP/Buddies.hs 
@@ -1,87 +0,0 @@-{- xmpp buddies- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Assistant.XMPP.Buddies where--import Assistant.XMPP-import Annex.Common-import Assistant.Types.Buddies--import Network.Protocol.XMPP-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T--genBuddyKey :: JID -> BuddyKey-genBuddyKey j = BuddyKey $ formatJID $ baseJID j--buddyName :: JID -> Text-buddyName j = maybe (T.pack "") strNode (jidNode j)--ucFirst :: Text -> Text-ucFirst s = let (first, rest) = T.splitAt 1 s-	in T.concat [T.toUpper first, rest]--{- Summary of info about a buddy.- -- - If the buddy has no clients at all anymore, returns Nothing. -}-buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey)-buddySummary pairedwith b = case clients of-	((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j)-	[] -> Nothing-  where-	away = S.null (buddyPresent b) && S.null (buddyAssistants b)-	canpair = not $ S.null (buddyAssistants b)-	clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b-	alreadypaired j = baseJID j `elem` pairedwith--{- Updates the buddies with XMPP presence info. -}-updateBuddies :: Presence -> Buddies -> Buddies-updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key-  where-	key = genBuddyKey jid-	update (Just b) = Just $ applyPresence p b-	update Nothing = newBuddy p-updateBuddies _ = id--{- Creates a new buddy based on XMPP presence info. -}-newBuddy :: Presence -> Maybe Buddy-newBuddy p-	| presenceType p == PresenceAvailable = go-	| presenceType p == PresenceUnavailable = go-	| otherwise = Nothing-  where-	go = make <$> presenceFrom p-	make _jid = applyPresence p $ Buddy-		{ buddyPresent = S.empty-		, buddyAway = S.empty-		, buddyAssistants = S.empty-		, buddyPairing = False-		}--applyPresence :: Presence -> Buddy -> Buddy-applyPresence p b = fromMaybe b $! go <$> presenceFrom p-  where-	go jid-		| presenceType p == PresenceUnavailable = b-			{ buddyAway = addto $ buddyAway b-			, buddyPresent = removefrom $ buddyPresent b-			, buddyAssistants = removefrom $ buddyAssistants b-			}-		| hasGitAnnexTag p = b-			{ buddyAssistants = addto $ buddyAssistants b-			, buddyAway = removefrom $ buddyAway b }-		| presenceType p == PresenceAvailable = b-			{ buddyPresent = addto $ buddyPresent b-			, buddyAway = removefrom $ buddyAway b-			}-		| otherwise = b-	  where-		client = Client jid-		removefrom = S.filter (/= client)-		addto = S.insert client
− Assistant/XMPP/Client.hs 
@@ -1,83 +0,0 @@-{- xmpp client support- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Assistant.XMPP.Client where--import Assistant.Common-import Utility.SRV-import Creds--import Network.Protocol.XMPP-import Network-import Control.Concurrent-import qualified Data.Text as T--{- Everything we need to know to connect to an XMPP server. -}-data XMPPCreds = XMPPCreds-	{ xmppUsername :: T.Text-	, xmppPassword :: T.Text-	, xmppHostname :: HostName-	, xmppPort :: Int-	, xmppJID :: T.Text-	}-	deriving (Read, Show)--connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]-connectXMPP c a = case parseJID (xmppJID c) of-	Nothing -> error "bad JID"-	Just jid -> connectXMPP' jid c a--{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}-connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]-connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord)-  where-	srvrecord = mkSRVTcp "xmpp-client" $-		T.unpack $ strDomain $ jidDomain jid-	serverjid = JID Nothing (jidDomain jid) Nothing--	handlesrv [] = do-		let h = xmppHostname c-		let p = PortNumber $ fromIntegral $ xmppPort c-		r <- run h p $ a jid-		return [r]-	handlesrv srvs = go [] srvs--	go l [] = return l-	go l ((h,p):rest) = do-		{- Try each SRV record in turn, until one connects,-		 - at which point the MVar will be full. -}-		mv <- newEmptyMVar-		r <- run h p $ do-			liftIO $ putMVar mv ()-			a jid-		ifM (isEmptyMVar mv)-			( go (r : l) rest-			, return (r : l)-			)--	{- Async exceptions are let through so the XMPP thread can-	 - be killed. -}-	run h p a' = do-		r <- tryNonAsync $-			runClientError (Server serverjid h p) jid-				(xmppUsername c) (xmppPassword c) (void a')-		return ((h, p), r)--{- XMPP runClient, that throws errors rather than returning an Either -}-runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a-runClientError s j u p x = either (error . show) return =<< runClient s j u p x--getXMPPCreds :: Annex (Maybe XMPPCreds)-getXMPPCreds = parse <$> readCacheCreds xmppCredsFile-  where-	parse s = readish =<< s--setXMPPCreds :: XMPPCreds -> Annex ()-setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile--xmppCredsFile :: FilePath-xmppCredsFile = "xmpp"
− Assistant/XMPP/Git.hs 
@@ -1,381 +0,0 @@-{- git over XMPP- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE CPP #-}--module Assistant.XMPP.Git where--import Assistant.Common-import Assistant.NetMessager-import Assistant.Types.NetMessager-import Assistant.XMPP-import Assistant.XMPP.Buddies-import Assistant.DaemonStatus-import Assistant.Alert-import Assistant.MakeRemote-import Assistant.Sync-import qualified Command.Sync-import qualified Annex.Branch-import Annex.Path-import Annex.UUID-import Logs.UUID-import Annex.TaggedPush-import Annex.CatFile-import Config-import Git-import qualified Types.Remote as Remote-import qualified Remote as Remote-import Remote.List-import Utility.FileMode-import Utility.Shell-import Utility.Env--import Network.Protocol.XMPP-import qualified Data.Text as T-import System.Posix.Types-import qualified System.Posix.IO-import Control.Concurrent-import System.Timeout-import qualified Data.ByteString as B-import qualified Data.Map as M--{- Largest chunk of data to send in a single XMPP message. -}-chunkSize :: Int-chunkSize = 4096--{- How long to wait for an expected message before assuming the other side- - has gone away and canceling a push. - -- - This needs to be long enough to allow a message of up to 2+ times- - chunkSize to propigate up to a XMPP server, perhaps across to another- - server, and back down to us. On the other hand, other XMPP pushes can be- - delayed for running until the timeout is reached, so it should not be- - excessive.- -}-xmppTimeout :: Int-xmppTimeout = 120000000 -- 120 seconds--finishXMPPPairing :: JID -> UUID -> Assistant ()-finishXMPPPairing jid u = void $ alertWhile alert $-	makeXMPPGitRemote buddy (baseJID jid) u-  where-	buddy = T.unpack $ buddyName jid-	alert = pairRequestAcknowledgedAlert buddy Nothing--gitXMPPLocation :: JID -> String-gitXMPPLocation jid = "xmpp::" ++ T.unpack (formatJID $ baseJID jid)--makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool-makeXMPPGitRemote buddyname jid u = do-	remote <- liftAnnex $ addRemote $-		makeGitRemote buddyname $ gitXMPPLocation jid-	liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u-	liftAnnex $ void remoteListRefresh-	remote' <- liftAnnex $ fromMaybe (error "failed to add remote")-		<$> Remote.byName (Just buddyname)-	syncRemote remote'-	return True--{- Pushes over XMPP, communicating with a specific client.- - Runs an arbitrary IO action to push, which should run git-push with- - an xmpp:: url.- -- - To handle xmpp:: urls, git push will run git-remote-xmpp, which is- - injected into its PATH, and in turn runs git-annex xmppgit. The- - dataflow them becomes:- - - - git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp- -                                                          |- - git receive-pack <--> xmppReceivePack <---------------> xmpp- - - - The pipe between git-annex xmppgit and us is set up and communicated- - using two environment variables, relayIn and relayOut, that are set- - to the file descriptors to use. Another, relayControl, is used to- - propigate the exit status of git receive-pack.- -- - We listen at the other end of the pipe and relay to and from XMPP.- -}-xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool-xmppPush cid gitpush = do-	u <- liftAnnex getUUID-	sendNetMessage $ Pushing cid (StartingPush u)--	(Fd inf, writepush) <- liftIO System.Posix.IO.createPipe-	(readpush, Fd outf) <- liftIO System.Posix.IO.createPipe-	(Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe--	tmpdir <- gettmpdir-	installwrapper tmpdir--	environ <- liftIO getEnvironment-	path <- liftIO getSearchPath-	let myenviron = addEntries-		[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)-		, (relayIn, show inf)-		, (relayOut, show outf)-		, (relayControl, show controlf)-		]-		environ--	inh <- liftIO $ fdToHandle readpush-	outh <- liftIO $ fdToHandle writepush-	controlh <- liftIO $ fdToHandle writecontrol-	-	t1 <- forkIO <~> toxmpp 0 inh-	t2 <- forkIO <~> fromxmpp outh controlh--	{- This can take a long time to run, so avoid running it in the-	 - Annex monad. Also, override environment. -}-	g <- liftAnnex gitRepo-	r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }--	liftIO $ do-		mapM_ killThread [t1, t2]-		mapM_ hClose [inh, outh, controlh]-		mapM_ closeFd [Fd inf, Fd outf, Fd controlf]-	-	return r-  where-	toxmpp seqnum inh = do-		b <- liftIO $ B.hGetSome inh chunkSize-		if B.null b-			then liftIO $ killThread =<< myThreadId-			else do-				let seqnum' = succ seqnum-				sendNetMessage $ Pushing cid $-					SendPackOutput seqnum' b-				toxmpp seqnum' inh-	-	fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg-	  where-		handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = -			liftIO $ writeChunk outh b-		handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) =-			liftIO $ do-				hPrint controlh exitcode-				hFlush controlh-		handlemsg (Just _) = noop-		handlemsg Nothing = do-			debug ["timeout waiting for git receive-pack output via XMPP"]-			-- Send a synthetic exit code to git-annex-			-- xmppgit, which will exit and cause git push-			-- to die.-			liftIO $ do-				hPrint controlh (ExitFailure 1)-				hFlush controlh-				killThread =<< myThreadId-	-	installwrapper tmpdir = liftIO $ do-		createDirectoryIfMissing True tmpdir-		let wrapper = tmpdir </> "git-remote-xmpp"-		program <- programPath-		writeFile wrapper $ unlines-			[ shebang_local-			, "exec " ++ program ++ " xmppgit"-			]-		modifyFileMode wrapper $ addModes executeModes-	-	{- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp-	 - dir (ie, not on a crippled filesystem where we can't make-	 - the wrapper executable). -}-	gettmpdir = do-		v <- liftIO $ getEnv "GIT_ANNEX_TMP_DIR"-		case v of-			Nothing -> do-				tmp <- liftAnnex $ fromRepo gitAnnexTmpMiscDir-				return $ tmp </> "xmppgit"-			Just d -> return $ d </> "xmppgit"--type EnvVar = String--envVar :: String -> EnvVar-envVar s = "GIT_ANNEX_XMPPGIT_" ++ s--relayIn :: EnvVar-relayIn = envVar "IN"--relayOut :: EnvVar-relayOut = envVar "OUT"--relayControl :: EnvVar-relayControl = envVar "CONTROL"--relayHandle :: EnvVar -> IO Handle-relayHandle var = do-	v <- getEnv var-	case readish =<< v of-		Nothing -> error $ var ++ " not set"-		Just n -> fdToHandle $ Fd n--{- Called by git-annex xmppgit.- -- - git-push is talking to us on stdin- - we're talking to git-push on stdout- - git-receive-pack is talking to us on relayIn (via XMPP)- - we're talking to git-receive-pack on relayOut (via XMPP)- - git-receive-pack's exit code will be passed to us on relayControl- -}-xmppGitRelay :: IO ()-xmppGitRelay = do-	flip relay stdout =<< relayHandle relayIn-	relay stdin =<< relayHandle relayOut-	code <- hGetLine =<< relayHandle relayControl-	exitWith $ fromMaybe (ExitFailure 1) $ readish code-  where-	{- Is it possible to set up pipes and not need to copy the data-	 - ourselves? See splice(2) -}-	relay fromh toh = void $ forkIO $ forever $ do-		b <- B.hGetSome fromh chunkSize-		when (B.null b) $ do-			hClose fromh-			hClose toh-			killThread =<< myThreadId-		writeChunk toh b--{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating- - its exit status to XMPP. -}-xmppReceivePack :: ClientID -> Assistant Bool-xmppReceivePack cid = do-	repodir <- liftAnnex $ fromRepo repoPath-	let p = (proc "git" ["receive-pack", repodir])-		{ std_in = CreatePipe-		, std_out = CreatePipe-		, std_err = Inherit-		}-	(Just inh, Just outh, _, pid) <- liftIO $ createProcess p-	readertid <- forkIO <~> relayfromxmpp inh-	relaytoxmpp 0 outh-	code <- liftIO $ waitForProcess pid-	void $ sendNetMessage $ Pushing cid $ ReceivePackDone code-	liftIO $ do-		killThread readertid-		hClose inh-		hClose outh-		return $ code == ExitSuccess-  where-	relaytoxmpp seqnum outh = do-		b <- liftIO $ B.hGetSome outh chunkSize-		-- empty is EOF, so exit-		unless (B.null b) $ do-			let seqnum' = succ seqnum-			sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b-			relaytoxmpp seqnum' outh-	relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg-	  where-		handlemsg (Just (Pushing _ (SendPackOutput _ b))) =-			liftIO $ writeChunk inh b-		handlemsg (Just _) = noop-		handlemsg Nothing = do-			debug ["timeout waiting for git send-pack output via XMPP"]-			-- closing the handle will make git receive-pack exit-			liftIO $ do-				hClose inh-				killThread =<< myThreadId--xmppRemotes :: ClientID -> UUID -> Assistant [Remote]-xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of-	Nothing -> return []-	Just jid -> do-		let loc = gitXMPPLocation jid-		um <- liftAnnex uuidMap-		filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes -			<$> getDaemonStatus-  where-	matching loc r = repoIsUrl r && repoLocation r == loc-	knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um--{- Returns the ClientID that it pushed to. -}-runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)-runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =-	go =<< liftAnnex (join Command.Sync.getCurrBranch)-  where-	go (Just branch, _) = do-		rs <- xmppRemotes cid theiruuid-		liftAnnex $ Annex.Branch.commit "update"-		(g, u) <- liftAnnex $ (,)-			<$> gitRepo-			<*> getUUID-		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g-		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus-		if null rs-			then return Nothing-			else do-				forM_ rs $ \r -> do-					void $ alertWhile (syncAlert [r]) $-						xmppPush cid (taggedPush u selfjid branch r)-					checkcloudrepos r-				return $ Just cid-	go _ = return Nothing-runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do-	rs <- xmppRemotes cid theiruuid-	if null rs-		then return Nothing-		else do-			void $ alertWhile (syncAlert rs) $-				xmppReceivePack cid-			mapM_ checkcloudrepos rs-			return $ Just cid-runPush _ _ = return Nothing--{- Check if any of the shas that can be pushed are ones we do not- - have.- -- - (Older clients send no shas, so when there are none, always- - request a push.)- -}-handlePushNotice :: NetMessage -> Assistant ()-handlePushNotice (Pushing cid (CanPush theiruuid shas)) =-	unlessM (null <$> xmppRemotes cid theiruuid) $-		if null shas-			then go-			else ifM (haveall shas)-				( debug ["ignoring CanPush with known shas"]-				, go-				)-  where-	go = do-		u <- liftAnnex getUUID-		sendNetMessage $ Pushing cid (PushRequest u)-	haveall l = liftAnnex $ not <$> anyM donthave l-	donthave sha = isNothing <$> catObjectDetails sha-handlePushNotice _ = noop--writeChunk :: Handle -> B.ByteString -> IO ()-writeChunk h b = do-	B.hPut h b-	hFlush h--{- Gets NetMessages for a PushSide, ensures they are in order,- - and runs an action to handle each in turn. The action will be passed- - Nothing on timeout.- -- - Does not currently reorder messages, but does ensure that any - - duplicate messages, or messages not in the sequence, are discarded.- -}-withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()-withPushMessagesInSequence cid side a = loop 0-  where-	loop seqnum = do-		m <- timeout xmppTimeout <~> waitInbox cid side-		let go s = a m >> loop s-		let next = seqnum + 1-		case extractSequence =<< m of-			Just seqnum'-				| seqnum' == next -> go next-				| seqnum' == 0 -> go seqnum-				| seqnum' == seqnum -> do-					debug ["ignoring duplicate sequence number", show seqnum]-					loop seqnum-				| otherwise -> do-					debug ["ignoring out of order sequence number", show seqnum', "expected", show next]-					loop seqnum-			Nothing -> go seqnum--extractSequence :: NetMessage -> Maybe Int-extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum-extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum-extractSequence _ = Nothing
Backend/Utilities.hs view
@@ -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.
Build/DistributionUpdate.hs view
@@ -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
Build/EvilSplicer.hs view
@@ -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
BuildFlags.hs view
@@ -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
CHANGELOG view
@@ -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 <id@joeyh.name>  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.
@@ -2,11 +2,11 @@ Source: native package  Files: *-Copyright: © 2010-2016 Joey Hess <id@joeyh.name>+Copyright: © 2010-2017 Joey Hess <id@joeyh.name> License: GPL-3+  Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*-Copyright: © 2012-2016 Joey Hess <id@joeyh.name>+Copyright: © 2012-2017 Joey Hess <id@joeyh.name>            © 2014 Sören Brunk License: AGPL-3+ @@ -21,7 +21,7 @@ License: BSD-2-clause  Files: Utility/*-Copyright: 2012-2016 Joey Hess <id@joeyh.name>+Copyright: 2012-2017 Joey Hess <id@joeyh.name> License: BSD-2-clause  Files: Utility/Gpg.hs Utility/DirWatcher*
CmdLine/Batch.hs view
@@ -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. --
CmdLine/GitAnnex.hs view
@@ -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
Command/AddUrl.hs view
@@ -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
Command/EnableTor.hs view
@@ -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
Command/FromKey.hs view
@@ -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
Command/ImportFeed.hs view
@@ -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 				)
Command/MetaData.hs view
@@ -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
Command/P2P.hs view
@@ -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
Command/ReKey.hs view
@@ -126,6 +126,6 @@ 			Database.Keys.removeAssociatedFile oldkey  				=<< inRepo (toTopFilePath file) 		)--	logStatus newkey InfoPresent+	whenM (inAnnex newkey) $+		logStatus newkey InfoPresent 	return True
Command/RegisterUrl.hs view
@@ -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
Command/TransferKeys.hs view
@@ -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
Command/Vicfg.hs view
@@ -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
− Command/XMPPGit.hs 
@@ -1,48 +0,0 @@-{- git-annex command- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Command.XMPPGit where--import Command-import Assistant.XMPP.Git--cmd :: Command-cmd = noCommit $ dontCheck repoExists $-	noRepo (parseparams startNoRepo) $ -		command "xmppgit" SectionPlumbing "git to XMPP relay"-			paramNothing (parseparams seek)-  where-	parseparams = withParams--seek :: CmdParams -> CommandSeek-seek = withWords start--start :: CmdParams -> CommandStart-start _ = do-	liftIO gitRemoteHelper-	liftIO xmppGitRelay-	stop--startNoRepo :: CmdParams -> IO ()-startNoRepo _ = xmppGitRelay--{- A basic implementation of the git-remote-helpers protocol. -}-gitRemoteHelper :: IO ()-gitRemoteHelper = do-	expect "capabilities"-	respond ["connect"]-	expect "connect git-receive-pack"-	respond []-  where-	expect s = do-		gitcmd <- getLine-		unless (gitcmd == s) $-			error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ gitcmd-	respond l = do-		mapM_ putStrLn l-		putStrLn ""-		hFlush stdout
Common.hs view
@@ -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
Config.hs view
@@ -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"
Database/Handle.hs view
@@ -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
Git/CatFile.hs view
@@ -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
Git/Command.hs view
@@ -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 ()
Git/Config.hs view
@@ -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)
Git/HashObject.hs view
@@ -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
Git/Queue.hs view
@@ -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
Git/Repair.hs view
@@ -614,4 +614,4 @@ safeReadFile :: FilePath -> IO String safeReadFile f = do 	allowRead f-	readFileStrictAnyEncoding f+	readFileStrict f
Git/UnionMerge.hs view
@@ -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.
Git/UpdateIndex.hs view
@@ -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"]
Logs/Transfer.hs view
@@ -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
Logs/Unused.hs view
@@ -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
Messages.hs view
@@ -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. -}
NEWS view
@@ -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 <id@joeyh.name>  Tue, 27 Dec 2016 16:37:46 -0400+ git-annex (4.20131002) unstable; urgency=low     The layout of gcrypt repositories has changed, and
P2P/Address.hs view
@@ -90,3 +90,6 @@  p2pAddressCredsFile :: FilePath p2pAddressCredsFile = "p2paddrs"++torAppName :: AppName+torAppName = "tor-annex"
P2P/Annex.hs view
@@ -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
P2P/IO.hs view
@@ -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.
Remote.hs view
@@ -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
Remote/BitTorrent.hs view
@@ -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
Remote/External.hs view
@@ -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
RemoteDaemon/Core.hs view
@@ -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
RemoteDaemon/Transport.hs view
@@ -26,5 +26,5 @@ 	, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport) 	] -remoteServers :: [TransportHandle -> IO ()]+remoteServers :: [Server] remoteServers = [RemoteDaemon.Transport.Tor.server]
RemoteDaemon/Transport/Tor.hs view
@@ -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
RemoteDaemon/Types.hs view
@@ -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
Test.hs view
@@ -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"
Utility/CoProcess.hs view
@@ -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 ()
Utility/ExternalSHA.hs view
@@ -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
Utility/FileSystemEncoding.hs view
@@ -1,6 +1,6 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>  -  - 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
Utility/Lsof.hs view
@@ -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)
+ Utility/MagicWormhole.hs view
@@ -0,0 +1,160 @@+{- Magic Wormhole integration+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - 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"
Utility/Misc.hs view
@@ -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.
Utility/Quvi.hs view
@@ -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
Utility/Shell.hs view
@@ -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
+ Utility/Su.hs view
@@ -0,0 +1,102 @@+{- su to root+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - 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
Utility/SystemDirectory.hs view
@@ -13,4 +13,4 @@ 	module System.Directory ) where -import System.Directory hiding (isSymbolicLink)+import System.Directory hiding (isSymbolicLink, getFileSize)
Utility/Tor.hs view
@@ -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"
Utility/Url.hs view
@@ -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
Utility/WebApp.hs view
@@ -84,7 +84,6 @@  -- disable buggy sloworis attack prevention code webAppSettings :: Settings- webAppSettings = setTimeout halfhour defaultSettings   where 	halfhour = 30 * 60
doc/git-annex-enable-tor.mdwn view
@@ -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
doc/git-annex-p2p.mdwn view
@@ -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
− doc/git-annex-xmppgit.mdwn 
@@ -1,23 +0,0 @@-# NAME--git-annex xmppgit - git to XMPP relay--# SYNOPSIS--git annex xmppgit--# DESCRIPTION--This command is used internally by the assistant to perform git pulls over XMPP.--# SEE ALSO--[[git-annex]](1)--[[git-annex-assistant]](1)--# AUTHOR--Joey Hess <id@joeyh.name>--Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex.mdwn view
@@ -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.<name>.annex-xmppaddress`--  Used to identify the XMPP address of a Jabber buddy.-  Normally this is set up by the git-annex assistant when pairing over XMPP.  * `remote.<name>.gcrypt`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20161210+Version: 6.20170101 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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
git-annex.hs view
@@ -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
stack.yaml view
@@ -13,7 +13,6 @@     webapp: true     magicmime: false     dbus: false-    xmpp: false     android: false     androidsplice: false packages:
templates/configurators/addrepository/connection.hamlet view
@@ -1,3 +1,3 @@-^{makeXMPPConnection}- ^{makeSshRepository}++^{makeWormholePairing}
templates/configurators/addrepository/misc.hamlet view
@@ -8,7 +8,7 @@   <a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> #   between computers.  -^{makeXMPPConnection}+^{makeWormholePairing}  <h3>   <a href="@{StartLocalPairR}">
+ templates/configurators/addrepository/wormholepairing.hamlet view
@@ -0,0 +1,13 @@+<h3>+  <a href="@{StartWormholePairSelfR}">+    <span .glyphicon .glyphicon-plus-sign>+    \ Share with your other devices+<p>+  Keep files in sync between your devices running git-annex.++<h3>+  <a href="@{StartWormholePairFriendR}">+    <span .glyphicon .glyphicon-plus-sign>+    \ Share with a friend+<p>+  Combine your repository with a friend's repository, and share your files.
− templates/configurators/addrepository/xmppconnection.hamlet 
@@ -1,13 +0,0 @@-<h3>-  <a href="@{StartXMPPPairSelfR}">-    <span .glyphicon .glyphicon-plus-sign>-    \ Share with your other devices-<p>-  Keep files in sync between your devices running git-annex.--<h3>-  <a href="@{StartXMPPPairFriendR}">-    <span .glyphicon .glyphicon-plus-sign>-    \ Share with a friend-<p>-  Combine your repository with a friend's repository, and share your files.
− templates/configurators/delete/xmpp.hamlet 
@@ -1,12 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Disconnecting from Jabber-    <p>-      This won't delete the repository or repositories at the other end-      of the Jabber connection, but it will disconnect from them, and stop-      using Jabber.-    <p>-    <a .btn .btn-primary href="@{DisconnectXMPPR}">-      <span .glyphicon .glyphicon-minus>-      \ Disconnect
templates/configurators/main.hamlet view
@@ -27,16 +27,3 @@           Unused files       <p>         Configure what to do with old and deleted files.-  <div .row>-    <div .col-sm-4>-      <h3>-        <a href="@{XMPPConfigR}">-          Jabber account-      $if xmppconfigured-        <p>-          Your jabber account is set up, and will be used to keep #-          in touch with remote devices, and with your friends.-      $else-        <p>-          Keep in touch with remote devices, and with your friends, #-          by configuring a jabber account.
+ templates/configurators/needmagicwormhole.hamlet view
@@ -0,0 +1,11 @@+<div .col-sm-9>+  <div .content-box>+    <h2>+      Need Magic Wormhole+    <p>+      You need to install #+      <a href="https://github.com/warner/magic-wormhole">+        Magic Wormhole+    <p>+      <a .btn .btn-primary .btn-lg href="">+        Retry
+ templates/configurators/needtor.hamlet view
@@ -0,0 +1,11 @@+<div .col-sm-9>+  <div .content-box>+    <h2>+      Need Tor+    <p>+      You need to install #+      <a href="https://torproject.org/">+        Tor+    <p>+      <a .btn .btn-primary .btn-lg href="">+        Retry
+ templates/configurators/pairing/wormhole/prompt.hamlet view
@@ -0,0 +1,59 @@+<div .col-sm-9>+  <div .content-box>+    <h2>+      $case pairingwith+        $of PairingWithSelf+          Pairing your devices+        $of PairingWithFriend+          Pairing with a friend+    <p>+      Pairing will connect two git-annex repositories using #+      <a href="https://torproject.org/">Tor</a>, #+      allowing files to be shared between them.+    <p>+      $case pairingwith+        $of PairingWithSelf+          This device's #+        $of PairingWithFriend+          Your repository's #+      pairing code is: <b><big>#{Wormhole.fromCode ourcode}</big></b>+    <p>+      $case pairingwith+        $of PairingWithSelf+          Enter that code into the device you want to pair with. #+        $of PairingWithFriend+          Tell that code to your friend. #+    <p>+      <form method="post" .form-horizontal enctype=#{enctype}>+        <fieldset>+          ^{form}+          ^{webAppFormAuthToken}+          <div .form-group>+            <div .col-sm-10 .col-sm-offset-2>+              <button .btn .btn-primary type=submit>+                Finish pairing+  <div .alert .alert-info>+    <h3 .alert-heading>+      ^{htmlIcon InfoIcon} Keep pairing codes safe+    $case pairingwith+      $of PairingWithSelf+        <p>+          Pairing codes can only be used a single time, but if someone #+          saw the pairing codes before you use them, they could #+          pair with your devices. So be careful with the pairing codes!+      $of PairingWithFriend+        <p>+          Pairing codes can only be used a single time, but if someone #+          overhears you exchanging them with your friend, they could #+          pair with your repositories. #+        <p>+          Here are some suggestions for how to exchange the pairing #+          code with your friend, with the safest ways first:+          <ul>+            <li>+              In person.+            <li>+              In an encrypted message #+              (gpg signed email, Off The Record (OTR) conversation, etc).+            <li>+              By a voice phone call.
+ templates/configurators/pairing/wormhole/start.hamlet view
@@ -0,0 +1,35 @@+<div .col-sm-9>+  <div .content-box>+    <h2>+      $case pairingwith+        $of PairingWithSelf+          Preparing for pairing your devices+        $of PairingWithFriend+          Preparing for sharing with a friend+    <p>+      This will connect two git-annex repositories using #+      <a href="https://torproject.org/">Tor</a>, #+      allowing files to be shared between them.+    <p>+      First, a Tor hidden service needs to be set up on this computer.+    <p>+      <a .btn .btn-primary onclick="$('#setupmodal').modal('show');" href="@{PrepareWormholePairR pairingwith}">+        <span .glyphicon .glyphicon-resize-small>+        \ Let's get started #+<div .modal .fade #setupmodal>+  <div .modal-dialog>+    <div .modal-content>+      <div .modal-header>+        <h3>+          Enabling Tor hidden service ...+      <div .modal-body>+        $case describePasswordPrompt' sucommand+          $of Nothing+            #+          $of (Just promptdesc)+            <p>+              #{promptdesc} in order to enable the Tor hidden service.+        <p>+          This could take several minutes to finish. If it #+          is taking too long, check that you are connected to the #+          network, and that Tor is working.
− templates/configurators/pairing/xmpp/end.hamlet 
@@ -1,33 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    $if inprogress-      <h2>-        Pair request sent ...-      <p>-        $maybe name <- friend-          A pair request has been sent to #{name}. Now it's up to them #-          to accept it and finish pairing.-        $nothing-          A pair request has been sent to all other devices that #-          have been configured to use your jabber account. #-          It will be answered automatically by any devices that see it.-    $else-      Pair request accepted.-    <h2>-      Configure a shared cloud repository-    $maybe name <- friend-      <p>-        &#9730; To share files with #{name}, you'll need a repository in #-        the cloud, that you both can access.-    $nothing-      <p>-        &#9730; To share files with your other devices, when they're not #-        nearby, you'll need a repository in the cloud.-      <p>-        Make sure that your other devices are configured to access a #-        cloud repository, and that the same repository is enabled here #-        too.-    ^{cloudRepoList}-    <h2>-      Add a cloud repository-    ^{makeCloudRepositories}
− templates/configurators/pairing/xmpp/friend/confirm.hamlet 
@@ -1,12 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Pair request received from #{name}-    <p>-      Pairing with #{name} will combine your two git annex #-      repositories into one, allowing you to share files.-    <p>-      <a .btn .btn-primary .btn-lg href="@{FinishXMPPPairFriendR pairkey}">-        Accept pair request-      <a .btn .btn-default .btn-lg href="@{DashboardR}">-        No thanks
− templates/configurators/pairing/xmpp/friend/prompt.hamlet 
@@ -1,13 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Share with a friend-    <p>-      You can combine your repository with a friend's repository #-      to share your files. Your repositories will automatically be kept in #-      sync. Only do this if you want your friend to see all the files #-      in this repository!-    <p>-      Here are the friends currently available via your Jabber account.-      <p>-        ^{buddyListDisplay}
− templates/configurators/pairing/xmpp/self/prompt.hamlet 
@@ -1,21 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Sharing with your other devices-    <p>-      If you have multiple devices, all running git-annex, and using #-      your Jabber account #{account}, you can configure them to share #-      your files between themselves.-    <p>-      For example, you can have a computer at home, one at work, and a #-      laptop, and their repositories will automatically be kept in sync.-    <p>-      Make sure your other devices are online and configured to use #-      your Jabber account before continuing. Note that <b>all</b> #-      repositories configured to use the same Jabber account will be #-      combined together when you do this.-    <p>-      <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">-        Start sharing with my other devices #-      <a .btn .btn-default .btn-lg href="@{DashboardR}">-        Cancel
− templates/configurators/pairing/xmpp/self/retry.hamlet 
@@ -1,12 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Unable to get in touch with any other devices.-    <p>-      Make sure your other devices are online and configured to use #-      your Jabber account before continuing.-    <p>-      <a .btn .btn-primary .btn-lg href="@{RunningXMPPPairSelfR}">-        Start sharing with my other devices #-      <a .btn .btn-default .btn-lg href="@{DashboardR}">-        Cancel
− templates/configurators/xmpp.hamlet 
@@ -1,43 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Configuring jabber account-    <p>-      A jabber account is used to communicate between #-      devices that are not in direct contact. #-      It can also be used to pair up with a friend's repository, if desired.-    <p>-      It's fine to reuse an existing jabber account; git-annex won't #-      post any messages to it.-    <p>-      $maybe msg <- problem-        <span .glyphicon .glyphicon-warning-sign>-        \ Unable to connect to the Jabber server. #-        Maybe you entered the wrong password? (Error message: #{msg})-      $nothing-        <span .glyphicon .glyphicon-user>-        \ If you have a Gmail account, you can use #-        Google Talk. Just enter your full Gmail address #-        <small>(<tt>you@gmail.com</tt>)</small> #-        and password below.-    <p>-      <form method="post" .form-horizontal enctype=#{enctype}>-        <fieldset>-          ^{form}-          ^{webAppFormAuthToken}-          <div .form-group>-            <div .col-sm-10 .col-sm-offset-2>-              <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">-                Use this account-              \ -              <a .btn .btn-default href="@{DisconnectXMPPR}">-                Stop using this account-<div .modal .fade #workingmodal>-  <div .modal-dialog>-    <div .modal-content>-      <div .modal-header>-        <h3>-          Testing account ...-      <div .modal-body>-        <p>-          Testing jabber account. This could take a minute.
− templates/configurators/xmpp/buddylist.hamlet 
@@ -1,40 +0,0 @@-<div ##{ident}>-  <table .table>-    <tbody>-    $if null buddies-      <tr>-        <td>-          $if isNothing myjid-            Not connected to the jabber server. Check your network connection ...-          $else-            Searching...-    $else-      $forall (name, away, canpair, paired, buddyid) <- buddies-        <tr>-          <td>-            $if isself buddyid-              <span .glyphicon .glyphicon-star> #-              <span :away:.text-muted>-                your other devices-            $else-              <span .glyphicon .glyphicon-user> #-              <span :away:.text-muted>-                  #{name}-          <td>-            $if away-              <span .text-muted>-                away-            $else-              $if paired-                <span .label .label-success>-                  paired-              $else-                $if canpair-                  $if isself buddyid-                    <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairSelfR}">-                      Start pairing-                  $else-                    <a .btn .btn-primary .btn-sm href="@{RunningXMPPPairFriendR buddyid}">-                      Start pairing-                $else-                  not using git-annex
− templates/configurators/xmpp/disabled.hamlet 
@@ -1,6 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Jabber not supported-    <p>-      This build of git-annex does not support Jabber. Sorry!
− templates/configurators/xmpp/needcloudrepo.hamlet 
@@ -1,18 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      &#9730; Configure a shared cloud repository-    $maybe name <- buddyname-      <p>-        You and #{name} have combined your repositores. But you can't open #-        each other's files yet. To start sharing files with #{name}, #-        you need a repository in the cloud, that you both can access.-    $nothing-      <p>-        You've combined the repositories on two or more of your devices. #-        But files are not flowing yet. To start sharing files #-        between your devices, you should set up a repository in the cloud.-    ^{cloudRepoList}-    <h2>-      Add a cloud repository-    ^{makeCloudRepositories}
templates/documentation/about.hamlet view
@@ -9,7 +9,7 @@       For full details, see #       <a href="http://git-annex.branchable.com/">the git-annex website</a>.     <hr>-      git-annex is © 2010-2014 Joey Hess. It is free software, licensed #+      git-annex is © 2010-2017 Joey Hess. It is free software, licensed #       under the terms of the GNU General Public License, version 3 or above. #       This webapp is licensed under the terms of the GNU Affero General #       Public License, version 3 or above. #