git-annex 6.20161118 → 6.20161210

raw patch · 75 files changed

+2669/−288 lines, 75 filesdep +freedep +socksdep +stm-chansdep ~http-conduitsetup-changed

Dependencies added: free, socks, stm-chans

Dependency ranges changed: http-conduit

Files

Annex/ChangedRefs.hs +108/−0
Annex/Notification.hs +5/−1
Annex/SpecialRemote.hs +1/−2
Annex/Transfer.hs +5/−0
Assistant/Fsck.hs +1/−1
Assistant/Gpg.hs +1/−1
Assistant/Repair.hs +1/−1
Assistant/Restart.hs +1/−1
Assistant/Threads/RemoteControl.hs +1/−1
Assistant/Threads/WebApp.hs +2/−1
Assistant/Upgrade.hs +1/−1
Assistant/WebApp.hs +1/−1
Assistant/WebApp/Notifications.hs +1/−1
Assistant/WebApp/Types.hs +1/−0
Build/EvilSplicer.hs +14/−2
Build/Mans.hs +5/−2
CHANGELOG +31/−0
CmdLine/GitAnnex.hs +6/−2
CmdLine/GitRemoteTorAnnex.hs +66/−0
Command/Add.hs +3/−7
Command/AddUrl.hs +11/−6
Command/EnableRemote.hs +3/−4
Command/EnableTor.hs +35/−0
Command/FromKey.hs +8/−6
Command/LockContent.hs +2/−1
Command/Map.hs +17/−7
Command/NotifyChanges.hs +14/−54
Command/P2P.hs +100/−0
Command/ReKey.hs +31/−7
Command/Reinject.hs +1/−2
Command/RemoteDaemon.hs +19/−12
Command/RmUrl.hs +26/−6
Command/Schedule.hs +1/−1
Command/TransferInfo.hs +2/−1
Creds.hs +2/−1
P2P/Address.hs +92/−0
P2P/Annex.hs +154/−0
P2P/Auth.hs +66/−0
P2P/IO.hs +304/−0
P2P/Protocol.hs +484/−0
Remote/External/Types.hs +0/−8
Remote/Git.hs +11/−6
Remote/List.hs +3/−1
Remote/P2P.hs +196/−0
Remote/S3.hs +9/−2
Remote/WebDAV.hs +17/−0
RemoteDaemon/Common.hs +23/−1
RemoteDaemon/Core.hs +29/−7
RemoteDaemon/Transport.hs +6/−0
RemoteDaemon/Transport/Ssh.hs +9/−27
RemoteDaemon/Transport/Ssh/Types.hs +2/−2
RemoteDaemon/Transport/Tor.hs +173/−0
RemoteDaemon/Types.hs +2/−12
Setup.hs +5/−3
Types/Creds.hs +1/−1
Types/Key.hs +5/−0
Types/UUID.hs +6/−0
Utility/AuthToken.hs +99/−0
Utility/Metered.hs +29/−14
Utility/SimpleProtocol.hs +39/−1
Utility/Tor.hs +144/−0
Utility/Url.hs +8/−0
Utility/WebApp.hs +2/−23
doc/git-annex-add.mdwn +3/−3
doc/git-annex-enable-tor.mdwn +32/−0
doc/git-annex-fromkey.mdwn +5/−3
doc/git-annex-map.mdwn +3/−3
doc/git-annex-p2p.mdwn +45/−0
doc/git-annex-rekey.mdwn +5/−1
doc/git-annex-remotedaemon.mdwn +34/−10
doc/git-annex-rmurl.mdwn +9/−1
doc/git-annex.mdwn +18/−6
doc/git-remote-tor-annex.mdwn +36/−0
git-annex.cabal +25/−7
git-annex.hs +9/−13

+ Annex/ChangedRefs.hs view

@@ -0,0 +1,108 @@+{- Waiting for changed git refs+ -+ - Copyright 2014-216 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.ChangedRefs+	( ChangedRefs(..)+	, ChangedRefsHandle+	, waitChangedRefs+	, drainChangedRefs+	, stopWatchingChangedRefs+	, watchChangedRefs+	) where++import Annex.Common+import Utility.DirWatcher+import Utility.DirWatcher.Types+import qualified Git+import Git.Sha+import qualified Utility.SimpleProtocol as Proto++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMChan++newtype ChangedRefs = ChangedRefs [Git.Ref]+	deriving (Show)++instance Proto.Serializable ChangedRefs where+	serialize (ChangedRefs l) = unwords $ map Git.fromRef l+	deserialize = Just . ChangedRefs . map Git.Ref . words++data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)++-- | Wait for one or more git refs to change.+--+-- When possible, coalesce ref writes that occur closely together+-- in time. Delay up to 0.05 seconds to get more ref writes.+waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs+waitChangedRefs (ChangedRefsHandle _ chan) = do+	v <- atomically $ readTBMChan chan+	case v of+		Nothing -> return $ ChangedRefs []+		Just r -> do+			threadDelay 50000+			rs <- atomically $ loop []+			return $ ChangedRefs (r:rs)+  where+	loop rs = do+		v <- tryReadTBMChan chan+		case v of+			Just (Just r) -> loop (r:rs)+			_ -> return rs++-- | Remove any changes that might be buffered in the channel,+-- without waiting for any new changes.+drainChangedRefs :: ChangedRefsHandle -> IO ()+drainChangedRefs (ChangedRefsHandle _ chan) = atomically go+  where+	go = do+		v <- tryReadTBMChan chan+		case v of+			Just (Just _) -> go+			_ -> return ()++stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()+stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do+	stopWatchDir wh+	atomically $ closeTBMChan chan+	drainChangedRefs h++watchChangedRefs :: Annex (Maybe ChangedRefsHandle)+watchChangedRefs = do+	-- This channel is used to accumulate notifications,+	-- because the DirWatcher might have multiple threads that find+	-- changes at the same time. It is bounded to allow a watcher+	-- to be started once and reused, without too many changes being+	-- buffered in memory.+	chan <- liftIO $ newTBMChanIO 100+	+	g <- gitRepo+	let refdir = Git.localGitDir g </> "refs"+	liftIO $ createDirectoryIfMissing True refdir++	let notifyhook = Just $ notifyHook chan+	let hooks = mkWatchHooks+		{ addHook = notifyhook+		, modifyHook = notifyhook+		}++	if canWatch+		then do+			h <- liftIO $ watchDir refdir (const False) True hooks id+			return $ Just $ ChangedRefsHandle h chan+		else return Nothing++notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()+notifyHook chan reffile _+	| ".lock" `isSuffixOf` reffile = noop+	| otherwise = void $ do+		sha <- catchDefaultIO Nothing $+			extractSha <$> readFile reffile+		-- When the channel is full, there is probably no reader+		-- running, or ref changes have been occuring very fast,+		-- so it's ok to not write the change to it.+		maybe noop (void . atomically . tryWriteTBMChan chan) sha

Annex/Notification.hs view

@@ -7,7 +7,7 @@  {-# LANGUAGE CPP #-} -module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where+module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where  import Annex.Common import Types.Transfer@@ -20,6 +20,10 @@  -- Witness that notification has happened. data NotifyWitness = NotifyWitness++-- Only use when no notification should be done.+noNotification :: NotifyWitness+noNotification = NotifyWitness  {- Wrap around an action that performs a transfer, which may run multiple  - attempts. Displays notification when supported and when the user asked

Annex/SpecialRemote.hs view

@@ -13,11 +13,10 @@ import Logs.Remote import Logs.Trust import qualified Git.Config+import Git.Types (RemoteName)  import qualified Data.Map as M import Data.Ord--type RemoteName = String  {- See if there's an existing special remote with this name.  -

Annex/Transfer.hs view

@@ -45,6 +45,11 @@ 	observeBool = fst 	observeFailure = (False, UnVerified) +instance Observable (Either e Bool) where+	observeBool (Left _) = False+	observeBool (Right b) = b+	observeFailure = Right False+ upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v upload u key f d a _witness = guardHaveUUID u $  	runTransfer (Transfer Upload u key) f d a

Assistant/Fsck.hs view

@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU AGPL version 3 or higher.+ - Licensed under the GNU GPL version 3 or higher.  -}  module Assistant.Fsck where

Assistant/Gpg.hs view

@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU AGPL version 3 or higher.+ - Licensed under the GNU GPL version 3 or higher.  -}  module Assistant.Gpg where

Assistant/Repair.hs view

@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU AGPL version 3 or higher.+ - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}

Assistant/Restart.hs view

@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU AGPL version 3 or higher.+ - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}

Assistant/Threads/RemoteControl.hs view

@@ -30,7 +30,7 @@ remoteControlThread = namedThread "RemoteControl" $ do 	program <- liftIO programPath 	(cmd, params) <- liftIO $ toBatchCommand-		(program, [Param "remotedaemon"])+		(program, [Param "remotedaemon", Param "--foreground"]) 	let p = proc cmd (toCommand params) 	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p 		{ std_in = CreatePipe

Assistant/Threads/WebApp.hs view

@@ -39,6 +39,7 @@ import Assistant.WebApp.Repair import Assistant.Types.ThreadedMonad import Utility.WebApp+import Utility.AuthToken import Utility.Tmp import Utility.FileMode import Git@@ -75,7 +76,7 @@ #endif 	webapp <- WebApp 		<$> pure assistantdata-		<*> genAuthToken+		<*> genAuthToken 128 		<*> getreldir 		<*> pure staticRoutes 		<*> pure postfirstrun

Assistant/Upgrade.hs view

@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU AGPL version 3 or higher.+ - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}

Assistant/WebApp.hs view

@@ -14,7 +14,7 @@ import Assistant.Common import Utility.NotificationBroadcaster import Utility.Yesod-import Utility.WebApp+import Utility.AuthToken  import Data.Text (Text) import Control.Concurrent

Assistant/WebApp/Notifications.hs view

@@ -16,7 +16,7 @@ import Assistant.Types.Buddies import Utility.NotificationBroadcaster import Utility.Yesod-import Utility.WebApp+import Utility.AuthToken  import Data.Text (Text) import qualified Data.Text as T

Assistant/WebApp/Types.hs view

@@ -20,6 +20,7 @@ import Assistant.Pairing import Assistant.Types.Buddies import Utility.NotificationBroadcaster+import Utility.AuthToken import Utility.WebApp import Utility.Yesod import Types.Transfer

Build/EvilSplicer.hs view

