diff options
| -rw-r--r-- | Remote/External/Types.hs | 8 | ||||
| -rw-r--r-- | Remote/Helper/P2P.hs | 247 | ||||
| -rw-r--r-- | RemoteDaemon/Types.hs | 4 | ||||
| -rw-r--r-- | Types/Key.hs | 5 | ||||
| -rw-r--r-- | Types/UUID.hs | 6 | ||||
| -rw-r--r-- | Utility/SimpleProtocol.hs | 7 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 2 |
8 files changed, 268 insertions, 12 deletions
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 <id@joeyh.name> + - + - 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 |