basic data types and serialization for external special remote protocol
This is mostly straightforward, but did turn out quite nicely stronly typed, and with a quite nice automatic tokenization and parsing of received messages. Made a few minor changes to the protocol to clear up ambiguities and make it easier to parse. Note particularly that setting remote configuration is moved to a separate command, which allows a remote to set arbitrary data.
This commit is contained in:
Joey Hess
parent
0222a7252c
commit
1dc930063a
2 changed files with 269 additions and 12 deletions
252
Remote/External.hs
Normal file
252
Remote/External.hs
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
{- External special remote interface.
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
|
||||
|
||||
module Remote.External (remote) where
|
||||
|
||||
import Data.Char
|
||||
|
||||
import Common.Annex
|
||||
import Types.Remote
|
||||
import Types.Key
|
||||
import qualified Git
|
||||
import Config
|
||||
import Remote.Helper.Special
|
||||
import Remote.Helper.Encryptable
|
||||
import Crypto
|
||||
import Utility.Metered
|
||||
import Logs.Transfer
|
||||
import Config.Cost
|
||||
|
||||
remote :: RemoteType
|
||||
remote = RemoteType {
|
||||
typename = "hook",
|
||||
enumerate = findSpecialRemotes "hooktype",
|
||||
generate = gen,
|
||||
setup = undefined
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||
gen r u c gc = do
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
return $ Just $ encryptableRemote c
|
||||
(storeEncrypted $ getGpgEncParams (c,gc))
|
||||
retrieveEncrypted
|
||||
Remote {
|
||||
uuid = u,
|
||||
cost = cst,
|
||||
name = Git.repoDescribe r,
|
||||
storeKey = store,
|
||||
retrieveKeyFile = retrieve,
|
||||
retrieveKeyFileCheap = retrieveCheap,
|
||||
removeKey = remove,
|
||||
hasKey = checkPresent r,
|
||||
hasKeyCheap = False,
|
||||
whereisKey = Nothing,
|
||||
remoteFsck = Nothing,
|
||||
repairRepo = Nothing,
|
||||
config = c,
|
||||
localpath = Nothing,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
readonly = False,
|
||||
globallyAvailable = False,
|
||||
remotetype = remote
|
||||
}
|
||||
|
||||
store :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store k _f _p = undefined
|
||||
|
||||
storeEncrypted :: [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
||||
storeEncrypted gpgOpts (cipher, enck) k _p = undefined
|
||||
|
||||
retrieve :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieve k _f d _p = undefined
|
||||
|
||||
retrieveCheap :: Key -> FilePath -> Annex Bool
|
||||
retrieveCheap _ _ = undefined
|
||||
|
||||
retrieveEncrypted :: (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveEncrypted (cipher, enck) _ f _p = undefined
|
||||
|
||||
remove :: Key -> Annex Bool
|
||||
remove k = undefined
|
||||
|
||||
checkPresent :: Git.Repo -> Key -> Annex (Either String Bool)
|
||||
checkPresent r k = undefined
|
||||
|
||||
-- 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
|
||||
| INITREMOTE
|
||||
| GETCOST
|
||||
| TRANSFER Direction Key FilePath
|
||||
| CHECKPRESENT Key
|
||||
| REMOVE Key
|
||||
deriving (Show)
|
||||
|
||||
instance Sendable Request where
|
||||
formatMessage PREPARE = ["PREPARE"]
|
||||
formatMessage INITREMOTE = ["INITREMOTE"]
|
||||
formatMessage GETCOST = ["GETCOST"]
|
||||
formatMessage (TRANSFER direction key file) =
|
||||
[ "TRANSFER", serialize direction, serialize key, serialize file ]
|
||||
formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ]
|
||||
formatMessage (REMOVE key) = [ "REMOVE", serialize key ]
|
||||
|
||||
-- Responses the external remote can make to requests.
|
||||
data Response
|
||||
= PREPARE_SUCCESS
|
||||
| TRANSFER_SUCCESS Direction Key
|
||||
| TRANSFER_FAILURE Direction Key ErrorMsg
|
||||
| CHECKPRESENT_SUCCESS Key
|
||||
| CHECKPRESENT_FAILURE Key
|
||||
| CHECKPRESENT_UNKNOWN Key ErrorMsg
|
||||
| REMOVE_SUCCESS Key
|
||||
| REMOVE_FAILURE Key ErrorMsg
|
||||
| COST Cost
|
||||
| COST_UNKNOWN
|
||||
| INITREMOTE_SUCCESS
|
||||
| INITREMOTE_FAILURE ErrorMsg
|
||||
deriving (Show)
|
||||
|
||||
instance Receivable Response where
|
||||
parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS
|
||||
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 "COST_UNKNOWN" = parse0 COST_UNKNOWN
|
||||
parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS
|
||||
parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE
|
||||
parseCommand _ = parseFail
|
||||
|
||||
-- Requests that the external remote can send at any time it's in control.
|
||||
data RemoteRequest
|
||||
= VERSION Int
|
||||
| PROGRESS Direction Key Int
|
||||
| DIRHASH Key
|
||||
| SETCONFIG Setting String
|
||||
| GETCONFIG Setting
|
||||
| SETSTATE Key String
|
||||
| GETSTATE Key
|
||||
deriving (Show)
|
||||
|
||||
instance Receivable RemoteRequest where
|
||||
parseCommand "VERSION" = parse1 VERSION
|
||||
parseCommand "PROGRESS" = parse3 PROGRESS
|
||||
parseCommand "DIRHASH" = parse1 DIRHASH
|
||||
parseCommand "SETCONFIG" = parse2 SETCONFIG
|
||||
parseCommand "GETCONFIG" = parse1 GETCONFIG
|
||||
parseCommand "SETSTATE" = parse2 SETSTATE
|
||||
parseCommand "GETSTATE" = parse1 GETSTATE
|
||||
parseCommand _ = parseFail
|
||||
|
||||
-- Responses to RemoteRequest.
|
||||
data RemoteResponse
|
||||
= VALUE String
|
||||
deriving (Show)
|
||||
|
||||
instance Sendable RemoteResponse where
|
||||
formatMessage (VALUE s) = [ "VALUE", serialize s ]
|
||||
|
||||
-- Messages that can be sent at any time by either git-annex or the remote.
|
||||
data AsyncMessages
|
||||
= ERROR ErrorMsg
|
||||
deriving (Show)
|
||||
|
||||
instance Sendable AsyncMessages where
|
||||
formatMessage (ERROR err) = [ "ERROR", serialize err ]
|
||||
|
||||
instance Receivable AsyncMessages where
|
||||
parseCommand "ERROR" = parse1 ERROR
|
||||
parseCommand _ = parseFail
|
||||
|
||||
-- Data types used for parameters when communicating with the remote.
|
||||
-- All are serializable.
|
||||
type ErrorMsg = String
|
||||
type Setting = String
|
||||
|
||||
class Serializable a where
|
||||
serialize :: a -> String
|
||||
deserialize :: String -> Maybe a
|
||||
|
||||
instance Serializable Direction where
|
||||
serialize Upload = "STORE"
|
||||
serialize Download = "RETRIEVE"
|
||||
|
||||
deserialize "STORE" = Just Upload
|
||||
deserialize "RETRIEVE" = Just Download
|
||||
deserialize _ = Nothing
|
||||
|
||||
instance Serializable Key where
|
||||
serialize = key2file
|
||||
deserialize = file2key
|
||||
|
||||
instance Serializable [Char] where
|
||||
serialize = id
|
||||
deserialize = Just
|
||||
|
||||
instance Serializable Cost where
|
||||
serialize = show
|
||||
deserialize = readish
|
||||
|
||||
instance Serializable Int where
|
||||
serialize = show
|
||||
deserialize = 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 :: 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue