diff options
49 files changed, 2275 insertions, 129 deletions
diff --git a/Annex/Notification.hs b/Annex/Notification.hs index 4f492878b..e61b362ad 100644 --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -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 @@ -21,6 +21,10 @@ import qualified DBus.Client -- 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 - for it. -} diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index 02799db85..0fd24f023 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -13,12 +13,11 @@ import Types.Remote (RemoteConfig, RemoteConfigKey, typename, setup) 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. - - Prefer remotes that are not dead when a name appears multiple times. -} diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs index 447b493c6..1aa8bc9c8 100644 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -30,7 +30,7 @@ remoteControlThread :: NamedThread 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 diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index f9a456f35..a5cd38504 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -39,6 +39,7 @@ import Assistant.WebApp.OtherRepos 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 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost #endif webapp <- WebApp <$> pure assistantdata - <*> genAuthToken + <*> genAuthToken 128 <*> getreldir <*> pure staticRoutes <*> pure postfirstrun diff --git a/Build/Mans.hs b/Build/Mans.hs index cf86d983d..2ea9b4197 100644 --- a/Build/Mans.hs +++ b/Build/Mans.hs @@ -50,8 +50,11 @@ buildMans = do 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" @@ -1,5 +1,12 @@ git-annex (6.20161119) UNRELEASED; 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. diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index e989f3f43..a12366b74 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -52,6 +52,7 @@ import qualified Command.Init 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.Direct 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 @@ import qualified Command.WebApp #ifdef WITH_XMPP import qualified Command.XMPPGit #endif -import qualified Command.RemoteDaemon #endif import qualified Command.Test #ifdef WITH_TESTSUITE @@ -142,6 +144,7 @@ cmds testoptparser testrunner = , 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 @@ cmds testoptparser testrunner = , 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 @@ cmds testoptparser testrunner = #ifdef WITH_XMPP , Command.XMPPGit.cmd #endif - , Command.RemoteDaemon.cmd #endif , Command.Test.cmd testoptparser testrunner #ifdef WITH_TESTSUITE diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs new file mode 100644 index 000000000..c4bf26c85 --- /dev/null +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -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 + res <- connectService onionaddress onionport service + exitWith (fromMaybe (ExitFailure 1) res) + 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 (Maybe 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 diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index e1af8bb7a..61cd543e6 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -12,6 +12,7 @@ import qualified Annex 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 @@ start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes =<< 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 @@ startNormalRemote name r = do 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 diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs new file mode 100644 index 000000000..d24ecb2dc --- /dev/null +++ b/Command/EnableTor.hs @@ -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 diff --git a/Command/P2P.hs b/Command/P2P.hs new file mode 100644 index 000000000..21632f3da --- /dev/null +++ b/Command/P2P.hs @@ -0,0 +1,98 @@ +{- 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` giveup "Unable to connect with peer. Please check that the peer is connected to the network, and try again." + u <- getUUID + v <- liftIO $ runNetProto conn $ P2P.auth u authtoken + case v of + Just (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 + _ -> giveup "Unable to authenticate with peer. Please check the address and try again." diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 97aa602e7..7d2da9420 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -16,8 +16,7 @@ import Types.KeySource 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 diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 7c7ecef4b..c17417104 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -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 @@ -15,6 +15,7 @@ module Creds ( getEnvCredPair, writeCacheCreds, readCacheCreds, + cacheCredsFile, removeCreds, includeCredsInfo, ) where @@ -156,7 +157,7 @@ readCacheCredPair storage = maybe Nothing decodeCredPair <$> 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 @@ -55,6 +55,7 @@ install-bins: build install -d $(DESTDIR)$(PREFIX)/bin install git-annex $(DESTDIR)$(PREFIX)/bin ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell + ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-remote-tor-annex install-misc: Build/InstallDesktopFile ./Build/InstallDesktopFile $(PREFIX)/bin/git-annex || true @@ -133,6 +134,7 @@ linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs cp git-annex "$(LINUXSTANDALONE_DEST)/bin/" strip "$(LINUXSTANDALONE_DEST)/bin/git-annex" ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell" + ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-remote-tor-annex" zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE cp doc/logo_16x16.png doc/logo.svg $(LINUXSTANDALONE_DEST) cp standalone/trustedkeys.gpg $(LINUXSTANDALONE_DEST) @@ -194,6 +196,7 @@ osxapp: Build/Standalone Build/OSXMkLibs cp git-annex "$(OSXAPP_BASE)" strip "$(OSXAPP_BASE)/git-annex" ln -sf git-annex "$(OSXAPP_BASE)/git-annex-shell" + ln -sf git-annex "$(OSXAPP_BASE)/git-remote-tor-annex" gzcat standalone/licences.gz > $(OSXAPP_BASE)/LICENSE cp $(OSXAPP_BASE)/LICENSE tmp/build-dmg/LICENSE.txt cp standalone/trustedkeys.gpg $(OSXAPP_DEST)/Contents/MacOS diff --git a/P2P/Address.hs b/P2P/Address.hs new file mode 100644 index 000000000..09ffc7973 --- /dev/null +++ b/P2P/Address.hs @@ -0,0 +1,89 @@ +{- 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) = + "tor-annex::" ++ onionaddr ++ ":" ++ show onionport + unformatP2PAddress s + | "tor-annex::" `isPrefixOf` s = do + let s' = dropWhile (== ':') $ dropWhile (/= ':') s + let (onionaddr, ps) = separate (== ':') s' + onionport <- readish ps + return (TorAnnex (OnionAddress onionaddr) onionport) + | otherwise = Nothing + +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" diff --git a/P2P/Annex.hs b/P2P/Annex.hs new file mode 100644 index 000000000..4105abe32 --- /dev/null +++ b/P2P/Annex.hs @@ -0,0 +1,128 @@ +{- 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 P2P.Protocol +import P2P.IO +import Logs.Location +import Types.NumCopies + +import Control.Monad.Free +import qualified Data.ByteString.Lazy as L + +-- When we're serving a peer, we know their uuid, and can use it to update +-- transfer logs. +data RunMode + = Serving UUID + | Client + +-- Full interpreter for Proto, that can receive and send objects. +runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Maybe a) +runFullProto runmode conn = go + where + go :: RunProto Annex + go (Pure v) = pure (Just 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 (Maybe 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)) + -- TODO transfer log not updated + ReadContent k af (Offset o) next -> do + v <- tryNonAsync $ prepSendAnnex k + case v of + -- The check can detect a problem after the + -- content is sent, 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 $ + liftIO $ do + h <- openBinaryFile f ReadMode + when (o /= 0) $ + hSeek h AbsoluteSeek o + L.hGetContents h + case v' of + Left _ -> return Nothing + Right b -> runner (next b) + _ -> return Nothing + StoreContent k af o l b next -> do + ok <- flip catchNonAsync (const $ return False) $ + transfer download k af $ + getViaTmp AlwaysVerify k $ \tmp -> + unVerified $ storefile tmp o l b + runner (next ok) + StoreContentTo dest o l b next -> do + ok <- flip catchNonAsync (const $ return False) $ + storefile dest o l b + runner (next ok) + SetPresent k u next -> do + v <- tryNonAsync $ logChange k u InfoPresent + case v of + Left _ -> return Nothing + Right () -> runner next + CheckContentPresent k next -> do + v <- tryNonAsync $ inAnnex k + case v of + Left _ -> return Nothing + Right result -> runner (next result) + RemoveContent k next -> do + v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do + removeAnnex contentlock + logStatus k InfoMissing + return True + case v of + Left _ -> return Nothing + 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 + where + transfer mk k af ta = case runmode of + -- Update transfer logs when serving. + Serving theiruuid -> + mk theiruuid k af noRetry (const ta) noNotification + -- Transfer logs are updated higher in the stack when + -- a client. + Client -> ta + storefile dest (Offset o) (Len l) b = liftIO $ do + withBinaryFile dest WriteMode $ \h -> do + when (o /= 0) $ + hSeek h AbsoluteSeek o + L.hPut h b + sz <- getFileSize dest + return (toInteger sz == l) diff --git a/P2P/Auth.hs b/P2P/Auth.hs new file mode 100644 index 000000000..0025957c7 --- /dev/null +++ b/P2P/Auth.hs @@ -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 diff --git a/P2P/IO.hs b/P2P/IO.hs new file mode 100644 index 000000000..ea15ecfc3 --- /dev/null +++ b/P2P/IO.hs @@ -0,0 +1,285 @@ +{- 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 + +-- Type of interpreters of the Proto free monad. +type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Maybe 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 (Maybe a) +runNetProto conn = go + where + go :: RunProto IO + go (Pure v) = pure (Just v) + go (Free (Net n)) = runNet conn go n + go (Free (Local _)) = return Nothing + +-- 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 (Maybe a) +runNet conn runner f = case f of + SendMessage m next -> do + v <- liftIO $ tryNonAsync $ do + hPutStrLn (connOhdl conn) (unwords (formatMessage m)) + hFlush (connOhdl conn) + case v of + Left _e -> return Nothing + Right () -> runner next + ReceiveMessage next -> do + v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn) + case v of + Left _e -> return Nothing + Right l -> case parseMessage l of + Just 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 + _ -> return Nothing + ReceiveBytes len p next -> do + v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p + case v of + Left _e -> return Nothing + 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 + Nothing -> return Nothing + Just exitcode -> runner (next exitcode) + RelayService service next -> do + v <- liftIO $ runRelayService conn runnerio service + case v of + Nothing -> return Nothing + Just () -> 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 + +-- 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 (Maybe ExitCode) +runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go + where + setup = do + v <- newEmptyMVar + void $ async $ relayFeeder runner v + void $ async $ relayReader v hout + return v + + cleanup _ = do + hClose hin + hClose hout + + go v = relayHelper runner v hin + +runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Maybe ()) +runRelayService conn runner service = bracket setup cleanup go + 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 + 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, _, hin, _, _) = do + r <- relayHelper runner v hin + case r of + Nothing -> return Nothing + Just 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 -> Handle -> IO (Maybe ExitCode) +relayHelper runner v hin = loop + where + loop = do + d <- takeMVar v + case d of + RelayFromPeer b -> do + L.hPut hin b + hFlush hin + loop + RelayToPeer b -> do + r <- runner $ net $ relayToPeer (RelayToPeer b) + case r of + Nothing -> return Nothing + Just () -> loop + RelayDone exitcode -> do + _ <- runner $ net $ relayToPeer (RelayDone exitcode) + return (Just exitcode) + +-- Takes input from the peer, and puts it into the MVar for processing. +-- Repeats until the peer tells it it's done or hangs up. +relayFeeder :: RunProto IO -> MVar RelayData -> IO () +relayFeeder runner v = loop + where + loop = do + mrd <- runner $ net relayFromPeer + case mrd of + Nothing -> putMVar v (RelayDone (ExitFailure 1)) + Just rd -> do + putMVar v rd + case rd of + RelayDone _ -> return () + _ -> loop + +-- 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 diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs new file mode 100644 index 000000000..b1e2bf481 --- /dev/null +++ b/P2P/Protocol.hs @@ -0,0 +1,461 @@ +{- 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 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 + +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 + | 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 (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 "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 -> c) + -- ^ Lazily reads the content of a key. Note that the content + -- may change while it's being sent. + | StoreContent Key AssociatedFile Offset Len 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 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. + 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 + return ServerContinue + handler _ = return ServerUnexpected + +sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool +sendContent key af offset p = do + (len, content) <- readContentLen key af offset + net $ sendMessage (DATA len) + net $ sendBytes len content p + checkSuccess + +receiveContent :: MeterUpdate -> Local Len -> (Offset -> Len -> L.ByteString -> Local Bool) -> (Offset -> Message) -> Proto Bool +receiveContent p sizer storer mkmsg = do + Len n <- local sizer + 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 + +-- Reads content from an offset. The Len should correspond to +-- the length of the ByteString, but to avoid buffering the content +-- in memory, is gotten using contentSize. +readContentLen :: Key -> AssociatedFile -> Offset -> Proto (Len, L.ByteString) +readContentLen key af (Offset offset) = go =<< local (contentSize key) + where + go Nothing = return (Len 0, L.empty) + go (Just (Len totallen)) = do + let len = totallen - offset + if len <= 0 + then return (Len 0, L.empty) + else do + content <- local $ + readContent key af (Offset offset) + return (Len len, content) + +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 () diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 2306989bb..ef8724ee7 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -250,14 +250,6 @@ instance Proto.Serializable Direction where 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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 3304e2069..41fb46e82 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -49,6 +49,8 @@ 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 +132,9 @@ configRead autoinit r = do 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 diff --git a/Remote/List.hs b/Remote/List.hs index 9c231b124..a5e305622 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -23,6 +23,7 @@ import qualified Git.Config 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 :: [RemoteType] remoteTypes = [ Remote.Git.remote , Remote.GCrypt.remote + , Remote.P2P.remote #ifdef WITH_S3 , Remote.S3.remote #endif @@ -116,4 +118,4 @@ updateRemote remote = do {- 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 ] diff --git a/Remote/P2P.hs b/Remote/P2P.hs new file mode 100644 index 000000000..1d7ede30f --- /dev/null +++ b/Remote/P2P.hs @@ -0,0 +1,191 @@ +{- 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 + r <- runFullProto Client conn a + -- When runFullProto fails, the connection is no longer usable, + -- so close it. + if isJust r + then return (OpenConnection conn, r) + else do + liftIO $ closeConnection conn + return (ClosedConnection, 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 + Just (Just theiruuid) + | u == theiruuid -> return (OpenConnection conn) + | otherwise -> do + liftIO $ closeConnection conn + warning "Remote peer uuid seems to have changed." + return ClosedConnection + _ -> do + liftIO $ closeConnection conn + warning "Unable to authenticate with peer." + return ClosedConnection + Left _e -> do + warning "Unable to connect to peer." + return ClosedConnection diff --git a/Remote/S3.hs b/Remote/S3.hs index c6f23333f..4c1bd5784 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -193,7 +193,7 @@ store _r info h = fileStorer $ \k f p -> do 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 diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index 5fa413155..446948da6 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -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,6 +17,7 @@ import qualified Git import qualified Git.Types as Git import qualified Git.CurrentRepo import Utility.SimpleProtocol +import Utility.ThreadScheduler import Config import Annex.Ssh @@ -26,8 +27,8 @@ import Control.Concurrent.STM 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,8 +45,25 @@ runForeground = do 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) @@ -56,6 +74,7 @@ runController ichan ochan = do h <- genTransportHandle m <- genRemoteMap h ochan startrunning m + mapM_ (\s -> async (s h)) remoteServers go h False m where go h paused m = do diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs index 0e2040d1f..6605012de 100644 --- a/RemoteDaemon/Transport.hs +++ b/RemoteDaemon/Transport.hs @@ -10,6 +10,7 @@ module RemoteDaemon.Transport where import RemoteDaemon.Types import qualified RemoteDaemon.Transport.Ssh import qualified RemoteDaemon.Transport.GCrypt +import qualified RemoteDaemon.Transport.Tor import qualified Git.GCrypt import qualified Data.Map as M @@ -22,3 +23,6 @@ remoteTransports = M.fromList [ ("ssh:", RemoteDaemon.Transport.Ssh.transport) , (Git.GCrypt.urlScheme, RemoteDaemon.Transport.GCrypt.transport) ] + +remoteServers :: [TransportHandle -> IO ()] +remoteServers = [RemoteDaemon.Transport.Tor.server] diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs new file mode 100644 index 000000000..e5d4e97ad --- /dev/null +++ b/RemoteDaemon/Transport/Tor.hs @@ -0,0 +1,101 @@ +{- git-remote-daemon, tor hidden service transport + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module RemoteDaemon.Transport.Tor (server) where + +import Common +import qualified Annex +import Annex.Concurrent +import RemoteDaemon.Types +import RemoteDaemon.Common +import Utility.Tor +import Utility.FileMode +import Utility.AuthToken +import P2P.Protocol +import P2P.IO +import P2P.Annex +import P2P.Auth +import Annex.UUID +import Types.UUID +import Messages +import Git + +import System.PosixCompat.User +import Network.Socket +import Control.Concurrent +import System.Log.Logger (debugM) +import Control.Concurrent.STM + +-- Run tor hidden service. +server :: TransportHandle -> IO () +server th@(TransportHandle (LocalRepo r) _) = do + u <- liftAnnex th getUUID + + q <- newTBQueueIO maxConnections + replicateM_ maxConnections $ + forkIO $ forever $ serveClient th u r q + + uid <- getRealUserID + let ident = fromUUID u + let sock = hiddenServiceSocketFile uid ident + nukeFile sock + soc <- socket AF_UNIX Stream defaultProtocol + bind soc (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] + listen soc 2 + debugM "remotedaemon" "tor hidden service running" + forever $ do + (conn, _) <- accept soc + h <- setupHandle conn + ok <- atomically $ ifM (isFullTBQueue q) + ( return False + , do + writeTBQueue 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 = 10 + +serveClient :: TransportHandle -> UUID -> Repo -> TBQueue Handle -> IO () +serveClient th u r q = bracket setup cleanup go + where + setup = atomically $ readTBQueue q + cleanup = hClose + go h = do + debugM "remotedaemon" "serving a TOR connection" + -- 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 $ serveAuth u + case v of + Just (Just theiruuid) -> void $ + runFullProto (Serving theiruuid) conn $ + serveAuthed u + _ -> return () + -- Merge the duplicated state back in. + liftAnnex th $ mergeState st' + debugM "remotedaemon" "done with TOR connection" diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs index f85219ea5..ba88aa685 100644 --- a/RemoteDaemon/Types.hs +++ b/RemoteDaemon/Types.hs @@ -100,10 +100,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 @@ -33,17 +33,19 @@ main = defaultMainWithHooks simpleUserHooks 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 diff --git a/Types/Creds.hs b/Types/Creds.hs index ad1827bc9..6a9e1287f 100644 --- a/Types/Creds.hs +++ b/Types/Creds.hs @@ -11,4 +11,4 @@ type Creds = String -- can be any data that contains credentials type CredPair = (Login, Password) type Login = String -type Password = String -- todo: use securemem +type Password = String diff --git a/Types/Key.hs b/Types/Key.hs index 3642eca1c..598fe43cc 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -27,6 +27,7 @@ import qualified Data.Text as T 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. -} @@ -129,6 +130,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 <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t") diff --git a/Types/UUID.hs b/Types/UUID.hs index 4212eaa7f..f5c9cda30 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -13,6 +13,8 @@ import qualified Data.Map as M 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 :: String -> Bool isUUID = isJust . U.fromString type UUIDMap = M.Map UUID String + +instance Proto.Serializable UUID where + serialize = fromUUID + deserialize = Just . toUUID diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs new file mode 100644 index 000000000..191b4f5c9 --- /dev/null +++ b/Utility/AuthToken.hs @@ -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 diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 440aa3f07..b80d3ae3f 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2106 Joey Hess <id@joeyh.name> + - Copyright 2012-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -85,9 +85,12 @@ streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h {- 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 @@ -112,24 +115,24 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) - 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 @@ -145,6 +148,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed 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 diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 708f590e7..473129218 100644 --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -5,6 +5,9 @@ - License: BSD-2-clause -} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Utility.SimpleProtocol ( Sendable(..), Receivable(..), @@ -21,6 +24,7 @@ module Utility.SimpleProtocol ( import Data.Char import GHC.IO.Handle +import System.Exit (ExitCode(..)) import Common @@ -88,3 +92,13 @@ dupIoHandles = do nullh `hDuplicateTo` stdin stderr `hDuplicateTo` stdout return (readh, writeh) + +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 diff --git a/Utility/Tor.hs b/Utility/Tor.hs new file mode 100644 index 000000000..5457a5a24 --- /dev/null +++ b/Utility/Tor.hs @@ -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" diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 63ca33520..a90772b10 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -12,7 +12,7 @@ module Utility.WebApp where 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 qualified Data.CaseInsensitive as CI 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.Char.Utf8 (fromText) 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 @@ webAppSessionBackend _ = do 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 @@ checkAuthToken extractAuthToken r predicate 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 () diff --git a/debian/control b/debian/control index a07797462..1d2313954 100644 --- a/debian/control +++ b/debian/control @@ -64,6 +64,7 @@ Build-Depends: libghc-xml-types-dev, libghc-async-dev, libghc-monad-logger-dev, + ligghc-free-dev, libghc-feed-dev (>= 0.3.9.2), libghc-regex-tdfa-dev, libghc-tasty-dev (>= 0.7), @@ -76,6 +77,7 @@ Build-Depends: libghc-disk-free-space-dev, libghc-mountpoints-dev, libghc-magic-dev, + libghc-socks-dev, lsof [linux-any], ikiwiki, libimage-magick-perl, diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn index 5c410999f..6a098ba51 100644 --- a/doc/design/assistant/telehash.mdwn +++ b/doc/design/assistant/telehash.mdwn @@ -66,18 +66,17 @@ or [cjdns](https://github.com/cjdelisle/cjdns) or tor or i2p or [magic wormhole] ## general design -* Make address.log that contains (uuid, transport, address, Maybe authtoken) -* The authtoken is an additional guard, to protect against transports - where the address might be able to be guessed, or observed by the rest of - the network. -* Some addresses can be used with only the provided authtoken - from the address.log. Remotes can be auto-enabled for these. -* Other addresses have Nothing povided for the authtoken, and one - has to instead be provided during manual enabling of the remote. +* There is a generic P2P protocol, which should be usable with any P2P + system that can send messages between peers. +* A p2p remote has an url like tor-annex::fijdksajdksjfkj, which connects + to a specific peer. The peer's address may be kept private, but + the design allows the address to be public without giving access to + the peer. +* An authtoken also needs to be presented when connecting with a peer. + This is stored in local creds storage and must be kept private. * The remotedaemon runs, and/or communicates with the program implementing - the network transport. For example for tor, the remotedaemon runs - the hidden service, and also connects to the tor hidden services of - other nodes. + the P2P network. For example for tor, the remotedaemon runs the + hidden service. * The remotedaemon handles both sides of git push over the transport. * The remotedaemon may also support sending objects over the transport, depending on the transport. @@ -123,6 +122,10 @@ so won't want to type that in. Need discovery. for Bob to confirm he's ready to finish pairing, this will fail, because Bob won't get to that point if the authtoken is intercepted. + Check out + <https://en.wikipedia.org/wiki/Password-authenticated_key_agreement> + for more MITM resistance. + ## local lan detection At connection time, after authentication, the remote can send diff --git a/doc/git-annex-enable-tor.mdwn b/doc/git-annex-enable-tor.mdwn new file mode 100644 index 000000000..1c1738027 --- /dev/null +++ b/doc/git-annex-enable-tor.mdwn @@ -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. diff --git a/doc/git-annex-p2p.mdwn b/doc/git-annex-p2p.mdwn new file mode 100644 index 000000000..5bf48178f --- /dev/null +++ b/doc/git-annex-p2p.mdwn @@ -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. diff --git a/doc/git-annex-remotedaemon.mdwn b/doc/git-annex-remotedaemon.mdwn index 69b516283..d4960c4ff 100644 --- a/doc/git-annex-remotedaemon.mdwn +++ b/doc/git-annex-remotedaemon.mdwn @@ -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,18 +8,38 @@ git annex remotedaemon # 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. +This is useful to detect when remotes have received git pushes, so the +changes can be promptly fetched and the local repository updated. -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, and fetch the changes from +it. 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 as 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 @@ -27,6 +47,10 @@ It's normal for this process to be running when the assistant is running. [[git-annex-assistant]](1) +[[git-annex-enable-tor]](1) + +[[git-annex-p2p]](1) + # AUTHOR Joey Hess <id@joeyh.name> diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 955f67629..d0cc31019 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -212,6 +212,12 @@ subdirectories). 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 @@ subdirectories). See [[git-annex-repair]](1) for details. +* `remotedaemon` + + Persistent communication with remotes. + + See [[git-annex-remotedaemon]](1) for details. + +* `p2p` + + Configure peer-2-Peer links between repositories. + + See [[git-annex-p2p]](1) for details. + # QUERY COMMANDS * `find [path ...]` @@ -652,12 +670,6 @@ subdirectories). 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` This command is used internally by the assistant to perform git pulls diff --git a/doc/git-remote-tor-annex.mdwn b/doc/git-remote-tor-annex.mdwn new file mode 100644 index 000000000..4e41de877 --- /dev/null +++ b/doc/git-remote-tor-annex.mdwn @@ -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. diff --git a/doc/tips/peer_to_peer_network_with_tor.mdwn b/doc/tips/peer_to_peer_network_with_tor.mdwn new file mode 100644 index 000000000..718a9218d --- /dev/null +++ b/doc/tips/peer_to_peer_network_with_tor.mdwn @@ -0,0 +1,132 @@ +git-annex has recently gotten support for running as a +[Tor](http://http://torproject.org/) hidden service. This is a nice secure +and easy to use way to connect repositories between peers in different +locations, without needing any central server. + +## setting up the first peer + +First, you need to get Tor installed and running. See +[their website](http://http://torproject.org/), or try a command like: + + sudo apt-get install tor + +To make git-annex use Tor, run these commands in your git-annex repository: + + sudo git annex enable-tor $(id -u) + git annex remotedaemon + git annex p2p --gen-addresses + +The p2p command will output a long address, such as: + + tor-annex::eeaytkuhaupbarfi.onion:4412:7f53c5b65b8957ef626fd461ceaae8056e3dbc459ae715e4 + +At this point, git-annex is running as a tor hidden service, but +it will only talk to peers who know that address. + +## adding additional peers + +To add a peer, get tor installed and running on it. + + sudo apt-get install tor + +You need a git-annex repository on the new peer. It's fine to start +with a new empty repository: + + git init annex + cd annex + git annex init + +And make git-annex use Tor, by running these commands in the git-annex +repository: + + sudo git annex enable-tor $(id -u) + git annex remotedaemon + +Now, tell the new peer about the address of the first peer. +This will make a git remote named "peer1", which connects, +through Tor, to the repository on the other peer. + + git annex p2p --link peer1 + +That command will prompt for an address; paste in the address that was +generated on the first peer, and then press Enter. + +Now you can run any commands you normally would to sync with the +peer1 remote: + + git annex sync --content peer1 + +You can also generate an address for this new peer, by running `git annex +p2p --gen-addresses`, and link other peers to that address using `git annex +p2p --link`. It's often useful to link peers up in both directions, +so peer1 is a remote of peer2 and peer2 is a remote of peer1. + +Any number of peers can be connected this way, within reason. + +## git-annex remotedaemon + +Notice the `git annex remotedaemon` being run in the above examples. +That command runs the Tor hidden service so that other peers +can connect to your repository over Tor. + +So, you may want to arrange for the remotedaemon to be started on boot. +You can do that with a simple cron job: + + @reboot cd myannexrepo && git annex remotedaemon + +If you use the git-annex assistant, and have it auto-starting on boot, it +will take care of starting the remotedaemon for you. + +## onion addresses and authentication + +You don't need to know about this, but it might be helpful to understand +how it works. + +git-annex's Tor support uses onion address as the address of a git remote. +You can `git pull`, push, etc with those onion addresses: + + git pull tor-annnex::eeaytkuhaupbarfi.onion:4412 + git remote add peer1 tor-annnex::eeaytkuhaupbarfi.onion:4412 + +Onion addresses are semi-public. When you add a remote, they appear in your +`.git/config` file. For security, there's a second level of authentication +that git-annex uses to make sure that only people you want to can access +your repository over Tor. That takes the form of a long string of numbers +and letters, like "7f53c5b65b8957ef626fd461ceaae8056e3dbc459ae715e4". + +The addresses generated by `git annex peer --gen-addresses` +combine the onion address with the authentication data. + +When you run `git annex peer --link`, it sets up a git remote using +the onion address, and it stashes the authentication data away in a file in +`.git/annex/creds/` + +## security + +Tor hidden services can be quite secure. But this doesn't mean that using +git-annex over Tor is automatically perfectly secure. Here are some things +to consider: + +* Anyone who learns the address of a peer can connect to that peer, + download the whole history of the git repository, and any available + annexed files. They can also upload new files to the peer, and even + remove annexed files from the peer. So consider ways that the address + of a peer might be exposed. + +* While Tor can be used to anonymize who you are, git defaults to including + your name and email address in git commit messages. So if you want an + anonymous git-annex repository, you'll need to configure git not to do + that. + +* Using Tor prevents listeners from decrypting your traffic. But, they'll + probably still know you're using Tor. Also, by traffic analysis, + they may be able to guess if you're using git-annex over tor, and even + make guesses about the sizes and types of files that you're exchanging + with peers. + +* There have been past attacks on the Tor network that have exposed + who was running Tor hidden services. + <https://blog.torproject.org/blog/tor-security-advisory-relay-early-traffic-confirmation-attack> + +* An attacker who can connect to the git-annex Tor hidden service, even + without authenticating, can try to perform denial of service attacks. diff --git a/doc/todo/tor.mdwn b/doc/todo/tor.mdwn new file mode 100644 index 000000000..b1a4f8f54 --- /dev/null +++ b/doc/todo/tor.mdwn @@ -0,0 +1,19 @@ +git-annex sync over tor + +Mostly working! + +Current todo list: + +* copy --to peer seems to make the remotedaemon buffer the content in + memory, more than I'd expect. +* update progress meters +* Think about locking some more. What happens if the connection to the peer + is dropped while we think we're locking content there from being dropped? +* merge to master + +Eventually: + +* address exchange via electrum-mnemonic or magic wormhole (see PAKE) +* webapp UI for easy pairing +* friend-of-a-friend peer discovery to build more interconnected networks + of nodes diff --git a/git-annex.cabal b/git-annex.cabal index 7535c5037..c894e6610 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -59,6 +59,7 @@ Extra-Source-Files: 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 @@ Extra-Source-Files: 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 @@ Extra-Source-Files: 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 @@ Executable git-annex MissingH, hslogger, monad-logger, + free, utf8-string, bytestring, text, @@ -364,7 +368,9 @@ Executable git-annex aeson, unordered-containers, feed, - regex-tdfa + regex-tdfa, + socks, + securemem CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports @@ -468,7 +474,6 @@ Executable git-annex clientsession, template-haskell, shakespeare (>= 2.0.0), - securemem, byteable CPP-Options: -DWITH_WEBAPP @@ -699,6 +704,7 @@ Executable git-annex CmdLine.GitAnnexShell.Fields CmdLine.GlobalSetter CmdLine.Option + CmdLine.GitRemoteTorAnnex CmdLine.Seek CmdLine.Usage Command @@ -722,6 +728,7 @@ Executable git-annex Command.DropKey Command.DropUnused Command.EnableRemote + Command.EnableTor Command.ExamineKey Command.Expire Command.Find @@ -757,6 +764,7 @@ Executable git-annex Command.Move Command.NotifyChanges Command.NumCopies + Command.P2P Command.PreCommit Command.Proxy Command.ReKey @@ -899,6 +907,11 @@ Executable git-annex Messages.Internal Messages.JSON Messages.Progress + P2P.Address + P2P.Annex + P2P.Auth + P2P.IO + P2P.Protocol Remote Remote.BitTorrent Remote.Bup @@ -923,6 +936,7 @@ Executable git-annex Remote.Helper.Ssh Remote.Hook Remote.List + Remote.P2P Remote.Rsync Remote.Rsync.RsyncUrl Remote.S3 @@ -934,6 +948,7 @@ Executable git-annex RemoteDaemon.Core RemoteDaemon.Transport RemoteDaemon.Transport.GCrypt + RemoteDaemon.Transport.Tor RemoteDaemon.Transport.Ssh RemoteDaemon.Transport.Ssh.Types RemoteDaemon.Types @@ -980,6 +995,7 @@ Executable git-annex Upgrade.V4 Upgrade.V5 Utility.Applicative + Utility.AuthToken Utility.Base64 Utility.Batch Utility.Bloom @@ -1060,6 +1076,7 @@ Executable git-annex Utility.ThreadLock Utility.ThreadScheduler Utility.Tmp + Utility.Tor Utility.Touch Utility.Url Utility.UserInfo diff --git a/git-annex.hs b/git-annex.hs index ca8eecd2a..d5fab7f47 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -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 Network.Socket (withSocketsDo) import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell +import qualified CmdLine.GitRemoteTorAnnex import qualified Test #ifdef mingw32_HOST_OS @@ -23,20 +24,15 @@ import Utility.Env 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. |