@@ -474,7 +474,7 @@ 	 - 	 - To fix, we could just put a semicolon at the start of every line 	 - containing " -> " ... Except that lambdas also contain that.-	 - But we can get around that: GHC outputs lambas like this:+	 - But we can get around that: GHC outputs lambdas like this: 	 - 	 - \ foo 	 -   -> bar@@ -486,9 +486,19 @@ 	 - 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+		void newline 		indent1 <- many1 $ char ' ' 		prefix <- manyTill (noneOf "\n") (try (string "-> ")) 		if length prefix > 20@@ -497,7 +507,9 @@ 				then unexpected "lambda expression" 				else if null prefix 					then unexpected "second line of lambda"-					else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> "+					else if "=>" `isSuffixOf` lastline+						then unexpected "probably type signature"+						else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> " 	{- Sometimes cases themselves span multiple lines: 	 - 	 - Nothing

Build/Mans.hs view

@@ -50,8 +50,11 @@ 			else return (Just dest)  isManSrc :: FilePath -> Bool-isManSrc s = "git-annex" `isPrefixOf` (takeFileName s)-	&& takeExtension s == ".mdwn"+isManSrc s+	| not (takeExtension s == ".mdwn") = False+	| otherwise = "git-annex" `isPrefixOf` f || "git-remote-" `isPrefixOf` f+  where+	f = takeFileName s  srcToDest :: FilePath -> FilePath srcToDest s = "man" </> progName s ++ ".1"

CHANGELOG view

@@ -1,3 +1,34 @@+git-annex (6.20161210) unstable; urgency=medium++  * 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.+  * Added git-remote-tor-annex, which allows git pull and push to the tor+    hidden service.+  * remotedaemon: Fork to background by default. Added --foreground switch+    to enable old behavior.+  * addurl: Fix bug in checking annex.largefiles expressions using+    largerthan, mimetype, and smallerthan; the first two always failed+    to match, and the latter always matched.+  * Relicense 5 source files that are not part of the webapp from AGPL to GPL.+  * map: Run xdot if it's available in PATH. On OSX, the dot command+    does not support graphical display, while xdot does.+  * Debian: xdot is a better interactive viewer than dot, so Suggest+    xdot, rather than graphviz.+  * rmurl: Multiple pairs of files and urls can be provided on the+    command line.+  * rmurl: Added --batch mode.+  * fromkey: Accept multiple pairs of files and keys.+    Thanks, Daniel Brooks.+  * rekey: Added --batch mode.+  * add: Stage modified non-large files when running in indirect mode. +    (This was already done in v6 mode and direct mode.)+  * git-annex-shell, remotedaemon, git remote: Fix some memory DOS attacks.+  * Fix build with http-client 0.5.+    Thanks, Alper Nebi Yasak.++ -- Joey Hess <id@joeyh.name>  Sat, 10 Dec 2016 11:56:25 -0400+ git-annex (6.20161118) unstable; urgency=medium    * git-annex.cabal: Loosen bounds on persistent to allow 2.5, which

CmdLine/GitAnnex.hs view

@@ -52,6 +52,7 @@ import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote+import qualified Command.EnableTor import qualified Command.Expire import qualified Command.Repair import qualified Command.Unused@@ -95,11 +96,13 @@ import qualified Command.Indirect import qualified Command.Upgrade import qualified Command.Forget+import qualified Command.P2P import qualified Command.Proxy import qualified Command.DiffDriver import qualified Command.Smudge import qualified Command.Undo import qualified Command.Version+import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT import qualified Command.Watch import qualified Command.Assistant@@ -109,7 +112,6 @@ #ifdef WITH_XMPP import qualified Command.XMPPGit #endif-import qualified Command.RemoteDaemon #endif import qualified Command.Test #ifdef WITH_TESTSUITE@@ -142,6 +144,7 @@ 	, Command.Describe.cmd 	, Command.InitRemote.cmd 	, Command.EnableRemote.cmd+	, Command.EnableTor.cmd 	, Command.Reinject.cmd 	, Command.Unannex.cmd 	, Command.Uninit.cmd@@ -202,11 +205,13 @@ 	, Command.Indirect.cmd 	, Command.Upgrade.cmd 	, Command.Forget.cmd+	, Command.P2P.cmd 	, Command.Proxy.cmd 	, Command.DiffDriver.cmd 	, Command.Smudge.cmd 	, Command.Undo.cmd 	, Command.Version.cmd+	, Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT 	, Command.Watch.cmd 	, Command.Assistant.cmd@@ -216,7 +221,6 @@ #ifdef WITH_XMPP 	, Command.XMPPGit.cmd #endif-	, Command.RemoteDaemon.cmd #endif 	, Command.Test.cmd testoptparser testrunner #ifdef WITH_TESTSUITE

+ CmdLine/GitRemoteTorAnnex.hs view

@@ -0,0 +1,66 @@+{- git-remote-tor-annex program+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module CmdLine.GitRemoteTorAnnex where++import Common+import qualified Annex+import qualified Git.CurrentRepo+import P2P.Protocol+import P2P.IO+import Utility.Tor+import Utility.AuthToken+import Annex.UUID+import P2P.Address+import P2P.Auth++run :: [String] -> IO ()+run (_remotename:address:[]) = forever $ do+	-- gitremote-helpers protocol+	l <- getLine+	case l of+		"capabilities" -> putStrLn "connect" >> ready+		"connect git-upload-pack" -> go UploadPack+		"connect git-receive-pack" -> go ReceivePack+		_ -> error $ "git-remote-helpers protocol error at " ++ show l+  where+	(onionaddress, onionport)+		| '/' `elem` address = parseAddressPort $+			reverse $ takeWhile (/= '/') $ reverse address+		| otherwise = parseAddressPort address+	go service = do+		ready+		either giveup exitWith+			=<< connectService onionaddress onionport service+	ready = do+		putStrLn ""+		hFlush stdout+		+run (_remotename:[]) = giveup "remote address not configured"+run _ = giveup "expected remote name and address parameters"++parseAddressPort :: String -> (OnionAddress, OnionPort)+parseAddressPort s = +	let (a, sp) = separate (== ':') s+	in case readish sp of+		Nothing -> giveup "onion address must include port number"+		Just p -> (OnionAddress a, p)++connectService :: OnionAddress -> OnionPort -> Service -> IO (Either String ExitCode)+connectService address port service = do+	state <- Annex.new =<< Git.CurrentRepo.get+	Annex.eval state $ do+		authtoken <- fromMaybe nullAuthToken+			<$> loadP2PRemoteAuthToken (TorAnnex address port)+		myuuid <- getUUID+		g <- Annex.gitRepo+		conn <- liftIO $ connectPeer g (TorAnnex address port)+		liftIO $ runNetProto conn $ do+			v <- auth myuuid authtoken+			case v of+				Just _theiruuid -> connect service stdin stdout+				Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv

Command/Add.hs view

@@ -41,9 +41,6 @@ 		) 	<*> parseBatchOption -{- Add acts on both files not checked into git yet, and unlocked files.- -- - In direct mode, it acts on any files that have changed. -} seek :: AddOptions -> CommandSeek seek o = allowConcurrentOutput $ do 	matcher <- largeFilesMatcher@@ -59,10 +56,9 @@ 		NoBatch -> do 			let go a = a gofile (addThese o) 			go (withFilesNotInGit (not $ includeDotFiles o))-			ifM (versionSupportsUnlockedPointers <||> isDirect)-				( go withFilesMaybeModified-				, go withFilesOldUnlocked-				)+			go withFilesMaybeModified+			unlessM (versionSupportsUnlockedPointers <||> isDirect) $+				go withFilesOldUnlocked  {- Pass file off to git-add. -} startSmall :: FilePath -> CommandStart

Command/AddUrl.hs view

@@ -340,13 +340,18 @@ cleanup u url file key mtmp = case mtmp of 	Nothing -> go 	Just tmp -> do+		-- Move to final location for large file check.+		liftIO $ renameFile tmp file 		largematcher <- largeFilesMatcher-		ifM (checkFileMatcher largematcher file)-			( go-			, do-				liftIO $ renameFile tmp file-				void $ Command.Add.addSmall file-			)+		large <- checkFileMatcher largematcher file+		if large+			then do+				-- Move back to tmp because addAnnexedFile+				-- needs the file in a different location+				-- than the work tree file.+				liftIO $ renameFile file tmp+				go+			else void $ Command.Add.addSmall file   where 	go = do 		maybeShowJSON $ JSONChunk [("key", key2file key)]

Command/EnableRemote.hs view

@@ -12,6 +12,7 @@ import qualified Logs.Remote import qualified Types.Remote as R import qualified Git+import qualified Git.Types as Git import qualified Annex.SpecialRemote import qualified Remote import qualified Types.Remote as Remote@@ -40,9 +41,7 @@ 		=<< Annex.SpecialRemote.findExisting name 	go (r:_) = startNormalRemote name r -type RemoteName = String--startNormalRemote :: RemoteName -> Git.Repo -> CommandStart+startNormalRemote :: Git.RemoteName -> Git.Repo -> CommandStart startNormalRemote name r = do 	showStart "enableremote" name 	next $ next $ do@@ -51,7 +50,7 @@ 		u <- getRepoUUID r' 		return $ u /= NoUUID -startSpecialRemote :: RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart+startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart startSpecialRemote name config Nothing = do 	m <- Annex.SpecialRemote.specialRemoteMap 	confm <- Logs.Remote.readRemoteLog

+ Command/EnableTor.hs view

@@ -0,0 +1,35 @@+{- git-annex command+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.EnableTor where++import Command+import P2P.Address+import Utility.Tor+import Annex.UUID++-- This runs as root, so avoid making any commits or initializing+-- git-annex, or doing other things that create root-owned files.+cmd :: Command+cmd = noCommit $ dontCheck repoExists $+	command "enable-tor" SectionSetup "enable tor hidden service"+		"uid" (withParams seek)++seek :: CmdParams -> CommandSeek+seek = withWords start++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."+		(onionaddr, onionport) <- liftIO $+			addHiddenService userid (fromUUID uuid)+		storeP2PAddress $ TorAnnex onionaddr onionport+		stop

Command/FromKey.hs view

@@ -20,16 +20,17 @@ cmd :: Command cmd = notDirect $ notBareRepo $ 	command "fromkey" SectionPlumbing "adds a file using a specific key"-		(paramPair paramKey paramPath)+		(paramRepeating (paramPair paramKey paramPath)) 		(withParams seek)  seek :: CmdParams -> CommandSeek+seek [] = withNothing startMass [] seek ps = do 	force <- Annex.getState Annex.force-	withWords (start force) ps+	withPairs (start force) ps -start :: Bool -> [String] -> CommandStart-start force (keyname:file:[]) = do+start :: Bool -> (String, FilePath) -> CommandStart+start force (keyname, file) = do 	let key = mkKey keyname 	unless force $ do 		inbackend <- inAnnex key@@ -37,10 +38,11 @@ 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" 	showStart "fromkey" file 	next $ perform key file-start _ [] = do++startMass :: CommandStart+startMass = do 	showStart "fromkey" "stdin" 	next massAdd-start _ _ = giveup "specify a key and a dest file"  massAdd :: CommandPerform massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents

Command/LockContent.hs view

@@ -10,6 +10,7 @@ import Command import Annex.Content import Remote.Helper.Ssh (contentLockedMarker)+import Utility.SimpleProtocol  cmd :: Command cmd = noCommit $ @@ -37,7 +38,7 @@ 		( liftIO $ do 			putStrLn contentLockedMarker 			hFlush stdout-			_ <- getLine+			_ <- getProtocolLine stdin 			return True 		, return False 		)

Command/Map.hs view

@@ -47,14 +47,24 @@ 	liftIO $ writeFile file (drawMap rs trustmap umap) 	next $ next $ 		ifM (Annex.getState Annex.fast)-			( do-				showLongNote $ "left map in " ++ file-				return True-			, do-				showLongNote $ "running: dot -Tx11 " ++ file-				showOutput-				liftIO $ boolSystem "dot" [Param "-Tx11", File file]+			( runViewer file []+			, runViewer file+	 			[ ("xdot", [File file])+				, ("dot", [Param "-Tx11", File file])+				]	 			)++runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool+runViewer file [] = do+	showLongNote $ "left map in " ++ file+	return True+runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)+	( do+		showLongNote $ "running: " ++ c ++ unwords (toCommand ps)+		showOutput+		liftIO $ boolSystem c ps+	, runViewer file rest+	)  {- Generates a graph for dot(1). Each repository, and any other uuids  - (except for dead ones), are displayed as a node, and each of its

Command/NotifyChanges.hs view

@@ -8,15 +8,11 @@ module Command.NotifyChanges where  import Command-import Utility.DirWatcher-import Utility.DirWatcher.Types-import qualified Git-import Git.Sha+import Annex.ChangedRefs import RemoteDaemon.Transport.Ssh.Types+import Utility.SimpleProtocol -import Control.Concurrent import Control.Concurrent.Async-import Control.Concurrent.STM  cmd :: Command cmd = noCommit $ @@ -28,55 +24,19 @@ seek = withNothing start  start :: CommandStart-start = do-	-- This channel is used to accumulate notifcations,-	-- because the DirWatcher might have multiple threads that find-	-- changes at the same time.-	chan <- liftIO newTChanIO-	-	g <- gitRepo-	let refdir = Git.localGitDir g </> "refs"-	liftIO $ createDirectoryIfMissing True refdir--	let notifyhook = Just $ notifyHook chan-	let hooks = mkWatchHooks-		{ addHook = notifyhook-		, modifyHook = notifyhook-		}--	void $ liftIO $ watchDir refdir (const False) True hooks id--	let sender = do-		send READY-		forever $ send . CHANGED =<< drain chan-	-	-- No messages need to be received from the caller,-	-- but when it closes the connection, notice and terminate.-	let receiver = forever $ void getLine-	void $ liftIO $ concurrently sender receiver-	stop--notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()-notifyHook chan reffile _-	| ".lock" `isSuffixOf` reffile = noop-	| otherwise = void $ do-		sha <- catchDefaultIO Nothing $-			extractSha <$> readFile reffile-		maybe noop (atomically . writeTChan chan) sha---- When possible, coalesce ref writes that occur closely together--- in time. Delay up to 0.05 seconds to get more ref writes.-drain :: TChan Git.Sha -> IO [Git.Sha]-drain chan = do-	r <- atomically $ readTChan chan-	threadDelay 50000-	rs <- atomically $ drain' chan-	return (r:rs)--drain' :: TChan Git.Sha -> STM [Git.Sha]-drain' chan = loop []+start = go =<< watchChangedRefs   where-	loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan+	go (Just h) = do+		-- No messages need to be received from the caller,+		-- but when it closes the connection, notice and terminate.+		let receiver = forever $ void $ getProtocolLine stdin+		let sender = forever $ send . CHANGED =<< waitChangedRefs h++		liftIO $ send READY+		void $ liftIO $ concurrently sender receiver+		liftIO $ stopWatchingChangedRefs h+		stop+	go Nothing = stop  send :: Notification -> IO () send n = do

+ Command/P2P.hs view

@@ -0,0 +1,100 @@+{- git-annex command+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.P2P where++import Command+import P2P.Address+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++cmd :: Command+cmd = command "p2p" SectionSetup+	"configure peer-2-peer links between repositories"+	paramNothing (seek <$$> optParser)++data P2POpts+	= GenAddresses+	| LinkRemote RemoteName++optParser :: CmdParamsDesc -> Parser P2POpts +optParser _ = genaddresses <|> linkremote+  where+	genaddresses = flag' GenAddresses+		( long "gen-addresses"+		<> help "generate addresses that allow accessing this repository over P2P networks"+		)+	linkremote = LinkRemote <$> strOption+		( long "link"+		<> metavar paramRemote+		<> help "specify name to use for git remote"+		)++seek :: P2POpts -> CommandSeek+seek GenAddresses = genAddresses =<< loadP2PAddresses+seek (LinkRemote name) = commandAction $+	linkRemote (Git.Remote.makeLegalName name)++-- Only addresses are output to stdout, to allow scripting.+genAddresses :: [P2PAddress] -> Annex ()+genAddresses [] = giveup "No P2P networks are currrently available."+genAddresses addrs = do+	authtoken <- liftIO $ genAuthToken 128+	storeP2PAuthToken authtoken+	earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!"+	liftIO $ putStr $ unlines $+		map formatP2PAddress $+			map (`P2PAddressAuth` authtoken) addrs++-- Address is read from stdin, to avoid leaking it in shell history.+linkRemote :: RemoteName -> CommandStart+linkRemote remotename = do+	showStart "p2p link" remotename+	next $ next prompt+  where+	prompt = do+		liftIO $ putStrLn ""+		liftIO $ putStr "Enter peer address: "+		liftIO $ hFlush stdout+		s <- liftIO getLine+		if null s+			then do+				liftIO $ hPutStrLn stderr "Nothing entered, giving up."+				return False+			else case unformatP2PAddress s of+				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 ++ ")"

Command/ReKey.hs view

@@ -25,15 +25,39 @@ 	command "rekey" SectionPlumbing 		"change keys used for files" 		(paramRepeating $ paramPair paramPath paramKey)-		(withParams seek)+		(seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withPairs start+data ReKeyOptions = ReKeyOptions+	{ reKeyThese :: CmdParams+	, batchOption :: BatchMode+	} -start :: (FilePath, String) -> CommandStart-start (file, keyname) = ifAnnexed file go stop+optParser :: CmdParamsDesc -> Parser ReKeyOptions+optParser desc = ReKeyOptions+	<$> cmdParams desc+	<*> parseBatchOption++-- Split on the last space, since a FilePath can contain whitespace,+-- but a Key very rarely does.+batchParser :: String -> Either String (FilePath, Key)+batchParser s = case separate (== ' ') (reverse s) of+	(rk, rf)+		| null rk || null rf -> Left "Expected: \"file key\""+		| otherwise -> case file2key (reverse rk) of+			Nothing -> Left "bad key"+			Just k -> Right (reverse rf, k)++seek :: ReKeyOptions -> CommandSeek+seek o = case batchOption o of+	Batch -> batchInput batchParser (batchCommandAction . start)+	NoBatch -> withPairs (start . parsekey) (reKeyThese o)   where-	newkey = fromMaybe (giveup "bad key") $ file2key keyname+	parsekey (file, skey) =+		(file, fromMaybe (giveup "bad key") (file2key skey))++start :: (FilePath, Key) -> CommandStart+start (file, newkey) = ifAnnexed file go stop+  where 	go oldkey 		| oldkey == newkey = stop 		| otherwise = do@@ -44,7 +68,7 @@ perform file oldkey newkey = do 	ifM (inAnnex oldkey)  		( unlessM (linkKey file oldkey newkey) $-			error "failed"+			giveup "failed" 		, unlessM (Annex.getState Annex.force) $ 			giveup $ file ++ " is not available (use --force to override)" 		)

Command/Reinject.hs view

@@ -16,8 +16,7 @@ cmd :: Command cmd = command "reinject" SectionUtility  	"inject content of file back into annex"-	(paramRepeating (paramPair "SRC" "DEST")-		`paramOr` "--known " ++ paramRepeating "SRC")+	(paramRepeating (paramPair "SRC" "DEST")) 	(seek <$$> optParser)  data ReinjectOptions = ReinjectOptions

Command/RemoteDaemon.hs view

@@ -1,25 +1,32 @@ {- git-annex command  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Command.RemoteDaemon where  import Command import RemoteDaemon.Core+import Utility.Daemon  cmd :: Command-cmd = noCommit $ -	command "remotedaemon" SectionPlumbing-		"detects when remotes have changed, and fetches from them"-		paramNothing (withParams seek)--seek :: CmdParams -> CommandSeek-seek = withNothing start+cmd = noCommit $+	command "remotedaemon" SectionMaintenance+		"persistent communication with remotes"+		paramNothing (run <$$> const parseDaemonOptions) -start :: CommandStart-start = do-	liftIO runForeground-	stop+run :: DaemonOptions -> CommandSeek+run o+	| stopDaemonOption o = error "--stop not implemented for remotedaemon"+	| foregroundDaemonOption o = liftIO runInteractive+	| otherwise = do+#ifndef mingw32_HOST_OS+		nullfd <- liftIO $ openFd "/dev/null" ReadOnly Nothing defaultFileFlags+		liftIO $ daemonize nullfd Nothing False runNonInteractive+#else+		liftIO $ foreground Nothing runNonInteractive	+#endif

Command/RmUrl.hs view

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,13 +15,33 @@ cmd = notBareRepo $ 	command "rmurl" SectionCommon  		"record file is not available at url"-		(paramPair paramFile paramUrl)-		(withParams seek)+		(paramRepeating (paramPair paramFile paramUrl))+		(seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withPairs start+data RmUrlOptions = RmUrlOptions+	{ rmThese :: CmdParams+	, batchOption :: BatchMode+	} -start :: (FilePath, String) -> CommandStart+optParser :: CmdParamsDesc -> Parser RmUrlOptions+optParser desc = RmUrlOptions+	<$> cmdParams desc+	<*> parseBatchOption++seek :: RmUrlOptions -> CommandSeek+seek o = case batchOption o of+	Batch -> batchInput batchParser (batchCommandAction . start)+	NoBatch -> withPairs start (rmThese o)++-- Split on the last space, since a FilePath can contain whitespace,+-- but a url should not.+batchParser :: String -> Either String (FilePath, URLString)+batchParser s = case separate (== ' ') (reverse s) of+	(ru, rf)+		| null ru || null rf -> Left "Expected: \"file url\""+		| otherwise -> Right (reverse rf, reverse ru)++start :: (FilePath, URLString) -> CommandStart start (file, url) = flip whenAnnexed file $ \_ key -> do 	showStart "rmurl" file 	next $ next $ cleanup url key

Command/Schedule.hs view

@@ -29,7 +29,7 @@   where 	parse (name:[]) = go name performGet 	parse (name:expr:[]) = go name $ \uuid -> do-		showStart "schedile" name+		showStart "schedule" name 		performSet expr uuid 	parse _ = giveup "Specify a repository."

Command/TransferInfo.hs view

@@ -13,6 +13,7 @@ import Logs.Transfer import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered+import Utility.SimpleProtocol  cmd :: Command cmd = noCommit $ @@ -62,4 +63,4 @@ start _ = giveup "wrong number of parameters"  readUpdate :: IO (Maybe Integer)-readUpdate = readish <$> getLine+readUpdate = maybe Nothing readish <$> getProtocolLine stdin

Creds.hs view

@@ -15,6 +15,7 @@ 	getEnvCredPair, 	writeCacheCreds, 	readCacheCreds,+	cacheCredsFile, 	removeCreds, 	includeCredsInfo, ) where@@ -156,7 +157,7 @@ 	<$> readCacheCreds (credPairFile storage)  readCacheCreds :: FilePath -> Annex (Maybe Creds)-readCacheCreds f = liftIO . catchMaybeIO . readFile =<< cacheCredsFile f+readCacheCreds f = liftIO . catchMaybeIO . readFileStrict =<< cacheCredsFile f  cacheCredsFile :: FilePath -> Annex FilePath cacheCredsFile basefile = do

+ P2P/Address.hs view

@@ -0,0 +1,92 @@+{- P2P protocol addresses+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module P2P.Address where++import qualified Annex+import Annex.Common+import Git+import Git.Types+import Creds+import Utility.AuthToken+import Utility.Tor++import qualified Data.Text as T++-- | A P2P address, without an AuthToken.+--+-- This is enough information to connect to the peer,+-- but not enough to authenticate with it.+data P2PAddress = TorAnnex OnionAddress OnionPort+	deriving (Eq, Show)++-- | A P2P address, with an AuthToken.+--+-- This is enough information to connect to the peer, and authenticate with+-- it.+data P2PAddressAuth = P2PAddressAuth P2PAddress AuthToken+	deriving (Eq, Show)++class FormatP2PAddress a where+	formatP2PAddress :: a -> String+	unformatP2PAddress :: String -> Maybe a++instance FormatP2PAddress P2PAddress where+	formatP2PAddress (TorAnnex (OnionAddress onionaddr) onionport) =+		torAnnexScheme ++ ":" ++ onionaddr ++ ":" ++ show onionport+	unformatP2PAddress s+		| (torAnnexScheme ++ ":") `isPrefixOf` s = do+			let s' = dropWhile (== ':') $ dropWhile (/= ':') s+			let (onionaddr, ps) = separate (== ':') s'+			onionport <- readish ps+			return (TorAnnex (OnionAddress onionaddr) onionport)+		| otherwise = Nothing++torAnnexScheme :: String+torAnnexScheme = "tor-annex:"++instance FormatP2PAddress P2PAddressAuth where+	formatP2PAddress (P2PAddressAuth addr authtoken) =+		formatP2PAddress addr ++ ":" ++ T.unpack (fromAuthToken authtoken)+	unformatP2PAddress s = do+		let (ra, rs) = separate (== ':') (reverse s)+		addr <- unformatP2PAddress (reverse rs)+		authtoken <- toAuthToken (T.pack $ reverse ra)+		return (P2PAddressAuth addr authtoken)++repoP2PAddress :: Repo -> Maybe P2PAddress+repoP2PAddress (Repo { location = Url url }) = unformatP2PAddress (show url)+repoP2PAddress _ = Nothing++-- | Load known P2P addresses for this repository.+loadP2PAddresses :: Annex [P2PAddress]+loadP2PAddresses = mapMaybe unformatP2PAddress . maybe [] lines+	<$> readCacheCreds p2pAddressCredsFile++-- | Store a new P2P address for this repository.+storeP2PAddress :: P2PAddress -> Annex ()+storeP2PAddress addr = do+	addrs <- loadP2PAddresses+	unless (addr `elem` addrs) $ do+		let s = unlines $ map formatP2PAddress (addr:addrs)+		let tmpnam = p2pAddressCredsFile ++ ".new"+		writeCacheCreds s tmpnam+		tmpf <- cacheCredsFile tmpnam+		destf <- cacheCredsFile p2pAddressCredsFile+		-- This may be run by root, so make the creds file+		-- and directory have the same owner and group as+		-- the git repository directory has.+		st <- liftIO . getFileStatus =<< Annex.fromRepo repoLocation+		let fixowner f = setOwnerAndGroup f (fileOwner st) (fileGroup st)+		liftIO $ do+			fixowner tmpf+			fixowner (takeDirectory tmpf)+			fixowner (takeDirectory (takeDirectory tmpf))+			renameFile tmpf destf++p2pAddressCredsFile :: FilePath+p2pAddressCredsFile = "p2paddrs"

+ P2P/Annex.hs view

@@ -0,0 +1,154 @@+{- P2P protocol, Annex implementation+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes, FlexibleContexts #-}++module P2P.Annex+	( RunMode(..)+	, P2PConnection(..)+	, runFullProto+	) where++import Annex.Common+import Annex.Content+import Annex.Transfer+import Annex.ChangedRefs+import P2P.Protocol+import P2P.IO+import Logs.Location+import Types.NumCopies+import Utility.Metered++import Control.Monad.Free++data RunMode+	= Serving UUID (Maybe ChangedRefsHandle)+	| Client++-- Full interpreter for Proto, that can receive and send objects.+runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Either String a)+runFullProto runmode conn = go+  where+	go :: RunProto Annex+	go (Pure v) = return (Right v)+	go (Free (Net n)) = runNet conn go n+	go (Free (Local l)) = runLocal runmode go l++runLocal :: RunMode -> RunProto Annex -> LocalF (Proto a) -> Annex (Either String a)+runLocal runmode runner a = case a of+	TmpContentSize k next -> do+		tmp <- fromRepo $ gitAnnexTmpObjectLocation k+		size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp+		runner (next (Len size))+	FileSize f next -> do+		size <- liftIO $ catchDefaultIO 0 $ getFileSize f+		runner (next (Len size))+	ContentSize k next -> do+		let getsize = liftIO . catchMaybeIO . getFileSize+		size <- inAnnex' isJust Nothing getsize k+		runner (next (Len <$> size))+	ReadContent k af o sender next -> do+		v <- tryNonAsync $ prepSendAnnex k+		case v of+			-- The check can detect if the file+			-- changed while it was transferred, but we don't+			-- use it. Instead, the receiving peer must+			-- AlwaysVerify the content it receives.+			Right (Just (f, _check)) -> do+				v' <- tryNonAsync $+					transfer upload k af $+						sinkfile f o sender+				case v' of+					Left e -> return (Left (show e))+					Right (Left e) -> return (Left (show e))+					Right (Right ok) -> runner (next ok)+			-- content not available+ 			Right Nothing -> runner (next False)+			Left e -> return (Left (show e))+	StoreContent k af o l getb next -> do+		ok <- flip catchNonAsync (const $ return False) $+			transfer download k af $ \p ->+				getViaTmp AlwaysVerify k $ \tmp ->+					unVerified $ storefile tmp o l getb p+		runner (next ok)+	StoreContentTo dest o l getb next -> do+		ok <- flip catchNonAsync (const $ return False) $+			storefile dest o l getb nullMeterUpdate+		runner (next ok)+	SetPresent k u next -> do+		v <- tryNonAsync $ logChange k u InfoPresent+		case v of+			Left e -> return (Left (show e))+			Right () -> runner next+	CheckContentPresent k next -> do+		v <- tryNonAsync $ inAnnex k+		case v of+			Left e -> return (Left (show e))+			Right result -> runner (next result)+	RemoveContent k next -> do+		v <- tryNonAsync $+			ifM (Annex.Content.inAnnex k)+				( lockContentForRemoval k $ \contentlock -> do+					removeAnnex contentlock+					logStatus k InfoMissing+					return True+				, return True+				)+		case v of+			Left e -> return (Left (show e))+			Right result -> runner (next result)+	TryLockContent k protoaction next -> do+		v <- tryNonAsync $ lockContentShared k $ \verifiedcopy -> +			case verifiedcopy of+				LockedCopy _ -> runner (protoaction True)+				_ -> runner (protoaction False)+		-- If locking fails, lockContentShared throws an exception.+		-- Let the peer know it failed.+		case v of+			Left _ -> runner $ do+				protoaction False+				next+			Right _ -> runner next+	WaitRefChange next -> case runmode of+		Serving _ (Just h) -> do+			v <- tryNonAsync $ liftIO $ waitChangedRefs h+			case v of+				Left e -> return (Left (show e))+				Right changedrefs -> runner (next changedrefs)+		_ -> return $ Left "change notification not available"+  where+	transfer mk k af ta = case runmode of+		-- Update transfer logs when serving.+		Serving theiruuid _ -> +			mk theiruuid k af noRetry ta noNotification+		-- Transfer logs are updated higher in the stack when+		-- a client.+		Client -> ta nullMeterUpdate+	+	storefile dest (Offset o) (Len l) getb p = do+		let p' = offsetMeterUpdate p (toBytesProcessed o)+		v <- runner getb+		case v of+			Right b -> liftIO $ do+				withBinaryFile dest ReadWriteMode $ \h -> do+					when (o /= 0) $+						hSeek h AbsoluteSeek o+					meteredWrite p' h b+				sz <- getFileSize dest+				return (toInteger sz == l + o)+			Left e -> error e+	+	sinkfile f (Offset o) sender p = bracket setup cleanup go+	  where+		setup = liftIO $ openBinaryFile f ReadMode+		cleanup = liftIO . hClose+		go h = do+			let p' = offsetMeterUpdate p (toBytesProcessed o)+			when (o /= 0) $+				liftIO $ hSeek h AbsoluteSeek o+			b <- liftIO $ hGetContentsMetered h p'+			runner (sender b)

+ P2P/Auth.hs view

@@ -0,0 +1,66 @@+{- P2P authtokens+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module P2P.Auth where++import Annex.Common+import Creds+import P2P.Address+import Utility.AuthToken+import Utility.Tor+import Utility.Env++import qualified Data.Text as T++-- | Load authtokens that are accepted by this repository.+loadP2PAuthTokens :: Annex AllowedAuthTokens+loadP2PAuthTokens = allowedAuthTokens <$> loadP2PAuthTokens'++loadP2PAuthTokens' :: Annex [AuthToken]+loadP2PAuthTokens' = mapMaybe toAuthToken+        . map T.pack+        . lines+        . fromMaybe []+        <$> readCacheCreds p2pAuthCredsFile++-- | Stores an AuthToken, making it be accepted by this repository.+storeP2PAuthToken :: AuthToken -> Annex ()+storeP2PAuthToken t = do+	ts <- loadP2PAuthTokens'+	unless (t `elem` ts) $ do+		let d = unlines $ map (T.unpack . fromAuthToken) (t:ts)+		writeCacheCreds d p2pAuthCredsFile++p2pAuthCredsFile :: FilePath+p2pAuthCredsFile = "p2pauth"++-- | Loads the AuthToken to use when connecting with a given P2P address.+--+-- It's loaded from the first line of the creds file, but+-- GIT_ANNEX_P2P_AUTHTOKEN overrides.+loadP2PRemoteAuthToken :: P2PAddress -> Annex (Maybe AuthToken)+loadP2PRemoteAuthToken addr = maybe Nothing mk <$> getM id+	[ liftIO $ getEnv "GIT_ANNEX_P2P_AUTHTOKEN"+	, readCacheCreds (addressCredsFile addr)+	]+  where+	mk = toAuthToken . T.pack . takeWhile (/= '\n')++p2pAuthTokenEnv :: String+p2pAuthTokenEnv = "GIT_ANNEX_P2P_AUTHTOKEN"++-- | Stores the AuthToken o use when connecting with a given P2P address.+storeP2PRemoteAuthToken :: P2PAddress -> AuthToken -> Annex ()+storeP2PRemoteAuthToken addr t = writeCacheCreds+	(T.unpack $ fromAuthToken t)+	(addressCredsFile addr)++addressCredsFile :: P2PAddress -> FilePath+-- We can omit the port and just use the onion address for the creds file,+-- because any given tor hidden service runs on a single port and has a+-- unique onion address.+addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) = onionaddr

+ P2P/IO.hs view

@@ -0,0 +1,304 @@+{- P2P protocol, IO implementation+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-}++module P2P.IO+	( RunProto+	, P2PConnection(..)+	, connectPeer+	, closeConnection+	, setupHandle+	, runNetProto+	, runNet+	) where++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 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)++-- Type of interpreters of the Proto free monad.+type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Either String a)++data P2PConnection = P2PConnection+	{ connRepo :: Repo+	, connCheckAuth :: (AuthToken -> Bool)+	, connIhdl :: Handle+	, connOhdl :: Handle+	}++-- Opens a connection to a peer. Does not authenticate with it.+connectPeer :: Git.Repo -> P2PAddress -> IO P2PConnection+connectPeer g (TorAnnex onionaddress onionport) = do+	h <- setupHandle =<< connectHiddenService onionaddress onionport+	return $ P2PConnection+		{ connRepo = g+		, connCheckAuth = const False+		, connIhdl = h+		, connOhdl = h+		}++closeConnection :: P2PConnection -> IO ()+closeConnection conn = do+	hClose (connIhdl conn)+	hClose (connOhdl conn)++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.+--+-- This only runs Net actions. No Local actions will be run+-- (those need the Annex monad) -- if the interpreter reaches any,+-- it returns Nothing.+runNetProto :: P2PConnection -> Proto a -> IO (Either String a)+runNetProto conn = go+  where+	go :: RunProto IO+	go (Pure v) = return (Right v)+	go (Free (Net n)) = runNet conn go n+	go (Free (Local _)) = return (Left "unexpected annex operation attempted")++-- Interpreter of the Net part of Proto.+--+-- An interpreter of Proto has to be provided, to handle the rest of Proto+-- actions.+runNet :: (MonadIO m, MonadMask m) => P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either String a)+runNet conn runner f = case f of+	SendMessage m next -> do+		v <- liftIO $ tryNonAsync $ do+			let l = unwords (formatMessage m)+			debugMessage "P2P >" m+			hPutStrLn (connOhdl conn) l+			hFlush (connOhdl conn)+		case v of+			Left e -> return (Left (show e))+			Right () -> runner next+	ReceiveMessage next -> do+		v <- liftIO $ tryNonAsync $ getProtocolLine (connIhdl conn)+		case v of+			Left e -> return (Left (show e))+			Right Nothing -> return (Left "protocol error")+			Right (Just l) -> case parseMessage l of+					Just m -> do+						liftIO $ debugMessage "P2P <" m+						runner (next m)+					Nothing -> runner $ do+						let e = ERROR $ "protocol parse error: " ++ show l+						net $ sendMessage e+						next e+	SendBytes len b p next -> do+		v <- liftIO $ tryNonAsync $ do+			ok <- sendExactly len b (connOhdl conn) p+			hFlush (connOhdl conn)+			return ok+		case v of+			Right True -> runner next+			Right False -> return (Left "short data write")+			Left e -> return (Left (show e))+	ReceiveBytes len p next -> do+		v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p+		case v of+			Left e -> return (Left (show e))+			Right b -> runner (next b)+	CheckAuthToken _u t next -> do+		let authed = connCheckAuth conn t+		runner (next authed)+	Relay hin hout next -> do+		v <- liftIO $ runRelay runnerio hin hout+		case v of+			Left e -> return (Left e)+			Right exitcode -> runner (next exitcode)+	RelayService service next -> do+		v <- liftIO $ runRelayService conn runnerio service+		case v of+			Left e -> return (Left e)+			Right () -> runner next+  where+	-- This is only used for running Net actions when relaying,+	-- so it's ok to use runNetProto, despite it not supporting+	-- all Proto actions.+	runnerio = runNetProto conn++debugMessage :: String -> Message -> IO ()+debugMessage prefix m = debugM "p2p" $+	prefix ++ " " ++ unwords (formatMessage safem)+  where+	safem = case m of+		AUTH u _ -> AUTH u nullAuthToken+		_ -> m++-- Send exactly the specified number of bytes or returns False.+--+-- The ByteString can be larger or smaller than the specified length.+-- For example, it can be lazily streaming from a file that gets+-- appended to, or truncated.+--+-- Must avoid sending too many bytes as it would confuse the other end.+-- This is easily dealt with by truncating it.+--+-- If too few bytes are sent, the only option is to give up on this+-- connection. False is returned to indicate this problem.+sendExactly :: Len -> L.ByteString -> Handle -> MeterUpdate -> IO Bool+sendExactly (Len n) b h p = do+	sent <- meteredWrite' p h (L.take (fromIntegral n) b)+	return (fromBytesProcessed sent == n)++receiveExactly :: Len -> Handle -> MeterUpdate -> IO L.ByteString+receiveExactly (Len n) h p = hGetMetered h (Just n) p++runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Either String ExitCode)+runRelay runner (RelayHandle hout) (RelayHandle hin) = +	bracket setup cleanup go+		`catchNonAsync` (return . Left . show)+  where+	setup = do+		v <- newEmptyMVar+		void $ async $ relayFeeder runner v hin+		void $ async $ relayReader v hout+		return v+	+	cleanup _ = do+		hClose hin+		hClose hout+	+	go v = relayHelper runner v++runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either String ())+runRelayService conn runner service = +	bracket setup cleanup go+		`catchNonAsync` (return . Left . show)+  where+	cmd = case service of+		UploadPack -> "upload-pack"+		ReceivePack -> "receive-pack"+	+	serviceproc = gitCreateProcess+		[ Param cmd+		, File (repoPath (connRepo conn))+		] (connRepo conn)++	setup = do+		(Just hin, Just hout, _, pid) <- createProcess serviceproc+			{ std_out = CreatePipe+			, std_in = CreatePipe+			}+		v <- newEmptyMVar+		void $ async $ relayFeeder runner v hin+		void $ async $ relayReader v hout+		waiter <- async $ waitexit v pid+		return (v, waiter, hin, hout, pid)++	cleanup (_, waiter, hin, hout, pid) = do+		hClose hin+		hClose hout+		cancel waiter+		void $ waitForProcess pid++	go (v, _, _, _, _) = do+		r <- relayHelper runner v+		case r of+			Left e -> return (Left (show e))+			Right exitcode -> runner $ net $ relayToPeer (RelayDone exitcode)+	+	waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid++-- Processes RelayData as it is put into the MVar.+relayHelper :: RunProto IO -> MVar RelayData -> IO (Either String ExitCode)+relayHelper runner v = loop+  where+	loop = do+		d <- takeMVar v+		case d of+			RelayToPeer b -> do+				r <- runner $ net $ relayToPeer (RelayToPeer b)+				case r of+					Left e -> return (Left e)+					Right () -> loop+			RelayDone exitcode -> do+				_ <- runner $ net $ relayToPeer (RelayDone exitcode)+				return (Right exitcode)+			RelayFromPeer _ -> loop -- not handled here++-- Takes input from the peer, and sends it to the relay process's stdin.+-- Repeats until the peer tells it it's done or hangs up.+relayFeeder :: RunProto IO -> MVar RelayData -> Handle -> IO ()+relayFeeder runner v hin = loop+  where+	loop = do+		mrd <- runner $ net relayFromPeer+		case mrd of+			Left _e ->+				putMVar v (RelayDone (ExitFailure 1))+			Right (RelayDone exitcode) ->+				putMVar v (RelayDone exitcode)+			Right (RelayFromPeer b) -> do+				L.hPut hin b+				hFlush hin+				loop+			Right (RelayToPeer _) -> loop -- not handled here++-- Reads input from the Handle and puts it into the MVar for relaying to+-- the peer. Continues until EOF on the Handle.+relayReader :: MVar RelayData -> Handle -> IO ()+relayReader v hout = loop+  where+	loop = do+		bs <- getsome []+		case bs of+			[] -> return ()+			_ -> do+				putMVar v $ RelayToPeer (L.fromChunks bs)+				loop+	+	-- Waiit for the first available chunk. Then, without blocking,+	-- try to get more chunks, in case a stream of chunks is being+	-- written in close succession. +	--+	-- On Windows, hGetNonBlocking is broken, so avoid using it there.+	getsome [] = do+		b <- B.hGetSome hout chunk+		if B.null b+			then return []+#ifndef mingw32_HOST_OS+			else getsome [b]+#else+			else return [b]+#endif+	getsome bs = do+		b <- B.hGetNonBlocking hout chunk+		if B.null b+			then return (reverse bs)+			else getsome (b:bs)+	+	chunk = 65536

+ P2P/Protocol.hs view

@@ -0,0 +1,484 @@+{- P2P protocol+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module P2P.Protocol where++import qualified Utility.SimpleProtocol as Proto+import Types.Key+import Types.UUID+import Utility.AuthToken+import Utility.Applicative+import Utility.PartialPrelude+import Utility.Metered+import Git.FilePath+import Annex.ChangedRefs (ChangedRefs)++import Control.Monad+import Control.Monad.Free+import Control.Monad.Free.TH+import Control.Monad.Catch+import System.FilePath+import System.Exit (ExitCode(..))+import System.IO+import qualified Data.ByteString.Lazy as L+import Data.Char+import Control.Applicative+import Prelude++newtype Offset = Offset Integer+	deriving (Show)++newtype Len = Len Integer+	deriving (Show)++-- | Service as used by the connect message is gitremote-helpers(1)+data Service = UploadPack | ReceivePack+	deriving (Show)++-- | Messages in the protocol. The peer that makes the connection+-- always initiates requests, and the other peer makes responses to them.+data Message+	= AUTH UUID AuthToken -- uuid of the peer that is authenticating+	| AUTH_SUCCESS UUID -- uuid of the remote peer+	| AUTH_FAILURE+	| CONNECT Service+	| CONNECTDONE ExitCode+	| NOTIFYCHANGE+	| CHANGED ChangedRefs+	| CHECKPRESENT Key+	| LOCKCONTENT Key+	| UNLOCKCONTENT+	| REMOVE Key+	| GET Offset AssociatedFile Key+	| PUT AssociatedFile Key+	| PUT_FROM Offset+	| ALREADY_HAVE+	| SUCCESS+	| FAILURE+	| DATA Len -- followed by bytes of data+	| ERROR String+	deriving (Show)++instance Proto.Sendable Message where+	formatMessage (AUTH uuid authtoken) = ["AUTH", Proto.serialize uuid, Proto.serialize authtoken]+	formatMessage (AUTH_SUCCESS uuid) = ["AUTH-SUCCESS",  Proto.serialize uuid]+	formatMessage AUTH_FAILURE = ["AUTH-FAILURE"]+	formatMessage (CONNECT service) = ["CONNECT", Proto.serialize service]+	formatMessage (CONNECTDONE exitcode) = ["CONNECTDONE", Proto.serialize exitcode]+	formatMessage NOTIFYCHANGE = ["NOTIFYCHANGE"]+	formatMessage (CHANGED refs) = ["CHANGED", Proto.serialize refs]+	formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key]+	formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key]+	formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"]+	formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key]+	formatMessage (GET offset af key) = ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key]+	formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key]+	formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset]+	formatMessage ALREADY_HAVE = ["ALREADY-HAVE"]+	formatMessage SUCCESS = ["SUCCESS"]+	formatMessage FAILURE = ["FAILURE"]+	formatMessage (DATA len) = ["DATA", Proto.serialize len]+	formatMessage (ERROR err) = ["ERROR", Proto.serialize err]++instance Proto.Receivable Message where+	parseCommand "AUTH" = Proto.parse2 AUTH+	parseCommand "AUTH-SUCCESS" = Proto.parse1 AUTH_SUCCESS+	parseCommand "AUTH-FAILURE" = Proto.parse0 AUTH_FAILURE+	parseCommand "CONNECT" = Proto.parse1 CONNECT+	parseCommand "CONNECTDONE" = Proto.parse1 CONNECTDONE+	parseCommand "NOTIFYCHANGE" = Proto.parse0 NOTIFYCHANGE+	parseCommand "CHANGED" = Proto.parse1 CHANGED+	parseCommand "CHECKPRESENT" = Proto.parse1 CHECKPRESENT+	parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT+	parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT+	parseCommand "REMOVE" = Proto.parse1 REMOVE+	parseCommand "GET" = Proto.parse3 GET+	parseCommand "PUT" = Proto.parse2 PUT+	parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM+	parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE+	parseCommand "SUCCESS" = Proto.parse0 SUCCESS+	parseCommand "FAILURE" = Proto.parse0 FAILURE+	parseCommand "DATA" = Proto.parse1 DATA+	parseCommand "ERROR" = Proto.parse1 ERROR+	parseCommand _ = Proto.parseFail++instance Proto.Serializable Offset where+	serialize (Offset n) = show n+	deserialize = Offset <$$> readish++instance Proto.Serializable Len where+	serialize (Len n) = show n+	deserialize = Len <$$> readish++instance Proto.Serializable Service where+	serialize UploadPack = "git-upload-pack"+	serialize ReceivePack = "git-receive-pack"+	deserialize "git-upload-pack" = Just UploadPack+	deserialize "git-receive-pack" = Just ReceivePack+	deserialize _ = Nothing++-- | Since AssociatedFile is not the last thing in a protocol line,+-- its serialization cannot contain any whitespace. This is handled+-- by replacing whitespace with '%' (and '%' with '%%')+--+-- When deserializing an AssociatedFile from a peer, it's sanitized,+-- to avoid any unusual characters that might cause problems when it's+-- displayed to the user.+--+-- These mungings are ok, because an AssociatedFile is only ever displayed+-- to the user and does not need to match a file on disk.+instance Proto.Serializable AssociatedFile where+	serialize Nothing = ""+	serialize (Just af) = toInternalGitPath $ concatMap esc af+	  where+		esc '%' = "%%"+		esc c +			| isSpace c = "%"+			| otherwise = [c]+	+	deserialize s = case fromInternalGitPath $ deesc [] s of+		[] -> Just Nothing+		f+			| isRelative f -> Just (Just f)+			| otherwise -> Nothing+	  where+	  	deesc b [] = reverse b+		deesc b ('%':'%':cs) = deesc ('%':b) cs+		deesc b ('%':cs) = deesc ('_':b) cs+		deesc b (c:cs)+			| isControl c = deesc ('_':b) cs+			| otherwise = deesc (c:b) cs++-- | Free monad for the protocol, combining net communication,+-- and local actions.+data ProtoF c = Net (NetF c) | Local (LocalF c)+	deriving (Functor)++type Proto = Free ProtoF++net :: Net a -> Proto a+net = hoistFree Net++local :: Local a -> Proto a+local = hoistFree Local++data NetF c+	= SendMessage Message c+	| ReceiveMessage (Message -> c)+	| SendBytes Len L.ByteString MeterUpdate c+	-- ^ Sends exactly Len bytes of data. (Any more or less will+	-- confuse the receiver.)+	| ReceiveBytes Len MeterUpdate (L.ByteString -> c)+	-- ^ Lazily reads bytes from peer. Stops once Len are read,+	-- or if connection is lost, and in either case returns the bytes+	-- that were read. This allows resuming interrupted transfers.+	| CheckAuthToken UUID AuthToken (Bool -> c)+	| RelayService Service c+	-- ^ Runs a service, relays its output to the peer, and data+	-- from the peer to it.+	| Relay RelayHandle RelayHandle (ExitCode -> c)+	-- ^ Reads from the first RelayHandle, and sends the data to a+	-- peer, while at the same time accepting input from the peer+	-- which is sent the the second RelayHandle. Continues until +	-- the peer sends an ExitCode.+	deriving (Functor)++type Net = Free NetF++newtype RelayHandle = RelayHandle Handle++data LocalF c+	= TmpContentSize Key (Len -> c)+	-- ^ Gets size of the temp file where received content may have+	-- been stored. If not present, returns 0.+	| FileSize FilePath (Len -> c)+	-- ^ Gets size of the content of a file. If not present, returns 0.+	| ContentSize Key (Maybe Len -> c)+	-- ^ Gets size of the content of a key, when the full content is+	-- present.+	| ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Bool) (Bool -> c)+	-- ^ Reads the content of a key and sends it to the callback.+	-- Note that the content may change while it's being sent.+	-- If the content is not available, sends L.empty to the callback.+	| StoreContent Key AssociatedFile Offset Len (Proto L.ByteString) (Bool -> c)+	-- ^ Stores content to the key's temp file starting at an offset.+	-- Once the whole content of the key has been stored, moves the+	-- temp file into place as the content of the key, and returns True.+	--+	-- Note: The ByteString may not contain the entire remaining content+	-- of the key. Only once the temp file size == Len has the whole+	-- content been transferred.+	| StoreContentTo FilePath Offset Len (Proto L.ByteString) (Bool -> c)+	-- ^ Stores the content to a temp file starting at an offset.+	-- Once the whole content of the key has been stored, returns True.+	--+	-- Note: The ByteString may not contain the entire remaining content+	-- of the key. Only once the temp file size == Len has the whole+	-- content been transferred.+	| SetPresent Key UUID c+	| CheckContentPresent Key (Bool -> c)+	-- ^ Checks if the whole content of the key is locally present.+	| RemoveContent Key (Bool -> c)+	-- ^ If the content is not present, still succeeds.+	-- May fail if not enough copies to safely drop, etc.+	| TryLockContent Key (Bool -> Proto ()) c+	-- ^ Try to lock the content of a key,  preventing it+	-- from being deleted, while running the provided protocol+	-- action. If unable to lock the content, runs the protocol action+	-- with False.+	| WaitRefChange (ChangedRefs -> c)+	-- ^ Waits for one or more git refs to change and returns them.+	deriving (Functor)++type Local = Free LocalF++-- Generate sendMessage etc functions for all free monad constructors.+$(makeFree ''NetF)+$(makeFree ''LocalF)++auth :: UUID -> AuthToken -> Proto (Maybe UUID)+auth myuuid t = do+	net $ sendMessage (AUTH myuuid t)+	r <- net receiveMessage+	case r of+		AUTH_SUCCESS theiruuid -> return $ Just theiruuid+		AUTH_FAILURE -> return Nothing+		_ -> do+			net $ sendMessage (ERROR "auth failed")+			return Nothing++checkPresent :: Key -> Proto Bool+checkPresent key = do+	net $ sendMessage (CHECKPRESENT key)+	checkSuccess++{- Locks content to prevent it from being dropped, while running an action.+ -+ - Note that this only guarantees that the content is locked as long as the+ - connection to the peer remains up. If the connection is unexpectededly+ - dropped, the peer will then unlock the content.+ -}+lockContentWhile +	:: MonadMask m +	=> (forall r. r -> Proto r -> m r)+	-> Key+	-> (Bool -> m a)+	-> m a+lockContentWhile runproto key a = bracket setup cleanup a+  where+	setup = runproto False $ do+		net $ sendMessage (LOCKCONTENT key)+		checkSuccess+	cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT+	cleanup False = return ()++remove :: Key -> Proto Bool+remove key = do+	net $ sendMessage (REMOVE key)+	checkSuccess++get :: FilePath -> Key -> AssociatedFile -> MeterUpdate -> Proto Bool+get dest key af p = receiveContent p sizer storer (\offset -> GET offset af key)+  where+	sizer = fileSize dest+	storer = storeContentTo dest++put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool+put key af p = do+	net $ sendMessage (PUT af key)+	r <- net receiveMessage+	case r of+		PUT_FROM offset -> sendContent key af offset p+		ALREADY_HAVE -> return True+		_ -> do+			net $ sendMessage (ERROR "expected PUT_FROM")+			return False++data ServerHandler a+	= ServerGot a+	| ServerContinue+	| ServerUnexpected++-- Server loop, getting messages from the client and handling them+serverLoop :: (Message -> Proto (ServerHandler a)) -> Proto (Maybe a)+serverLoop a = do+	cmd <- net receiveMessage+	case cmd of+		-- When the client sends ERROR to the server, the server+		-- gives up, since it's not clear what state the client+		-- is in, and so not possible to recover.+		ERROR _ -> return Nothing+		_ -> do+			v <- a cmd+			case v of+				ServerGot r -> return (Just r)+				ServerContinue -> serverLoop a+				-- If the client sends an unexpected message,+				-- the server will respond with ERROR, and+				-- always continues processing messages.+				--+				-- Since the protocol is not versioned, this+				-- is necessary to handle protocol changes+				-- robustly, since the client can detect when+				-- it's talking to a server that does not+				-- support some new feature, and fall back.+				ServerUnexpected -> do+					net $ sendMessage (ERROR "unexpected command")+					serverLoop a++-- | Serve the protocol, with an unauthenticated peer. Once the peer+-- successfully authenticates, returns their UUID.+serveAuth :: UUID -> Proto (Maybe UUID)+serveAuth myuuid = serverLoop handler+  where+	handler (AUTH theiruuid authtoken) = do+		ok <- net $ checkAuthToken theiruuid authtoken+		if ok+			then do+				net $ sendMessage (AUTH_SUCCESS myuuid)+				return (ServerGot theiruuid)+			else do+				net $ sendMessage AUTH_FAILURE+				return ServerContinue+	handler _ = return ServerUnexpected++-- | Serve the protocol, with a peer that has authenticated.+serveAuthed :: UUID -> Proto ()+serveAuthed myuuid = void $ serverLoop handler+  where+	handler (LOCKCONTENT key) = do+		local $ tryLockContent key $ \locked -> do+			sendSuccess locked+			when locked $ do+				r' <- net receiveMessage+				case r' of+					UNLOCKCONTENT -> return ()+					_ -> net $ sendMessage (ERROR "expected UNLOCKCONTENT")+		return ServerContinue+	handler (CHECKPRESENT key) = do+		sendSuccess =<< local (checkContentPresent key)+		return ServerContinue+	handler (REMOVE key) = do+		sendSuccess =<< local (removeContent key)+		return ServerContinue+	handler (PUT af key) = do+		have <- local $ checkContentPresent key+		if have+			then net $ sendMessage ALREADY_HAVE+			else do+				let sizer = tmpContentSize key+				let storer = storeContent key af+				ok <- receiveContent nullMeterUpdate sizer storer PUT_FROM+				when ok $+					local $ setPresent key myuuid+		return ServerContinue+	handler (GET offset key af) = do+		void $ sendContent af key offset nullMeterUpdate+		-- setPresent not called because the peer may have+		-- requested the data but not permanently stored it.+		return ServerContinue+	handler (CONNECT service) = do+		net $ relayService service+		-- After connecting to git, there may be unconsumed data+		-- from the git processes hanging around (even if they+		-- exited successfully), so stop serving this connection.+		return $ ServerGot ()+	handler NOTIFYCHANGE = do+		refs <- local waitRefChange+		net $ sendMessage (CHANGED refs)+		return ServerContinue+	handler _ = return ServerUnexpected++sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool+sendContent key af offset@(Offset n) p = go =<< local (contentSize key)+  where+ 	go Nothing = sender (Len 0) L.empty+	go (Just (Len totallen)) = do+		let len = totallen - n+		if len <= 0+			then sender (Len 0) L.empty+			else local $ readContent key af offset $+				sender (Len len)+	sender len content = do+		let p' = offsetMeterUpdate p (toBytesProcessed n)+		net $ sendMessage (DATA len)+		net $ sendBytes len content p'+		checkSuccess++receiveContent :: MeterUpdate -> Local Len -> (Offset -> Len -> Proto L.ByteString -> Local Bool) -> (Offset -> Message) -> Proto Bool+receiveContent p sizer storer mkmsg = do+	Len n <- local sizer+	let p' = offsetMeterUpdate p (toBytesProcessed n)+	let offset = Offset n+	net $ sendMessage (mkmsg offset)+	r <- net receiveMessage+	case r of+		DATA len -> do+			ok <- local $ storer offset len+				(net (receiveBytes len p'))+			sendSuccess ok+			return ok+		_ -> do+			net $ sendMessage (ERROR "expected DATA")+			return False++checkSuccess :: Proto Bool+checkSuccess = do+	ack <- net receiveMessage+	case ack of+		SUCCESS -> return True+		FAILURE -> return False+		_ -> do+			net $ sendMessage (ERROR "expected SUCCESS or FAILURE")+			return False++sendSuccess :: Bool -> Proto ()+sendSuccess True = net $ sendMessage SUCCESS+sendSuccess False = net $ sendMessage FAILURE++notifyChange :: Proto (Maybe ChangedRefs)+notifyChange = do+	net $ sendMessage NOTIFYCHANGE+	ack <- net receiveMessage+	case ack of+		CHANGED rs -> return (Just rs)+		_ -> do+			net $ sendMessage (ERROR "expected CHANGED")+			return Nothing++connect :: Service -> Handle -> Handle -> Proto ExitCode+connect service hin hout = do+	net $ sendMessage (CONNECT service)+	net $ relay (RelayHandle hin) (RelayHandle hout)++data RelayData+	= RelayToPeer L.ByteString+	| RelayFromPeer L.ByteString+	| RelayDone ExitCode+	deriving (Show)++relayFromPeer :: Net RelayData+relayFromPeer = do+	r <- receiveMessage+	case r of+		CONNECTDONE exitcode -> return $ RelayDone exitcode+		DATA len -> RelayFromPeer <$> receiveBytes len nullMeterUpdate+		_ -> do+			sendMessage $ ERROR "expected DATA or CONNECTDONE"+			return $ RelayDone $ ExitFailure 1++relayToPeer :: RelayData -> Net ()+relayToPeer (RelayDone exitcode) = sendMessage (CONNECTDONE exitcode)+relayToPeer (RelayToPeer b) = do+	let len = Len $ fromIntegral $ L.length b+	sendMessage (DATA len)+	sendBytes len b nullMeterUpdate+relayToPeer (RelayFromPeer _) = return ()

Remote/External/Types.hs view

@@ -250,14 +250,6 @@ 	deserialize "RETRIEVE" = Just Download 	deserialize _ = Nothing -instance Proto.Serializable Key where-	serialize = key2file-	deserialize = file2key--instance Proto.Serializable [Char] where-	serialize = id-	deserialize = Just- instance Proto.Serializable ProtocolVersion where 	serialize = show 	deserialize = readish

Remote/Git.hs view

@@ -45,10 +45,13 @@ #endif import Utility.Env import Utility.Batch+import Utility.SimpleProtocol import Remote.Helper.Git import Remote.Helper.Messages import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt+import qualified Remote.P2P+import P2P.Address import Annex.Path import Creds import Annex.CatFile@@ -130,7 +133,9 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc 	| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc-	| otherwise = go <$> remoteCost gc defcst+	| otherwise = case repoP2PAddress r of+		Nothing -> go <$> remoteCost gc defcst+		Just addr -> Remote.P2P.chainGen addr r u c gc   where 	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost 	go cst = Just new@@ -352,9 +357,9 @@ 			commitOnCleanup r $ onLocal r $ do 				ensureInitialized 				whenM (Annex.Content.inAnnex key) $ do-					Annex.Content.lockContentForRemoval key-						Annex.Content.removeAnnex-					logStatus key InfoMissing+					Annex.Content.lockContentForRemoval key $ \lock -> do+						Annex.Content.removeAnnex lock+						logStatus key InfoMissing 					Annex.Content.saveState True 				return True 	| Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported"@@ -386,7 +391,7 @@ 						, std_out = CreatePipe 						, std_err = UseHandle nullh 						}-		v <- liftIO $ tryIO $ hGetLine hout+		v <- liftIO $ tryIO $ getProtocolLine hout 		let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync 			[ hPutStrLn hout "" 			, hFlush hout@@ -404,7 +409,7 @@ 					void $ waitForProcess p 				failedlock 			Right l -				| l == Ssh.contentLockedMarker -> bracket_+				| l == Just Ssh.contentLockedMarker -> bracket_ 					noop 					signaldone  					(withVerifiedCopy LockedCopy r checkexited callback)

Remote/List.hs view

@@ -23,6 +23,7 @@  import qualified Remote.Git import qualified Remote.GCrypt+import qualified Remote.P2P #ifdef WITH_S3 import qualified Remote.S3 #endif@@ -44,6 +45,7 @@ remoteTypes = 	[ Remote.Git.remote 	, Remote.GCrypt.remote+	, Remote.P2P.remote #ifdef WITH_S3 	, Remote.S3.remote #endif@@ -116,4 +118,4 @@ {- Checks if a remote is syncable using git. -} gitSyncableRemote :: Remote -> Bool gitSyncableRemote r = remotetype r `elem`-	[ Remote.Git.remote, Remote.GCrypt.remote ]+	[ Remote.Git.remote, Remote.GCrypt.remote, Remote.P2P.remote ]

+ Remote/P2P.hs view

@@ -0,0 +1,196 @@+{- git remotes using the git-annex P2P protocol+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Remote.P2P (+	remote,+	chainGen+) where++import Annex.Common+import qualified Annex+import qualified P2P.Protocol as P2P+import P2P.Address+import P2P.Annex+import P2P.IO+import P2P.Auth+import Types.Remote+import Types.GitConfig+import qualified Git+import Annex.UUID+import Config+import Config.Cost+import Remote.Helper.Git+import Messages.Progress+import Utility.Metered+import Utility.AuthToken+import Types.NumCopies++import Control.Concurrent+import Control.Concurrent.STM++remote :: RemoteType+remote = RemoteType {+	typename = "p2p",+	-- Remote.Git takes care of enumerating P2P remotes,+	-- and will call chainGen on them.+	enumerate = const (return []),+	generate = \_ _ _ _ -> return Nothing,+	setup = error "P2P remotes are set up using git-annex p2p"+}++chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)+chainGen addr r u c gc = do+	connpool <- mkConnectionPool+	cst <- remoteCost gc expensiveRemoteCost+	let this = Remote +		{ uuid = u+		, cost = cst+		, name = Git.repoDescribe r+		, storeKey = store u addr connpool+		, retrieveKeyFile = retrieve u addr connpool+		, retrieveKeyFileCheap = \_ _ _ -> return False+		, removeKey = remove u addr connpool+		, lockContent = Just (lock u addr connpool)+		, checkPresent = checkpresent u addr connpool+		, checkPresentCheap = False+		, whereisKey = Nothing+		, remoteFsck = Nothing+		, repairRepo = Nothing+		, config = c+		, localpath = Nothing+		, repo = r+		, gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }+		, readonly = False+		, availability = GloballyAvailable+		, remotetype = remote+		, mkUnavailable = return Nothing+		, getInfo = gitRepoInfo this+		, claimUrl = Nothing+		, checkUrl = Nothing+	}+	return (Just this)++store :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool+store u addr connpool k af p = +	metered (Just p) k $ \p' -> fromMaybe False+		<$> runProto u addr connpool (P2P.put k af p')++retrieve :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)+retrieve u addr connpool k af dest p = unVerified $ +	metered (Just p) k $ \p' -> fromMaybe False +		<$> runProto u addr connpool (P2P.get dest k af p')++remove :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool+remove u addr connpool k = fromMaybe False+	<$> runProto u addr connpool (P2P.remove k)++checkpresent :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool+checkpresent u addr connpool k = maybe unavail return+	=<< runProto u addr connpool (P2P.checkPresent k)+  where+	unavail = giveup "can't connect to peer"++lock :: UUID -> P2PAddress -> ConnectionPool -> Key -> (VerifiedCopy -> Annex r) -> Annex r+lock u addr connpool k callback =+	withConnection u addr connpool $ \conn -> do+		connv <- liftIO $ newMVar conn+		let runproto d p = do+			c <- liftIO $ takeMVar connv+			(c', mr) <- runProto' p c+			liftIO $ putMVar connv c'+			return (fromMaybe d mr)+		r <- P2P.lockContentWhile runproto k go+		conn' <- liftIO $ takeMVar connv+		return (conn', r)+  where+	go False = giveup "can't lock content"+	go True = withVerifiedCopy LockedCopy u (return True) callback++-- | A connection to the peer.+data Connection +	= OpenConnection P2PConnection+	| ClosedConnection++type ConnectionPool = TVar [Connection]++mkConnectionPool :: Annex ConnectionPool+mkConnectionPool = liftIO $ newTVarIO []++-- Runs the Proto action.+runProto :: UUID -> P2PAddress -> ConnectionPool -> P2P.Proto a -> Annex (Maybe a)+runProto u addr connpool a = withConnection u addr connpool (runProto' a)++runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a)+runProto' _ ClosedConnection = return (ClosedConnection, Nothing)+runProto' a (OpenConnection conn) = do+	v <- runFullProto Client conn a+	-- When runFullProto fails, the connection is no longer usable,+	-- so close it.+	case v of+		Left e -> do+			warning $ "Lost connection to peer (" ++ e ++ ")"+			liftIO $ closeConnection conn+			return (ClosedConnection, Nothing)+		Right r -> return (OpenConnection conn, Just r)++-- Uses an open connection if one is available in the ConnectionPool;+-- otherwise opens a new connection.+--+-- Once the action is done, the connection is added back to the+-- ConnectionPool, unless it's no longer open.+withConnection :: UUID -> P2PAddress -> ConnectionPool -> (Connection -> Annex (Connection, a)) -> Annex a+withConnection u addr connpool a = bracketOnError get cache go+  where+	get = do+		mc <- liftIO $ atomically $ do+			l <- readTVar connpool+			case l of+				[] -> do+					writeTVar connpool []+					return Nothing+				(c:cs) -> do+					writeTVar connpool cs+					return (Just c)+		maybe (openConnection u addr) return mc+	+	cache ClosedConnection = return ()+	cache conn = liftIO $ atomically $ modifyTVar' connpool (conn:)++	go conn = do+		(conn', r) <- a conn+		cache conn'+		return r++openConnection :: UUID -> P2PAddress -> Annex Connection+openConnection u addr = do+	g <- Annex.gitRepo+	v <- liftIO $ tryNonAsync $ connectPeer g addr+	case v of+		Right conn -> do+			myuuid <- getUUID+			authtoken <- fromMaybe nullAuthToken+				<$> loadP2PRemoteAuthToken addr+			res <- liftIO $ runNetProto conn $+				P2P.auth myuuid authtoken+			case res of+				Right (Just theiruuid)+					| u == theiruuid -> return (OpenConnection conn)+					| otherwise -> do+						liftIO $ closeConnection conn+						warning "Remote peer uuid seems to have changed."+						return ClosedConnection+				Right Nothing -> do+					warning "Unable to authenticate with peer."+					liftIO $ closeConnection conn+					return ClosedConnection+				Left e -> do+					warning $ "Problem communicating with peer. (" ++ e ++ ")"+					liftIO $ closeConnection conn+					return ClosedConnection+		Left e -> do+			warning $ "Unable to connect to peer. (" ++ show e ++ ")"+			return ClosedConnection

Remote/S3.hs view

@@ -49,6 +49,13 @@ import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager) +#if MIN_VERSION_http_client(0,5,0)+import Network.HTTP.Client (responseTimeoutNone)+#else+responseTimeoutNone :: Maybe Int+responseTimeoutNone = Nothing+#endif+ type BucketName = String  remote :: RemoteType@@ -193,7 +200,7 @@ 		uploadid <- S3.imurUploadId <$> sendS3Handle h startreq  		-- The actual part size will be a even multiple of the-		-- 32k chunk size that hGetUntilMetered uses.+		-- 32k chunk size that lazy ByteStrings use. 		let partsz' = (partsz `div` toInteger defaultChunkSize) * toInteger defaultChunkSize  		-- Send parts of the file, taking care to stream each part@@ -430,7 +437,7 @@   where 	s3cfg = s3Configuration c 	httpcfg = managerSettings-		{ managerResponseTimeout = Nothing }+		{ managerResponseTimeout = responseTimeoutNone }  s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration c = cfg

Remote/WebDAV.hs view

@@ -5,6 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}  module Remote.WebDAV (remote, davCreds, configUrl) where@@ -34,6 +35,10 @@ import Annex.UUID import Remote.WebDAV.DavLocation +#if MIN_VERSION_http_client(0,5,0)+import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)+#endif+ remote :: RemoteType remote = RemoteType { 	typename = "webdav",@@ -302,15 +307,27 @@ {- Catch StatusCodeException and trim it to only the statusMessage part,  - eliminating a lot of noise, which can include the whole request that  - failed. The rethrown exception is no longer a StatusCodeException. -}+#if MIN_VERSION_http_client(0,5,0) prettifyExceptions :: DAVT IO a -> DAVT IO a prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go   where+	go (HttpExceptionRequest _ (StatusCodeException response message)) = error $ unwords+		[ "DAV failure:"+		, show (responseStatus response)+		, show (message)+		]+	go e = throwM e+#else+prettifyExceptions :: DAVT IO a -> DAVT IO a+prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go+  where 	go (StatusCodeException status _ _) = error $ unwords 		[ "DAV failure:" 		, show (statusCode status) 		, show (statusMessage status) 		] 	go e = throwM e+#endif  prepDAV :: DavUser -> DavPass -> DAVT IO () prepDAV user pass = do

