From fbaf45d0f22aa74df19f5d765a8b0ee4d3526a20 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Nov 2016 13:26:34 -0400 Subject: git-annex enable-tor command Tor unfortunately does not come out of the box configured to let hidden services register themselves on the fly via the ControlPort. And, changing the config to enable the ControlPort and a particular type of auth for it may break something already using the ControlPort, or lessen the security of the system. So, this leaves only one option to us: Add a hidden service to the torrc. git-annex enable-tor does so, and picks an unused high port for tor to listen on for connections to the hidden service. It's up to the caller to somehow pick a local port to listen on that won't be used by something else. That may be difficult to do.. This commit was sponsored by Jochen Bartl on Patreon. --- git-annex.cabal | 1 + 1 file changed, 1 insertion(+) (limited to 'git-annex.cabal') diff --git a/git-annex.cabal b/git-annex.cabal index 65abc8d32..dea5eb700 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1063,6 +1063,7 @@ Executable git-annex Utility.ThreadLock Utility.ThreadScheduler Utility.Tmp + Utility.Tor Utility.Touch Utility.Url Utility.UserInfo -- cgit v1.2.3 From d943787ca787d32071643d5b94efa312fafe6ba8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Nov 2016 11:19:57 -0400 Subject: unbreak all the autobuilders git-annex.cabal: Loosen bounds on persistent to allow 2.5, which on Debian has been patched to work with esqueleto. This may break cabal's resolver on non-Debian systems; if so, either use stack to build, or run cabal with --constraint='persistent ==2.2.4.1' Hopefully this mess with esqueleto will be resolved soon. https://github.com/prowdsponsor/esqueleto/issues/137 --- CHANGELOG | 11 +++++++++++ git-annex.cabal | 5 +---- 2 files changed, 12 insertions(+), 4 deletions(-) (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index 273bf520e..33f434df4 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +git-annex (6.20161112) UNRELEASED; urgency=medium + + * git-annex.cabal: Loosen bounds on persistent to allow 2.5, which + on Debian has been patched to work with esqueleto. + This may break cabal's resolver on non-Debian systems; + if so, either use stack to build, or run cabal with + --constraint='persistent ==2.2.4.1' + Hopefully this mess with esqueleto will be resolved soon. + + -- Joey Hess Tue, 15 Nov 2016 11:15:27 -0400 + git-annex (6.20161111) unstable; urgency=medium * Restarting a crashing git process could result in filename encoding diff --git a/git-annex.cabal b/git-annex.cabal index 65abc8d32..46b08d22d 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -359,10 +359,7 @@ Executable git-annex old-locale, esqueleto, persistent-sqlite, - -- Old version needed due to - -- https://github.com/prowdsponsor/esqueleto/issues/137 - -- and also temporarily to make ghc 8 builds work - persistent (< 2.5), + persistent, persistent-template, aeson, unordered-containers, -- cgit v1.2.3 From 49da2d5efdad0038f22bc5e3bc50cf117849d472 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 17 Nov 2016 17:19:04 -0400 Subject: implementation of peer-to-peer protocol For use with tor hidden services, and perhaps other transports later. Based on Utility.SimpleProtocol, it's a line-based protocol, interspersed with transfers of bytestrings of a specified size. Implementation of the local and remote sides of the protocol is done using a free monad. This lets monadic code be included here, without tying it to any particular way to get bytes peer-to-peer. This adds a dependency on the haskell package "free", although that was probably pulled in transitively from other dependencies already. This commit was sponsored by Jeff Goeke-Smith on Patreon. --- Remote/External/Types.hs | 8 -- Remote/Helper/P2P.hs | 247 ++++++++++++++++++++++++++++++++++++++++++++++ RemoteDaemon/Types.hs | 4 - Types/Key.hs | 5 + Types/UUID.hs | 6 ++ Utility/SimpleProtocol.hs | 7 ++ debian/control | 1 + git-annex.cabal | 2 + 8 files changed, 268 insertions(+), 12 deletions(-) create mode 100644 Remote/Helper/P2P.hs (limited to 'git-annex.cabal') 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/P2P.hs b/Remote/Helper/P2P.hs new file mode 100644 index 000000000..d973880f7 --- /dev/null +++ b/Remote/Helper/P2P.hs @@ -0,0 +1,247 @@ +{- P2P protocol + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} + +module Remote.Helper.P2P ( + AuthToken(..), + ProtoF(..), + runPure, + protoDump, + auth, + get, + put, + serve, +) where + +import qualified Utility.SimpleProtocol as Proto +import Types.Key +import Types.UUID +import Utility.Applicative +import Utility.PartialPrelude + +import Control.Monad +import Control.Monad.Free +import Control.Monad.Free.TH +import qualified Data.ByteString.Lazy as L + +newtype AuthToken = AuthToken String + deriving (Show) + +newtype Offset = Offset Integer + deriving (Show) + +newtype Len = Len Integer + 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 + | GET Offset Key + | PUT Key + | PUT_FROM Offset + | SUCCESS + | FAILURE + | DATA Len -- followed by bytes + | PROTO_ERROR String + deriving (Show) + +-- | Free monad for implementing actions that use the protocol. +data ProtoF next + = SendMessage Message next + | GetMessage (Message -> next) + | SendBytes Len L.ByteString next + | ReceiveBytes Len (L.ByteString -> next) + | KeyFileSize Key (Len -> next) + -- ^ Checks size of key file (dne = 0) + | ReadKeyFile Key Offset (L.ByteString -> next) + | WriteKeyFile Key Offset L.ByteString (Bool -> next) + | CheckAuthToken UUID AuthToken (Bool -> next) + | SetPresent Key UUID next + deriving (Functor) + +type Proto = Free ProtoF + +$(makeFree ''ProtoF) + +-- | 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 (SendMessage m next)) ms = (">", Just m):runPure next ms +runPure (Free (GetMessage _)) [] = [("not enough Messages provided", Nothing)] +runPure (Free (GetMessage next)) (m:ms) = ("<", Just m):runPure (next m) ms +runPure (Free (SendBytes _ _ next)) ms = ("> bytes", Nothing):runPure next ms +runPure (Free (ReceiveBytes _ next)) ms = ("< bytes", Nothing):runPure (next L.empty) ms +runPure (Free (KeyFileSize _ next)) ms = runPure (next (Len 100)) ms +runPure (Free (ReadKeyFile _ _ next)) ms = runPure (next L.empty) ms +runPure (Free (WriteKeyFile _ _ _ next)) ms = runPure (next True) ms +runPure (Free (CheckAuthToken _ _ next)) ms = runPure (next True) ms +runPure (Free (SetPresent _ _ next)) ms = runPure 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 + sendMessage (AUTH myuuid t) + r <- getMessage + case r of + AUTH_SUCCESS theiruuid -> return $ Just theiruuid + AUTH_FAILURE -> return Nothing + _ -> do + sendMessage (PROTO_ERROR "auth failed") + return Nothing + +get :: Key -> Proto Bool +get key = do + Len n <- keyFileSize key + let offset = Offset n + sendMessage (GET offset key) + r <- getMessage + case r of + DATA len -> receiveContent key offset len + _ -> do + sendMessage (PROTO_ERROR "expected DATA") + return False + +put :: Key -> Proto Bool +put key = do + sendMessage (PUT key) + r <- getMessage + case r of + PUT_FROM offset -> sendContent key offset + _ -> do + sendMessage (PROTO_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 PROTO_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 <- getMessage + case r of + AUTH theiruuid authtoken -> do + ok <- checkAuthToken theiruuid authtoken + if ok + then do + sendMessage (AUTH_SUCCESS myuuid) + go (Just theiruuid) + else do + sendMessage AUTH_FAILURE + go autheduuid + PROTO_ERROR _ -> return () + _ -> do + case autheduuid of + Just theiruuid -> authed theiruuid r + Nothing -> sendMessage (PROTO_ERROR "must AUTH first") + go autheduuid + + authed theiruuid r = case r of + GET offset key -> do + ok <- sendContent key offset + when ok $ + setPresent key theiruuid + PUT key -> do + (Len n) <- keyFileSize key + let offset = Offset n + sendMessage (PUT_FROM offset) + r' <- getMessage + case r' of + DATA len -> do + void $ receiveContent key offset len + setPresent key myuuid + _ -> sendMessage (PROTO_ERROR "expected DATA") + _ -> sendMessage (PROTO_ERROR "unexpected command") + +sendContent :: Key -> Offset -> Proto Bool +sendContent key offset = do + (len, content) <- readKeyFile' key offset + sendMessage (DATA len) + sendBytes len content + ack <- getMessage + case ack of + SUCCESS -> return True + FAILURE -> return False + _ -> do + sendMessage (PROTO_ERROR "expected SUCCESS or FAILURE") + return False + +receiveContent :: Key -> Offset -> Len -> Proto Bool +receiveContent key offset len = do + content <- receiveBytes len + ok <- writeKeyFile key offset content + sendMessage $ if ok then SUCCESS else FAILURE + return ok + +-- 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. +readKeyFile' :: Key -> Offset -> Proto (Len, L.ByteString) +readKeyFile' key (Offset offset) = do + (Len totallen) <- keyFileSize key + let len = totallen - offset + if len <= 0 + then return (Len 0, L.empty) + else do + content <- readKeyFile key (Offset offset) + return (Len len, content) + +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 (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 SUCCESS = ["SUCCESS"] + formatMessage FAILURE = ["FAILURE"] + formatMessage (DATA leng) = ["DATA", Proto.serialize leng] + formatMessage (PROTO_ERROR err) = ["PROTO-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 "GET" = Proto.parse2 GET + parseCommand "PUT" = Proto.parse1 PUT + parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM + parseCommand "SUCCESS" = Proto.parse0 SUCCESS + parseCommand "FAILURE" = Proto.parse0 FAILURE + parseCommand "DATA" = Proto.parse1 DATA + parseCommand "PROTO-ERROR" = Proto.parse1 PROTO_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 AuthToken where + serialize (AuthToken s) = s + deserialize = Just . AuthToken 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 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/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 708f590e7..728b135e8 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(..), @@ -88,3 +91,7 @@ dupIoHandles = do nullh `hDuplicateTo` stdin stderr `hDuplicateTo` stdout return (readh, writeh) + +instance Serializable [Char] where + serialize = id + deserialize = Just diff --git a/debian/control b/debian/control index ec77a2946..07630dfa2 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), diff --git a/git-annex.cabal b/git-annex.cabal index eb819463b..135653690 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -342,6 +342,7 @@ Executable git-annex MissingH, hslogger, monad-logger, + free, utf8-string, bytestring, text, @@ -918,6 +919,7 @@ Executable git-annex Remote.Helper.Hooks Remote.Helper.Http Remote.Helper.Messages + Remote.Helper.P2P Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh -- cgit v1.2.3 From deea98a53fa872704b9f85bc0c93d57f0798b9cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Nov 2016 11:59:49 -0400 Subject: releasing package git-annex version 6.20161118 --- CHANGELOG | 4 ++-- git-annex.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index 5bd9d3e9d..3777e6d5a 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,4 @@ -git-annex (6.20161112) UNRELEASED; urgency=medium +git-annex (6.20161118) unstable; urgency=medium * git-annex.cabal: Loosen bounds on persistent to allow 2.5, which on Debian has been patched to work with esqueleto. @@ -16,7 +16,7 @@ git-annex (6.20161112) UNRELEASED; urgency=medium * Linux arm standalone: Build with a 32kb page size, which is needed on several ARM NAS devices, including Drobo 5N, and WD NAS. - -- Joey Hess Tue, 15 Nov 2016 11:15:27 -0400 + -- Joey Hess Fri, 18 Nov 2016 11:43:14 -0400 git-annex (6.20161111) unstable; urgency=medium diff --git a/git-annex.cabal b/git-annex.cabal index 46b08d22d..7535c5037 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20161111 +Version: 6.20161118 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess -- cgit v1.2.3 From 513d36ae4de0be74b12112487d8e1b12b7c7f43e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 20 Nov 2016 12:08:16 -0400 Subject: implement p2p protocol for Handle This is most of the way to having the p2p protocol working over tor hidden services, at least enough to do git push/pull. The free monad was split into two, one for network operations and the other for local (Annex) operations. This will allow git-remote-tor-annex to run only an IO action, not needing the Annex monad. This commit was sponsored by Remy van Elst on Patreon. --- Remote/Helper/P2P.hs | 374 +++++++++++++++++++++++++----------------------- Remote/Helper/P2P/IO.hs | 159 ++++++++++++++++++++ git-annex.cabal | 1 + 3 files changed, 356 insertions(+), 178 deletions(-) create mode 100644 Remote/Helper/P2P/IO.hs (limited to 'git-annex.cabal') diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index d3d3dfa08..fbd6c2463 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -7,20 +7,7 @@ {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-} -module Remote.Helper.P2P ( - AuthToken(..), - ProtoF(..), - runPure, - protoDump, - auth, - checkPresent, - lockContentWhile, - remove, - get, - put, - connect, - serve, -) where +module Remote.Helper.P2P where import qualified Utility.SimpleProtocol as Proto import Types.Key @@ -33,7 +20,7 @@ import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.Catch import System.Exit (ExitCode(..)) -import System.IO (Handle) +import System.IO import qualified Data.ByteString.Lazy as L newtype AuthToken = AuthToken String @@ -49,10 +36,6 @@ newtype Len = Len Integer data Service = UploadPack | ReceivePack deriving (Show) -data RelayData - = RelayData L.ByteString - | RelayMessage Message - -- | Messages in the protocol. The peer that makes the connection -- always initiates requests, and the other peer makes responses to them. data Message @@ -75,72 +58,164 @@ data Message | ERROR String deriving (Show) --- | Free monad for implementing actions that use the protocol. -data ProtoF next - = SendMessage Message next - | ReceiveMessage (Message -> next) - | SendBytes Len L.ByteString next - | ReceiveBytes Len (L.ByteString -> next) +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 CONNECT + 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 AuthToken where + serialize (AuthToken s) = s + deserialize = Just . AuthToken + +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) + | Relay RelayHandle + (RelayData -> Net (Maybe ExitCode)) + (ExitCode -> c) + -- ^ Waits for data to be written to the RelayHandle, and for messages + -- to be received from the peer, and passes the data to the + -- callback, continuing until it returns an ExitCode. + | RelayService Service + (RelayHandle -> RelayData -> Net (Maybe ExitCode)) + (ExitCode -> c) + -- ^ Runs a service, and waits for it to output to stdout, + -- and for messages to be received from the peer, and passes + -- the data to the callback (which is also passed the service's + -- stdin RelayHandle), continuing uniil the service exits. + | WriteRelay RelayHandle L.ByteString c + -- ^ Write data to a relay's handle, flushing it immediately. + deriving (Functor) + +type Net = Free NetF + +data RelayData + = RelayData L.ByteString + | RelayMessage Message + +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 -> next) + = KeyFileSize Key (Len -> c) -- ^ Checks size of key file (dne = 0) - | ReadKeyFile Key Offset (L.ByteString -> next) - | WriteKeyFile Key Offset Len L.ByteString (Bool -> next) + | 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. - | CheckAuthToken UUID AuthToken (Bool -> next) - | SetPresent Key UUID next - | CheckContentPresent Key (Bool -> next) + | CheckAuthToken UUID AuthToken (Bool -> c) + | SetPresent Key UUID c + | CheckContentPresent Key (Bool -> c) -- ^ Checks if the whole content of the key is locally present. - | RemoveKeyFile Key (Bool -> next) + | 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 ()) next - | WriteHandle Handle L.ByteString next + | TryLockContent Key (Bool -> Proto ()) c -- ^ Try to lock the content of a key, preventing it -- from being deleted, and run the provided protocol action. - | Relay Handle (RelayData -> Proto (Maybe ExitCode)) (ExitCode -> next) - -- ^ Waits for data to be written to the Handle, and for messages - -- to be received from the peer, and passes the data to the - -- callback, continuing until it returns an ExitCode. - | RelayService Service - (Handle -> RelayData -> Proto (Maybe ExitCode)) - (ExitCode -> next) - -- ^ Runs a service, and waits for it to output to stdout, - -- and for messages to be received from the peer, and passes - -- the data to the callback (which is also passed the service's - -- stdin Handle), continuing uniil the service exits. deriving (Functor) -type Proto = Free ProtoF +type Local = Free LocalF -$(makeFree ''ProtoF) +-- 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 (SendMessage m next)) ms = (">", Just m):runPure next ms -runPure (Free (ReceiveMessage _)) [] = [("not enough Messages provided", Nothing)] -runPure (Free (ReceiveMessage next)) (m:ms) = ("<", Just m):runPure (next m) ms -runPure (Free (SendBytes _ _ next)) ms = ("> bytes", Nothing):runPure next ms -runPure (Free (ReceiveBytes _ next)) ms = ("< bytes", Nothing):runPure (next L.empty) ms -runPure (Free (KeyFileSize _ next)) ms = runPure (next (Len 100)) ms -runPure (Free (ReadKeyFile _ _ next)) ms = runPure (next L.empty) ms -runPure (Free (WriteKeyFile _ _ _ _ next)) ms = runPure (next True) ms -runPure (Free (CheckAuthToken _ _ next)) ms = runPure (next True) ms -runPure (Free (SetPresent _ _ next)) ms = runPure next ms -runPure (Free (CheckContentPresent _ next)) ms = runPure (next False) ms -runPure (Free (RemoveKeyFile _ next)) ms = runPure (next True) ms -runPure (Free (TryLockContent _ p next)) ms = runPure (p True >> next) ms -runPure (Free (WriteHandle _ _ next)) ms = runPure next ms -runPure (Free (Relay _ _ next)) ms = runPure (next ExitSuccess) ms -runPure (Free (RelayService _ _ next)) ms = runPure (next ExitSuccess) ms +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 (Relay _ _ next) ms = runPure (next ExitSuccess) ms +runNet (RelayService _ _ next) ms = runPure (next ExitSuccess) ms +runNet (WriteRelay _ _ 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 (CheckAuthToken _ _ 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' @@ -151,18 +226,18 @@ protoDump' (s, Just m) = s ++ " " ++ unwords (Proto.formatMessage m) auth :: UUID -> AuthToken -> Proto (Maybe UUID) auth myuuid t = do - sendMessage (AUTH myuuid t) - r <- receiveMessage + net $ sendMessage (AUTH myuuid t) + r <- net receiveMessage case r of AUTH_SUCCESS theiruuid -> return $ Just theiruuid AUTH_FAILURE -> return Nothing _ -> do - sendMessage (ERROR "auth failed") + net $ sendMessage (ERROR "auth failed") return Nothing checkPresent :: Key -> Proto Bool checkPresent key = do - sendMessage (CHECKPRESENT key) + net $ sendMessage (CHECKPRESENT key) checkSuccess {- Locks content to prevent it from being dropped, while running an action. @@ -180,14 +255,14 @@ lockContentWhile lockContentWhile runproto key a = bracket setup cleanup a where setup = runproto $ do - sendMessage (LOCKCONTENT key) + net $ sendMessage (LOCKCONTENT key) checkSuccess - cleanup True = runproto $ sendMessage UNLOCKCONTENT + cleanup True = runproto $ net $ sendMessage UNLOCKCONTENT cleanup False = return () remove :: Key -> Proto Bool remove key = do - sendMessage (REMOVE key) + net $ sendMessage (REMOVE key) checkSuccess get :: Key -> Proto Bool @@ -195,35 +270,15 @@ get key = receiveContent key (`GET` key) put :: Key -> Proto Bool put key = do - sendMessage (PUT key) - r <- receiveMessage + net $ sendMessage (PUT key) + r <- net receiveMessage case r of PUT_FROM offset -> sendContent key offset ALREADY_HAVE -> return True _ -> do - sendMessage (ERROR "expected PUT_FROM") + net $ sendMessage (ERROR "expected PUT_FROM") return False -connect :: Service -> Handle -> Handle -> Proto ExitCode -connect service hin hout = do - sendMessage (CONNECT service) - relay hin (relayCallback hout) - -relayCallback :: Handle -> RelayData -> Proto (Maybe ExitCode) -relayCallback hout (RelayMessage (DATA len)) = do - writeHandle hout =<< receiveBytes len - return Nothing -relayCallback _ (RelayMessage (CONNECTDONE exitcode)) = - return (Just exitcode) -relayCallback _ (RelayMessage _) = do - sendMessage (ERROR "expected DATA or CONNECTDONE") - return (Just (ExitFailure 1)) -relayCallback _ (RelayData b) = do - let len = Len $ fromIntegral $ L.length b - sendMessage (DATA len) - sendBytes len b - return Nothing - -- | Serve the protocol. -- -- Note that if the client sends an unexpected message, the server will @@ -240,153 +295,116 @@ serve :: UUID -> Proto () serve myuuid = go Nothing where go autheduuid = do - r <- receiveMessage + r <- net receiveMessage case r of AUTH theiruuid authtoken -> do - ok <- checkAuthToken theiruuid authtoken + ok <- local $ checkAuthToken theiruuid authtoken if ok then do - sendMessage (AUTH_SUCCESS myuuid) + net $ sendMessage (AUTH_SUCCESS myuuid) go (Just theiruuid) else do - sendMessage AUTH_FAILURE + net $ sendMessage AUTH_FAILURE go autheduuid ERROR _ -> return () _ -> do case autheduuid of Just theiruuid -> authed theiruuid r - Nothing -> sendMessage (ERROR "must AUTH first") + Nothing -> net $ sendMessage (ERROR "must AUTH first") go autheduuid authed _theiruuid r = case r of - LOCKCONTENT key -> tryLockContent key $ \locked -> do + LOCKCONTENT key -> local $ tryLockContent key $ \locked -> do sendSuccess locked when locked $ do - r' <- receiveMessage + r' <- net receiveMessage case r' of UNLOCKCONTENT -> return () - _ -> sendMessage (ERROR "expected UNLOCKCONTENT") - CHECKPRESENT key -> sendSuccess =<< checkContentPresent key - REMOVE key -> sendSuccess =<< removeKeyFile key + _ -> net $ sendMessage (ERROR "expected UNLOCKCONTENT") + CHECKPRESENT key -> sendSuccess =<< local (checkContentPresent key) + REMOVE key -> sendSuccess =<< local (removeKeyFile key) PUT key -> do - have <- checkContentPresent key + have <- local $ checkContentPresent key if have - then sendMessage ALREADY_HAVE + then net $ sendMessage ALREADY_HAVE else do ok <- receiveContent key PUT_FROM when ok $ - setPresent key myuuid + 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 -> do - exitcode <- relayService service relayCallback - sendMessage (CONNECTDONE exitcode) - _ -> sendMessage (ERROR "unexpected command") + exitcode <- net $ relayService service relayCallback + net $ sendMessage (CONNECTDONE exitcode) + _ -> net $ sendMessage (ERROR "unexpected command") sendContent :: Key -> Offset -> Proto Bool sendContent key offset = do (len, content) <- readKeyFileLen key offset - sendMessage (DATA len) - sendBytes len content + net $ sendMessage (DATA len) + net $ sendBytes len content checkSuccess receiveContent :: Key -> (Offset -> Message) -> Proto Bool receiveContent key mkmsg = do - Len n <- keyFileSize key + Len n <- local $ keyFileSize key let offset = Offset n - sendMessage (mkmsg offset) - r <- receiveMessage + net $ sendMessage (mkmsg offset) + r <- net receiveMessage case r of DATA len -> do - ok <- writeKeyFile key offset len =<< receiveBytes len + ok <- local . writeKeyFile key offset len + =<< net (receiveBytes len) sendSuccess ok return ok _ -> do - sendMessage (ERROR "expected DATA") + net $ sendMessage (ERROR "expected DATA") return False checkSuccess :: Proto Bool checkSuccess = do - ack <- receiveMessage + ack <- net receiveMessage case ack of SUCCESS -> return True FAILURE -> return False _ -> do - sendMessage (ERROR "expected SUCCESS or FAILURE") + net $ sendMessage (ERROR "expected SUCCESS or FAILURE") return False sendSuccess :: Bool -> Proto () -sendSuccess True = sendMessage SUCCESS -sendSuccess False = sendMessage FAILURE +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) <- keyFileSize key + (Len totallen) <- local $ keyFileSize key let len = totallen - offset if len <= 0 then return (Len 0, L.empty) else do - content <- readKeyFile key (Offset offset) + content <- local $ readKeyFile key (Offset offset) return (Len len, content) -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 CONNECT - 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 AuthToken where - serialize (AuthToken s) = s - deserialize = Just . AuthToken +connect :: Service -> Handle -> Handle -> Proto ExitCode +connect service hin hout = do + net $ sendMessage (CONNECT service) + net $ relay (RelayHandle hin) (relayCallback (RelayHandle hout)) -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 +relayCallback :: RelayHandle -> RelayData -> Net (Maybe ExitCode) +relayCallback hout (RelayMessage (DATA len)) = do + writeRelay hout =<< receiveBytes len + return Nothing +relayCallback _ (RelayMessage (CONNECTDONE exitcode)) = + return (Just exitcode) +relayCallback _ (RelayMessage _) = do + sendMessage (ERROR "expected DATA or CONNECTDONE") + return (Just (ExitFailure 1)) +relayCallback _ (RelayData b) = do + let len = Len $ fromIntegral $ L.length b + sendMessage (DATA len) + sendBytes len b + return Nothing diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs new file mode 100644 index 000000000..7179adc2b --- /dev/null +++ b/Remote/Helper/P2P/IO.hs @@ -0,0 +1,159 @@ +{- P2P protocol, partial IO implementation + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} + +module Remote.Helper.P2P.IO + ( RunProto + , runProtoHandle + ) where + +import Remote.Helper.P2P +import Utility.Process +import Git +import Git.Command +import Utility.SafeCommand +import Utility.SimpleProtocol + +import Control.Monad +import Control.Monad.Free +import Control.Monad.IO.Class +import Data.Maybe +import System.Exit (ExitCode(..)) +import System.IO +import Control.Concurrent +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +type RunProto = forall a m. MonadIO m => Proto a -> m a + +data S = S + { repo :: Repo + , hdl :: Handle + } + +-- Implementation of the protocol, communicating with a peer +-- over a Handle. No Local actions will be run. +runProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a +runProtoHandle h r = go + where + go :: RunProto + go (Pure a) = pure a + go (Free (Net n)) = runNetHandle (S r h) go n + go (Free (Local _)) = error "local actions not allowed" + +runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a +runNetHandle s runner f = case f of + SendMessage m next -> do + liftIO $ do + hPutStrLn (hdl s) (unwords (formatMessage m)) + hFlush (hdl s) + runner next + ReceiveMessage next -> do + l <- liftIO $ hGetLine (hdl s) + let m = fromMaybe (ERROR "protocol parse error") + (parseMessage l) + runner (next m) + SendBytes _len b next -> do + liftIO $ do + L.hPut (hdl s) b + hFlush (hdl s) + runner next + ReceiveBytes (Len n) next -> do + b <- liftIO $ L.hGet (hdl s) (fromIntegral n) + runner (next b) + Relay hout callback next -> + runRelay runner hout callback >>= runner . next + RelayService service callback next -> + runRelayService s runner service callback >>= runner . next + WriteRelay (RelayHandle h) b next -> do + liftIO $ do + L.hPut h b + hFlush h + runner next + +runRelay + :: MonadIO m + => RunProto + -> RelayHandle + -> (RelayData -> Net (Maybe ExitCode)) + -> m ExitCode +runRelay runner (RelayHandle hout) callback = do + v <- liftIO newEmptyMVar + _ <- liftIO $ forkIO $ readout v + feeder <- liftIO $ forkIO $ feedin v + exitcode <- liftIO $ drain v + liftIO $ killThread feeder + return exitcode + where + feedin v = forever $ do + m <- runner $ net receiveMessage + putMVar v $ RelayMessage m + + readout v = do + b <- B.hGetSome hout 65536 + if B.null b + then hClose hout + else do + putMVar v $ RelayData (L.fromChunks [b]) + readout v + + drain v = do + d <- takeMVar v + r <- runner $ net $ callback d + case r of + Nothing -> drain v + Just exitcode -> return exitcode + +runRelayService + :: MonadIO m + => S + -> RunProto + -> Service + -> (RelayHandle -> RelayData -> Net (Maybe ExitCode)) + -> m ExitCode +runRelayService s runner service callback = do + v <- liftIO newEmptyMVar + (Just hin, Just hout, _, pid) <- liftIO $ createProcess serviceproc + { std_out = CreatePipe + , std_in = CreatePipe + } + _ <- liftIO $ forkIO $ readout v hout + feeder <- liftIO $ forkIO $ feedin v + _ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid + exitcode <- liftIO $ drain v hin + liftIO $ killThread feeder + return exitcode + where + cmd = case service of + UploadPack -> "upload-pack" + ReceivePack -> "receive-pack" + serviceproc = gitCreateProcess [Param cmd, File (repoPath (repo s))] (repo s) + + drain v hin = do + d <- takeMVar v + case d of + Left exitcode -> do + hClose hin + return exitcode + Right relaydata -> do + _ <- runner $ net $ + callback (RelayHandle hin) relaydata + drain v hin + + readout v hout = do + b <- B.hGetSome hout 65536 + if B.null b + then hClose hout + else do + putMVar v $ Right $ + RelayData (L.fromChunks [b]) + readout v hout + + feedin v = forever $ do + m <- runner $ net receiveMessage + putMVar v $ Right $ RelayMessage m diff --git a/git-annex.cabal b/git-annex.cabal index 4fb4e1c3c..77c50b66e 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -920,6 +920,7 @@ Executable git-annex Remote.Helper.Http Remote.Helper.Messages Remote.Helper.P2P + Remote.Helper.P2P.IO Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh -- cgit v1.2.3 From dce8e76ef443e33d88b8301c86ebf080fceff511 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 20 Nov 2016 15:45:01 -0400 Subject: remotedaemon: serve tor hidden service --- CHANGELOG | 2 ++ Command/RemoteDaemon.hs | 2 +- Remote/Helper/P2P/IO.hs | 6 ++--- RemoteDaemon/Core.hs | 9 ++++++-- RemoteDaemon/Transport.hs | 4 ++++ RemoteDaemon/Transport/Tor.hs | 51 +++++++++++++++++++++++++++++++++++++++++++ Utility/Tor.hs | 19 +++++++++++----- git-annex.cabal | 1 + 8 files changed, 83 insertions(+), 11 deletions(-) create mode 100644 RemoteDaemon/Transport/Tor.hs (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index 692a22ea4..28a30c206 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,7 @@ git-annex (6.20161119) UNRELEASED; urgency=medium + * enable-tor: New command, enables tor hidden service for P2P syncing. + * remotedaemon: Serve tor hidden service. * remotedaemon: Fork to background by default. Added --foreground switch to enable old behavior. diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index c68cf816a..c17417104 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -14,7 +14,7 @@ import RemoteDaemon.Core import Utility.Daemon cmd :: Command -cmd = noCommit $ dontCheck repoExists $ +cmd = noCommit $ command "remotedaemon" SectionMaintenance "persistent communication with remotes" paramNothing (run <$$> const parseDaemonOptions) diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs index 7179adc2b..82ba2d6f9 100644 --- a/Remote/Helper/P2P/IO.hs +++ b/Remote/Helper/P2P/IO.hs @@ -9,7 +9,7 @@ module Remote.Helper.P2P.IO ( RunProto - , runProtoHandle + , runNetProtoHandle ) where import Remote.Helper.P2P @@ -38,8 +38,8 @@ data S = S -- Implementation of the protocol, communicating with a peer -- over a Handle. No Local actions will be run. -runProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a -runProtoHandle h r = go +runNetProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a +runNetProtoHandle h r = go where go :: RunProto go (Pure a) = pure a diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index 3b3f6d98d..446948da6 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -45,7 +45,9 @@ runInteractive = 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 @@ -59,7 +61,9 @@ runNonInteractive = do void $ atomically $ readTChan ochan let controller = runController ichan ochan - void $ tryIO $ reader `concurrently` writer `concurrently` controller + void $ tryIO $ reader + `concurrently` writer + `concurrently` controller type RemoteMap = M.Map Git.Repo (IO (), TChan Consumed) @@ -70,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..1527939b1 --- /dev/null +++ b/RemoteDaemon/Transport/Tor.hs @@ -0,0 +1,51 @@ +{- git-remote-daemon, tor hidden service transport + - + - Copyright 2016 Joey Hess + - + - 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.P2P +import Remote.Helper.P2P.IO +import Annex.UUID +import Types.UUID + +import System.PosixCompat.User +import Network.Socket +import Control.Concurrent +import System.Log.Logger (debugM) + +-- Run tor hidden service. +server :: TransportHandle -> IO () +server th@(TransportHandle (LocalRepo r) _) = do + u <- liftAnnex th getUUID + uid <- getRealUserID + let ident = fromUUID u + let sock = socketFile 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 + forkIO $ do + debugM "remotedaemon" "handling a connection" + h <- socketToHandle conn ReadWriteMode + hSetBuffering h LineBuffering + hSetBinaryMode h False + runNetProtoHandle h r (serve u) + hClose h + diff --git a/Utility/Tor.hs b/Utility/Tor.hs index a0a609008..b673c7105 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -15,6 +15,7 @@ import Data.Char type OnionPort = Int type OnionAddress = String type OnionSocket = FilePath +type UniqueIdent = String -- | Adds a hidden service connecting to localhost, using some kind -- of unique identifier. @@ -27,7 +28,7 @@ type OnionSocket = FilePath -- -- If there is already a hidden service for the specified unique -- identifier, returns its information without making any changes. -addHiddenService :: UserID -> String -> IO (OnionAddress, OnionPort, OnionSocket) +addHiddenService :: UserID -> UniqueIdent -> IO (OnionAddress, OnionPort, OnionSocket) addHiddenService uid ident = do ls <- lines <$> readFile torrc let portssocks = mapMaybe (parseportsock . separate isSpace) ls @@ -39,7 +40,7 @@ addHiddenService uid ident = do writeFile torrc $ unlines $ ls ++ [ "" - , "HiddenServiceDir " ++ hsdir + , "HiddenServiceDir " ++ hiddenServiceDir uid ident , "HiddenServicePort " ++ show newport ++ " unix:" ++ sockfile ] @@ -58,13 +59,12 @@ addHiddenService uid ident = do return (p, drop 1 (dropWhile (/= ':') l)) parseportsock _ = Nothing - hsdir = libDir "hidden_service_" ++ show uid ++ "_" ++ ident - sockfile = runDir uid ident ++ ".sock" + sockfile = socketFile uid ident waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort, OnionSocket) waithiddenservice 0 _ = error "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice n p = do - v <- tryIO $ readFile (hsdir "hostname") + v <- tryIO $ readFile $ hiddenServiceHostnameFile uid ident case v of Right s | ".onion\n" `isSuffixOf` s -> return (takeWhile (/= '\n') s, p, sockfile) @@ -80,3 +80,12 @@ libDir = "/var/lib/tor" runDir :: UserID -> FilePath runDir uid = "/var/run/user" show uid + +socketFile :: UserID -> UniqueIdent -> FilePath +socketFile uid ident = runDir uid ident ++ ".sock" + +hiddenServiceDir :: UserID -> UniqueIdent -> FilePath +hiddenServiceDir uid ident = libDir "hidden_service_" ++ show uid ++ "_" ++ ident + +hiddenServiceHostnameFile :: UserID -> UniqueIdent -> FilePath +hiddenServiceHostnameFile uid ident = hiddenServiceDir uid ident "hostname" diff --git a/git-annex.cabal b/git-annex.cabal index 77c50b66e..7a0e34b3a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -937,6 +937,7 @@ Executable git-annex RemoteDaemon.Core RemoteDaemon.Transport RemoteDaemon.Transport.GCrypt + RemoteDaemon.Transport.Tor RemoteDaemon.Transport.Ssh RemoteDaemon.Transport.Ssh.Types RemoteDaemon.Types -- cgit v1.2.3 From 01bf227ad1d9bd30d6fad2dc104b264a1f55c2c4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 21 Nov 2016 17:27:38 -0400 Subject: Added git-remote-tor-annex, which allows git pull and push to the tor hidden service. Almost working, but there's a bug in the relaying. Also, made tor hidden service setup pick a random port, to make it harder to port scan. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon. --- Build/Mans.hs | 7 +++-- CHANGELOG | 2 ++ CmdLine/GitRemoteTorAnnex.hs | 62 +++++++++++++++++++++++++++++++++++++++++ Command/EnableTor.hs | 8 +++--- Makefile | 3 ++ Remote/Helper/P2P.hs | 11 ++++++-- Remote/Helper/P2P/IO.hs | 64 +++++++++++++++++++++++++++---------------- Remote/Helper/Tor.hs | 34 +++++++++++++++++++++++ RemoteDaemon/Transport/Tor.hs | 6 ++-- Setup.hs | 8 ++++-- Types/Creds.hs | 2 +- Utility/Tor.hs | 40 ++++++++++++++++++++++----- debian/control | 1 + doc/git-annex-enable-tor.mdwn | 2 +- doc/git-remote-tor-annex.mdwn | 36 ++++++++++++++++++++++++ git-annex.cabal | 7 ++++- git-annex.hs | 22 ++++++--------- 17 files changed, 254 insertions(+), 61 deletions(-) create mode 100644 CmdLine/GitRemoteTorAnnex.hs create mode 100644 Remote/Helper/Tor.hs create mode 100644 doc/git-remote-tor-annex.mdwn (limited to 'git-annex.cabal') 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" diff --git a/CHANGELOG b/CHANGELOG index 28a30c206..cc20ec751 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -2,6 +2,8 @@ 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. diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs new file mode 100644 index 000000000..bc001f42f --- /dev/null +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -0,0 +1,62 @@ +{- git-remote-tor-annex program + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.GitRemoteTorAnnex where + +import Common +import qualified Annex +import qualified Git.CurrentRepo +import Remote.Helper.P2P +import Remote.Helper.P2P.IO +import Remote.Helper.Tor +import Utility.Tor +import Annex.UUID + +run :: [String] -> IO () +run (_remotename:address:[]) = forever $ do + -- gitremote-helpers protocol + l <- getLine + case l of + "capabilities" -> do + putStrLn "connect" + putStrLn "" + "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 + putStrLn "" + hFlush stdout + connectService onionaddress onionport service >>= exitWith +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 ExitCode +connectService address port service = do + state <- Annex.new =<< Git.CurrentRepo.get + Annex.eval state $ do + authtoken <- fromMaybe nullAuthToken + <$> getTorAuthToken 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 index 369ea7509..c581fa1d4 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -24,11 +24,11 @@ start :: CmdParams -> CommandStart start (suserid:uuid:[]) = case readish suserid of Nothing -> error "Bad userid" Just userid -> do - (onionaddr, onionport, onionsocket) <- liftIO $ + (OnionAddress onionaddr, onionport) <- liftIO $ addHiddenService userid uuid - liftIO $ putStrLn $ + liftIO $ putStrLn $ + "tor-annex::" ++ onionaddr ++ ":" ++ - show onionport ++ " " ++ - show onionsocket + show onionport ++ " " stop start _ = error "Bad params" diff --git a/Makefile b/Makefile index e05546c52..56e725db2 100644 --- a/Makefile +++ b/Makefile @@ -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/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 1e1519560..7e49968ee 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -26,6 +26,12 @@ import qualified Data.ByteString.Lazy as L newtype AuthToken = AuthToken String deriving (Show) +mkAuthToken :: String -> Maybe AuthToken +mkAuthToken = fmap AuthToken . headMaybe . lines + +nullAuthToken :: AuthToken +nullAuthToken = AuthToken "" + newtype Offset = Offset Integer deriving (Show) @@ -157,6 +163,7 @@ type Net = Free NetF data RelayData = RelayData L.ByteString | RelayMessage Message + deriving (Show) newtype RelayHandle = RelayHandle Handle @@ -400,8 +407,8 @@ relayCallback hout (RelayMessage (DATA len)) = do return Nothing relayCallback _ (RelayMessage (CONNECTDONE exitcode)) = return (Just exitcode) -relayCallback _ (RelayMessage _) = do - sendMessage (ERROR "expected DATA or CONNECTDONE") +relayCallback _ (RelayMessage m) = do + sendMessage $ ERROR $ "expected DATA or CONNECTDONE not " ++ unwords (Proto.formatMessage m) return (Just (ExitFailure 1)) relayCallback _ (RelayData b) = do let len = Len $ fromIntegral $ L.length b diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs index 6908fd68c..c6a80cdbf 100644 --- a/Remote/Helper/P2P/IO.hs +++ b/Remote/Helper/P2P/IO.hs @@ -19,6 +19,7 @@ import Git import Git.Command import Utility.SafeCommand import Utility.SimpleProtocol +import Utility.Exception import Control.Monad import Control.Monad.Free @@ -30,7 +31,7 @@ import Control.Concurrent import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -type RunProto = forall a m. MonadIO m => Proto a -> m a +type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m a data S = S { repo :: Repo @@ -40,7 +41,7 @@ data S = S -- Implementation of the protocol, communicating with a peer -- over a Handle. No Local actions will be run. -runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a +runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m a runNetProtoHandle i o r = go where go :: RunProto @@ -48,7 +49,7 @@ runNetProtoHandle i o r = go go (Free (Net n)) = runNetHandle (S r i o) go n go (Free (Local _)) = error "local actions not allowed" -runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a +runNetHandle :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m a runNetHandle s runner f = case f of SendMessage m next -> do liftIO $ do @@ -57,10 +58,11 @@ runNetHandle s runner f = case f of runner next ReceiveMessage next -> do l <- liftIO $ hGetLine (ihdl s) + -- liftIO $ hPutStrLn stderr ("< " ++ show l) case parseMessage l of Just m -> runner (next m) Nothing -> runner $ do - let e = ERROR "protocol parse error" + let e = ERROR $ "protocol parse error: " ++ show l net $ sendMessage e next e SendBytes _len b next -> do @@ -70,6 +72,7 @@ runNetHandle s runner f = case f of runner next ReceiveBytes (Len n) next -> do b <- liftIO $ L.hGet (ihdl s) (fromIntegral n) + --liftIO $ hPutStrLn stderr $ "!!!" ++ show (L.length b) runner (next b) CheckAuthToken u t next -> do authed <- return True -- TODO XXX FIXME really check @@ -80,7 +83,8 @@ runNetHandle s runner f = case f of runRelayService s runner service callback >>= runner . next WriteRelay (RelayHandle h) b next -> do liftIO $ do - L.hPut h b + -- L.hPut h b + hPutStrLn h (show ("relay got:", b, L.length b)) hFlush h runner next @@ -112,43 +116,57 @@ runRelay runner (RelayHandle hout) callback = do drain v = do d <- takeMVar v + liftIO $ hPutStrLn stderr (show d) r <- runner $ net $ callback d case r of Nothing -> drain v Just exitcode -> return exitcode runRelayService - :: MonadIO m + :: (MonadIO m, MonadMask m) => S -> RunProto -> Service -> (RelayHandle -> RelayData -> Net (Maybe ExitCode)) -> m ExitCode -runRelayService s runner service callback = do - v <- liftIO newEmptyMVar - (Just hin, Just hout, _, pid) <- liftIO $ createProcess serviceproc - { std_out = CreatePipe - , std_in = CreatePipe - } - _ <- liftIO $ forkIO $ readout v hout - feeder <- liftIO $ forkIO $ feedin v - _ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid - exitcode <- liftIO $ drain v hin - liftIO $ killThread feeder - return exitcode +runRelayService s runner service callback = 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) + + serviceproc = gitCreateProcess + [ Param cmd + , File (repoPath (repo s)) + ] (repo s) + + setup = do + v <- liftIO newEmptyMVar + (Just hin, Just hout, _, pid) <- liftIO $ + createProcess serviceproc + { std_out = CreatePipe + , std_in = CreatePipe + } + feeder <- liftIO $ forkIO $ feedin v + return (v, feeder, hin, hout, pid) + + cleanup (_, feeder, hin, hout, pid) = liftIO $ do + hClose hin + hClose hout + liftIO $ killThread feeder + void $ waitForProcess pid + + go (v, _, hin, hout, pid) = do + _ <- liftIO $ forkIO $ readout v hout + _ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid + liftIO $ drain v hin drain v hin = do d <- takeMVar v case d of - Left exitcode -> do - hClose hin - return exitcode + Left exitcode -> return exitcode Right relaydata -> do + liftIO $ hPutStrLn stderr ("> " ++ show relaydata) _ <- runner $ net $ callback (RelayHandle hin) relaydata drain v hin @@ -156,7 +174,7 @@ runRelayService s runner service callback = do readout v hout = do b <- B.hGetSome hout 65536 if B.null b - then hClose hout + then return () else do putMVar v $ Right $ RelayData (L.fromChunks [b]) diff --git a/Remote/Helper/Tor.hs b/Remote/Helper/Tor.hs new file mode 100644 index 000000000..e91083362 --- /dev/null +++ b/Remote/Helper/Tor.hs @@ -0,0 +1,34 @@ +{- Helpers for tor remotes. + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.Helper.Tor where + +import Annex.Common +import Remote.Helper.P2P (mkAuthToken, AuthToken) +import Creds +import Utility.Tor +import Utility.Env + +import Network.Socket + +getTorAuthToken :: OnionAddress -> Annex (Maybe AuthToken) +getTorAuthToken (OnionAddress onionaddress) = + maybe Nothing mkAuthToken <$> getM id + [ liftIO $ getEnv torAuthTokenEnv + , readCacheCreds onionaddress + ] + +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/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index da30bf944..e0922a766 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -12,6 +12,7 @@ import RemoteDaemon.Types import RemoteDaemon.Common import Utility.Tor import Utility.FileMode +import Remote.Helper.Tor import Remote.Helper.P2P import Remote.Helper.P2P.IO import Annex.UUID @@ -43,9 +44,6 @@ server th@(TransportHandle (LocalRepo r) _) = do (conn, _) <- accept soc forkIO $ do debugM "remotedaemon" "handling a connection" - h <- socketToHandle conn ReadWriteMode - hSetBuffering h LineBuffering - hSetBinaryMode h False + h <- torHandle conn runNetProtoHandle h h r (serve u) hClose h - diff --git a/Setup.hs b/Setup.hs index fe06a08b1..57efd86e0 100644 --- a/Setup.hs +++ b/Setup.hs @@ -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/Utility/Tor.hs b/Utility/Tor.hs index b673c7105..eedee8c6b 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -11,32 +11,53 @@ import Common import Utility.ThreadScheduler 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 -type OnionAddress = String +newtype OnionAddress = OnionAddress String type OnionSocket = FilePath type UniqueIdent = String +connectHiddenService :: OnionAddress -> OnionPort -> IO Socket +connectHiddenService (OnionAddress address) port = do + soc <- socket AF_UNIX Stream defaultProtocol + connect soc (SockAddrUnix "/run/user/1000/1ecd1f64-3234-47ec-876c-47c4bd7f7407.sock") + return soc + +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 port number for the hidden service that is not used by any --- other hidden service (and is >= 1024). Returns the hidden service's +-- 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, OnionSocket) +addHiddenService :: UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) addHiddenService uid ident = do 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 highports let newport = Prelude.head $ - filter (`notElem` map fst portssocks) [1024..] + filter (`notElem` map fst portssocks) highports writeFile torrc $ unlines $ ls ++ [ "" @@ -61,13 +82,18 @@ addHiddenService uid ident = do sockfile = socketFile uid ident - waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort, OnionSocket) + -- An infinite random list of high ports. + highports g = + let (g1, g2) = R.split g + in (R.randomRs (1025, 65534) g1, g2) + + waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice 0 _ = error "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 (takeWhile (/= '\n') s, p, sockfile) + return (OnionAddress (takeWhile (/= '\n') s), p) _ -> do threadDelaySeconds (Seconds 1) waithiddenservice (n-1) p diff --git a/debian/control b/debian/control index 07630dfa2..3196d8fcd 100644 --- a/debian/control +++ b/debian/control @@ -77,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 index 5355eef8b..ceaa4b121 100644 --- a/doc/git-annex-enable-tor.mdwn +++ b/doc/git-annex-enable-tor.mdwn @@ -10,7 +10,7 @@ git annex enable-tor userid uuid This plumbing-level command enables a tor hidden service for git-annex, using the specified repository uuid and userid. -It outputs to stdout a line of the form "address.onion:onionport socketfile" +It outputs the address of the hidden service to stdout. This command has to be run by root, since it modifies `/etc/tor/torrc`. 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 + +Warning: Automatically converted into a man page by mdwn2man. Edit with care. diff --git a/git-annex.cabal b/git-annex.cabal index 7a0e34b3a..751bd4bd4 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 @@ -365,7 +367,8 @@ Executable git-annex aeson, unordered-containers, feed, - regex-tdfa + regex-tdfa, + socks CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports @@ -700,6 +703,7 @@ Executable git-annex CmdLine.GitAnnexShell.Fields CmdLine.GlobalSetter CmdLine.Option + CmdLine.GitRemoteTorAnnex CmdLine.Seek CmdLine.Usage Command @@ -924,6 +928,7 @@ Executable git-annex Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh + Remote.Helper.Tor Remote.Hook Remote.List Remote.Rsync 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 + - Copyright 2010-2016 Joey Hess - - 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. -- cgit v1.2.3 From 8166ebdb34c513af648072e03682c8c503f57bdd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 22 Nov 2016 14:18:34 -0400 Subject: unified AuthToken type between webapp and tor --- Assistant/Threads/WebApp.hs | 3 +- CmdLine/GitRemoteTorAnnex.hs | 3 +- Remote/Helper/P2P.hs | 14 +------ Remote/Helper/Tor.hs | 12 ++++-- Utility/AuthToken.hs | 99 ++++++++++++++++++++++++++++++++++++++++++++ Utility/WebApp.hs | 25 +---------- git-annex.cabal | 5 ++- 7 files changed, 117 insertions(+), 44 deletions(-) create mode 100644 Utility/AuthToken.hs (limited to 'git-annex.cabal') 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/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index f3c3a81ae..3282cc081 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -14,6 +14,7 @@ import Remote.Helper.P2P import Remote.Helper.P2P.IO import Remote.Helper.Tor import Utility.Tor +import Utility.AuthToken import Annex.UUID run :: [String] -> IO () @@ -53,7 +54,7 @@ connectService address port service = do state <- Annex.new =<< Git.CurrentRepo.get Annex.eval state $ do authtoken <- fromMaybe nullAuthToken - <$> getTorAuthToken address + <$> getTorAuthTokenFor address myuuid <- getUUID g <- Annex.gitRepo h <- liftIO $ torHandle =<< connectHiddenService address port diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index eaa534fbe..9d9a3847b 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -12,6 +12,7 @@ module Remote.Helper.P2P where import qualified Utility.SimpleProtocol as Proto import Types.Key import Types.UUID +import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude @@ -23,15 +24,6 @@ import System.Exit (ExitCode(..)) import System.IO import qualified Data.ByteString.Lazy as L -newtype AuthToken = AuthToken String - deriving (Show) - -mkAuthToken :: String -> Maybe AuthToken -mkAuthToken = fmap AuthToken . headMaybe . lines - -nullAuthToken :: AuthToken -nullAuthToken = AuthToken "" - newtype Offset = Offset Integer deriving (Show) @@ -111,10 +103,6 @@ instance Proto.Serializable Len where serialize (Len n) = show n deserialize = Len <$$> readish -instance Proto.Serializable AuthToken where - serialize (AuthToken s) = s - deserialize = Just . AuthToken - instance Proto.Serializable Service where serialize UploadPack = "git-upload-pack" serialize ReceivePack = "git-receive-pack" diff --git a/Remote/Helper/Tor.hs b/Remote/Helper/Tor.hs index e91083362..25d192023 100644 --- a/Remote/Helper/Tor.hs +++ b/Remote/Helper/Tor.hs @@ -8,19 +8,23 @@ module Remote.Helper.Tor where import Annex.Common -import Remote.Helper.P2P (mkAuthToken, AuthToken) +import Utility.AuthToken import Creds import Utility.Tor import Utility.Env import Network.Socket +import qualified Data.Text as T -getTorAuthToken :: OnionAddress -> Annex (Maybe AuthToken) -getTorAuthToken (OnionAddress onionaddress) = - maybe Nothing mkAuthToken <$> getM id +-- 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" 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 + - + - 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/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/git-annex.cabal b/git-annex.cabal index 751bd4bd4..94d1ccf9c 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -368,7 +368,8 @@ Executable git-annex unordered-containers, feed, regex-tdfa, - socks + socks, + securemem CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports @@ -472,7 +473,6 @@ Executable git-annex clientsession, template-haskell, shakespeare (>= 2.0.0), - securemem, byteable CPP-Options: -DWITH_WEBAPP @@ -989,6 +989,7 @@ Executable git-annex Upgrade.V4 Upgrade.V5 Utility.Applicative + Utility.AuthToken Utility.Base64 Utility.Batch Utility.Bloom -- cgit v1.2.3 From d6ceefea050683c6e9022fa04bdefd9e28609990 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 22 Nov 2016 14:34:49 -0400 Subject: reorg --- P2P/IO.hs | 216 ++++++++++++++++++++++++++ P2P/Protocol.hs | 399 ++++++++++++++++++++++++++++++++++++++++++++++++ Remote/Helper/P2P.hs | 399 ------------------------------------------------ Remote/Helper/P2P/IO.hs | 216 -------------------------- git-annex.cabal | 4 +- 5 files changed, 617 insertions(+), 617 deletions(-) create mode 100644 P2P/IO.hs create mode 100644 P2P/Protocol.hs delete mode 100644 Remote/Helper/P2P.hs delete mode 100644 Remote/Helper/P2P/IO.hs (limited to 'git-annex.cabal') diff --git a/P2P/IO.hs b/P2P/IO.hs new file mode 100644 index 000000000..9a1243f52 --- /dev/null +++ b/P2P/IO.hs @@ -0,0 +1,216 @@ +{- P2P protocol, partial IO implementation + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, CPP #-} + +module P2P.IO + ( RunProto + , runNetProtoHandle + ) where + +import Remote.Helper.P2P +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 + - + - 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/Helper/P2P.hs b/Remote/Helper/P2P.hs deleted file mode 100644 index 9d9a3847b..000000000 --- a/Remote/Helper/P2P.hs +++ /dev/null @@ -1,399 +0,0 @@ -{- P2P protocol - - - - Copyright 2016 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-} - -module Remote.Helper.P2P 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/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs deleted file mode 100644 index c042d0bcc..000000000 --- a/Remote/Helper/P2P/IO.hs +++ /dev/null @@ -1,216 +0,0 @@ -{- P2P protocol, partial IO implementation - - - - Copyright 2016 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE RankNTypes, CPP #-} - -module Remote.Helper.P2P.IO - ( RunProto - , runNetProtoHandle - ) where - -import Remote.Helper.P2P -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/git-annex.cabal b/git-annex.cabal index 94d1ccf9c..fd8ce9ce2 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -904,6 +904,8 @@ Executable git-annex Messages.Internal Messages.JSON Messages.Progress + P2P.IO + P2P.Protocol Remote Remote.BitTorrent Remote.Bup @@ -923,8 +925,6 @@ Executable git-annex Remote.Helper.Hooks Remote.Helper.Http Remote.Helper.Messages - Remote.Helper.P2P - Remote.Helper.P2P.IO Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh -- cgit v1.2.3 From ee611985367b93539c9390a8067d28340dd972ad Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 22 Nov 2016 14:37:19 -0400 Subject: add P2P.Auth --- Creds.hs | 2 +- P2P/Auth.hs | 30 ++++++++++++++++++++++++++++++ git-annex.cabal | 1 + 3 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 P2P/Auth.hs (limited to 'git-annex.cabal') diff --git a/Creds.hs b/Creds.hs index 6be9b3391..de3cd2a06 100644 --- a/Creds.hs +++ b/Creds.hs @@ -156,7 +156,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 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 + - + - 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/git-annex.cabal b/git-annex.cabal index fd8ce9ce2..bd8c36063 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -904,6 +904,7 @@ Executable git-annex Messages.Internal Messages.JSON Messages.Progress + P2P.Auth P2P.IO P2P.Protocol Remote -- cgit v1.2.3 From 6fbf18025af8c697b515e83600f16de0c232a994 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Nov 2016 17:30:27 -0400 Subject: finish git-annex enable-tor Make it stash the address away for git-annex p2p to use later, rather than outputting it. And, look up the UUID itself. --- Command/EnableTor.hs | 27 ++++++++------- Creds.hs | 1 + P2P/Address.hs | 79 +++++++++++++++++++++++++++++++++++++++++++ Utility/Tor.hs | 10 +++--- doc/git-annex-enable-tor.mdwn | 14 ++++---- git-annex.cabal | 1 + 6 files changed, 106 insertions(+), 26 deletions(-) create mode 100644 P2P/Address.hs (limited to 'git-annex.cabal') diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index c581fa1d4..d24ecb2dc 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -8,27 +8,28 @@ 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, as that would create root-owned files. +-- git-annex, or doing other things that create root-owned files. cmd :: Command cmd = noCommit $ dontCheck repoExists $ - command "enable-tor" SectionSetup "" - "userid uuid" (withParams seek) + command "enable-tor" SectionSetup "enable tor hidden service" + "uid" (withParams seek) seek :: CmdParams -> CommandSeek seek = withWords start -start :: CmdParams -> CommandStart -start (suserid:uuid:[]) = case readish suserid of - Nothing -> error "Bad userid" +start :: [String] -> CommandStart +start ps = case readish =<< headMaybe ps of + Nothing -> giveup "Bad params" Just userid -> do - (OnionAddress onionaddr, onionport) <- liftIO $ - addHiddenService userid uuid - liftIO $ putStrLn $ - "tor-annex::" ++ - onionaddr ++ ":" ++ - show onionport ++ " " + 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 -start _ = error "Bad params" diff --git a/Creds.hs b/Creds.hs index de3cd2a06..b5181aa1e 100644 --- a/Creds.hs +++ b/Creds.hs @@ -15,6 +15,7 @@ module Creds ( getEnvCredPair, writeCacheCreds, readCacheCreds, + cacheCredsFile, removeCreds, includeCredsInfo, ) where diff --git a/P2P/Address.hs b/P2P/Address.hs new file mode 100644 index 000000000..315219683 --- /dev/null +++ b/P2P/Address.hs @@ -0,0 +1,79 @@ +{- P2P protocol addresses + - + - Copyright 2016 Joey Hess + - + - 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) + +loadP2PAddresses :: Annex [P2PAddress] +loadP2PAddresses = mapMaybe unformatP2PAddress . maybe [] lines + <$> readCacheCreds p2pAddressCredsFile + +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/Utility/Tor.hs b/Utility/Tor.hs index 3b9ddb6a6..e63bd82d4 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -21,7 +21,7 @@ import qualified System.Random as R type OnionPort = Int newtype OnionAddress = OnionAddress String - deriving (Show) + deriving (Show, Eq) type OnionSocket = FilePath @@ -57,7 +57,7 @@ addHiddenService uid ident = do case filter (\(_, s) -> s == sockfile) portssocks of ((p, _s):_) -> waithiddenservice 1 p _ -> do - highports <- R.getStdRandom highports + highports <- R.getStdRandom mkhighports let newport = Prelude.head $ filter (`notElem` map fst portssocks) highports writeFile torrc $ unlines $ @@ -74,7 +74,7 @@ addHiddenService uid ident = do , ("sefvice", [Param "tor", Param "reload"]) ] unless reloaded $ - error "failed to reload tor, perhaps the tor service is not running" + giveup "failed to reload tor, perhaps the tor service is not running" waithiddenservice 120 newport where parseportsock ("HiddenServicePort", l) = do @@ -85,12 +85,12 @@ addHiddenService uid ident = do sockfile = hiddenServiceSocketFile uid ident -- An infinite random list of high ports. - highports g = + mkhighports g = let (g1, g2) = R.split g in (R.randomRs (1025, 65534) g1, g2) waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) - waithiddenservice 0 _ = error "tor failed to create hidden service, perhaps the tor service is not running" + 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 diff --git a/doc/git-annex-enable-tor.mdwn b/doc/git-annex-enable-tor.mdwn index 9fb55db5f..1c1738027 100644 --- a/doc/git-annex-enable-tor.mdwn +++ b/doc/git-annex-enable-tor.mdwn @@ -4,20 +4,18 @@ git-annex enable-tor - enable tor hidden service # SYNOPSIS -git annex enable-tor userid uuid +sudo git annex enable-tor $(id -u) # DESCRIPTION -This plumbing-level command enables a tor hidden service for git-annex, -using the specified repository uuid and userid. +This command enables a tor hidden service for git-annex. -This command has to be run by root, since it modifies `/etc/tor/torrc`. +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. - -Use the `git-annex p2p --gen-address` command to give other users access -to your repository via the tor hidden service. +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 diff --git a/git-annex.cabal b/git-annex.cabal index bd8c36063..5a446ac7a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -904,6 +904,7 @@ Executable git-annex Messages.Internal Messages.JSON Messages.Progress + P2P.Address P2P.Auth P2P.IO P2P.Protocol -- cgit v1.2.3 From 66b3af4aa5c3bbb53fc27b25303c4e69364930f5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 30 Nov 2016 14:35:24 -0400 Subject: implement p2p command --- Annex/SpecialRemote.hs | 3 +- CHANGELOG | 1 + CmdLine/GitAnnex.hs | 2 + Command/EnableRemote.hs | 7 ++-- Command/P2P.hs | 61 +++++++++++++++++++++++++++++ P2P/Address.hs | 5 ++- P2P/Auth.hs | 37 +++++++++-------- doc/git-annex-p2p.mdwn | 8 +++- doc/tips/peer_to_peer_network_with_tor.mdwn | 16 ++++---- git-annex.cabal | 3 ++ 10 files changed, 110 insertions(+), 33 deletions(-) create mode 100644 Command/P2P.hs (limited to 'git-annex.cabal') 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/CHANGELOG b/CHANGELOG index 2eef5a422..b532e7674 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ 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. diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 0fa14c98b..a12366b74 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -96,6 +96,7 @@ 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 @@ -204,6 +205,7 @@ cmds testoptparser testrunner = , Command.Indirect.cmd , Command.Upgrade.cmd , Command.Forget.cmd + , Command.P2P.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd , Command.Smudge.cmd 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/P2P.hs b/Command/P2P.hs new file mode 100644 index 000000000..ec6e4be96 --- /dev/null +++ b/Command/P2P.hs @@ -0,0 +1,61 @@ +{- git-annex command + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.P2P where + +import Command +import Git.Types +import P2P.Address +import P2P.Auth +import Utility.AuthToken + +cmd :: Command +cmd = command "p2p" SectionSetup + "configure peer-2-peer links between repositories" + paramNothing (seek <$$> optParser) + +data P2POpts + = GenAddresses + | LinkRemote P2PAddressAuth 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 + <$> option readaddr + ( long "link" + <> metavar paramAddress + <> help "address of the peer to link with" + ) + <*> strOption + ( long "named" + <> metavar paramRemote + <> help "specify name to use for git remote" + ) + readaddr = eitherReader $ maybe (Left "address parse error") Right + . unformatP2PAddress + +seek :: P2POpts -> CommandSeek +seek GenAddresses = do + addrs <- loadP2PAddresses + if null addrs + then giveup "No P2P networks are currrently available." + else do + authtoken <- liftIO $ genAuthToken 128 + storeP2PAuthToken authtoken + -- Only addresses are output to stdout, to allow + -- scripting. + 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 +seek (LinkRemote addr name) = do + diff --git a/P2P/Address.hs b/P2P/Address.hs index 862f06a9c..19ff82a89 100644 --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -23,7 +23,10 @@ import qualified Data.Text as T data P2PAddress = TorAnnex OnionAddress OnionPort deriving (Eq, Show) --- | A P2P address, with an AuthToken +-- | 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) diff --git a/P2P/Auth.hs b/P2P/Auth.hs index 5c3feb713..2482c1dc0 100644 --- a/P2P/Auth.hs +++ b/P2P/Auth.hs @@ -1,4 +1,4 @@ -{- P2P protocol, authorization +{- P2P authtokens - - Copyright 2016 Joey Hess - @@ -7,24 +7,29 @@ module P2P.Auth where -import Common +import Annex.Common +import Creds 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' +-- | Load authtokens that are accepted by this repository. +loadP2PAuthTokens :: Annex AllowedAuthTokens +loadP2PAuthTokens = allowedAuthTokens <$> loadP2PAuthTokens' -getAuthTokens' :: Annex [AuthTokens] -getAuthTokens' = mapMaybe toAuthToken - . map T.pack - . lines - . fromMaybe [] - <$> readCacheCreds "tor" +loadP2PAuthTokens' :: Annex [AuthToken] +loadP2PAuthTokens' = mapMaybe toAuthToken + . map T.pack + . lines + . fromMaybe [] + <$> readCacheCreds p2pAuthCredsFile -addAuthToken :: AuthToken -> Annex () -addAuthToken t = do - ts <- getAuthTokens' - let d = unlines $ map (T.unpack . fromAuthToken) (t:ts) - writeCacheCreds d "tor" +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" diff --git a/doc/git-annex-p2p.mdwn b/doc/git-annex-p2p.mdwn index 8e06cc47c..049f90014 100644 --- a/doc/git-annex-p2p.mdwn +++ b/doc/git-annex-p2p.mdwn @@ -11,14 +11,18 @@ git annex p2p [options] 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 a P2P network. The address or addresses is output to stdout. + over the available P2P networks. The address or addresses is output to + stdout. -* `--link-remote remotename address` +* `--link address --named remotename` 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 diff --git a/doc/tips/peer_to_peer_network_with_tor.mdwn b/doc/tips/peer_to_peer_network_with_tor.mdwn index 94470b96a..de018e3ce 100644 --- a/doc/tips/peer_to_peer_network_with_tor.mdwn +++ b/doc/tips/peer_to_peer_network_with_tor.mdwn @@ -44,7 +44,7 @@ repository: Now, tell the new peer about the address of the first peer: - git annex p2p --link-remote peer1 tor-annnex::eeaytkuhaupbarfi.onion:4412:7f53c5b65b8957ef626fd461ceaae8056e3dbc459ae715e4 + git annex p2p --link tor-annnex::eeaytkuhaupbarfi.onion:4412:7f53c5b65b8957ef626fd461ceaae8056e3dbc459ae715e4 --named peer1 (Of course, you should paste in the address you generated earlier, not the example one shown above.) @@ -56,8 +56,8 @@ 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, +p2p --gen-address`, 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. @@ -88,14 +88,14 @@ You can `git pull`, push, etc with those onion addresses: 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". +`.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-address` combine the onion address with the authentication data. -When you run `git annex peer --link-remote`, it sets up a git remote using +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/` diff --git a/git-annex.cabal b/git-annex.cabal index 5a446ac7a..6991d2a04 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -91,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 @@ -727,6 +728,7 @@ Executable git-annex Command.DropKey Command.DropUnused Command.EnableRemote + Command.EnableTor Command.ExamineKey Command.Expire Command.Find @@ -762,6 +764,7 @@ Executable git-annex Command.Move Command.NotifyChanges Command.NumCopies + Command.P2P Command.PreCommit Command.Proxy Command.ReKey -- cgit v1.2.3 From 9d6ee2fe7fa1ec5511070a964ba35d9c9711e235 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 2 Dec 2016 13:50:56 -0400 Subject: make remote-daemon able to send and receive objects over tor Each worker thread needs to run in the Annex monad, but the remote-daemon's liftAnnex can only run 1 action at a time. Used Annex.Concurrent to deal with that. P2P.Annex is incomplete as of yet. --- P2P/Annex.hs | 36 ++++++++++++++++++++++++++++++++++++ RemoteDaemon/Transport/Tor.hs | 30 +++++++++++++++++++----------- git-annex.cabal | 1 + 3 files changed, 56 insertions(+), 11 deletions(-) create mode 100644 P2P/Annex.hs (limited to 'git-annex.cabal') diff --git a/P2P/Annex.hs b/P2P/Annex.hs new file mode 100644 index 000000000..ad4b458dd --- /dev/null +++ b/P2P/Annex.hs @@ -0,0 +1,36 @@ +{- P2P protocol, Annex implementation + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, FlexibleContexts #-} + +module P2P.Annex + ( RunEnv(..) + , runFullProto + ) where + +import Annex.Common +import Annex.Content +import P2P.Protocol +import P2P.IO + +import Control.Monad.Free + +-- Full interpreter for Proto, that can receive and send objects. +runFullProto :: RunEnv -> Proto a -> Annex (Maybe a) +runFullProto runenv = go + where + go :: RunProto Annex + go (Pure v) = pure (Just v) + go (Free (Net n)) = runNet runenv go n + go (Free (Local l)) = runLocal runenv go l + +runLocal :: RunEnv -> RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a) +runLocal runenv runner f = case f of + TmpContentSize k next -> do + tmp <- fromRepo $ gitAnnexTmpObjectLocation k + size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp + runner (next (Len size)) diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 75b1a7923..3c715fbde 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -8,6 +8,8 @@ module RemoteDaemon.Transport.Tor (server) where import Common +import qualified Annex +import Annex.Concurrent import RemoteDaemon.Types import RemoteDaemon.Common import Utility.Tor @@ -15,7 +17,7 @@ import Utility.FileMode import Utility.AuthToken import Remote.Helper.Tor import P2P.Protocol -import P2P.IO +import P2P.Annex import P2P.Auth import Annex.UUID import Types.UUID @@ -75,14 +77,20 @@ serveClient th u r q = bracket setup cleanup go cleanup = hClose go h = do debugM "remotedaemon" "serving a TOR connection" - -- Load auth tokens for every connection, to notice - -- when the allowed set is changed. - allowed <- liftAnnex th loadP2PAuthTokens - let runenv = RunEnv - { runRepo = r - , runCheckAuth = (`isAllowedAuthToken` allowed) - , runIhdl = h - , runOhdl = h - } - void $ runNetProto runenv (serve u) + -- 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 runenv = RunEnv + { runRepo = r + , runCheckAuth = (`isAllowedAuthToken` allowed) + , runIhdl = h + , runOhdl = h + } + void $ runFullProto runenv (serve u) + -- Merge the duplicated state back in. + liftAnnex th $ mergeState st' debugM "remotedaemon" "done with TOR connection" diff --git a/git-annex.cabal b/git-annex.cabal index 6991d2a04..f6d8c5482 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -908,6 +908,7 @@ Executable git-annex Messages.JSON Messages.Progress P2P.Address + P2P.Annex P2P.Auth P2P.IO P2P.Protocol -- cgit v1.2.3 From 43db49626e57214820e29341aed0024dd681e7bd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Dec 2016 12:19:47 -0400 Subject: stub Remote.P2P Similar to GCrypt remotes, P2P remotes have an url, so Remote.Git has to separate them out and handle them, passing off to Remote.P2P. This commit was sponsored by Ignacio on Patreon. --- P2P/Address.hs | 5 ++++ Remote/Git.hs | 6 +++- Remote/List.hs | 4 ++- Remote/P2P.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ git-annex.cabal | 1 + 5 files changed, 99 insertions(+), 2 deletions(-) create mode 100644 Remote/P2P.hs (limited to 'git-annex.cabal') diff --git a/P2P/Address.hs b/P2P/Address.hs index 19ff82a89..09ffc7973 100644 --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -10,6 +10,7 @@ module P2P.Address where import qualified Annex import Annex.Common import Git +import Git.Types import Creds import Utility.AuthToken import Utility.Tor @@ -54,6 +55,10 @@ instance FormatP2PAddress P2PAddressAuth where 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 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..e0428eeeb --- /dev/null +++ b/Remote/P2P.hs @@ -0,0 +1,85 @@ +{- git remotes using the git-annex P2P protocol + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.P2P ( + remote, + chainGen +) where + +import Annex.Common +import P2P.Address +import Types.Remote +import Types.GitConfig +import qualified Git +import Config +import Config.Cost +import Remote.Helper.Git +import Remote.Helper.Special + +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 + workerpool <- mkWorkerPool addr + cst <- remoteCost gc expensiveRemoteCost + let this = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = \_ _ _ -> return False + , removeKey = removeKeyDummy + , lockContent = Nothing -- TODO use p2p protocol locking + , checkPresent = checkPresentDummy + , 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 $ specialRemote' (specialRemoteCfg c) c + (simplyPrepare $ store this workerpool) + (simplyPrepare $ retrieve this workerpool) + (simplyPrepare $ remove this workerpool) + (simplyPrepare $ checkKey this workerpool) + this + +data WorkerPool = WorkerPool + +mkWorkerPool :: P2PAddress -> Annex WorkerPool +mkWorkerPool addr = undefined + +store :: Remote -> WorkerPool -> Storer +store r workerpool = undefined + +retrieve :: Remote -> WorkerPool -> Retriever +retrieve r workerpool = undefined + +remove :: Remote -> WorkerPool -> Remover +remove r workerpool k = undefined + +checkKey :: Remote -> WorkerPool -> CheckPresent +checkKey r workerpool k = undefined diff --git a/git-annex.cabal b/git-annex.cabal index f6d8c5482..7fcba0623 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -937,6 +937,7 @@ Executable git-annex Remote.Helper.Tor Remote.Hook Remote.List + Remote.P2P Remote.Rsync Remote.Rsync.RsyncUrl Remote.S3 -- cgit v1.2.3 From 5258f572d494d015c6c6e60c37a215bb95048bbd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Dec 2016 15:40:31 -0400 Subject: refactor --- CmdLine/GitRemoteTorAnnex.hs | 11 ++----- P2P/Annex.hs | 8 ++--- P2P/IO.hs | 73 +++++++++++++++++++++++++++++-------------- Remote/Helper/Tor.hs | 20 ------------ Remote/P2P.hs | 30 +++++++----------- RemoteDaemon/Transport/Tor.hs | 17 +++++----- git-annex.cabal | 1 - 7 files changed, 74 insertions(+), 86 deletions(-) delete mode 100644 Remote/Helper/Tor.hs (limited to 'git-annex.cabal') diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index 517ce7c82..c4bf26c85 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -12,7 +12,6 @@ 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 @@ -59,14 +58,8 @@ connectService address port service = do <$> loadP2PRemoteAuthToken (TorAnnex address port) myuuid <- getUUID g <- Annex.gitRepo - h <- liftIO $ torHandle =<< connectHiddenService address port - let runenv = RunEnv - { runRepo = g - , runCheckAuth = const False - , runIhdl = h - , runOhdl = h - } - liftIO $ runNetProto runenv $ do + conn <- liftIO $ connectPeer g (TorAnnex address port) + liftIO $ runNetProto conn $ do v <- auth myuuid authtoken case v of Just _theiruuid -> connect service stdin stdout diff --git a/P2P/Annex.hs b/P2P/Annex.hs index d0c00def3..4105abe32 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -9,7 +9,7 @@ module P2P.Annex ( RunMode(..) - , RunEnv(..) + , P2PConnection(..) , runFullProto ) where @@ -31,12 +31,12 @@ data RunMode | Client -- Full interpreter for Proto, that can receive and send objects. -runFullProto :: RunMode -> RunEnv -> Proto a -> Annex (Maybe a) -runFullProto runmode runenv = go +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 runenv go n + 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) diff --git a/P2P/IO.hs b/P2P/IO.hs index fb621ab2b..f63b2808b 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -9,12 +9,15 @@ module P2P.IO ( RunProto - , RunEnv(..) + , P2PConnection(..) + , connectPeer + , setupHandle , runNetProto , runNet ) where import P2P.Protocol +import P2P.Address import Utility.Process import Git import Git.Command @@ -22,11 +25,14 @@ import Utility.AuthToken import Utility.SafeCommand import Utility.SimpleProtocol import Utility.Exception +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 @@ -36,41 +42,60 @@ 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 RunEnv = RunEnv - { runRepo :: Repo - , runCheckAuth :: (AuthToken -> Bool) - , runIhdl :: Handle - , runOhdl :: Handle +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 + } + +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 :: RunEnv -> Proto a -> IO (Maybe a) -runNetProto runenv = go +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 runenv go n + 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) => RunEnv -> RunProto m -> NetF (Proto a) -> m (Maybe a) -runNet runenv runner f = case f of +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 (runOhdl runenv) (unwords (formatMessage m)) - hFlush (runOhdl runenv) + 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 (runIhdl runenv) + v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn) case v of Left _e -> return Nothing Right l -> case parseMessage l of @@ -81,19 +106,19 @@ runNet runenv runner f = case f of next e SendBytes len b next -> do v <- liftIO $ tryNonAsync $ do - ok <- sendExactly len b (runOhdl runenv) - hFlush (runOhdl runenv) + ok <- sendExactly len b (connOhdl conn) + hFlush (connOhdl conn) return ok case v of Right True -> runner next _ -> return Nothing ReceiveBytes (Len n) next -> do - v <- liftIO $ tryNonAsync $ L.hGet (runIhdl runenv) (fromIntegral n) + v <- liftIO $ tryNonAsync $ L.hGet (connIhdl conn) (fromIntegral n) case v of Left _e -> return Nothing Right b -> runner (next b) CheckAuthToken _u t next -> do - let authed = runCheckAuth runenv t + let authed = connCheckAuth conn t runner (next authed) Relay hin hout next -> do v <- liftIO $ runRelay runnerio hin hout @@ -101,7 +126,7 @@ runNet runenv runner f = case f of Nothing -> return Nothing Just exitcode -> runner (next exitcode) RelayService service next -> do - v <- liftIO $ runRelayService runenv runnerio service + v <- liftIO $ runRelayService conn runnerio service case v of Nothing -> return Nothing Just () -> runner next @@ -109,7 +134,7 @@ runNet runenv runner f = case f of -- 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 runenv + runnerio = runNetProto conn -- Send exactly the specified number of bytes or returns False. -- @@ -150,8 +175,8 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go go v = relayHelper runner v hin -runRelayService :: RunEnv -> RunProto IO -> Service -> IO (Maybe ()) -runRelayService runenv runner service = bracket setup cleanup go +runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Maybe ()) +runRelayService conn runner service = bracket setup cleanup go where cmd = case service of UploadPack -> "upload-pack" @@ -159,8 +184,8 @@ runRelayService runenv runner service = bracket setup cleanup go serviceproc = gitCreateProcess [ Param cmd - , File (repoPath (runRepo runenv)) - ] (runRepo runenv) + , File (repoPath (connRepo conn)) + ] (connRepo conn) setup = do (Just hin, Just hout, _, pid) <- createProcess serviceproc diff --git a/Remote/Helper/Tor.hs b/Remote/Helper/Tor.hs deleted file mode 100644 index b5a819c3b..000000000 --- a/Remote/Helper/Tor.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- Helpers for tor remotes. - - - - Copyright 2016 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Remote.Helper.Tor where - -import Annex.Common - -import Network.Socket - -torHandle :: Socket -> IO Handle -torHandle s = do - h <- socketToHandle s ReadWriteMode - hSetBuffering h LineBuffering - hSetBinaryMode h False - fileEncoding h - return h diff --git a/Remote/P2P.hs b/Remote/P2P.hs index f97d76e71..0c7ca0574 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -15,14 +15,13 @@ import qualified Annex import qualified P2P.Protocol as P2P import P2P.Address import P2P.Annex +import P2P.IO import Types.Remote import Types.GitConfig import qualified Git import Config import Config.Cost import Remote.Helper.Git -import Remote.Helper.Tor -import Utility.Tor import Utility.Metered import Types.NumCopies @@ -108,7 +107,7 @@ lock theiruuid addr connpool k callback = -- | A connection to the peer. data Connection - = TorAnnexConnection RunEnv + = OpenConnection P2PConnection | ClosedConnection type ConnectionPool = TVar [Connection] @@ -122,14 +121,15 @@ runProto addr connpool a = withConnection addr connpool (runProto' a) runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a) runProto' _ ClosedConnection = return (ClosedConnection, Nothing) -runProto' a conn@(TorAnnexConnection runenv) = do - r <- runFullProto Client runenv a +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 (conn, r) + then return (OpenConnection conn, r) else do - liftIO $ hClose (runIhdl runenv) + liftIO $ hClose (connIhdl conn) + liftIO $ hClose (connOhdl conn) return (ClosedConnection, r) -- Uses an open connection if one is available in the ConnectionPool; @@ -161,17 +161,9 @@ withConnection addr connpool a = bracketOnError get cache go return r openConnection :: P2PAddress -> Annex Connection -openConnection (TorAnnex onionaddress onionport) = do - v <- liftIO $ tryNonAsync $ - torHandle =<< connectHiddenService onionaddress onionport +openConnection addr = do + g <- Annex.gitRepo + v <- liftIO $ tryNonAsync $ connectPeer g addr case v of - Right h -> do - g <- Annex.gitRepo - let runenv = RunEnv - { runRepo = g - , runCheckAuth = const False - , runIhdl = h - , runOhdl = h - } - return (TorAnnexConnection runenv) + Right conn -> return (OpenConnection conn) Left _e -> return ClosedConnection diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 2caa7cdb1..e5d4e97ad 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -15,7 +15,6 @@ import RemoteDaemon.Common import Utility.Tor import Utility.FileMode import Utility.AuthToken -import Remote.Helper.Tor import P2P.Protocol import P2P.IO import P2P.Annex @@ -55,7 +54,7 @@ server th@(TransportHandle (LocalRepo r) _) = do debugM "remotedaemon" "tor hidden service running" forever $ do (conn, _) <- accept soc - h <- torHandle conn + h <- setupHandle conn ok <- atomically $ ifM (isFullTBQueue q) ( return False , do @@ -85,16 +84,16 @@ serveClient th u r q = bracket setup cleanup go -- Load auth tokens for every connection, to notice -- when the allowed set is changed. allowed <- loadP2PAuthTokens - let runenv = RunEnv - { runRepo = r - , runCheckAuth = (`isAllowedAuthToken` allowed) - , runIhdl = h - , runOhdl = h + let conn = P2PConnection + { connRepo = r + , connCheckAuth = (`isAllowedAuthToken` allowed) + , connIhdl = h + , connOhdl = h } - v <- liftIO $ runNetProto runenv $ serveAuth u + v <- liftIO $ runNetProto conn $ serveAuth u case v of Just (Just theiruuid) -> void $ - runFullProto (Serving theiruuid) runenv $ + runFullProto (Serving theiruuid) conn $ serveAuthed u _ -> return () -- Merge the duplicated state back in. diff --git a/git-annex.cabal b/git-annex.cabal index 7fcba0623..c894e6610 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -934,7 +934,6 @@ Executable git-annex Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh - Remote.Helper.Tor Remote.Hook Remote.List Remote.P2P -- cgit v1.2.3 From 97297980d1031b3c35e98e605a6c0034815846dd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Dec 2016 16:31:08 -0400 Subject: move byteable to main dep list Only the webapp had pulled it in, but the authtoken code uses it now. --- git-annex.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'git-annex.cabal') diff --git a/git-annex.cabal b/git-annex.cabal index c894e6610..465769ea0 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -370,6 +370,7 @@ Executable git-annex feed, regex-tdfa, socks, + byteable, securemem CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs @@ -473,8 +474,7 @@ Executable git-annex crypto-api, clientsession, template-haskell, - shakespeare (>= 2.0.0), - byteable + shakespeare (>= 2.0.0) CPP-Options: -DWITH_WEBAPP if flag(Pairing) -- cgit v1.2.3 From b3b800bb6140543306ec65751506ae2862ca345f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Dec 2016 14:52:38 -0400 Subject: refactor ref change watching Added to change notification to P2P protocol. Switched to a TBChan so that a single long-running thread can be started, and serve perhaps intermittent requests for change notifications, without buffering all changes in memory. The P2P runner currently starts up a new thread each times it waits for a change, but that should allow later reusing a thread. Although each connection from a peer will still need a new watcher thread to run. The dependency on stm-chans is more or less free; some stuff in yesod uses it, so it was already indirectly pulled in when building with the webapp. This commit was sponsored by Francois Marier on Patreon. --- Annex/ChangedRefs.hs | 105 ++++++++++++++++++++++++++++++++++++ Command/NotifyChanges.hs | 48 +++-------------- P2P/Annex.hs | 9 ++++ P2P/Protocol.hs | 13 +++++ RemoteDaemon/Transport/Ssh.hs | 3 +- RemoteDaemon/Transport/Ssh/Types.hs | 4 +- RemoteDaemon/Types.hs | 10 +--- debian/control | 1 + git-annex.cabal | 2 + 9 files changed, 142 insertions(+), 53 deletions(-) create mode 100644 Annex/ChangedRefs.hs (limited to 'git-annex.cabal') diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs new file mode 100644 index 000000000..0dc82d3b3 --- /dev/null +++ b/Annex/ChangedRefs.hs @@ -0,0 +1,105 @@ +{- Waiting for changed git refs + - + - Copyright 2014-216 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.ChangedRefs + ( ChangedRefs(..) + , ChangedRefsHandle + , waitChangedRefs + , drainChangedRefs + , stopWatchingChangedRefs + , watchChangedRefs + ) where + +import Annex.Common +import Utility.DirWatcher +import Utility.DirWatcher.Types +import qualified Git +import Git.Sha +import qualified Utility.SimpleProtocol as Proto + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMChan + +newtype ChangedRefs = ChangedRefs [Git.Ref] + deriving (Show) + +instance Proto.Serializable ChangedRefs where + serialize (ChangedRefs l) = unwords $ map Git.fromRef l + deserialize = Just . ChangedRefs . map Git.Ref . words + +data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha) + +-- | Wait for one or more git refs to change. +-- +-- When possible, coalesce ref writes that occur closely together +-- in time. Delay up to 0.05 seconds to get more ref writes. +waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs +waitChangedRefs (ChangedRefsHandle _ chan) = do + v <- atomically $ readTBMChan chan + case v of + Nothing -> return $ ChangedRefs [] + Just r -> do + threadDelay 50000 + rs <- atomically $ loop [] + return $ ChangedRefs (r:rs) + where + loop rs = do + v <- tryReadTBMChan chan + case v of + Just (Just r) -> loop (r:rs) + _ -> return rs + +-- | Remove any changes that might be buffered in the channel, +-- without waiting for any new changes. +drainChangedRefs :: ChangedRefsHandle -> IO () +drainChangedRefs (ChangedRefsHandle _ chan) = atomically go + where + go = do + v <- tryReadTBMChan chan + case v of + Just (Just _) -> go + _ -> return () + +stopWatchingChangedRefs :: ChangedRefsHandle -> IO () +stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do + stopWatchDir wh + atomically $ closeTBMChan chan + drainChangedRefs h + +watchChangedRefs :: Annex ChangedRefsHandle +watchChangedRefs = do + -- This channel is used to accumulate notifications, + -- because the DirWatcher might have multiple threads that find + -- changes at the same time. It is bounded to allow a watcher + -- to be started once and reused, without too many changes being + -- buffered in memory. + chan <- liftIO $ newTBMChanIO 100 + + g <- gitRepo + let refdir = Git.localGitDir g "refs" + liftIO $ createDirectoryIfMissing True refdir + + let notifyhook = Just $ notifyHook chan + let hooks = mkWatchHooks + { addHook = notifyhook + , modifyHook = notifyhook + } + + h <- liftIO $ watchDir refdir (const False) True hooks id + return $ ChangedRefsHandle h chan + +notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO () +notifyHook chan reffile _ + | ".lock" `isSuffixOf` reffile = noop + | otherwise = void $ do + sha <- catchDefaultIO Nothing $ + extractSha <$> readFile reffile + -- When the channel is full, there is probably no reader + -- running, or ref changes have been occuring very fast, + -- so it's ok to not write the change to it. + maybe noop (void . atomically . tryWriteTBMChan chan) sha diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs index bb9b10eee..83d7bca3f 100644 --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -8,6 +8,7 @@ module Command.NotifyChanges where import Command +import Annex.ChangedRefs import Utility.DirWatcher import Utility.DirWatcher.Types import qualified Git @@ -30,55 +31,18 @@ seek = withNothing start start :: CommandStart start = do - -- This channel is used to accumulate notifcations, - -- because the DirWatcher might have multiple threads that find - -- changes at the same time. - chan <- liftIO newTChanIO - - g <- gitRepo - let refdir = Git.localGitDir g "refs" - liftIO $ createDirectoryIfMissing True refdir + h <- watchChangedRefs - let notifyhook = Just $ notifyHook chan - let hooks = mkWatchHooks - { addHook = notifyhook - , modifyHook = notifyhook - } - - void $ liftIO $ watchDir refdir (const False) True hooks id - - let sender = do - send READY - forever $ send . CHANGED =<< drain chan - -- No messages need to be received from the caller, -- but when it closes the connection, notice and terminate. let receiver = forever $ void $ getProtocolLine stdin + let sender = forever $ send . CHANGED =<< waitChangedRefs h + + liftIO $ send READY void $ liftIO $ concurrently sender receiver + liftIO $ stopWatchingChangedRefs h stop -notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO () -notifyHook chan reffile _ - | ".lock" `isSuffixOf` reffile = noop - | otherwise = void $ do - sha <- catchDefaultIO Nothing $ - extractSha <$> readFile reffile - maybe noop (atomically . writeTChan chan) sha - --- When possible, coalesce ref writes that occur closely together --- in time. Delay up to 0.05 seconds to get more ref writes. -drain :: TChan Git.Sha -> IO [Git.Sha] -drain chan = do - r <- atomically $ readTChan chan - threadDelay 50000 - rs <- atomically $ drain' chan - return (r:rs) - -drain' :: TChan Git.Sha -> STM [Git.Sha] -drain' chan = loop [] - where - loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan - send :: Notification -> IO () send n = do putStrLn $ unwords $ formatMessage n diff --git a/P2P/Annex.hs b/P2P/Annex.hs index d24e65b0f..e9b59652c 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -16,6 +16,7 @@ module P2P.Annex import Annex.Common import Annex.Content import Annex.Transfer +import Annex.ChangedRefs import P2P.Protocol import P2P.IO import Logs.Location @@ -114,6 +115,14 @@ runLocal runmode runner a = case a of protoaction False next Right _ -> runner next + WaitRefChange next -> do + v <- tryNonAsync $ bracket + watchChangedRefs + (liftIO . stopWatchingChangedRefs) + (liftIO . waitChangedRefs) + case v of + Left e -> return (Left (show e)) + Right changedrefs -> runner (next changedrefs) where transfer mk k af ta = case runmode of -- Update transfer logs when serving. diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index 03c7c70cf..d8be3ff42 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -19,6 +19,7 @@ import Utility.Applicative import Utility.PartialPrelude import Utility.Metered import Git.FilePath +import Annex.ChangedRefs (ChangedRefs) import Control.Monad import Control.Monad.Free @@ -50,6 +51,8 @@ data Message | AUTH_FAILURE | CONNECT Service | CONNECTDONE ExitCode + | NOTIFYCHANGE + | CHANGED ChangedRefs | CHECKPRESENT Key | LOCKCONTENT Key | UNLOCKCONTENT @@ -70,6 +73,8 @@ instance Proto.Sendable Message where formatMessage AUTH_FAILURE = ["AUTH-FAILURE"] formatMessage (CONNECT service) = ["CONNECT", Proto.serialize service] formatMessage (CONNECTDONE exitcode) = ["CONNECTDONE", Proto.serialize exitcode] + formatMessage NOTIFYCHANGE = ["NOTIFYCHANGE"] + formatMessage (CHANGED refs) = ["CHANGED", Proto.serialize refs] formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key] formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key] formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"] @@ -89,6 +94,8 @@ instance Proto.Receivable Message where parseCommand "AUTH-FAILURE" = Proto.parse0 AUTH_FAILURE parseCommand "CONNECT" = Proto.parse1 CONNECT parseCommand "CONNECTDONE" = Proto.parse1 CONNECTDONE + parseCommand "NOTIFYCHANGE" = Proto.parse0 NOTIFYCHANGE + parseCommand "CHANGED" = Proto.parse1 CHANGED parseCommand "CHECKPRESENT" = Proto.parse1 CHECKPRESENT parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT @@ -227,6 +234,8 @@ data LocalF c -- from being deleted, while running the provided protocol -- action. If unable to lock the content, runs the protocol action -- with False. + | WaitRefChange (ChangedRefs -> c) + -- ^ Waits for one or more git refs to change and returns them. deriving (Functor) type Local = Free LocalF @@ -379,6 +388,10 @@ serveAuthed myuuid = void $ serverLoop handler handler (CONNECT service) = do net $ relayService service return ServerContinue + handler NOTIFYCHANGE = do + refs <- local waitRefChange + net $ sendMessage (CHANGED refs) + return ServerContinue handler _ = return ServerUnexpected sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs index 205165062..59502f8d3 100644 --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -17,6 +17,7 @@ import Utility.SimpleProtocol import qualified Git import Git.Command import Utility.ThreadScheduler +import Annex.ChangedRefs import Control.Concurrent.STM import Control.Concurrent.Async @@ -73,7 +74,7 @@ transportUsingCmd' cmd params (RemoteRepo r _) url transporthandle ichan ochan = Just SshRemote.READY -> do send (CONNECTED url) handlestdout fromh - Just (SshRemote.CHANGED shas) -> do + Just (SshRemote.CHANGED (ChangedRefs shas)) -> do whenM (checkNewShas transporthandle shas) $ fetch handlestdout fromh diff --git a/RemoteDaemon/Transport/Ssh/Types.hs b/RemoteDaemon/Transport/Ssh/Types.hs index fa6a55d3d..606e1a563 100644 --- a/RemoteDaemon/Transport/Ssh/Types.hs +++ b/RemoteDaemon/Transport/Ssh/Types.hs @@ -16,11 +16,11 @@ module RemoteDaemon.Transport.Ssh.Types ( ) where import qualified Utility.SimpleProtocol as Proto -import RemoteDaemon.Types (RefList) +import Annex.ChangedRefs (ChangedRefs) data Notification = READY - | CHANGED RefList + | CHANGED ChangedRefs instance Proto.Sendable Notification where formatMessage READY = ["READY"] diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs index ba88aa685..c0d74e038 100644 --- a/RemoteDaemon/Types.hs +++ b/RemoteDaemon/Types.hs @@ -5,7 +5,6 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module RemoteDaemon.Types where @@ -15,6 +14,7 @@ import qualified Annex import qualified Git.Types as Git import qualified Utility.SimpleProtocol as Proto import Types.GitConfig +import Annex.ChangedRefs (ChangedRefs) import Network.URI import Control.Concurrent @@ -52,13 +52,11 @@ data Consumed = PAUSE | LOSTNET | RESUME - | CHANGED RefList + | CHANGED ChangedRefs | RELOAD | STOP deriving (Show) -type RefList = [Git.Ref] - instance Proto.Sendable Emitted where formatMessage (CONNECTED remote) = ["CONNECTED", Proto.serialize remote] @@ -100,10 +98,6 @@ instance Proto.Serializable RemoteURI where serialize (RemoteURI u) = show u deserialize = RemoteURI <$$> parseURI -instance Proto.Serializable RefList where - serialize = unwords . map Git.fromRef - deserialize = Just . map Git.Ref . words - instance Proto.Serializable Bool where serialize False = "0" serialize True = "1" diff --git a/debian/control b/debian/control index 1d2313954..f5a9de840 100644 --- a/debian/control +++ b/debian/control @@ -50,6 +50,7 @@ Build-Depends: libghc-esqueleto-dev, libghc-securemem-dev, libghc-byteable-dev, + libghc-stm-chans-dev, libghc-dns-dev, libghc-case-insensitive-dev, libghc-http-types-dev, diff --git a/git-annex.cabal b/git-annex.cabal index 465769ea0..ec54a146d 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -371,6 +371,7 @@ Executable git-annex regex-tdfa, socks, byteable, + stm-chans, securemem CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs @@ -513,6 +514,7 @@ Executable git-annex Annex.Branch.Transitions Annex.BranchState Annex.CatFile + Annex.ChangedRefs Annex.CheckAttr Annex.CheckIgnore Annex.Common -- cgit v1.2.3 From cb5724155e20f247c3d4a987aa6635a8e5de039a Mon Sep 17 00:00:00 2001 From: Alper Nebi Yasak Date: Sat, 10 Dec 2016 15:24:27 +0300 Subject: Remove http-conduit (<2.2.0) constraint Since https://github.com/aristidb/aws/issues/206 is resolved, this constraint is no longer necessary. However, http-conduit (>=2.2.0) requires http-client (>=0.5.0) which introduces some breaking changes. This commit also implements those changes depending on the version. Fixes: https://git-annex.branchable.com/bugs/Build_with_aws_head_fails/ Signed-off-by: Alper Nebi Yasak --- Remote/S3.hs | 8 +++++++- Remote/WebDAV.hs | 17 +++++++++++++++++ Utility/Url.hs | 8 ++++++++ git-annex.cabal | 3 +-- 4 files changed, 33 insertions(+), 3 deletions(-) (limited to 'git-annex.cabal') diff --git a/Remote/S3.hs b/Remote/S3.hs index 4c1bd5784..9563b5a0f 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -49,6 +49,12 @@ import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager) +#if MIN_VERSION_http_client(0,5,0) +import Network.HTTP.Client (responseTimeoutNone) +#else +responseTimeoutNone = Nothing +#endif + type BucketName = String remote :: RemoteType @@ -430,7 +436,7 @@ withS3HandleMaybe c gc u a = do where s3cfg = s3Configuration c httpcfg = managerSettings - { managerResponseTimeout = Nothing } + { managerResponseTimeout = responseTimeoutNone } s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration c = cfg diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 19dbaa8af..14947f1e9 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -5,6 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Remote.WebDAV (remote, davCreds, configUrl) where @@ -34,6 +35,10 @@ import Utility.Url (URLString, matchStatusCodeException) import Annex.UUID import Remote.WebDAV.DavLocation +#if MIN_VERSION_http_client(0,5,0) +import Network.HTTP.Client (HttpExceptionContent(..), responseStatus) +#endif + remote :: RemoteType remote = RemoteType { typename = "webdav", @@ -302,6 +307,17 @@ goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do {- Catch StatusCodeException and trim it to only the statusMessage part, - eliminating a lot of noise, which can include the whole request that - failed. The rethrown exception is no longer a StatusCodeException. -} +#if MIN_VERSION_http_client(0,5,0) +prettifyExceptions :: DAVT IO a -> DAVT IO a +prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go + where + go (HttpExceptionRequest _ (StatusCodeException response message)) = error $ unwords + [ "DAV failure:" + , show (responseStatus response) + , show (message) + ] + go e = throwM e +#else prettifyExceptions :: DAVT IO a -> DAVT IO a prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go where @@ -311,6 +327,7 @@ prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go , show (statusMessage status) ] go e = throwM e +#endif prepDAV :: DavUser -> DavPass -> DAVT IO () prepDAV user pass = do diff --git a/Utility/Url.hs b/Utility/Url.hs index 9b68871dd..d0e1b3739 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -350,8 +350,16 @@ hUserAgent = "User-Agent" - - > catchJust (matchStatusCodeException (== notFound404)) -} +#if MIN_VERSION_http_client(0,5,0) +matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException +matchStatusCodeException want e@(HttpExceptionRequest _ (StatusCodeException r _)) + | want (responseStatus r) = Just e + | otherwise = Nothing +matchStatusCodeException _ _ = Nothing +#else matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException matchStatusCodeException want e@(StatusCodeException s _ _) | want s = Just e | otherwise = Nothing matchStatusCodeException _ _ = Nothing +#endif diff --git a/git-annex.cabal b/git-annex.cabal index ec54a146d..83d45a1d9 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -357,8 +357,7 @@ Executable git-annex resourcet, http-client, http-types, - -- Old version needed due to https://github.com/aristidb/aws/issues/206 - http-conduit (<2.2.0), + http-conduit, time, old-locale, esqueleto, -- cgit v1.2.3 From ea3e0cdcae74f217948a02110e774dd3e1ddc29a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 10 Dec 2016 12:23:18 -0400 Subject: releasing package git-annex version 6.20161210 --- CHANGELOG | 4 ++-- git-annex.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index 095d1e706..bb54989e8 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,4 @@ -git-annex (6.20161119) UNRELEASED; urgency=medium +git-annex (6.20161210) unstable; urgency=medium * enable-tor: New command, enables tor hidden service for P2P syncing. * p2p: New command, allows linking repositories using a P2P network. @@ -27,7 +27,7 @@ git-annex (6.20161119) UNRELEASED; urgency=medium * Fix build with http-client 0.5. Thanks, Alper Nebi Yasak. - -- Joey Hess Mon, 21 Nov 2016 11:27:50 -0400 + -- Joey Hess Sat, 10 Dec 2016 11:56:25 -0400 git-annex (6.20161118) unstable; urgency=medium diff --git a/git-annex.cabal b/git-annex.cabal index 83d45a1d9..6b81424ab 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20161118 +Version: 6.20161210 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess -- cgit v1.2.3 From 2d631990bbd24c4b6fbb317fc9308da5f7bfa196 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 17 Dec 2016 16:58:05 -0400 Subject: magic wormhole module This interacts with it using stdio, which is surprisingly hard. sendFile does not currently work, due to https://github.com/warner/magic-wormhole/issues/108 Parsing the output to find the magic code is done as robustly as possible, and should continue to work unless wormhole radically changes the format of its codes. Presumably it will never output something that looks like a wormhole code before the actual wormhole code; that would also break this. It would be better if there was a way to make wormhole not mix the code with other output, as requested in https://github.com/warner/magic-wormhole/issues/104 Only exchange of files/directories is supported. To exchange messages, https://github.com/warner/magic-wormhole/issues/99 would need to be resolved. I don't need message exchange however. --- Utility/MagicWormhole.hs | 112 +++++++++++++++++++++++++++++++++++++++++++++++ git-annex.cabal | 1 + 2 files changed, 113 insertions(+) create mode 100644 Utility/MagicWormhole.hs (limited to 'git-annex.cabal') diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs new file mode 100644 index 000000000..8a3758361 --- /dev/null +++ b/Utility/MagicWormhole.hs @@ -0,0 +1,112 @@ +{- Magic Wormhole integration + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.MagicWormHole where + +import Utility.Process +import Utility.SafeCommand +import Utility.Monad +import Utility.Misc +import Utility.FileSystemEncoding + +import System.IO +import System.Exit +import Control.Concurrent +import Control.Exception +import Data.Char + +-- | A Magic Wormhole code. +type Code = String + +-- | Codes have the form number-word-word and may contain 2 or more words. +validCode :: String -> Bool +validCode s = + let (n, r) = separate (== '-') s + (w1, w2) = separate (== '-') r + in and + [ not (null n) + , all isDigit n + , not (null w1) + , not (null w2) + , not $ any isSpace s + ] + +type CodeObserver = MVar Code + +type WormHoleParams = [CommandParam] + +mkCodeObserver :: IO CodeObserver +mkCodeObserver = newEmptyMVar + +waitCode :: CodeObserver -> IO Code +waitCode = takeMVar + +sendCode :: CodeObserver -> Code -> IO () +sendCode = putMVar + +-- | Sends a file. Once the send is underway, the Code will be sent to the +-- CodeObserver. +-- +-- Currently this has to parse the output of wormhole to find the code. +-- To make this as robust as possible, avoids looking for any particular +-- output strings, and only looks for the form of a wormhole code +-- (number-word-word). +-- +-- A request to make the code available in machine-parsable form is here: +-- https://github.com/warner/magic-wormhole/issues/104 +-- +-- XXX This currently fails due to +-- https://github.com/warner/magic-wormhole/issues/108 +sendFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool +sendFile f o ps = runWormHoleProcess p $ \_hin hout -> do + fileEncoding hout + findcode =<< words <$> hGetContents hout + where + p = wormHoleProcess (Param "send" : ps ++ [File f]) + findcode [] = return False + findcode (w:ws) + | validCode w = do + sendCode o w + return True + | otherwise = findcode ws + +-- | Receives a file. Once the receive is under way, the Code will be +-- read from the CodeObserver, and fed to it on stdin. +receiveFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool +receiveFile f o ps = runWormHoleProcess p $ \hin hout -> do + hPutStrLn hin =<< waitCode o + hFlush hin + return True + where + p = wormHoleProcess $ + [ Param "receive" + , Param "--accept-file" + , Param "--output-file" + , File f + ] ++ ps + +wormHoleProcess :: WormHoleParams -> CreateProcess +wormHoleProcess = proc "wormhole" . toCommand + +runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> IO Bool) -> IO Bool +runWormHoleProcess p consumer = bracketOnError setup cleanup go + where + setup = do + (Just hin, Just hout, Nothing, pid) + <- createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + return (hin, hout, pid) + cleanup (hin, hout, pid) = do + r <- waitForProcess pid + hClose hin + hClose hout + return $ case r of + ExitSuccess -> True + ExitFailure _ -> False + go h@(hin, hout, _) = consumer hin hout <&&> cleanup h diff --git a/git-annex.cabal b/git-annex.cabal index 6b81424ab..694ab2481 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1044,6 +1044,7 @@ Executable git-annex Utility.LockPool.Windows Utility.LogFile Utility.Lsof + Utility.MagicWormHole Utility.Matcher Utility.Metered Utility.Misc -- cgit v1.2.3 From 09e3fc83f8e9a006cea239fabcff81692e938ddc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 18 Dec 2016 16:50:58 -0400 Subject: p2p --pair with magic wormhole (untested) It builds. I have not tried to run it yet. :) This commit was sponsored by Jake Vosloo on Patreon. --- CHANGELOG | 5 +- Command/P2P.hs | 221 ++++++++++++++++++++++++---- Utility/MagicWormhole.hs | 13 +- debian/control | 1 + doc/git-annex-p2p.mdwn | 26 +++- doc/tips/peer_to_peer_network_with_tor.mdwn | 95 ++++++------ doc/todo/tor.mdwn | 4 +- git-annex.cabal | 2 +- 8 files changed, 288 insertions(+), 79 deletions(-) (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index b4659fa02..95d135507 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,8 @@ git-annex (6.20161211) UNRELEASED; urgency=medium - * Debian: Build webapp on armel. + * p2p --pair makes it easy to pair repositories over P2P, using + Magic Wormhole codes to find the other repository. + * Debian: Recommend magic-wormhole. * metadata --batch: Fix bug when conflicting metadata changes were made in the same batch run. * Pass annex.web-options to wget and curl after other options, so that @@ -14,6 +16,7 @@ git-annex (6.20161211) UNRELEASED; urgency=medium be processed without requiring it to be in the current encoding. * p2p: --link no longer takes a remote name, instead the --name option can be used. + * Debian: Build webapp on armel. -- Joey Hess Sun, 11 Dec 2016 21:29:51 -0400 diff --git a/Command/P2P.hs b/Command/P2P.hs index d59d774c4..ddc6c29df 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -12,13 +12,20 @@ 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 +import Utility.AuthToken +import Utility.Tmp +import Utility.FileMode +import Utility.ThreadScheduler +import qualified Utility.MagicWormhole as Wormhole + +import Control.Concurrent.Async +import qualified Data.Text as T cmd :: Command cmd = command "p2p" SectionSetup @@ -28,10 +35,11 @@ cmd = command "p2p" SectionSetup data P2POpts = GenAddresses | LinkRemote + | Pair optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName) optParser _ = (,) - <$> (genaddresses <|> linkremote) + <$> (pair <|> linkremote <|> genaddresses) <*> optional name where genaddresses = flag' GenAddresses @@ -42,7 +50,11 @@ optParser _ = (,) ( long "link" <> help "set up a P2P link to a git remote" ) - name = strOption + pair = flag' Pair + ( long "pair" + <> help "pair with another repository" + ) + name = Git.Remote.makeLegalName <$> strOption ( long "name" <> metavar paramName <> help "name of remote" @@ -51,9 +63,14 @@ optParser _ = (,) seek :: (P2POpts, Maybe RemoteName) -> CommandSeek seek (GenAddresses, _) = genAddresses =<< loadP2PAddresses seek (LinkRemote, Just name) = commandAction $ - linkRemote (Git.Remote.makeLegalName name) + linkRemote name seek (LinkRemote, Nothing) = commandAction $ linkRemote =<< unusedPeerRemoteName +seek (Pair, Just name) = commandAction $ + pairing name =<< loadP2PAddresses +seek (Pair, Nothing) = commandAction $ do + name <- unusedPeerRemoteName + pairing name =<< loadP2PAddresses unusedPeerRemoteName :: Annex RemoteName unusedPeerRemoteName = go (1 :: Integer) =<< usednames @@ -95,24 +112,178 @@ linkRemote remotename = do Nothing -> do liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again." prompt - Just addr -> setup addr - setup (P2PAddressAuth addr authtoken) = do - g <- Annex.gitRepo - conn <- liftIO $ connectPeer g addr - `catchNonAsync` connerror - u <- getUUID - v <- liftIO $ runNetProto conn $ P2P.auth u authtoken - case v of - Right (Just theiruuid) -> do - ok <- inRepo $ Git.Command.runBool - [ Param "remote", Param "add" - , Param remotename - , Param (formatP2PAddress addr) - ] - when ok $ do - storeUUIDIn (remoteConfig remotename "uuid") theiruuid - storeP2PRemoteAuthToken addr authtoken - return ok - Right Nothing -> giveup "Unable to authenticate with peer. Please check the address and try again." - Left e -> giveup $ "Unable to authenticate with peer: " ++ e - connerror e = giveup $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")" + Just addr -> do + r <- setupLink remotename addr + case r of + LinkSuccess -> return True + ConnectionError e -> giveup e + AuthenticationError e -> giveup e + +pairing :: RemoteName -> [P2PAddress] -> CommandStart +pairing _ [] = giveup "No P2P networks are currrently available." +pairing remotename addrs = do + showStart "p2p pair" remotename + next $ next $ do + r <- wormholePairing remotename addrs ui + case r of + PairSuccess -> return True + SendFailed -> do + warning "Failed sending data to pair." + return False + ReceiveFailed -> do + warning "Failed receiving data from pair." + return False + LinkFailed e -> do + warning $ "Failed linking to pair: " ++ e + return False + where + ui observer producer = do + ourcode <- Wormhole.waitCode observer + putStrLn "" + putStrLn $ "This repository's pairing code is: " ++ + Wormhole.fromCode ourcode + putStrLn "" + theircode <- getcode ourcode + Wormhole.sendCode producer theircode + + getcode ourcode = do + putStr "Enter the other repository's pairing code: " + hFlush stdout + fileEncoding stdin + l <- getLine + case Wormhole.toCode l of + Just code + | code /= ourcode -> return code + | otherwise -> do + putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository." + getcode ourcode + Nothing -> do + putStrLn "That does not look like a valid code. Try again..." + getcode ourcode + +-- We generate half of the authtoken; the pair will provide +-- the other half. +newtype HalfAuthToken = HalfAuthToken T.Text + deriving (Show) + +data PairData = PairData HalfAuthToken [P2PAddress] + deriving (Show) + +serializePairData :: PairData -> String +serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $ + T.unpack ha : map formatP2PAddress addrs + +deserializePairData :: String -> Maybe PairData +deserializePairData s = case lines s of + [] -> Nothing + (ha:l) -> do + addrs <- mapM unformatP2PAddress l + return (PairData (HalfAuthToken (T.pack ha)) addrs) + +data PairingResult + = PairSuccess + | SendFailed + | ReceiveFailed + | LinkFailed String + +wormholePairing + :: RemoteName + -> [P2PAddress] + -> (Wormhole.CodeObserver -> Wormhole.CodeProducer -> IO ()) + -> Annex PairingResult +wormholePairing remotename ouraddrs ui = do + ourhalf <- liftIO $ HalfAuthToken . fromAuthToken + <$> genAuthToken 64 + let ourpairdata = PairData ourhalf ouraddrs + + -- The magic wormhole interface only supports exchanging + -- files. Permissions of received files may allow others + -- to read them. So, set up a temp directory that only + -- we can read. + withTmpDir "pair" $ \tmp -> do + liftIO $ void $ tryIO $ modifyFileMode tmp $ + removeModes otherGroupModes + let sendf = tmp "send" + let recvf = tmp "recv" + liftIO $ writeFileProtected sendf $ + serializePairData ourpairdata + + observer <- liftIO Wormhole.mkCodeObserver + producer <- liftIO Wormhole.mkCodeProducer + void $ liftIO $ async $ ui observer producer + (sendres, recvres) <- liftIO $ + Wormhole.sendFile sendf observer [] + `concurrently` + Wormhole.receiveFile recvf producer [] + liftIO $ nukeFile sendf + if sendres /= True + then return SendFailed + else if recvres /= True + then return ReceiveFailed + else do + r <- liftIO $ tryIO $ + readFileStrictAnyEncoding recvf + case r of + Left _e -> return ReceiveFailed + Right s -> maybe + (return ReceiveFailed) + (finishPairing 100 remotename ourhalf) + (deserializePairData s) + +-- | Allow the peer we're pairing with to authenticate to us, +-- using an authtoken constructed from the two HalfAuthTokens. +-- Connect to the peer we're pairing with, and try to link to them. +-- +-- Multiple addresses may have been received for the peer. This only +-- makes a link to one address. +-- +-- Since we're racing the peer as they do the same, the first try is likely +-- to fail to authenticate. Can retry any number of times, to avoid the +-- users needing to redo the whole process. +finishPairing :: Int -> RemoteName -> HalfAuthToken -> PairData -> Annex PairingResult +finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToken theirhalf) theiraddrs) = do + case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of + (Just ourauthtoken, Just theirauthtoken) -> do + liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++ " ..." + storeP2PAuthToken ourauthtoken + go retries theiraddrs theirauthtoken + _ -> return ReceiveFailed + where + go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "." + go n [] theirauthtoken = do + liftIO $ threadDelaySeconds (Seconds 2) + liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..." + go (n-1) theiraddrs theirauthtoken + go n (addr:rest) theirauthtoken = do + r <- setupLink remotename (P2PAddressAuth addr theirauthtoken) + case r of + LinkSuccess -> return PairSuccess + _ -> go n rest theirauthtoken + +data LinkResult + = LinkSuccess + | ConnectionError String + | AuthenticationError String + +setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult +setupLink remotename (P2PAddressAuth addr authtoken) = do + g <- Annex.gitRepo + cv <- liftIO $ tryNonAsync $ connectPeer g addr + case cv of + Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")" + Right conn -> do + u <- getUUID + go =<< liftIO (runNetProto conn $ P2P.auth u authtoken) + where + go (Right (Just theiruuid)) = do + ok <- inRepo $ Git.Command.runBool + [ Param "remote", Param "add" + , Param remotename + , Param (formatP2PAddress addr) + ] + when ok $ do + storeUUIDIn (remoteConfig remotename "uuid") theiruuid + storeP2PRemoteAuthToken addr authtoken + return LinkSuccess + go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again." + go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs index a71cc69e0..9ab804800 100644 --- a/Utility/MagicWormhole.hs +++ b/Utility/MagicWormhole.hs @@ -5,9 +5,11 @@ - License: BSD-2-clause -} -module Utility.MagicWormHole ( +module Utility.MagicWormhole ( Code, mkCode, + toCode, + fromCode, validCode, CodeObserver, CodeProducer, @@ -32,9 +34,11 @@ import System.Exit import Control.Concurrent import Control.Exception import Data.Char +import Data.List -- | A Magic Wormhole code. newtype Code = Code String + deriving (Eq, Show) -- | Smart constructor for Code mkCode :: String -> Maybe Code @@ -42,6 +46,13 @@ mkCode s | validCode s = Just (Code s) | otherwise = Nothing +-- | Tries to fix up some common mistakes in a homan-entered code. +toCode :: String -> Maybe Code +toCode s = mkCode $ intercalate "-" $ words s + +fromCode :: Code -> String +fromCode (Code s) = s + -- | Codes have the form number-word-word and may contain 2 or more words. validCode :: String -> Bool validCode s = diff --git a/debian/control b/debian/control index 8be9fec99..644c22035 100644 --- a/debian/control +++ b/debian/control @@ -112,6 +112,7 @@ Recommends: git-remote-gcrypt (>= 0.20130908-6), nocache, aria2, + magic-wormhole, Suggests: xdot, bup, diff --git a/doc/git-annex-p2p.mdwn b/doc/git-annex-p2p.mdwn index 6c50c9dd2..127ed9a5d 100644 --- a/doc/git-annex-p2p.mdwn +++ b/doc/git-annex-p2p.mdwn @@ -16,11 +16,30 @@ services. # OPTIONS +* `--pair` + + Run this in two repositories to pair them together over the P2P network. + + This will print out a code phrase, like "3-mango-elephant", and + will prompt for you to enter the code phrase from the other repository. + + Once code phrases have been exchanged, the two repositories will + be paired. A git remote will be created for the other repository, + with a name like "peer1". + + This uses [Magic Wormhole](https://github.com/warner/magic-wormhole) + to verify the code phrases and securely communicate the P2P addresses of + the repositories, so you will need it installed on both computers that are + being paired. + * `--gen-address` Generates addresses that can be used to access this git-annex repository over the available P2P networks. The address or addresses is output to - stdout. + stdout. + + Note that anyone who knows these addresses can access your + repository over the P2P networks. * `--link` @@ -34,7 +53,8 @@ services. * `--name` - Specify a name to use when setting up a git remote. + Specify a name to use when setting up a git remote with `--link` + or `--pair`. # SEE ALSO @@ -44,6 +64,8 @@ services. [[git-annex-remotedaemon]](1) +wormhole(1) + # AUTHOR Joey Hess diff --git a/doc/tips/peer_to_peer_network_with_tor.mdwn b/doc/tips/peer_to_peer_network_with_tor.mdwn index 9c97735e4..b6aafa534 100644 --- a/doc/tips/peer_to_peer_network_with_tor.mdwn +++ b/doc/tips/peer_to_peer_network_with_tor.mdwn @@ -1,69 +1,56 @@ git-annex has recently gotten support for running as a [Tor](https://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. +and easy to use way to connect repositories in different +locations. No account on a central server is needed; it's peer-to-peer. -## setting up the first peer +## dependencies -First, you need to get Tor installed and running. See +To use this, you need to get Tor installed and running. See [their website](https://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: +You also need to install [Magic Wormhole](https://github.com/warner/magic-wormhole). - 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 + sudo apt-get install magic-wormhole -At this point, git-annex is running as a tor hidden service, but -it will only talk to peers who know that address. +## pairing two repositories -## adding additional peers - -To add a peer, get tor installed and running on it. - - sudo apt-get install tor +You have two git-annex repositories on different computers, and want to +connect them together over Tor so they share their contents. Or, you and a +friend want to connect your repositories together. Pairing is an easy way +to accomplish this. -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: +In each git-annex repository, run these commands: 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. +Now git-annex is running as a Tor hidden service, but +it will only talk to peers after pairing with them. + +In both repositories, run this command: - git annex p2p --link --name peer1 + git annex p2p --pair -That command will prompt for an address; paste in the address that was -generated on the first peer, and then press Enter. +This will print out a code phrase, like "11-incredible-tumeric", +and prompt for you to enter the other repository's code phrase. -Now you can run any commands you normally would to sync with the -peer1 remote: +Once the code phrases are exchanged, the two repositories will be securely +connected to one-another via Tor. Each will have a git remote, with a name +like "peer1", which connects to the other repository. - git annex sync --content peer1 +Then, you can run commands like `git annex sync peer1 --content` to sync +with the paired repository. -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. +The Magic Wormhole code phrases used during pairing will no longer be +useful for anything afterwards. -Any number of peers can be connected this way, within reason. +Pairing connects just two repositories, but you can repeat the process to +pair with as many other repositories as you like, in order to build up +larger networks of repositories. -## starting git-annex remotedaemon +## starting git-annex remotedaemon on boot Notice the `git annex remotedaemon` being run in the above examples. That command runs the Tor hidden service so that other peers @@ -72,7 +59,7 @@ 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 + @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. @@ -84,9 +71,9 @@ bandwidth to go around. So, distributing large quantities (gigabytes) of data over Tor may be slow, and should probably be avoided. One way to avoid sending much data over tor is to set up an encrypted -[[special_remote|special_remotes]]. git-annex knows that Tor is rather -expensive to use, so if a file is available on a special remote as well as -over Tor, it will download it from the special remote. +[[special_remote|special_remotes]] someplace. git-annex knows that Tor is +rather expensive to use, so if a file is available on a special remote as +well as over Tor, it will download it from the special remote. You can contribute to the Tor network by [running a Tor relay or bridge](https://www.torproject.org/getinvolved/relays.html.en). @@ -115,6 +102,9 @@ 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/` +When you pair repositories, these addresses are exchanged using +[Magic Wormhole](https://github.com/warner/magic-wormhole). + ## security Tor hidden services can be quite secure. But this doesn't mean that using @@ -144,3 +134,14 @@ to consider: * An attacker who can connect to the git-annex Tor hidden service, even without authenticating, can try to perform denial of service attacks. + +* Magic wormhole is pretty secure, but the code phrase could be guessed + (unlikely) or intercepted. An attacker gets just one chance to try to enter + the correct code phrase, before pairing finishes. If the attacker + successfully guesses/intercepts both code phrases, they can MITM the + pairing process. + + If you don't want to use magic wormhole, you can instead manually generate + addresses with `git annex p2p --gen-addresses` and send them over an + authenticated, encrypted channel (such as OTR) to a friend to add with + `git annex p2p --link`. This may be more secure, if you get it right. diff --git a/doc/todo/tor.mdwn b/doc/todo/tor.mdwn index 262926d0f..cb0bc4d41 100644 --- a/doc/todo/tor.mdwn +++ b/doc/todo/tor.mdwn @@ -16,8 +16,8 @@ Eventually: * Limiting authtokens to read-only access. * Revoking authtokens. (This and read-only need a name associated with an authtoken, so the user can adjust its configuration after creating it.) -* address exchange for peering. See [[design/assistant/telehash]]. -* Webapp UI to set it upt. +* Pairing via magic wormhole. +* Webapp UI to set it up. * friend-of-a-friend peer discovery to build more interconnected networks of nodes * Discovery of nodes on same LAN, and direct connection to them. diff --git a/git-annex.cabal b/git-annex.cabal index 694ab2481..2f07c8437 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1044,7 +1044,7 @@ Executable git-annex Utility.LockPool.Windows Utility.LogFile Utility.Lsof - Utility.MagicWormHole + Utility.MagicWormhole Utility.Matcher Utility.Metered Utility.Misc -- cgit v1.2.3 From 5387e0e1aeee46b94ad6e0a1d59b1422a8048665 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 20 Dec 2016 17:40:36 -0400 Subject: enable-tor: No longer needs to be run as root. When run by not root, su's to root automatically. This commit was sponsored by Brock Spratlen on Patreon. --- CHANGELOG | 1 + Command/EnableTor.hs | 32 +++++++++++++++-- Utility/Su.hs | 54 +++++++++++++++++++++++++++++ doc/git-annex-enable-tor.mdwn | 8 +++-- doc/tips/peer_to_peer_network_with_tor.mdwn | 2 +- git-annex.cabal | 1 + 6 files changed, 92 insertions(+), 6 deletions(-) create mode 100644 Utility/Su.hs (limited to 'git-annex.cabal') diff --git a/CHANGELOG b/CHANGELOG index 65a3da82b..220aeea41 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -21,6 +21,7 @@ git-annex (6.20161211) UNRELEASED; urgency=medium present in the local repo even when it was not. * enable-tor: Put tor sockets in /var/lib/tor-annex/, rather than in /etc/tor/hidden_service/. + * enable-tor: No longer needs to be run as root. * Fix build with directory-1.3. * Debian: Suggest tor and magic-wormhole. * Debian: Build webapp on armel. diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index c6d477b4e..91d5af701 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -5,12 +5,20 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Command.EnableTor where import Command import P2P.Address import Utility.Tor import Annex.UUID +import Config.Files + +#ifndef mingw32_HOST_OS +import Utility.Su +import System.Posix.User +#endif -- This runs as root, so avoid making any commits or initializing -- git-annex, or doing other things that create root-owned files. @@ -23,9 +31,27 @@ seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart -start ps = case readish =<< headMaybe ps of - Nothing -> giveup "Bad params" - Just userid -> do +start os = do +#ifndef mingw32_HOST_OS + curruserid <- liftIO getEffectiveUserID + if curruserid == 0 + then case readish =<< headMaybe os of + Nothing -> giveup "Need user-id parameter." + Just userid -> go userid + else do + liftIO $ putStrLn "Need root access to enable tor..." + gitannex <- liftIO readProgramFile + let ps = [Param (cmdname cmd), Param (show curruserid)] + ifM (liftIO $ runAsRoot gitannex ps) + ( stop + , giveup $ unwords $ + [ "Failed to run as root:" , gitannex ] ++ toCommand ps + ) +#else + go 0 +#endif + where + go userid = do uuid <- getUUID when (uuid == NoUUID) $ giveup "This can only be run in a git-annex repository." diff --git a/Utility/Su.hs b/Utility/Su.hs new file mode 100644 index 000000000..4244074d7 --- /dev/null +++ b/Utility/Su.hs @@ -0,0 +1,54 @@ +{- su to root + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Su where + +import Common +import Utility.Env +import Utility.Path + +import System.Posix.Terminal + +-- Runs a command as root, fairly portably. +-- +-- Does not use sudo commands if something else is available, because +-- the user may not be in sudoers and we couldn't differentiate between +-- that and the command failing. Although, some commands like gksu +-- decide based on the system's configuration whether sudo should be used. +runAsRoot :: String -> [CommandParam] -> IO Bool +runAsRoot cmd ps = go =<< firstM (inPath . fst) =<< selectcmds + where + go Nothing = return False + go (Just (cmd', ps')) = boolSystem cmd' ps' + + selectcmds = ifM (inx <||> (not <$> atconsole)) + ( return (graphicalcmds ++ consolecmds) + , return consolecmds + ) + + inx = isJust <$> getEnv "DISPLAY" + atconsole = queryTerminal stdInput + + -- These will only work when the user is logged into a desktop. + graphicalcmds = + [ ("gksu", [Param shellcmd]) + , ("kdesu", [Param shellcmd]) + -- Available in Debian's menu package; knows about lots of + -- ways to gain root. + , ("su-to-root", [Param "-X", Param "-c", Param shellcmd]) + -- OSX native way to run a command as root, prompts in GUI + , ("osascript", [Param "-e", Param ("do shell script \"" ++ shellcmd ++ "\" with administrator privileges")]) + ] + + -- These will only work when run in a console. + consolecmds = + [ ("su", [Param "-c", Param "--", Param cmd] ++ ps) + , ("sudo", [Param cmd] ++ ps) + , ("su-to-root", [Param "-c", Param shellcmd]) + ] + + shellcmd = unwords $ map shellEscape (cmd:toCommand ps) diff --git a/doc/git-annex-enable-tor.mdwn b/doc/git-annex-enable-tor.mdwn index 1c1738027..f06966400 100644 --- a/doc/git-annex-enable-tor.mdwn +++ b/doc/git-annex-enable-tor.mdwn @@ -4,14 +4,18 @@ git-annex enable-tor - enable tor hidden service # SYNOPSIS +git annex enable-tor + sudo git annex enable-tor $(id -u) # DESCRIPTION This command enables a tor hidden service for git-annex. -It has to be run by root, since it modifies `/etc/tor/torrc`. -Pass it your user id number, as output by `id -u` +It modifies `/etc/tor/torrc` to register the hidden service. If run as a +normal user, it will try to use sudo/su/etc to get root access to modify +that file. If you run it as root, pass it your non-root user id number, +as output by `id -u` After this command is run, `git annex remotedaemon` can be run to serve the tor hidden service, and then `git-annex p2p --gen-address` can be run to diff --git a/doc/tips/peer_to_peer_network_with_tor.mdwn b/doc/tips/peer_to_peer_network_with_tor.mdwn index a57d8a544..ce00b0424 100644 --- a/doc/tips/peer_to_peer_network_with_tor.mdwn +++ b/doc/tips/peer_to_peer_network_with_tor.mdwn @@ -23,7 +23,7 @@ to accomplish this. In each git-annex repository, run these commands: - sudo git annex enable-tor $(id -u) + git annex enable-tor git annex remotedaemon Now git-annex is running as a Tor hidden service, but diff --git a/git-annex.cabal b/git-annex.cabal index 2f07c8437..81a6ac3ad 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1072,6 +1072,7 @@ Executable git-annex Utility.Shell Utility.SimpleProtocol Utility.SshConfig + Utility.Su Utility.SystemDirectory Utility.TList Utility.Tense -- cgit v1.2.3