diff options
| -rw-r--r-- | Remote/External.hs | 252 | ||||
| -rw-r--r-- | doc/design/external_special_remote_protocol.mdwn | 29 |
2 files changed, 269 insertions, 12 deletions
diff --git a/Remote/External.hs b/Remote/External.hs new file mode 100644 index 000000000..c3297c7ea --- /dev/null +++ b/Remote/External.hs @@ -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 diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index 19640fb7f..a17ce96fc 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -95,9 +95,10 @@ send one of the corresponding replies listed in the next section. (See Config/Cost.hs for some standard costs.) * `TRANSFER STORE|RETRIEVE Key File` Requests the transfer of a key. For Send, the File is the file to upload; - for Receive the File is where to store the download. Note that the File - should not influence the filename used on the remote. The filename used - should be derived from the Key. + for Receive the File is where to store the download. + Note that the File should not influence the filename used on the remote. + The filename used should be derived from the Key, and will not contain + any whitespace. Multiple transfers might be requested by git-annex, but it's fine for the program to serialize them and only do one at a time. * `CHECKPRESENT Key` @@ -130,17 +131,14 @@ while it's handling a request. * `REMOVE-SUCCESS Key` Indicates the key has been removed from the remote. May be returned if the remote didn't have the key at the point removal was requested. -* `REMOVE-FAILURE Key` +* `REMOVE-FAILURE Key ErrorMsg` Indicates that the key was unable to be removed from the remote. * `COST Int` Indicates the cost of the remote. * `COST-UNKNOWN` Indicates the remote has no opinion of its cost. -* `INITREMOTE-SUCCESS Setting=Value ...` +* `INITREMOTE-SUCCESS` Indicates the INITREMOTE succeeded and the remote is ready to use. - The settings and values can optionally be returned. They will be added - to the existing configuration of the remote (and may change existing - values in it). * `INITREMOTE-FAILURE ErrorMsg` Indicates that INITREMOTE failed. @@ -154,8 +152,8 @@ in control. thing at startup, as until it sees this git-annex does not know how to talk with the special remote program! * `PROGRESS STORE|RETRIEVE Key Int` - Indicates the current progress of the transfer. May be repeated any - number of times during the transfer process. This is highly recommended + Indicates the current progress of the transfer (in bytes). May be repeated + any number of times during the transfer process. This is highly recommended for STORE. (It is optional but good for RETRIEVE.) (git-annex does not send a reply to this message.) * `DIRHASH Key` @@ -163,7 +161,13 @@ in control. This is always the same for any given Key, so can be used for eg, creating hash directory structures to store Keys in. (git-annex replies with VALUE followed by the value.) -* `GETCONFIG Setting` +* `SETCONFIG Setting` + Sets one of the special remote's configuration settings. These settings + are stored in the git-annex branch, so will be available if the same + special remote is used elsewhere. + (Typically only done during INITREMOTE, although it is accepted at other + times.) +* `GETCONFIG Setting` Gets one of the special remote's configuration settings. (git-annex replies with VALUE followed by the value.) * `SETSTATE Key Value` @@ -206,7 +210,8 @@ while read line; do # XXX do anything necessary to create resources # used by the remote. Try to be idempotent. # Use GETCONFIG to get any needed configuration - # settings. + # settings, and SETCONFIG to set any persistent + # configuration settings. echo INITREMOTE-SUCCESS ;; GETCOST) |