RemoteDaemon/Common.hs view

@@ -1,6 +1,6 @@ {- git-remote-daemon utilities  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -9,6 +9,8 @@ 	( liftAnnex 	, inLocalRepo 	, checkNewShas+	, ConnectionStatus(..)+	, robustConnection 	) where  import qualified Annex@@ -16,6 +18,7 @@ import RemoteDaemon.Types import qualified Git import Annex.CatFile+import Utility.ThreadScheduler  import Control.Concurrent @@ -40,3 +43,22 @@ 	check [] = return True 	check (r:rs) = maybe (check rs) (const $ return False) 		=<< liftAnnex transporthandle (catObjectDetails r)++data ConnectionStatus = ConnectionStopping | ConnectionClosed++{- Make connection robust, retrying on error, with exponential backoff. -}+robustConnection :: Int -> IO ConnectionStatus -> IO ()+robustConnection backoff a = +	caught =<< a `catchNonAsync` (const $ return ConnectionClosed)+  where+	caught ConnectionStopping = return ()+	caught ConnectionClosed = do+		threadDelaySeconds (Seconds backoff)+		robustConnection increasedbackoff a++	increasedbackoff+		| b2 > maxbackoff = maxbackoff+		| otherwise = b2+	  where+		b2 = backoff * 2+		maxbackoff = 3600 -- one hour

RemoteDaemon/Core.hs view

@@ -1,11 +1,11 @@ {- git-remote-daemon core  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -module RemoteDaemon.Core (runForeground) where+module RemoteDaemon.Core (runInteractive, runNonInteractive) where  import qualified Annex import Common@@ -17,8 +17,10 @@ import qualified Git.Types as Git import qualified Git.CurrentRepo import Utility.SimpleProtocol+import Utility.ThreadScheduler import Config import Annex.Ssh+import Types.Messages  import Control.Concurrent import Control.Concurrent.Async@@ -26,8 +28,8 @@ import Network.URI import qualified Data.Map as M -runForeground :: IO ()-runForeground = do+runInteractive :: IO ()+runInteractive = do 	(readh, writeh) <- dupIoHandles 	ichan <- newTChanIO :: IO (TChan Consumed) 	ochan <- newTChanIO :: IO (TChan Emitted)@@ -44,9 +46,26 @@ 	let controller = runController ichan ochan 	 	-- If any thread fails, the rest will be killed.-	void $ tryIO $-		reader `concurrently` writer `concurrently` controller+	void $ tryIO $ reader+		`concurrently` writer+		`concurrently` controller +runNonInteractive :: IO ()+runNonInteractive = do+	ichan <- newTChanIO :: IO (TChan Consumed)+	ochan <- newTChanIO :: IO (TChan Emitted)+	+	let reader = forever $ do+		threadDelaySeconds (Seconds (60*60))+		atomically $ writeTChan ichan RELOAD+	let writer = forever $+		void $ atomically $ readTChan ochan+	let controller = runController ichan ochan+	+	void $ tryIO $ reader+		`concurrently` writer+		`concurrently` controller+ type RemoteMap = M.Map Git.Repo (IO (), TChan Consumed)  -- Runs the transports, dispatching messages to them, and handling@@ -56,6 +75,7 @@ 	h <- genTransportHandle 	m <- genRemoteMap h ochan 	startrunning m+	mapM_ (\s -> async (s h)) remoteServers 	go h False m   where 	go h paused m = do@@ -132,7 +152,9 @@ genTransportHandle = do 	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get 	g <- Annex.repo <$> readMVar annexstate-	return $ TransportHandle (LocalRepo g) annexstate+	let h = TransportHandle (LocalRepo g) annexstate+	liftAnnex h $ Annex.setOutput QuietOutput+	return h  updateTransportHandle :: TransportHandle -> IO TransportHandle updateTransportHandle h@(TransportHandle _g annexstate) = do

RemoteDaemon/Transport.hs view

@@ -10,7 +10,9 @@ import RemoteDaemon.Types import qualified RemoteDaemon.Transport.Ssh import qualified RemoteDaemon.Transport.GCrypt+import qualified RemoteDaemon.Transport.Tor import qualified Git.GCrypt+import P2P.Address (torAnnexScheme)  import qualified Data.Map as M @@ -21,4 +23,8 @@ remoteTransports = M.fromList 	[ ("ssh:", RemoteDaemon.Transport.Ssh.transport) 	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.GCrypt.transport)+	, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport) 	]++remoteServers :: [TransportHandle -> IO ()]+remoteServers = [RemoteDaemon.Transport.Tor.server]

