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

@@ -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

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

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

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")

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

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

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),

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