factored out Utility.SimpleProtocol from the external special remote implementation

1 files changed, 60 insertions, 107 deletions

diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 1e17a2c4c..983764f70 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Remote.External.Types (
 	External(..),
@@ -15,9 +16,9 @@ module Remote.External.Types (
 	withExternalLock,
 	ExternalState(..),
 	PrepareStatus(..),
-	parseMessage,
-	Sendable(..),
-	Receivable(..),
+	Proto.parseMessage,
+	Proto.Sendable(..),
+	Proto.Receivable(..),
 	Request(..),
 	needsPREPARE,
 	Response(..),
@@ -39,12 +40,11 @@ import Logs.Transfer (Direction(..))
 import Config.Cost (Cost)
 import Types.Remote (RemoteConfig)
 import Types.Availability (Availability(..))
+import qualified Utility.SimpleProtocol as Proto
 
-import Data.Char
 import Control.Concurrent.STM
 
 -- If the remote is not yet running, the ExternalState TMVar is empty.
--- The 
 data External = External
 	{ externalType :: ExternalType
 	, externalUUID :: UUID
@@ -85,22 +85,6 @@ withExternalLock external = bracketIO setup cleanup
 	cleanup = atomically . putTMVar v
 	v = externalLock external
 
--- Messages that git-annex can send.
-class Sendable m where
-	formatMessage :: m -> [String]
-
--- Messages that git-annex can receive.
-class Receivable m where
-	-- Passed the first word of the message, returns
-	-- a Parser that can be be fed the rest of the message to generate
-	-- the value.
-	parseCommand :: String -> Parser m
-
-parseMessage :: (Receivable m) => String -> Maybe m
-parseMessage s = parseCommand command rest
-  where
-	(command, rest) = splitWord s
-
 -- Messages that can be sent to the external remote to request it do something.
 data Request 
 	= PREPARE 
@@ -118,15 +102,19 @@ needsPREPARE PREPARE = False
 needsPREPARE INITREMOTE = False
 needsPREPARE _ = True
 
-instance Sendable Request where
+instance Proto.Sendable Request where
 	formatMessage PREPARE = ["PREPARE"]
 	formatMessage INITREMOTE = ["INITREMOTE"]
 	formatMessage GETCOST = ["GETCOST"]
 	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]
 	formatMessage (TRANSFER direction key file) =
-		[ "TRANSFER", serialize direction, serialize key, serialize file ]
-	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ]
-	formatMessage (REMOVE key) = [ "REMOVE", serialize key ]
+		[ "TRANSFER"
+		, Proto.serialize direction
+		, Proto.serialize key
+		, Proto.serialize file
+		]
+	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", Proto.serialize key ]
+	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
 
 -- Responses the external remote can make to requests.
 data Response
@@ -146,22 +134,22 @@ data Response
 	| UNSUPPORTED_REQUEST
 	deriving (Show)
 
-instance Receivable Response where
-	parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS
-	parseCommand "PREPARE-FAILURE" = parse1 PREPARE_FAILURE
-	parseCommand "TRANSFER-SUCCESS" = parse2 TRANSFER_SUCCESS
-	parseCommand "TRANSFER-FAILURE" = parse3 TRANSFER_FAILURE
-	parseCommand "CHECKPRESENT-SUCCESS" = parse1 CHECKPRESENT_SUCCESS
-	parseCommand "CHECKPRESENT-FAILURE" = parse1 CHECKPRESENT_FAILURE
-	parseCommand "CHECKPRESENT-UNKNOWN" = parse2 CHECKPRESENT_UNKNOWN
-	parseCommand "REMOVE-SUCCESS" = parse1 REMOVE_SUCCESS
-	parseCommand "REMOVE-FAILURE" = parse2 REMOVE_FAILURE
-	parseCommand "COST" = parse1 COST
-	parseCommand "AVAILABILITY" = parse1 AVAILABILITY
-	parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS
-	parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE
-	parseCommand "UNSUPPORTED-REQUEST" = parse0 UNSUPPORTED_REQUEST
-	parseCommand _ = parseFail
+instance Proto.Receivable Response where
+	parseCommand "PREPARE-SUCCESS" = Proto.parse0 PREPARE_SUCCESS
+	parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE
+	parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS
+	parseCommand "TRANSFER-FAILURE" = Proto.parse3 TRANSFER_FAILURE
+	parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS
+	parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE
+	parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN
+	parseCommand "REMOVE-SUCCESS" = Proto.parse1 REMOVE_SUCCESS
+	parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE
+	parseCommand "COST" = Proto.parse1 COST
+	parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY
+	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS
+	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
+	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
+	parseCommand _ = Proto.parseFail
 
 -- Requests that the external remote can send at any time it's in control.
 data RemoteRequest
@@ -181,22 +169,22 @@ data RemoteRequest
 	| DEBUG String
 	deriving (Show)
 
-instance Receivable RemoteRequest where
-	parseCommand "VERSION" = parse1 VERSION
-	parseCommand "PROGRESS" = parse1 PROGRESS
-	parseCommand "DIRHASH" = parse1 DIRHASH
-	parseCommand "SETCONFIG" = parse2 SETCONFIG
-	parseCommand "GETCONFIG" = parse1 GETCONFIG
-	parseCommand "SETCREDS" = parse3 SETCREDS
-	parseCommand "GETCREDS" = parse1 GETCREDS
-	parseCommand "GETUUID" = parse0 GETUUID
-	parseCommand "GETGITDIR" = parse0 GETGITDIR
-	parseCommand "SETWANTED" = parse1 SETWANTED
-	parseCommand "GETWANTED" = parse0 GETWANTED
-	parseCommand "SETSTATE" = parse2 SETSTATE
-	parseCommand "GETSTATE" = parse1 GETSTATE
-	parseCommand "DEBUG" = parse1 DEBUG
-	parseCommand _ = parseFail
+instance Proto.Receivable RemoteRequest where
+	parseCommand "VERSION" = Proto.parse1 VERSION
+	parseCommand "PROGRESS" = Proto.parse1 PROGRESS
+	parseCommand "DIRHASH" = Proto.parse1 DIRHASH
+	parseCommand "SETCONFIG" = Proto.parse2 SETCONFIG
+	parseCommand "GETCONFIG" = Proto.parse1 GETCONFIG
+	parseCommand "SETCREDS" = Proto.parse3 SETCREDS
+	parseCommand "GETCREDS" = Proto.parse1 GETCREDS
+	parseCommand "GETUUID" = Proto.parse0 GETUUID
+	parseCommand "GETGITDIR" = Proto.parse0 GETGITDIR
+	parseCommand "SETWANTED" = Proto.parse1 SETWANTED
+	parseCommand "GETWANTED" = Proto.parse0 GETWANTED
+	parseCommand "SETSTATE" = Proto.parse2 SETSTATE
+	parseCommand "GETSTATE" = Proto.parse1 GETSTATE
+	parseCommand "DEBUG" = Proto.parse1 DEBUG
+	parseCommand _ = Proto.parseFail
 
 -- Responses to RemoteRequest.
 data RemoteResponse
@@ -204,21 +192,21 @@ data RemoteResponse
 	| CREDS String String
 	deriving (Show)
 
-instance Sendable RemoteResponse where
-	formatMessage (VALUE s) = [ "VALUE", serialize s ]
-	formatMessage (CREDS login password) = [ "CREDS", serialize login, serialize password ]
+instance Proto.Sendable RemoteResponse where
+	formatMessage (VALUE s) = [ "VALUE", Proto.serialize s ]
+	formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ]
 
 -- Messages that can be sent at any time by either git-annex or the remote.
 data AsyncMessage
 	= ERROR ErrorMsg
 	deriving (Show)
 
