diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-11-22 14:34:49 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-11-22 14:37:09 -0400 |
commit | d6ceefea050683c6e9022fa04bdefd9e28609990 (patch) | |
tree | 276620f21f1e49e9ed0a9fe7580d1aa37782d4f1 /Remote/Helper/P2P.hs | |
parent | 8166ebdb34c513af648072e03682c8c503f57bdd (diff) |
reorg
Diffstat (limited to 'Remote/Helper/P2P.hs')
-rw-r--r-- | Remote/Helper/P2P.hs | 399 |
1 files changed, 0 insertions, 399 deletions
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 <id@joeyh.name> - - - - 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 () |