diff options
37 files changed, 1574 insertions, 95 deletions
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..576feb5f0 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 512 <*> 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,11 @@ git-annex (6.20161119) UNRELEASED; urgency=medium + * enable-tor: New command, enables tor hidden service for P2P syncing. + * 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..0fa14c98b 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 @@ -100,6 +101,7 @@ 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 +111,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 +143,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 @@ -207,6 +209,7 @@ cmds testoptparser testrunner = , Command.Smudge.cmd , Command.Undo.cmd , Command.Version.cmd + , Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT , Command.Watch.cmd , Command.Assistant.cmd @@ -216,7 +219,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..3b2dcc050 --- /dev/null +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -0,0 +1,65 @@ +{- 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 Remote.Helper.Tor +import Utility.Tor +import Utility.AuthToken +import Annex.UUID + +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 + <$> getTorAuthTokenFor address + myuuid <- getUUID + g <- Annex.gitRepo + h <- liftIO $ torHandle =<< connectHiddenService address port + runNetProtoHandle h h g $ do + v <- auth myuuid authtoken + case v of + Just _theiruuid -> connect service stdin stdout + Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ torAuthTokenEnv 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/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..862f06a9c --- /dev/null +++ b/P2P/Address.hs @@ -0,0 +1,81 @@ +{- 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 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 +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) + +-- | 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/Auth.hs b/P2P/Auth.hs new file mode 100644 index 000000000..5c3feb713 --- /dev/null +++ b/P2P/Auth.hs @@ -0,0 +1,30 @@ +{- P2P protocol, authorization + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module P2P.Auth where + +import Common +import Utility.AuthToken + +import qualified Data.Text as T + +-- Use .git/annex/creds/p2p to hold AuthTokens of authorized peers. +getAuthTokens :: Annex AllowedAuthTokens +getAuthTokens = allowedAuthTokens <$> getAuthTokens' + +getAuthTokens' :: Annex [AuthTokens] +getAuthTokens' = mapMaybe toAuthToken + . map T.pack + . lines + . fromMaybe [] + <$> readCacheCreds "tor" + +addAuthToken :: AuthToken -> Annex () +addAuthToken t = do + ts <- getAuthTokens' + let d = unlines $ map (T.unpack . fromAuthToken) (t:ts) + writeCacheCreds d "tor" diff --git a/P2P/IO.hs b/P2P/IO.hs new file mode 100644 index 000000000..822eb524e --- /dev/null +++ b/P2P/IO.hs @@ -0,0 +1,216 @@ +{- P2P protocol, partial IO implementation + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, CPP #-} + +module P2P.IO + ( RunProto + , runNetProtoHandle + ) where + +import P2P.Protocol +import Utility.Process +import Git +import Git.Command +import Utility.SafeCommand +import Utility.SimpleProtocol +import Utility.Exception + +import Control.Monad +import Control.Monad.Free +import Control.Monad.IO.Class +import System.Exit (ExitCode(..)) +import System.IO +import Control.Concurrent +import Control.Concurrent.Async +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m (Maybe a) + +data S = S + { repo :: Repo + , ihdl :: Handle + , ohdl :: Handle + } + +-- Implementation of the protocol, communicating with a peer +-- over a Handle. No Local actions will be run. +runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m (Maybe a) +runNetProtoHandle i o r = go + where + go :: RunProto + go (Pure v) = pure (Just v) + go (Free (Net n)) = runNetHandle (S r i o) go n + go (Free (Local _)) = return Nothing + +runNetHandle :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m (Maybe a) +runNetHandle s runner f = case f of + SendMessage m next -> do + v <- liftIO $ tryIO $ do + hPutStrLn (ohdl s) (unwords (formatMessage m)) + hFlush (ohdl s) + case v of + Left _e -> return Nothing + Right () -> runner next + ReceiveMessage next -> do + v <- liftIO $ tryIO $ hGetLine (ihdl s) + 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 next -> do + v <- liftIO $ tryIO $ do + L.hPut (ohdl s) b + hFlush (ohdl s) + case v of + Left _e -> return Nothing + Right () -> runner next + ReceiveBytes (Len n) next -> do + v <- liftIO $ tryIO $ L.hGet (ihdl s) (fromIntegral n) + case v of + Left _e -> return Nothing + Right b -> runner (next b) + CheckAuthToken u t next -> do + authed <- return True -- TODO XXX FIXME really check + runner (next authed) + Relay hin hout next -> do + v <- liftIO $ runRelay runner hin hout + case v of + Nothing -> return Nothing + Just exitcode -> runner (next exitcode) + RelayService service next -> do + v <- liftIO $ runRelayService s runner service + case v of + Nothing -> return Nothing + Just () -> runner next + +runRelay :: RunProto -> 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 :: S -> RunProto -> Service -> IO (Maybe ()) +runRelayService s runner service = bracket setup cleanup go + where + cmd = case service of + UploadPack -> "upload-pack" + ReceivePack -> "receive-pack" + + serviceproc = gitCreateProcess + [ Param cmd + , File (repoPath (repo s)) + ] (repo s) + + 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 -> 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 -> 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..381949af1 --- /dev/null +++ b/P2P/Protocol.hs @@ -0,0 +1,399 @@ +{- P2P protocol + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-} + +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 Control.Monad +import Control.Monad.Free +import Control.Monad.Free.TH +import Control.Monad.Catch +import System.Exit (ExitCode(..)) +import System.IO +import qualified Data.ByteString.Lazy as L + +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 Key + | PUT 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 key) = ["GET", Proto.serialize offset, Proto.serialize key] + formatMessage (PUT key) = ["PUT", 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.parse2 GET + parseCommand "PUT" = Proto.parse1 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 + +-- | 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 c + | ReceiveBytes Len (L.ByteString -> c) + | 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 + -- ^ 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. + = KeyFileSize Key (Len -> c) + -- ^ Checks size of key file (dne = 0) + | ReadKeyFile Key Offset (L.ByteString -> c) + | WriteKeyFile Key Offset Len L.ByteString (Bool -> c) + -- ^ Writes to key file starting at an offset. Returns True + -- once the whole content of the key is stored in the key file. + -- + -- Note: The ByteString may not contain the entire remaining content + -- of the key. Only once the key 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. + | RemoveKeyFile Key (Bool -> c) + -- ^ If the key file 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, and run the provided protocol action. + deriving (Functor) + +type Local = Free LocalF + +-- Generate sendMessage etc functions for all free monad constructors. +$(makeFree ''NetF) +$(makeFree ''LocalF) + +-- | Running Proto actions purely, to see what they do. +runPure :: Show r => Proto r -> [Message] -> [(String, Maybe Message)] +runPure (Pure r) _ = [("result: " ++ show r, Nothing)] +runPure (Free (Net n)) ms = runNet n ms +runPure (Free (Local n)) ms = runLocal n ms + +runNet :: Show r => NetF (Proto r) -> [Message] -> [(String, Maybe Message)] +runNet (SendMessage m next) ms = (">", Just m):runPure next ms +runNet (ReceiveMessage _) [] = [("not enough Messages provided", Nothing)] +runNet (ReceiveMessage next) (m:ms) = ("<", Just m):runPure (next m) ms +runNet (SendBytes _ _ next) ms = ("> bytes", Nothing):runPure next ms +runNet (ReceiveBytes _ next) ms = ("< bytes", Nothing):runPure (next L.empty) ms +runNet (CheckAuthToken _ _ next) ms = runPure (next True) ms +runNet (Relay _ _ next) ms = runPure (next ExitSuccess) ms +runNet (RelayService _ next) ms = runPure next ms + +runLocal :: Show r => LocalF (Proto r) -> [Message] -> [(String, Maybe Message)] +runLocal (KeyFileSize _ next) ms = runPure (next (Len 100)) ms +runLocal (ReadKeyFile _ _ next) ms = runPure (next L.empty) ms +runLocal (WriteKeyFile _ _ _ _ next) ms = runPure (next True) ms +runLocal (SetPresent _ _ next) ms = runPure next ms +runLocal (CheckContentPresent _ next) ms = runPure (next False) ms +runLocal (RemoveKeyFile _ next) ms = runPure (next True) ms +runLocal (TryLockContent _ p next) ms = runPure (p True >> next) ms + +protoDump :: [(String, Maybe Message)] -> String +protoDump = unlines . map protoDump' + +protoDump' :: (String, Maybe Message) -> String +protoDump' (s, Nothing) = s +protoDump' (s, Just m) = s ++ " " ++ unwords (Proto.formatMessage m) + +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. Proto r -> m r) + -> Key + -> (Bool -> m ()) + -> m () +lockContentWhile runproto key a = bracket setup cleanup a + where + setup = runproto $ 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 :: Key -> Proto Bool +get key = receiveContent key (`GET` key) + +put :: Key -> Proto Bool +put key = do + net $ sendMessage (PUT key) + r <- net receiveMessage + case r of + PUT_FROM offset -> sendContent key offset + ALREADY_HAVE -> return True + _ -> do + net $ sendMessage (ERROR "expected PUT_FROM") + return False + +-- | Serve the protocol. +-- +-- Note that if the client sends an unexpected message, the server will +-- respond with PTOTO_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. +-- +-- When the client sends ERROR to the server, the server gives up, +-- since it's not clear what state the client is is, and so not possible to +-- recover. +serve :: UUID -> Proto () +serve myuuid = go Nothing + where + go autheduuid = do + r <- net receiveMessage + case r of + AUTH theiruuid authtoken -> do + ok <- net $ checkAuthToken theiruuid authtoken + if ok + then do + net $ sendMessage (AUTH_SUCCESS myuuid) + go (Just theiruuid) + else do + net $ sendMessage AUTH_FAILURE + go autheduuid + ERROR _ -> return () + _ -> do + case autheduuid of + Just theiruuid -> authed theiruuid r + Nothing -> net $ sendMessage (ERROR "must AUTH first") + go autheduuid + + authed _theiruuid r = case r of + LOCKCONTENT key -> local $ tryLockContent key $ \locked -> do + sendSuccess locked + when locked $ do + r' <- net receiveMessage + case r' of + UNLOCKCONTENT -> return () + _ -> net $ sendMessage (ERROR "expected UNLOCKCONTENT") + CHECKPRESENT key -> sendSuccess =<< local (checkContentPresent key) + REMOVE key -> sendSuccess =<< local (removeKeyFile key) + PUT key -> do + have <- local $ checkContentPresent key + if have + then net $ sendMessage ALREADY_HAVE + else do + ok <- receiveContent key PUT_FROM + when ok $ + local $ setPresent key myuuid + -- setPresent not called because the peer may have + -- requested the data but not permanatly stored it. + GET offset key -> void $ sendContent key offset + CONNECT service -> net $ relayService service + _ -> net $ sendMessage (ERROR "unexpected command") + +sendContent :: Key -> Offset -> Proto Bool +sendContent key offset = do + (len, content) <- readKeyFileLen key offset + net $ sendMessage (DATA len) + net $ sendBytes len content + checkSuccess + +receiveContent :: Key -> (Offset -> Message) -> Proto Bool +receiveContent key mkmsg = do + Len n <- local $ keyFileSize key + let offset = Offset n + net $ sendMessage (mkmsg offset) + r <- net receiveMessage + case r of + DATA len -> do + ok <- local . writeKeyFile key offset len + =<< net (receiveBytes len) + 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 key file from an offset. The Len should correspond to +-- the length of the ByteString, but to avoid buffering the content +-- in memory, is gotten using keyFileSize. +readKeyFileLen :: Key -> Offset -> Proto (Len, L.ByteString) +readKeyFileLen key (Offset offset) = do + (Len totallen) <- local $ keyFileSize key + let len = totallen - offset + if len <= 0 + then return (Len 0, L.empty) + else do + content <- local $ readKeyFile key (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 + _ -> 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 +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/Helper/Tor.hs b/Remote/Helper/Tor.hs new file mode 100644 index 000000000..25d192023 --- /dev/null +++ b/Remote/Helper/Tor.hs @@ -0,0 +1,38 @@ +{- Helpers for tor remotes. + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.Helper.Tor where + +import Annex.Common +import Utility.AuthToken +import Creds +import Utility.Tor +import Utility.Env + +import Network.Socket +import qualified Data.Text as T + +-- Read the first line of the creds file. Environment variable overrides. +getTorAuthTokenFor :: OnionAddress -> Annex (Maybe AuthToken) +getTorAuthTokenFor (OnionAddress onionaddress) = + maybe Nothing mk <$> getM id + [ liftIO $ getEnv torAuthTokenEnv + , readCacheCreds onionaddress + ] + where + mk = toAuthToken . T.pack . takeWhile (/= '\n') + +torAuthTokenEnv :: String +torAuthTokenEnv = "GIT_ANNEX_TOR_AUTHTOKEN" + +torHandle :: Socket -> IO Handle +torHandle s = do + h <- socketToHandle s ReadWriteMode + hSetBuffering h LineBuffering + hSetBinaryMode h False + fileEncoding h + return h 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..ccb84d1e9 --- /dev/null +++ b/RemoteDaemon/Transport/Tor.hs @@ -0,0 +1,77 @@ +{- 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 RemoteDaemon.Types +import RemoteDaemon.Common +import Utility.Tor +import Utility.FileMode +import Remote.Helper.Tor +import P2P.Protocol +import P2P.IO +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 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 <- torHandle 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 :: UUID -> Repo -> TBQueue Handle -> IO () +serveClient u r q = bracket setup cleanup go + where + setup = atomically $ readTBQueue q + cleanup = hClose + go h = do + debugM "remotedaemon" "serving a TOR connection" + void $ runNetProtoHandle h h r (serve u) + 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/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 ec77a2946..3196d8fcd 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/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..8e06cc47c --- /dev/null +++ b/doc/git-annex-p2p.mdwn @@ -0,0 +1,39 @@ +# 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. + +# OPTIONS + +* `--gen-address` + + Generates addresses that can be used to access this git-annex repository + over a P2P network. The address or addresses is output to stdout. + +* `--link-remote remotename address` + + Sets up a git remote with the specified remotename that is accessed over + a P2P network. The address is one generated in the remote repository using + `git annex p2p --gen-address` + +# 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..63b459ed8 --- /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_TOR_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..94470b96a --- /dev/null +++ b/doc/tips/peer_to_peer_network_with_tor.mdwn @@ -0,0 +1,101 @@ +git-annex has recently gotten support for running as a +[Tor](http://http://torproject.org/) hidden service. This is a great, and +very secure way to connect repositories between computers in different +locations, without needing any central server. + +## 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 + git annex remotedaemon + git annex p2p --gen-address + +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 + git annex remotedaemon + +Now, tell the new peer about the address of the first peer: + + git annex p2p --link-remote peer1 tor-annnex::eeaytkuhaupbarfi.onion:4412:7f53c5b65b8957ef626fd461ceaae8056e3dbc459ae715e4 + +(Of course, you should paste in the address you generated earlier, +not the example one shown above.) + +Now this git-annex repository will have a remote named "peer1" +which connects, through Tor, to the repository on the other peer. +You can run any commands you normally would to sync with that remote: + + git annex sync --content peer1 + +You can also generate an address for this new peer, by running `git annex +p2p --gen-address`, and add that address to other peers using `git annex +p2p --link-remote`. 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. So, 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-address` +combine the onion address with the authentication data. + +When you run `git annex peer --link-remote`, it sets up a git remote using +the onion address, and it stashes the authentication data away in a file in +`.git/annex/creds/` diff --git a/git-annex.cabal b/git-annex.cabal index 7535c5037..5a446ac7a 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 @@ -136,6 +137,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 +344,7 @@ Executable git-annex MissingH, hslogger, monad-logger, + free, utf8-string, bytestring, text, @@ -364,7 +367,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 +473,6 @@ Executable git-annex clientsession, template-haskell, shakespeare (>= 2.0.0), - securemem, byteable CPP-Options: -DWITH_WEBAPP @@ -699,6 +703,7 @@ Executable git-annex CmdLine.GitAnnexShell.Fields CmdLine.GlobalSetter CmdLine.Option + CmdLine.GitRemoteTorAnnex CmdLine.Seek CmdLine.Usage Command @@ -899,6 +904,10 @@ Executable git-annex Messages.Internal Messages.JSON Messages.Progress + P2P.Address + P2P.Auth + P2P.IO + P2P.Protocol Remote Remote.BitTorrent Remote.Bup @@ -921,6 +930,7 @@ Executable git-annex Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh + Remote.Helper.Tor Remote.Hook Remote.List Remote.Rsync @@ -934,6 +944,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 +991,7 @@ Executable git-annex Upgrade.V4 Upgrade.V5 Utility.Applicative + Utility.AuthToken Utility.Base64 Utility.Batch Utility.Bloom @@ -1060,6 +1072,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. |