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.
This commit is contained in:
Joey Hess
parent
409a85b264
commit
6c565ec905
10 changed files with 509 additions and 205 deletions
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import Assistant.Common
|
|||
import Assistant.WebApp.Types
|
||||
import Assistant.Sync
|
||||
import qualified Remote
|
||||
import qualified Types.Remote as Remote
|
||||
import qualified Config
|
||||
import Config.Cost
|
||||
import Types.StandardGroups
|
||||
|
|
@ -31,6 +32,6 @@ setupCloudRemote defaultgroup mcost maker = do
|
|||
r <- liftAnnex $ addRemote maker
|
||||
liftAnnex $ do
|
||||
setStandardGroup (Remote.uuid r) defaultgroup
|
||||
maybe noop (Config.setRemoteCost r) mcost
|
||||
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
|
||||
liftAssistant $ syncRemote r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
|
|||
|
|
@ -223,7 +223,7 @@ getRepositoriesReorderR = do
|
|||
rs <- catMaybes <$> mapM Remote.remoteFromUUID list
|
||||
forM_ (reorderCosts remote rs) $ \(r, newcost) ->
|
||||
when (Remote.cost r /= newcost) $
|
||||
setRemoteCost r newcost
|
||||
setRemoteCost (Remote.repo r) newcost
|
||||
void remoteListRefresh
|
||||
fromjs = toUUID . T.unpack
|
||||
|
||||
|
|
|
|||
17
Config.hs
17
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.<name>.annex-cost, or if remote.<name>.annex-cost-command
|
||||
- is set and prints a number, that is used. -}
|
||||
remoteCost :: RemoteGitConfig -> Cost -> Annex Cost
|
||||
remoteCost c def = case remoteAnnexCostCommand c of
|
||||
Just cmd | not (null cmd) -> liftIO $
|
||||
(fromMaybe def . readish) <$>
|
||||
readProcess "sh" ["-c", cmd]
|
||||
_ -> return $ fromMaybe def $ remoteAnnexCost c
|
||||
remoteCost c def = fromMaybe def <$> remoteCost' c
|
||||
|
||||
setRemoteCost :: Remote -> Cost -> Annex ()
|
||||
setRemoteCost r c = setConfig (remoteConfig (Remote.repo r) "cost") (show c)
|
||||
remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost)
|
||||
remoteCost' c = case remoteAnnexCostCommand c of
|
||||
Just cmd | not (null cmd) -> liftIO $
|
||||
readish <$> readProcess "sh" ["-c", cmd]
|
||||
_ -> return $ remoteAnnexCost 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
where
|
||||
externaltype = fromMaybe (error "missing externaltype") $ remoteAnnexExternalType gc
|
||||
|
||||
store :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store k _f _p = undefined
|
||||
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
|
||||
|
||||
storeEncrypted :: [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
||||
storeEncrypted gpgOpts (cipher, enck) k _p = undefined
|
||||
external <- newExternal externaltype
|
||||
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
||||
INITREMOTE_SUCCESS -> Just noop
|
||||
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
||||
_ -> Nothing
|
||||
|
||||
retrieve :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieve k _f d _p = undefined
|
||||
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
|
||||
retrieveCheap _ _ = return False
|
||||
|
||||
retrieveEncrypted :: (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveEncrypted (cipher, enck) _ f _p = undefined
|
||||
retrieveEncrypted :: External -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveEncrypted external (cipher, enck) _ f _p = safely $ undefined
|
||||
|
||||
remove :: Key -> Annex Bool
|
||||
remove k = 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 :: 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
|
||||
checkPresent :: External -> Key -> Annex (Either String Bool)
|
||||
checkPresent external k = either (Left . show) id <$> tryAnnex go
|
||||
where
|
||||
(command, rest) = splitWord s
|
||||
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
|
||||
|
||||
-- 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)
|
||||
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
|
||||
|
||||
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.
|
||||
{- 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.
|
||||
-}
|
||||
type Parser a = String -> Maybe a
|
||||
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
|
||||
|
||||
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
|
||||
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
|
||||
(p1, p2) = splitWord s
|
||||
loop = receiveMessage lck external responsehandler
|
||||
(\rreq -> Just $ handleRemoteRequest rreq >> loop)
|
||||
(\msg -> Just $ handleAsyncMessage msg >> loop)
|
||||
|
||||
parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a
|
||||
parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
|
||||
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, rest) = splitWord s
|
||||
(p2, p3) = splitWord rest
|
||||
protocolError s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\""
|
||||
|
||||
splitWord :: String -> (String, String)
|
||||
splitWord = separate isSpace
|
||||
{- 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
|
||||
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
|
||||
}
|
||||
|
||||
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
|
||||
|
|
|
|||
254
Remote/External/Types.hs
vendored
Normal file
254
Remote/External/Types.hs
vendored
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
{- External special remote data types.
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue