From 37de1fc1863379c4bc8f71210e63530a06ff8335 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 5 Apr 2014 13:29:28 -0400 Subject: factored out Utility.SimpleProtocol from the external special remote implementation --- Remote/External/Types.hs | 167 +++++++++++++++++------------------------------ 1 file changed, 60 insertions(+), 107 deletions(-) (limited to 'Remote') 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 -- cgit v1.2.3