RemoteDaemon/Transport/Ssh.hs view

@@ -16,7 +16,7 @@ import Utility.SimpleProtocol import qualified Git import Git.Command-import Utility.ThreadScheduler+import Annex.ChangedRefs  import Control.Concurrent.STM import Control.Concurrent.Async@@ -37,7 +37,7 @@  transportUsingCmd' :: FilePath -> [CommandParam] -> Transport transportUsingCmd' cmd params (RemoteRepo r _) url transporthandle ichan ochan =-	robustly 1 $ do+	robustConnection 1 $ do 		(Just toh, Just fromh, Just errh, pid) <- 			createProcess (proc cmd (toCommand params)) 			{ std_in = CreatePipe@@ -68,23 +68,23 @@ 		send (DONESYNCING url ok) 		 	handlestdout fromh = do-		l <- hGetLine fromh-		case parseMessage l of+		ml <- getProtocolLine fromh+		case parseMessage =<< ml of 			Just SshRemote.READY -> do 				send (CONNECTED url) 				handlestdout fromh-			Just (SshRemote.CHANGED shas) -> do+			Just (SshRemote.CHANGED (ChangedRefs shas)) -> do 				whenM (checkNewShas transporthandle shas) $ 					fetch 				handlestdout fromh 			-- avoid reconnect on protocol error-			Nothing -> return Stopping+			Nothing -> return ConnectionStopping 	 	handlecontrol = do 		msg <- atomically $ readTChan ichan 		case msg of-			STOP -> return Stopping-			LOSTNET -> return Stopping+			STOP -> return ConnectionStopping+			LOSTNET -> return ConnectionStopping 			_ -> handlecontrol  	-- Old versions of git-annex-shell that do not support@@ -102,23 +102,5 @@ 					, "needs its git-annex upgraded" 					, "to 5.20140405 or newer" 					]-				return Stopping+				return ConnectionStopping 			else handlestderr errh--data Status = Stopping | ConnectionClosed--{- Make connection robustly, with exponential backoff on failure. -}-robustly :: Int -> IO Status -> IO ()-robustly backoff a = caught =<< catchDefaultIO ConnectionClosed a-  where-	caught Stopping = return ()-	caught ConnectionClosed = do-		threadDelaySeconds (Seconds backoff)-		robustly increasedbackoff a--	increasedbackoff-		| b2 > maxbackoff = maxbackoff-		| otherwise = b2-	  where-		b2 = backoff * 2-		maxbackoff = 3600 -- one hour

