From f8dd20a34d7851d7e3827387d323ffab585a25a2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 26 Dec 2013 18:23:13 -0400 Subject: external special remotes mostly implemented (untested) This has not been tested at all. It compiles! The only known missing things are support for encryption, and for get/set of special remote configuration, and of key state. (The latter needs separate work to add a new per-key log file to store that state.) Only thing I don't much like is that initremote needs to be passed both type=external and externaltype=foo. It would be better to have just type=foo Most of this is quite straightforward code, that largely wrote itself given the types. The only tricky parts were: * Need to lock the remote when using it to eg make a request, because in theory git-annex could have multiple threads that each try to use a remote at the same time. I don't think that git-annex ever does that currently, but better safe than sorry. * Rather than starting up every external special remote program when git-annex starts, they are started only on demand, when first used. This will avoid slowdown, especially when running fast git-annex query commands. Once started, they keep running until git-annex stops, currently, which may not be ideal, but it's hard to know a better time to stop them. * Bit of a chicken and egg problem with caching the cost of the remote, because setting annex-cost in the git config needs the remote to already be set up. Managed to finesse that. This commit was sponsored by Lukas Anzinger. --- Assistant/Pairing/MakeRemote.hs | 3 +- Config.hs | 15 +- Remote/External.hs | 445 ++++++++++++++++++++++------------------ Remote/External/Types.hs | 254 +++++++++++++++++++++++ Remote/Hook.hs | 2 +- Remote/List.hs | 2 + Types/GitConfig.hs | 2 + Utility/Metered.hs | 2 +- 8 files changed, 514 insertions(+), 211 deletions(-) create mode 100644 Remote/External/Types.hs diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 144b236a4..3f3823664 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -15,6 +15,7 @@ import Assistant.MakeRemote import Assistant.Sync import Config.Cost import Config +import qualified Types.Remote as Remote import Network.Socket import qualified Data.Text as T @@ -46,7 +47,7 @@ finishedLocalPairing msg keypair = do ] Nothing r <- liftAnnex $ addRemote $ makeSshRemote sshdata - liftAnnex $ setRemoteCost r semiExpensiveRemoteCost + liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost syncRemote r {- Mostly a straightforward conversion. Except: diff --git a/Config.hs b/Config.hs index 0c6b64f50..3c6f3faa1 100644 --- a/Config.hs +++ b/Config.hs @@ -12,7 +12,6 @@ import qualified Git import qualified Git.Config import qualified Git.Command import qualified Annex -import qualified Types.Remote as Remote import Config.Cost type UnqualifiedConfigKey = String @@ -55,14 +54,16 @@ annexConfig key = ConfigKey $ "annex." ++ key - by remote..annex-cost, or if remote..annex-cost-command - is set and prints a number, that is used. -} remoteCost :: RemoteGitConfig -> Cost -> Annex Cost -remoteCost c def = case remoteAnnexCostCommand c of +remoteCost c def = fromMaybe def <$> remoteCost' c + +remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost) +remoteCost' c = case remoteAnnexCostCommand c of Just cmd | not (null cmd) -> liftIO $ - (fromMaybe def . readish) <$> - readProcess "sh" ["-c", cmd] - _ -> return $ fromMaybe def $ remoteAnnexCost c + readish <$> readProcess "sh" ["-c", cmd] + _ -> return $ remoteAnnexCost c -setRemoteCost :: Remote -> Cost -> Annex () -setRemoteCost r c = setConfig (remoteConfig (Remote.repo r) "cost") (show c) +setRemoteCost :: Git.Repo -> Cost -> Annex () +setRemoteCost r c = setConfig (remoteConfig r "cost") (show c) getNumCopies :: Maybe Int -> Annex Int getNumCopies (Just v) = return v diff --git a/Remote/External.hs b/Remote/External.hs index 1520acea3..ae026ca1f 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -5,15 +5,12 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} - module Remote.External (remote) where -import Data.Char - +import Remote.External.Types +import qualified Annex import Common.Annex import Types.Remote -import Types.Key import qualified Git import Config import Remote.Helper.Special @@ -22,30 +19,39 @@ import Crypto import Utility.Metered import Logs.Transfer import Config.Cost +import Annex.Content +import Annex.UUID +import Annex.Exception + +import Control.Concurrent.STM +import System.Process (std_in, std_out, std_err) +import qualified Data.Map as M remote :: RemoteType remote = RemoteType { - typename = "hook", - enumerate = findSpecialRemotes "hooktype", + typename = "external", + enumerate = findSpecialRemotes "externaltype", generate = gen, - setup = undefined + setup = externalSetup } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do - cst <- remoteCost gc expensiveRemoteCost + external <- newExternal externaltype + Annex.addCleanup (fromUUID u) $ stopExternal external + cst <- getCost external r gc return $ Just $ encryptableRemote c - (storeEncrypted $ getGpgEncParams (c,gc)) - retrieveEncrypted + (storeEncrypted external $ getGpgEncParams (c,gc)) + (retrieveEncrypted external) Remote { uuid = u, cost = cst, name = Git.repoDescribe r, - storeKey = store, - retrieveKeyFile = retrieve, + storeKey = store external, + retrieveKeyFile = retrieve external, retrieveKeyFileCheap = retrieveCheap, - removeKey = remove, - hasKey = checkPresent r, + removeKey = remove external, + hasKey = checkPresent external, hasKeyCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -58,197 +64,234 @@ gen r u c gc = do 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 + where + externaltype = fromMaybe (error "missing externaltype") $ remoteAnnexExternalType gc + +externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) +externalSetup mu c = do + u <- maybe (liftIO genUUID) return mu + let externaltype = fromMaybe (error "Specify externaltype=") $ + M.lookup "externaltype" c + c' <- encryptionSetup c + + external <- newExternal externaltype + handleRequest external INITREMOTE Nothing $ \resp -> case resp of + INITREMOTE_SUCCESS -> Just noop + INITREMOTE_FAILURE errmsg -> Just $ error errmsg + _ -> Nothing + + gitConfigSpecialRemote u c' "externaltype" externaltype + return (c', u) + +store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store external k _f p = safely $ sendAnnex k rollback $ \f -> + handleRequest external (TRANSFER Upload k f) (Just p) $ \resp -> + case resp of + TRANSFER_SUCCESS Upload k' + | k == k' -> Just $ return True + TRANSFER_FAILURE Upload k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing + where + rollback = void $ remove external k + +storeEncrypted :: External -> [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool +storeEncrypted external gpgOpts (cipher, enck) k _p = safely $ undefined + +retrieve :: External -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +retrieve external k _f d p = safely $ + handleRequest external (TRANSFER Download k d) (Just p) $ \resp -> + case resp of + TRANSFER_SUCCESS Download k' + | k == k' -> Just $ return True + TRANSFER_FAILURE Download k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing 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 +retrieveCheap _ _ = return False + +retrieveEncrypted :: External -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool +retrieveEncrypted external (cipher, enck) _ f _p = safely $ undefined + +remove :: External -> Key -> Annex Bool +remove external k = safely $ + handleRequest external (REMOVE k) Nothing $ \resp -> + case resp of + REMOVE_SUCCESS k' + | k == k' -> Just $ return True + REMOVE_FAILURE k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing + +checkPresent :: External -> Key -> Annex (Either String Bool) +checkPresent external k = either (Left . show) id <$> tryAnnex go 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 - | UNKNOWN_REQUEST - 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 "UNKNOWN-REQUEST" = parse0 UNKNOWN_REQUEST - 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 + go = handleRequest external (CHECKPRESENT k) Nothing $ \resp -> + case resp of + CHECKPRESENT_SUCCESS k' + | k' == k -> Just $ return $ Right True + CHECKPRESENT_FAILURE k' + | k' == k -> Just $ return $ Right False + CHECKPRESENT_UNKNOWN k' errmsg + | k' == k -> Just $ return $ Left errmsg + _ -> Nothing + +safely :: Annex Bool -> Annex Bool +safely a = go =<< tryAnnex a + where + go (Right r) = return r + go (Left e) = do + warning $ show e + return False -parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a -parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 +{- Sends a Request to the external remote, and waits for it to generate + - a Response that the responsehandler accepts. + - + - While the external remote is processing the Request, it may send + - any number of RemoteRequests, that are handled here. + - + - Only one request can be made at a time, so locking is used. + - + - May throw exceptions, for example on protocol errors. + -} +handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequest external req mp responsehandler = + withExternalLock external $ \lck -> + handleRequest' lck external req mp responsehandler + +handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequest' lck external req mp responsehandler = do + sendMessage lck external req + loop + where + loop = receiveMessage lck external responsehandler + (\rreq -> Just $ handleRemoteRequest rreq >> loop) + (\msg -> Just $ handleAsyncMessage msg >> loop) + + handleRemoteRequest (PROGRESS bytesprocessed) = + maybe noop (\a -> liftIO $ a bytesprocessed) mp + handleRemoteRequest (DIRHASH k) = + sendMessage lck external (VALUE $ hashDirMixed k) + handleRemoteRequest (SETCONFIG setting value) = error "TODO" + handleRemoteRequest (GETCONFIG setting) = error "TODO" + handleRemoteRequest (SETSTATE k value) = error "TODO" + handleRemoteRequest (GETSTATE k) = error "TODO" + handleRemoteRequest (VERSION _) = + sendMessage lck external (ERROR "too late to send VERSION") + + handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err + +sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex () +sendMessage lck external m = + fromExternal lck external externalSend $ \h -> + liftIO $ hPutStrLn h $ unwords $ formatMessage m + +{- Waits for a message from the external remote, and passes it to the + - apppropriate handler. + - + - If the handler returns Nothing, this is a protocol error.-} +receiveMessage + :: ExternalLock + -> External + -> (Response -> Maybe (Annex a)) + -> (RemoteRequest -> Maybe (Annex a)) + -> (AsyncMessage -> Maybe (Annex a)) + -> Annex a +receiveMessage lck external handleresponse handlerequest handleasync = do + s <- fromExternal lck external externalReceive $ liftIO . hGetLine + case parseMessage s :: Maybe Response of + Just resp -> maybe (protocolError s) id (handleresponse resp) + Nothing -> case parseMessage s :: Maybe RemoteRequest of + Just req -> maybe (protocolError s) id (handlerequest req) + Nothing -> case parseMessage s :: Maybe AsyncMessage of + Just msg -> maybe (protocolError s) id (handleasync msg) + Nothing -> protocolError s where - (p1, p2) = splitWord s + protocolError s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\"" -parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a -parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 +{- Starts up the external remote if it's not yet running, + - and passes a value extracted from its state to an action. + -} +fromExternal :: ExternalLock -> External -> (ExternalState -> v) -> (v -> Annex a) -> Annex a +fromExternal lck external extractor a = + go =<< liftIO (atomically (tryReadTMVar v)) where - (p1, rest) = splitWord s - (p2, p3) = splitWord rest + go (Just st) = run st + go Nothing = do + st <- startExternal $ externalType external + void $ liftIO $ atomically $ swapTMVar v st + + {- Handle initial protocol startup; check the VERSION + - the remote sends, and send it the PREPARE request. -} + receiveMessage lck external + (const Nothing) + (checkVersion lck external) + (const Nothing) + handleRequest' lck external PREPARE Nothing $ \resp -> + case resp of + PREPARE_SUCCESS -> Just $ run st + _ -> Nothing + + run st = a $ extractor st + v = externalState external + +{- Starts an external remote process running, but does not handle checking + - VERSION, etc. -} +startExternal :: ExternalType -> Annex ExternalState +startExternal externaltype = liftIO $ do + (Just hin, Just hout, _, pid) <- createProcess $ + (proc (externalRemoteProgram externaltype) []) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + fileEncoding hin + fileEncoding hout + return $ ExternalState + { externalSend = hin + , externalReceive = hout + , externalPid = pid + } -splitWord :: String -> (String, String) -splitWord = separate isSpace +stopExternal :: External -> Annex () +stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v) + where + stop Nothing = noop + stop (Just st) = do + void $ atomically $ tryTakeTMVar v + hClose $ externalSend st + hClose $ externalReceive st + void $ waitForProcess $ externalPid st + v = externalState external + +externalRemoteProgram :: ExternalType -> String +externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype + +checkVersion :: ExternalLock -> External -> RemoteRequest -> Maybe (Annex ()) +checkVersion lck external (VERSION v) = Just $ + if v `elem` supportedProtocolVersions + then noop + else sendMessage lck external (ERROR "unsupported VERSION") +checkVersion _ _ _ = Nothing + +{- Caches the cost in the git config to avoid needing to start up an + - external special remote every time time just to ask it what its + - cost is. -} +getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost +getCost external r gc = go =<< remoteCost' gc + where + go (Just c) = return c + go Nothing = do + c <- handleRequest external GETCOST Nothing $ \req -> case req of + COST c -> Just $ return c + COST_UNKNOWN -> Just $ return expensiveRemoteCost + _ -> Nothing + setRemoteCost r c + return c diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs new file mode 100644 index 000000000..ed8534a07 --- /dev/null +++ b/Remote/External/Types.hs @@ -0,0 +1,254 @@ +{- External special remote data types. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Remote.External.Types ( + External(..), + newExternal, + ExternalType, + ExternalLock, + withExternalLock, + ExternalState(..), + parseMessage, + Sendable(..), + Receivable(..), + Request(..), + Response(..), + RemoteRequest(..), + RemoteResponse(..), + AsyncMessage(..), + ErrorMsg, + Setting, + ProtocolVersion, + supportedProtocolVersions, +) where + +import Common.Annex +import Types.Key +import Utility.Metered +import Logs.Transfer +import Config.Cost +import Annex.Exception + +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 + -- Empty until the remote is running. + , externalState :: TMVar ExternalState + -- Empty when a remote is in use. + , externalLock :: TMVar ExternalLock + } + +newExternal :: ExternalType -> Annex External +newExternal externaltype = liftIO $ External + <$> pure externaltype + <*> atomically newEmptyTMVar + <*> atomically (newTMVar ExternalLock) + +type ExternalType = String + +data ExternalState = ExternalState + { externalSend :: Handle + , externalReceive :: Handle + , externalPid :: ProcessHandle + } + +-- Constructor is not exported, and only created by newExternal. +data ExternalLock = ExternalLock + +withExternalLock :: External -> (ExternalLock -> Annex a) -> Annex a +withExternalLock external = bracketIO setup cleanup + where + setup = atomically $ takeTMVar v + 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 + | 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 + | UNKNOWN_REQUEST + 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 "UNKNOWN-REQUEST" = parse0 UNKNOWN_REQUEST + parseCommand _ = parseFail + +-- Requests that the external remote can send at any time it's in control. +data RemoteRequest + = VERSION ProtocolVersion + | PROGRESS BytesProcessed + | DIRHASH Key + | SETCONFIG Setting String + | GETCONFIG Setting + | SETSTATE Key String + | GETSTATE Key + 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 "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 AsyncMessage + = ERROR ErrorMsg + deriving (Show) + +instance Sendable AsyncMessage where + formatMessage (ERROR err) = [ "ERROR", serialize err ] + +instance Receivable AsyncMessage 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 +type ProtocolVersion = Int + +supportedProtocolVersions :: [ProtocolVersion] +supportedProtocolVersions = [1] + +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 ProtocolVersion where + serialize = show + deserialize = readish + +instance Serializable Cost where + serialize = show + deserialize = readish + +instance 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 :: 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/Remote/Hook.hs b/Remote/Hook.hs index 55ff78514..2d41f51c6 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -63,7 +63,7 @@ gen r u c gc = do remotetype = remote } where - hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc + hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) hookSetup mu c = do diff --git a/Remote/List.hs b/Remote/List.hs index d53b92912..d01d23944 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -35,6 +35,7 @@ import qualified Remote.WebDAV #endif import qualified Remote.Glacier import qualified Remote.Hook +import qualified Remote.External remoteTypes :: [RemoteType] remoteTypes = @@ -52,6 +53,7 @@ remoteTypes = #endif , Remote.Glacier.remote , Remote.Hook.remote + , Remote.External.remote ] {- Builds a list of all available Remotes. diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 7224f43ff..afb40a795 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -113,6 +113,7 @@ data RemoteGitConfig = RemoteGitConfig , remoteAnnexDirectory :: Maybe FilePath , remoteAnnexGCrypt :: Maybe String , remoteAnnexHookType :: Maybe String + , remoteAnnexExternalType :: Maybe String {- A regular git remote's git repository config. -} , remoteGitConfig :: Maybe GitConfig } @@ -137,6 +138,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig , remoteAnnexDirectory = notempty $ getmaybe "directory" , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt" , remoteAnnexHookType = notempty $ getmaybe "hooktype" + , remoteAnnexExternalType = notempty $ getmaybe "externaltype" , remoteGitConfig = Nothing } where diff --git a/Utility/Metered.hs b/Utility/Metered.hs index f33ad443a..7ad9b1215 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -25,7 +25,7 @@ type MeterUpdate = (BytesProcessed -> IO ()) {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer - deriving (Eq, Ord) + deriving (Eq, Ord, Show) class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed -- cgit v1.2.3