diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-11-20 12:08:16 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-11-20 12:16:32 -0400 |
commit | 513d36ae4de0be74b12112487d8e1b12b7c7f43e (patch) | |
tree | a4f73a5db7ce011870f19b5cadb754c70d499a8f /Remote/Helper/P2P.hs | |
parent | 885bcb7fe1f6ec9c7aa395ba99a379aee9d2567a (diff) |
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.
Diffstat (limited to 'Remote/Helper/P2P.hs')
-rw-r--r-- | Remote/Helper/P2P.hs | 374 |
1 files changed, 196 insertions, 178 deletions
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 |