mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

factored out Utility.SimpleProtocol from the external special remote implementation

Browse source
This commit is contained in:
Joey Hess 2014-04-05 13:29:28 -04:00
parent 4e601cf124
commit 5af30678c7
2 changed files with 135 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

167
Remote/External/Types.hs vendored
View file

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

75
Utility/SimpleProtocol.hs Normal file
View file

@ -0,0 +1,75 @@
{- Simple line-based protocols.
-
- Copyright 2013-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.SimpleProtocol (
Sendable(..),
Receivable(..),
parseMessage,
Serializable(..),
Parser,
parseFail,
parse0,
parse1,
parse2,
parse3,
) where
import Control.Applicative
import Data.Char
import Utility.Misc
-- Messages that can be sent.
class Sendable m where
formatMessage :: m -> [String]
-- Messages that can be received.
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
class Serializable a where
serialize :: a -> String
deserialize :: String -> Maybe a
{- 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 :: Serializable p1 => (p1 -> a) -> Parser a
parse1 mk p1 = mk <$> deserialize p1
parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a
parse2 mk s = mk <$> deserialize p1 <*> deserialize p2
where
(p1, p2) = splitWord s
parse3 :: (Serializable p1, Serializable p2, Serializable 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