-instance Sendable AsyncMessage where
-	formatMessage (ERROR err) = [ "ERROR", serialize err ]
+instance Proto.Sendable AsyncMessage where
+	formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ]
 
-instance Receivable AsyncMessage where
-	parseCommand "ERROR" = parse1 ERROR
-	parseCommand _ = parseFail
+instance Proto.Receivable AsyncMessage where
+	parseCommand "ERROR" = Proto.parse1 ERROR
+	parseCommand _ = Proto.parseFail
 
 -- Data types used for parameters when communicating with the remote.
 -- All are serializable.
@@ -229,11 +217,7 @@ type ProtocolVersion = Int
 supportedProtocolVersions :: [ProtocolVersion]
 supportedProtocolVersions = [1]
 
-class ExternalSerializable a where
-	serialize :: a -> String
-	deserialize :: String -> Maybe a
-
-instance ExternalSerializable Direction where
+instance Proto.Serializable Direction where
 	serialize Upload = "STORE"
 	serialize Download = "RETRIEVE"
 
@@ -241,23 +225,23 @@ instance ExternalSerializable Direction where
 	deserialize "RETRIEVE" = Just Download
 	deserialize _ = Nothing
 
-instance ExternalSerializable Key where
+instance Proto.Serializable Key where
 	serialize = key2file
 	deserialize = file2key
 
-instance ExternalSerializable [Char] where
+instance Proto.Serializable [Char] where
 	serialize = id
 	deserialize = Just
 
-instance ExternalSerializable ProtocolVersion where
+instance Proto.Serializable ProtocolVersion where
 	serialize = show
 	deserialize = readish
 
-instance ExternalSerializable Cost where
+instance Proto.Serializable Cost where
 	serialize = show
 	deserialize = readish
 
-instance ExternalSerializable Availability where
+instance Proto.Serializable Availability where
 	serialize GloballyAvailable = "GLOBAL"
 	serialize LocallyAvailable = "LOCAL"
 
@@ -265,37 +249,6 @@ instance ExternalSerializable Availability where
 	deserialize "LOCAL" = Just LocallyAvailable
 	deserialize _ = Nothing
 
-instance ExternalSerializable BytesProcessed where
+instance Proto.Serializable BytesProcessed where
 	serialize (BytesProcessed n) = show n
 	deserialize = BytesProcessed <$$> readish
-
-{- Parsing the parameters of messages. Using the right parseN ensures
- - that the string is split into exactly the requested number of words,
- - which allows the last parameter of a message to contain arbitrary
- - whitespace, etc, without needing any special quoting.
- -}
-type Parser a = String -> Maybe a
-
-parseFail :: Parser a
-parseFail _ = Nothing
-
-parse0 :: a -> Parser a
-parse0 mk "" = Just mk
-parse0 _ _ = Nothing
-
-parse1 :: ExternalSerializable p1 => (p1 -> a) -> Parser a
-parse1 mk p1 = mk <$> deserialize p1
-
-parse2 :: (ExternalSerializable p1, ExternalSerializable p2) => (p1 -> p2 -> a) -> Parser a
-parse2 mk s = mk <$> deserialize p1 <*> deserialize p2
-  where
-	(p1, p2) = splitWord s
-
-parse3 :: (ExternalSerializable p1, ExternalSerializable p2, ExternalSerializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a
-parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
-  where
-	(p1, rest) = splitWord s
-	(p2, p3) = splitWord rest
-
-splitWord :: String -> (String, String)
-splitWord = separate isSpace