RemoteDaemon/Transport/Ssh/Types.hs view

@@ -16,11 +16,11 @@ ) where  import qualified Utility.SimpleProtocol as Proto-import RemoteDaemon.Types (RefList)+import Annex.ChangedRefs (ChangedRefs)  data Notification 	= READY-	| CHANGED RefList+	| CHANGED ChangedRefs  instance Proto.Sendable Notification where 	formatMessage READY = ["READY"]

+ RemoteDaemon/Transport/Tor.hs view

@@ -0,0 +1,173 @@+{- git-remote-daemon, tor hidden service server and transport+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module RemoteDaemon.Transport.Tor (server, transport) where++import Common+import qualified Annex+import Annex.Concurrent+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+import P2P.Annex+import P2P.Auth+import P2P.Address+import Annex.UUID+import Types.UUID+import Messages+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++	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+				return True+			)+		unless ok $ do+			hClose h+			warningIO "dropped Tor connection, too busy"++-- How many clients to serve at a time, maximum. This is to avoid DOS attacks.+maxConnections :: Int+maxConnections = 100++serveClient :: TransportHandle -> UUID -> Repo -> TBMQueue Handle -> IO ()+serveClient th u r q = bracket setup cleanup start+  where+	setup = do+		h <- atomically $ readTBMQueue q+		debugM "remotedaemon" "serving a Tor connection"+		return h+	+	cleanup Nothing = return ()+	cleanup (Just h) = do+		debugM "remotedaemon" "done with Tor connection"+		hClose h++	start Nothing = return ()+	start (Just h) = do+		-- Avoid doing any work in the liftAnnex, since only one+		-- can run at a time.+		st <- liftAnnex th dupState+		((), st') <- Annex.run st $ do+			-- Load auth tokens for every connection, to notice+			-- when the allowed set is changed.+			allowed <- loadP2PAuthTokens+			let conn = P2PConnection+				{ connRepo = r+				, connCheckAuth = (`isAllowedAuthToken` allowed)+				, connIhdl = h+				, connOhdl = h+				}+			v <- liftIO $ runNetProto conn $ P2P.serveAuth u+			case v of+				Right (Just theiruuid) -> authed conn theiruuid+				Right Nothing -> liftIO $+					debugM "remotedaemon" "Tor connection failed to authenticate"+				Left e -> liftIO $+					debugM "remotedaemon" ("Tor connection error before authentication: " ++ e)+		-- Merge the duplicated state back in.+		liftAnnex th $ mergeState st'+	+	authed conn theiruuid = +		bracket watchChangedRefs (liftIO . maybe noop stopWatchingChangedRefs) $ \crh -> do+			v' <- runFullProto (Serving theiruuid crh) conn $+				P2P.serveAuthed u+			case v' of+				Right () -> return ()+				Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error: " ++ e)++-- Connect to peer's tor hidden service.+transport :: Transport+transport (RemoteRepo r _) url@(RemoteURI uri) th ichan ochan =+	case unformatP2PAddress (show uri) of+		Nothing -> return ()+		Just addr -> robustConnection 1 $ do+			g <- liftAnnex th Annex.gitRepo+			bracket (connectPeer g addr) closeConnection (go addr)+  where+	go addr conn = do+		myuuid <- liftAnnex th getUUID+		authtoken <- fromMaybe nullAuthToken+			<$> liftAnnex th (loadP2PRemoteAuthToken addr)+		res <- runNetProto conn $+			P2P.auth myuuid authtoken+		case res of+			Right (Just theiruuid) -> do+				expecteduuid <- liftAnnex th $ getRepoUUID r+				if expecteduuid == theiruuid+					then do+						send (CONNECTED url)+						status <- handlecontrol+							`race` handlepeer conn+						send (DISCONNECTED url)+						return $ either id id status+					else return ConnectionStopping+			_ -> return ConnectionClosed+	+	send msg = atomically $ writeTChan ochan msg+	+	handlecontrol = do+		msg <- atomically $ readTChan ichan+		case msg of+			STOP -> return ConnectionStopping+			LOSTNET -> return ConnectionStopping+			_ -> handlecontrol++	handlepeer conn = do+		v <- runNetProto conn P2P.notifyChange+		case v of+			Right (Just (ChangedRefs shas)) -> do+				whenM (checkNewShas th shas) $+					fetch+				handlepeer conn+			_ -> return ConnectionClosed+	+	fetch = do+		send (SYNCING url)+		ok <- inLocalRepo th $+			runBool [Param "fetch", Param $ Git.repoDescribe r]+		send (DONESYNCING url ok)

RemoteDaemon/Types.hs view

@@ -5,7 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module RemoteDaemon.Types where@@ -15,6 +14,7 @@ import qualified Git.Types as Git import qualified Utility.SimpleProtocol as Proto import Types.GitConfig+import Annex.ChangedRefs (ChangedRefs)  import Network.URI import Control.Concurrent@@ -52,13 +52,11 @@ 	= PAUSE 	| LOSTNET 	| RESUME-	| CHANGED RefList+	| CHANGED ChangedRefs 	| RELOAD 	| STOP 	deriving (Show) -type RefList = [Git.Ref]- instance Proto.Sendable Emitted where 	formatMessage (CONNECTED remote) = 		["CONNECTED", Proto.serialize remote]@@ -99,14 +97,6 @@ instance Proto.Serializable RemoteURI where 	serialize (RemoteURI u) = show u 	deserialize = RemoteURI <$$> parseURI--instance Proto.Serializable [Char] where-	serialize = id-	deserialize = Just--instance Proto.Serializable RefList where-	serialize = unwords . map Git.fromRef-	deserialize = Just . map Git.Ref . words  instance Proto.Serializable Bool where 	serialize False = "0"

Setup.hs view

@@ -33,17 +33,19 @@  myPostCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () myPostCopy _ flags pkg lbi = when (System.Info.os /= "mingw32") $ do-	installGitAnnexShell dest verbosity pkg lbi+	installGitAnnexLinks dest verbosity pkg lbi 	installManpages      dest verbosity pkg lbi 	installDesktopFile   dest verbosity pkg lbi   where 	dest      = fromFlag $ copyDest flags 	verbosity = fromFlag $ copyVerbosity flags -installGitAnnexShell :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-installGitAnnexShell copyDest verbosity pkg lbi =+installGitAnnexLinks :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+installGitAnnexLinks copyDest verbosity pkg lbi = do 	rawSystemExit verbosity "ln" 		["-sf", "git-annex", dstBinDir </> "git-annex-shell"]+	rawSystemExit verbosity "ln"+		["-sf", "git-annex", dstBinDir </> "git-remote-tor-annex"]   where 	dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest

Types/Creds.hs view

@@ -11,4 +11,4 @@  type CredPair = (Login, Password) type Login = String-type Password = String -- todo: use securemem+type Password = String

Types/Key.hs view

@@ -27,6 +27,7 @@ import Common import Utility.QuickCheck import Utility.Bloom+import qualified Utility.SimpleProtocol as Proto  {- A Key has a unique name, which is derived from a particular backend,  - and may contain other optional metadata. -}@@ -128,6 +129,10 @@ instance FromJSON Key where 	parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t 	parseJSON _ = mempty++instance Proto.Serializable Key where+	serialize = key2file+	deserialize = file2key  instance Arbitrary Key where 	arbitrary = Key

Types/UUID.hs view

@@ -13,6 +13,8 @@ import qualified Data.UUID as U import Data.Maybe +import qualified Utility.SimpleProtocol as Proto+ -- A UUID is either an arbitrary opaque string, or UUID info may be missing. data UUID = NoUUID | UUID String 	deriving (Eq, Ord, Show, Read)@@ -35,3 +37,7 @@ isUUID = isJust . U.fromString  type UUIDMap = M.Map UUID String++instance Proto.Serializable UUID where+	serialize = fromUUID+	deserialize = Just . toUUID

+ Utility/AuthToken.hs view

@@ -0,0 +1,99 @@+{- authentication tokens+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.AuthToken (+	AuthToken,+	toAuthToken,+	fromAuthToken,+	nullAuthToken,+	genAuthToken,+	AllowedAuthTokens,+	allowedAuthTokens,+	isAllowedAuthToken,+) where++import qualified Utility.SimpleProtocol as Proto+import Utility.Hash++import Data.SecureMem+import Data.Maybe+import Data.Char+import Data.Byteable+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Lazy as L+import "crypto-api" Crypto.Random++-- | An AuthToken is stored in secue memory, with constant time comparison.+--+-- It can have varying length, depending on the security needs of the+-- application.+--+-- To avoid decoding issues, and presentation issues, the content+-- of an AuthToken is limited to ASCII characters a-z, and 0-9.+-- This is enforced by all exported AuthToken constructors.+newtype AuthToken = AuthToken SecureMem+	deriving (Show, Eq)++allowedChar :: Char -> Bool+allowedChar c = isAsciiUpper c || isAsciiLower c || isDigit c++instance Proto.Serializable AuthToken where+	serialize = T.unpack . fromAuthToken+	deserialize = toAuthToken . T.pack++fromAuthToken :: AuthToken -> T.Text+fromAuthToken (AuthToken t ) = TE.decodeLatin1 (toBytes t)++-- | Upper-case characters are lower-cased to make them fit in the allowed+-- character set. This allows AuthTokens to be compared effectively+-- case-insensitively. +--+-- Returns Nothing if any disallowed characters are present.+toAuthToken :: T.Text -> Maybe AuthToken+toAuthToken t+	| all allowedChar s = Just $ AuthToken $ +		secureMemFromByteString $ TE.encodeUtf8 $ T.pack s+	| otherwise = Nothing+  where+	s = map toLower $ T.unpack t++-- | The empty AuthToken, for those times when you don't want any security.+nullAuthToken :: AuthToken+nullAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 T.empty++-- | Generates an AuthToken of a specified length. This is done by+-- generating a random bytestring, hashing it with sha2 512, and truncating+-- to the specified length.+--+-- That limits the maximum length to 128, but with 512 bytes of entropy,+-- that should be sufficient for any application.+genAuthToken :: Int -> IO AuthToken+genAuthToken len = do+	g <- newGenIO :: IO SystemRandom+	return $+		case genBytes 512 g of+			Left e -> error $ "failed to generate auth token: " ++ show e+			Right (s, _) -> fromMaybe (error "auth token encoding failed") $+				toAuthToken $ T.pack $ take len $+					show $ sha2_512 $ L.fromChunks [s]++-- | For when several AuthTokens are allowed to be used.+newtype AllowedAuthTokens = AllowedAuthTokens [AuthToken]++allowedAuthTokens :: [AuthToken] -> AllowedAuthTokens+allowedAuthTokens = AllowedAuthTokens++-- | Note that every item in the list is checked, even if the first one+-- is allowed, so that comparison is constant-time.+isAllowedAuthToken :: AuthToken -> AllowedAuthTokens -> Bool+isAllowedAuthToken t (AllowedAuthTokens l) = go False l+  where+	go ok [] = ok+	go ok (i:is)+		| t == i = go True is+		| otherwise = go ok is

Utility/Metered.hs view

@@ -1,11 +1,11 @@ {- Metered IO and actions  -- - Copyright 2012-2106 Joey Hess <id@joeyh.name>+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} -{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, BangPatterns #-}  module Utility.Metered where @@ -85,12 +85,15 @@  {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()-meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite meterupdate h = void . meteredWrite' meterupdate h++meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed+meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks    where-	go _ [] = return ()+	go sofar [] = return sofar 	go sofar (c:cs) = do 		S.hPut h c-		let sofar' = addBytesProcessed sofar $ S.length c+		let !sofar' = addBytesProcessed sofar $ S.length c 		meterupdate sofar' 		go sofar' cs @@ -112,30 +115,30 @@  - meter updates, so use caution.  -} hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString-hGetContentsMetered h = hGetUntilMetered h (const True)+hGetContentsMetered h = hGetMetered h Nothing -{- Reads from the Handle, updating the meter after each chunk.+{- Reads from the Handle, updating the meter after each chunk is read.  -+ - Stops at EOF, or when the requested number of bytes have been read.+ - Closes the Handle at EOF, but otherwise leaves it open.+ -  - Note that the meter update is run in unsafeInterleaveIO, which means that  - it can be run at any time. It's even possible for updates to run out  - of order, as different parts of the ByteString are consumed.- -- - Stops at EOF, or when keepgoing evaluates to False.- - Closes the Handle at EOF, but otherwise leaves it open.  -}-hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString-hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed+hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString+hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed   where 	lazyRead sofar = unsafeInterleaveIO $ loop sofar  	loop sofar = do-		c <- S.hGet h defaultChunkSize+		c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) 		if S.null c 			then do 				hClose h 				return $ L.empty 			else do-				let sofar' = addBytesProcessed sofar (S.length c)+				let !sofar' = addBytesProcessed sofar (S.length c) 				meterupdate sofar' 				if keepgoing (fromBytesProcessed sofar') 					then do@@ -145,6 +148,18 @@ 						cs <- lazyRead sofar' 						return $ L.append (L.fromChunks [c]) cs 					else return $ L.fromChunks [c]+	+	keepgoing n = case wantsize of+		Nothing -> True+		Just sz -> n < sz+	+	nextchunksize n = case wantsize of+		Nothing -> defaultChunkSize+		Just sz -> +			let togo = sz - n+			in if togo < toInteger defaultChunkSize+				then fromIntegral togo+				else defaultChunkSize  {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int

Utility/SimpleProtocol.hs view

@@ -1,10 +1,13 @@ {- Simple line-based protocols.  -- - Copyright 2013-2014 Joey Hess <id@joeyh.name>+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} +{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Utility.SimpleProtocol ( 	Sendable(..), 	Receivable(..),@@ -17,10 +20,12 @@ 	parse2, 	parse3, 	dupIoHandles,+	getProtocolLine, ) where  import Data.Char import GHC.IO.Handle+import System.Exit (ExitCode(..))  import Common @@ -44,6 +49,16 @@ 	serialize :: a -> String 	deserialize :: String -> Maybe a +instance Serializable [Char] where+	serialize = id+	deserialize = Just++instance Serializable ExitCode where+	serialize ExitSuccess = "0"+	serialize (ExitFailure n) = show n+	deserialize "0" = Just ExitSuccess+	deserialize s = ExitFailure <$> readish s+ {- Parsing the parameters of messages. Using the right parseN ensures  - that the string is split into exactly the requested number of words,  - which allows the last parameter of a message to contain arbitrary@@ -88,3 +103,26 @@ 	nullh `hDuplicateTo` stdin 	stderr `hDuplicateTo` stdout 	return (readh, writeh)++{- Reads a line, but to avoid super-long lines eating memory, returns+ - Nothing if 32 kb have been read without seeing a '\n'+ -+ - If there is a '\r' before the '\n', it is removed, to support+ - systems using "\r\n" at ends of lines + -+ - This implementation is not super efficient, but as long as the Handle+ - supports buffering, it avoids reading a character at a time at the+ - syscall level.+ -}+getProtocolLine :: Handle -> IO (Maybe String)+getProtocolLine h = go (32768 :: Int) []+  where+	go 0 _ = return Nothing+	go n l = do+		c <- hGetChar h+		if c == '\n'+			then return $ Just $ reverse $ +				case l of+					('\r':rest) -> rest+					_ -> l+			else go (n-1) (c:l)

+ Utility/Tor.hs view

@@ -0,0 +1,144 @@+{- tor interface+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Tor where++import Common+import Utility.ThreadScheduler+import Utility.FileMode++import System.PosixCompat.Types+import Data.Char+import Network.Socket+import Network.Socks5+import qualified Data.ByteString.UTF8 as BU8+import qualified System.Random as R++type OnionPort = Int++newtype OnionAddress = OnionAddress String+	deriving (Show, Eq)++type OnionSocket = FilePath++type UniqueIdent = String++connectHiddenService :: OnionAddress -> OnionPort -> IO Socket+connectHiddenService (OnionAddress address) port = do+	(s, _) <- socksConnect torsockconf socksaddr+	return s+  where+	torsocksport = 9050+	torsockconf = defaultSocksConf "127.0.0.1" torsocksport+	socksdomain = SocksAddrDomainName (BU8.fromString address)+	socksaddr = SocksAddress socksdomain (fromIntegral port)++-- | Adds a hidden service connecting to localhost, using some kind+-- of unique identifier.+--+-- This will only work if run as root, and tor has to already be running.+--+-- Picks a random high port number for the hidden service that is not+-- used by any other hidden service. Returns the hidden service's+-- onion address, port, and the unix socket file to use.+-- +-- 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+	let portssocks = mapMaybe (parseportsock . separate isSpace) ls+	case filter (\(_, s) -> s == sockfile) portssocks of+		((p, _s):_) -> waithiddenservice 1 p+		_ -> do+			highports <- R.getStdRandom mkhighports+			let newport = Prelude.head $+				filter (`notElem` map fst portssocks) highports+			writeFile torrc $ unlines $+				ls +++				[ ""+				, "HiddenServiceDir " ++ hiddenServiceDir uid ident+				, "HiddenServicePort " ++ show newport ++ +					" unix:" ++ sockfile+				]+			-- Reload tor, so it will see the new hidden+			-- service and generate the hostname file for it.+			reloaded <- anyM (uncurry boolSystem)+				[ ("systemctl", [Param "reload", Param "tor"])+				, ("sefvice", [Param "tor", Param "reload"])+				]+			unless reloaded $+				giveup "failed to reload tor, perhaps the tor service is not running"+			waithiddenservice 120 newport+  where+	parseportsock ("HiddenServicePort", l) = do+		p <- readish $ takeWhile (not . isSpace) l+		return (p, drop 1 (dropWhile (/= ':') l))+	parseportsock _ = Nothing+	+	sockfile = hiddenServiceSocketFile uid ident++	-- An infinite random list of high ports.+	mkhighports g = +		let (g1, g2) = R.split g+		in (R.randomRs (1025, 65534) g1, g2)++	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+		case v of+			Right s | ".onion\n" `isSuffixOf` s ->+				return (OnionAddress (takeWhile (/= '\n') s), p)+			_ -> do+				threadDelaySeconds (Seconds 1)+				waithiddenservice (n-1) p++-- | 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++hiddenServiceHostnameFile :: UserID -> UniqueIdent -> FilePath+hiddenServiceHostnameFile uid ident = hiddenServiceDir 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.+--+-- 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"++-- | Sets up the directory for the socketFile, with appropriate+-- permissions. Must run as root.+prepHiddenServiceSocketDir :: UserID -> UniqueIdent -> IO ()+prepHiddenServiceSocketDir uid ident = do+	createDirectoryIfMissing True d+	setOwnerAndGroup d uid (-1)+	modifyFileMode d $+		addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]+  where+	d = takeDirectory $ hiddenServiceSocketFile uid ident++torrc :: FilePath+torrc = "/etc/tor/torrc"++libDir :: FilePath+libDir = "/var/lib/tor"++etcDir :: FilePath+etcDir = "/etc/tor"

Utility/Url.hs view

@@ -350,8 +350,16 @@  -  - > catchJust (matchStatusCodeException (== notFound404))  -}+#if MIN_VERSION_http_client(0,5,0) matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException+matchStatusCodeException want e@(HttpExceptionRequest _ (StatusCodeException r _))+	| want (responseStatus r) = Just e+	| otherwise = Nothing+matchStatusCodeException _ _ = Nothing+#else+matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException matchStatusCodeException want e@(StatusCodeException s _ _) 	| want s = Just e 	| otherwise = Nothing matchStatusCodeException _ _ = Nothing+#endif

Utility/WebApp.hs view

@@ -12,7 +12,7 @@ import Common import Utility.Tmp import Utility.FileMode-import Utility.Hash+import Utility.AuthToken  import qualified Yesod import qualified Network.Wai as Wai@@ -23,7 +23,6 @@ import Network.Socket import "crypto-api" Crypto.Random import qualified Web.ClientSession as CS-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -31,8 +30,6 @@ import Blaze.ByteString.Builder (Builder) import Control.Arrow ((***)) import Control.Concurrent-import Data.SecureMem-import Data.Byteable #ifdef __ANDROID__ import Data.Endian #endif@@ -159,24 +156,6 @@ 		Just . Yesod.clientSessionBackend key . fst 			<$> Yesod.clientSessionDateCacher timeout -type AuthToken = SecureMem--toAuthToken :: T.Text -> AuthToken-toAuthToken = secureMemFromByteString . TE.encodeUtf8--fromAuthToken :: AuthToken -> T.Text-fromAuthToken = TE.decodeLatin1 . toBytes--{- Generates a random sha2_512 string, encapsulated in a SecureMem,- - suitable to be used for an authentication secret. -}-genAuthToken :: IO AuthToken-genAuthToken = do-	g <- newGenIO :: IO SystemRandom-	return $-		case genBytes 512 g of-			Left e -> error $ "failed to generate auth token: " ++ show e-			Right (s, _) -> toAuthToken $ T.pack $ show $ sha2_512 $ L.fromChunks [s]- {- A Yesod isAuthorized method, which checks the auth cgi parameter  - against a token extracted from the Yesod application.  -@@ -193,7 +172,7 @@ 		webapp <- Yesod.getYesod 		req <- Yesod.getRequest 		let params = Yesod.reqGetParams req-		if (toAuthToken <$> lookup "auth" params) == Just (extractAuthToken webapp)+		if (toAuthToken =<< lookup "auth" params) == Just (extractAuthToken webapp) 			then return Yesod.Authorized 			else Yesod.sendResponseStatus unauthorized401 ()

doc/git-annex-add.mdwn view

@@ -15,9 +15,9 @@ Files that are already checked into git and are unmodified, or that git has been configured to ignore will be silently skipped. -If annex.largefiles is configured, and does not match a file, `git annex-add` will behave the same as `git add` and add the non-large file directly-to the git repository, instead of to the annex.+If annex.largefiles is configured, and does not match a file, +`git annex add` will behave the same as `git add` and add the+non-large file directly to the git repository, instead of to the annex.  Large files are added to the annex in locked form, which prevents further modification of their content unless unlocked by [[git-annex-unlock]](1).

+ doc/git-annex-enable-tor.mdwn view

@@ -0,0 +1,32 @@+# NAME++git-annex enable-tor - enable tor hidden service++# SYNOPSIS++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`++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+give other users access to your repository via the tor hidden service.++# SEE ALSO++[[git-annex]](1)++[[git-annex-p2p-auth]](1)++[[git-annex-remotedaemon]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.

doc/git-annex-fromkey.mdwn view

@@ -4,14 +4,16 @@  # SYNOPSIS -git annex fromkey `[key file]`+git annex fromkey `[key file ...]`  # DESCRIPTION  This plumbing-level command can be used to manually set up a file in the git repository to link to a specified key. -If the key and file are not specified on the command line, they are+Multiple pairs of file and key can be given in a single command line.++If no key and file pair are specified on the command line, they are instead read from stdin. Any number of lines can be provided in this mode, each containing a key and filename, separated by a single space. @@ -26,7 +28,7 @@ * `--force`    Allow making a file link to a key whose content is not in the local-  repository. The key may not be known to git-annex at all.  +  repository. The key may not be known to git-annex at all.  # SEE ALSO

doc/git-annex-map.mdwn view

@@ -10,8 +10,8 @@  Helps you keep track of your repositories, and the connections between them, by going out and looking at all the ones it can get to, and generating a-Graphviz file displaying it all. If the `dot` command is available, it is-used to display the file to your screen (using x11 backend).+Graphviz file displaying it all. If the `xdot` or `dot` command is available,+it is used to display the file to your screen.    This command only connects to hosts that the host it's run on can directly connect to. It does not try to tunnel through intermediate hosts.@@ -37,7 +37,7 @@  * `--fast` -  Disable using `dot` to display the generated Graphviz file.+  Don't display the generated Graphviz file, but save it for later use.  # SEE ALSO

+ doc/git-annex-p2p.mdwn view

@@ -0,0 +1,45 @@+# NAME++git-annex p2p - configure peer-2-peer links between repositories++# SYNOPSIS++git annex p2p [options]++# DESCRIPTION++This command can be used to link git-annex repositories over peer-2-peer+networks.++Currently, the only P2P network supported by git-annex is Tor hidden+services.++# OPTIONS++* `--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.++* `--link remotename`++  Sets up a git remote with the specified remotename 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.++# SEE ALSO++[[git-annex]](1)++[[git-annex-enable-tor]](1)++[[git-annex-remotedaemon]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.

doc/git-annex-rekey.mdwn view

@@ -20,7 +20,11 @@   Allow rekeying of even files whose content is not currently available.   Use with caution. -# OPTIONS+* `--batch`++  Enables batch mode, in which lines are read from stdin.+  Each line should contain the file, and the new key to use for that file,+  separated by a single space.  # SEE ALSO

doc/git-annex-remotedaemon.mdwn view

@@ -1,6 +1,6 @@ # NAME -git-annex remotedaemon - detects when remotes have changed, and fetches from them+git-annex remotedaemon - persistent communication with remotes  # SYNOPSIS @@ -8,24 +8,48 @@  # DESCRIPTION -This plumbing-level command is used by the assistant to detect-when remotes have received git pushes, so the changes can be promptly-fetched and the local repository updated.+The remotedaemon provides persistent communication with remotes.+It detects when git branches on remotes have changes, and fetches+the changes from them. -This is a better alternative to the [[git-annex-xmppgit]](1)-hack.+The assistant runs the remotedaemon and communicates with it on+stdio using a simple textual protocol. -For the remotedaemon to work, the git remote must have-[[git-annex-shell]](1) installed, with notifychanges support.-The first version of git-annex-shell that supports it is 5.20140405.+Several types of remotes are supported: -It's normal for this process to be running when the assistant is running.+For ssh remotes, the remotedaemon tries to maintain a connection to the+remote git repository, and uses git-annex-shell notifychanges to detect+when the remote git repository has changed. For this to work, the git+remote must have [[git-annex-shell]](1) installed, with notifychanges+support. The first version of git-annex-shell that supports it is+5.20140405. +For tor-annex remotes, the remotedaemon runs a tor hidden service,+accepting connections from other nodes and serving up the contents of the+repository. This is only done if you first run `git annex enable-tor`.+Use `git annex p2p` to configure access to tor-annex remotes.++# OPTIONS++* `--foreground`++Don't fork to the background, and communicate on stdin/stdout using a+simple textual protocol. The assistant runs the remotedaemon this way.++Commands in the protocol include LOSTNET, which tells the remotedaemon+that the network connection has been lost, and causes it to stop any TCP+connctions. That can be followed by RESUME when the network connection+comes back up.+ # SEE ALSO  [[git-annex]](1)  [[git-annex-assistant]](1)++[[git-annex-enable-tor]](1)++[[git-annex-p2p]](1)  # AUTHOR

doc/git-annex-rmurl.mdwn view

@@ -4,11 +4,19 @@  # SYNOPSIS -git annex rmurl `file url`+git annex rmurl `[file url ..]`  # DESCRIPTION  Record that the file is no longer available at the url.++# OPTIONS++* `--batch`++  Enables batch mode, in which lines are read from stdin.+  Each line should contain the file, and the url to remove from that file,+  separated by a single space.  # SEE ALSO

doc/git-annex.mdwn view

@@ -212,6 +212,12 @@      See [[git-annex-enableremote]](1) for details. +* `enable-tor`++  Sets up tor hidden service.+  +  See [[git-annex-enable-tor]](1) for details.+ * `numcopies [N]`    Configure desired number of copies.@@ -379,6 +385,18 @@      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.++  See [[git-annex-p2p]](1) for details.+ # QUERY COMMANDS  * `find [path ...]`@@ -651,12 +669,6 @@   of being symlinks.    See [[git-annex-smudge]](1) for details.--* `remotedaemon`--  Detects when network remotes have received git pushes and fetches from them.--  See [[git-annex-remotedaemon]](1) for details.  * `xmppgit`

+ doc/git-remote-tor-annex.mdwn view

@@ -0,0 +1,36 @@+# NAME++git-remote-tor-annex - remote helper program to talk to git-annex over tor++# SYNOPSIS++git fetch tor-annex::address.onion:port++git remote add tor tor-annex::address.onion:port++# DESCRIPTION++This is a git remote helper program that allows git to pull and push+over tor(1), communicating with a tor hidden service.++The tor hidden service probably requires an authtoken to use it.+The authtoken can be provided in the environment variable+`GIT_ANNEX_P2P_AUTHTOKEN`. Or, if there is a file in +`.git/annex/creds/` matching the onion address of the hidden+service, its first line is used as the authtoken.++# SEE ALSO++git-remote-helpers(1)++[[git-annex]](1)++[[git-annex-enable-tor]](1)++[[git-annex-remotedaemon]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.

git-annex.cabal view

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20161118+Version: 6.20161210 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -59,6 +59,7 @@   doc/git-annex-dropunused.mdwn   doc/git-annex-edit.mdwn   doc/git-annex-enableremote.mdwn+  doc/git-annex-enable-tor.mdwn   doc/git-annex-examinekey.mdwn   doc/git-annex-expire.mdwn   doc/git-annex-find.mdwn@@ -90,6 +91,7 @@   doc/git-annex-mirror.mdwn   doc/git-annex-move.mdwn   doc/git-annex-numcopies.mdwn+  doc/git-annex-p2p.mdwn   doc/git-annex-pre-commit.mdwn   doc/git-annex-preferred-content.mdwn   doc/git-annex-proxy.mdwn@@ -136,6 +138,7 @@   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   Build/mdwn2man@@ -342,6 +345,7 @@    MissingH,    hslogger,    monad-logger,+   free,    utf8-string,    bytestring,    text,@@ -353,8 +357,7 @@    resourcet,    http-client,    http-types,-   -- Old version needed due to https://github.com/aristidb/aws/issues/206-   http-conduit (<2.2.0),+   http-conduit,    time,    old-locale,    esqueleto,@@ -364,7 +367,11 @@    aeson,    unordered-containers,    feed,-   regex-tdfa+   regex-tdfa,+   socks,+   byteable,+   stm-chans,+   securemem   CC-Options: -Wall   GHC-Options: -Wall -fno-warn-tabs   Extensions: PackageImports@@ -467,9 +474,7 @@      crypto-api,      clientsession,      template-haskell,-     shakespeare (>= 2.0.0),-     securemem,-     byteable+     shakespeare (>= 2.0.0)     CPP-Options: -DWITH_WEBAPP    if flag(Pairing)@@ -508,6 +513,7 @@     Annex.Branch.Transitions     Annex.BranchState     Annex.CatFile+    Annex.ChangedRefs     Annex.CheckAttr     Annex.CheckIgnore     Annex.Common@@ -699,6 +705,7 @@     CmdLine.GitAnnexShell.Fields     CmdLine.GlobalSetter     CmdLine.Option+    CmdLine.GitRemoteTorAnnex     CmdLine.Seek     CmdLine.Usage     Command@@ -722,6 +729,7 @@     Command.DropKey     Command.DropUnused     Command.EnableRemote+    Command.EnableTor     Command.ExamineKey     Command.Expire     Command.Find@@ -757,6 +765,7 @@     Command.Move     Command.NotifyChanges     Command.NumCopies+    Command.P2P     Command.PreCommit     Command.Proxy     Command.ReKey@@ -899,6 +908,11 @@     Messages.Internal     Messages.JSON     Messages.Progress+    P2P.Address+    P2P.Annex+    P2P.Auth+    P2P.IO+    P2P.Protocol     Remote     Remote.BitTorrent     Remote.Bup@@ -923,6 +937,7 @@     Remote.Helper.Ssh     Remote.Hook     Remote.List+    Remote.P2P     Remote.Rsync     Remote.Rsync.RsyncUrl     Remote.S3@@ -934,6 +949,7 @@     RemoteDaemon.Core     RemoteDaemon.Transport     RemoteDaemon.Transport.GCrypt+    RemoteDaemon.Transport.Tor     RemoteDaemon.Transport.Ssh     RemoteDaemon.Transport.Ssh.Types     RemoteDaemon.Types@@ -980,6 +996,7 @@     Upgrade.V4     Upgrade.V5     Utility.Applicative+    Utility.AuthToken     Utility.Base64     Utility.Batch     Utility.Bloom@@ -1060,6 +1077,7 @@     Utility.ThreadLock     Utility.ThreadScheduler     Utility.Tmp+    Utility.Tor     Utility.Touch     Utility.Url     Utility.UserInfo

git-annex.hs view

@@ -1,6 +1,6 @@ {- git-annex main program dispatch  -- - Copyright 2010-2014 Joey Hess <id@joeyh.name>+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,6 +13,7 @@  import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell+import qualified CmdLine.GitRemoteTorAnnex import qualified Test  #ifdef mingw32_HOST_OS@@ -23,20 +24,15 @@ main :: IO () main = withSocketsDo $ do 	ps <- getArgs-	run ps =<< getProgName-  where-	run ps n-		| isshell n = CmdLine.GitAnnexShell.run ps-		| otherwise = #ifdef mingw32_HOST_OS-			do-				winEnv-				gitannex ps-#else-			gitannex ps+	winEnv #endif-	gitannex = CmdLine.GitAnnex.run Test.optParser Test.runner-	isshell n = takeFileName n == "git-annex-shell"+	run ps =<< getProgName+  where+	run ps n = case takeFileName n of+		"git-annex-shell" -> CmdLine.GitAnnexShell.run ps+		"git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps+		_  -> CmdLine.GitAnnex.run Test.optParser Test.runner ps  #ifdef mingw32_HOST_OS {- On Windows, if HOME is not set, probe it and set it.