add GETINFO to external protocol (for ronnypfa)

External special remotes can now add info to `git annex info $remote`, by
replying to the GETINFO message.

Had to generalize some helpers to allow consuming multiple messages from
the remote.

The code added to Remote/* here is AGPL licensed, thus changed the license
of the files.

This commit was sponsored by Jake Vosloo on Patreon.
This commit is contained in:
Joey Hess 2018-06-08 11:52:20 -04:00
parent 8397151b2b
commit c3c28f7617
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 149 additions and 67 deletions

View file

@ -7,6 +7,8 @@ git-annex (6.20180530) UNRELEASED; urgency=medium
way can be used. way can be used.
* Fix problems accessing repositories over http when annex.tune.* * Fix problems accessing repositories over http when annex.tune.*
is configured. is configured.
* External special remotes can now add info to `git annex info $remote`,
by replying to the GETINFO message.
-- Joey Hess <id@joeyh.name> Wed, 30 May 2018 11:49:08 -0400 -- Joey Hess <id@joeyh.name> Wed, 30 May 2018 11:49:08 -0400

View file

@ -10,7 +10,7 @@ Copyright: © 2012-2017 Joey Hess <id@joeyh.name>
© 2014 Sören Brunk © 2014 Sören Brunk
License: AGPL-3+ License: AGPL-3+
Files: Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Files: Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Remote/External.hs Remote/Extermal/Types.hs
Copyright: © 2011-2018 Joey Hess <id@joeyh.name> Copyright: © 2011-2018 Joey Hess <id@joeyh.name>
License: AGPL-3+ License: AGPL-3+

View file

@ -1,8 +1,8 @@
{- External special remote interface. {- External special remote interface.
- -
- Copyright 2013-2016 Joey Hess <id@joeyh.name> - Copyright 2013-2018 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
module Remote.External (remote) where module Remote.External (remote) where
@ -61,6 +61,7 @@ gen r u c gc
readonlyRemoveKey readonlyRemoveKey
(checkKeyUrl r) (checkKeyUrl r)
Nothing Nothing
(externalInfo externaltype)
Nothing Nothing
Nothing Nothing
exportUnsupported exportUnsupported
@ -94,12 +95,13 @@ gen r u c gc
(removeKeyM external) (removeKeyM external)
(checkPresentM external) (checkPresentM external)
(Just (whereisKeyM external)) (Just (whereisKeyM external))
(getInfoM external)
(Just (claimUrlM external)) (Just (claimUrlM external))
(Just (checkUrlM external)) (Just (checkUrlM external))
exportactions exportactions
cheapexportsupported cheapexportsupported
where where
mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl exportactions cheapexportsupported = do mk cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do
let rmt = Remote let rmt = Remote
{ uuid = u { uuid = u
, cost = cst , cost = cst
@ -125,7 +127,7 @@ gen r u c gc
{ exportSupported = cheapexportsupported } { exportSupported = cheapexportsupported }
, mkUnavailable = gen r u c $ , mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" } gc { remoteAnnexExternalType = Just "!dne!" }
, getInfo = return [("externaltype", externaltype)] , getInfo = togetinfo
, claimUrl = toclaimurl , claimUrl = toclaimurl
, checkUrl = tocheckurl , checkUrl = tocheckurl
} }
@ -151,7 +153,7 @@ externalSetup _ mu _ c gc = do
_ -> do _ -> do
external <- newExternal externaltype u c' gc external <- newExternal externaltype u c' gc
handleRequest external INITREMOTE Nothing $ \resp -> case resp of handleRequest external INITREMOTE Nothing $ \resp -> case resp of
INITREMOTE_SUCCESS -> Just noop INITREMOTE_SUCCESS -> result ()
INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
_ -> Nothing _ -> Nothing
withExternalState external $ withExternalState external $
@ -171,21 +173,20 @@ checkExportSupported' :: External -> Annex Bool
checkExportSupported' external = go `catchNonAsync` (const (return False)) checkExportSupported' external = go `catchNonAsync` (const (return False))
where where
go = handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of go = handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of
EXPORTSUPPORTED_SUCCESS -> Just $ return True EXPORTSUPPORTED_SUCCESS -> result True
EXPORTSUPPORTED_FAILURE -> Just $ return False EXPORTSUPPORTED_FAILURE -> result False
UNSUPPORTED_REQUEST -> Just $ return False UNSUPPORTED_REQUEST -> result False
_ -> Nothing _ -> Nothing
storeKeyM :: External -> Storer storeKeyM :: External -> Storer
storeKeyM external = fileStorer $ \k f p -> storeKeyM external = fileStorer $ \k f p ->
handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Upload k' | k == k' -> TRANSFER_SUCCESS Upload k' | k == k' -> result True
Just $ return True
TRANSFER_FAILURE Upload k' errmsg | k == k' -> TRANSFER_FAILURE Upload k' errmsg | k == k' ->
Just $ do Just $ do
warning errmsg warning errmsg
return False return (Result False)
_ -> Nothing _ -> Nothing
retrieveKeyFileM :: External -> Retriever retrieveKeyFileM :: External -> Retriever
@ -193,7 +194,7 @@ retrieveKeyFileM external = fileRetriever $ \d k p ->
handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp -> handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Download k' TRANSFER_SUCCESS Download k'
| k == k' -> Just $ return () | k == k' -> result ()
TRANSFER_FAILURE Download k' errmsg TRANSFER_FAILURE Download k' errmsg
| k == k' -> Just $ giveup errmsg | k == k' -> Just $ giveup errmsg
_ -> Nothing _ -> Nothing
@ -203,11 +204,11 @@ removeKeyM external k = safely $
handleRequestKey external REMOVE k Nothing $ \resp -> handleRequestKey external REMOVE k Nothing $ \resp ->
case resp of case resp of
REMOVE_SUCCESS k' REMOVE_SUCCESS k'
| k == k' -> Just $ return True | k == k' -> result True
REMOVE_FAILURE k' errmsg REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do | k == k' -> Just $ do
warning errmsg warning errmsg
return False return (Result False)
_ -> Nothing _ -> Nothing
checkPresentM :: External -> CheckPresent checkPresentM :: External -> CheckPresent
@ -216,32 +217,31 @@ checkPresentM external k = either giveup id <$> go
go = handleRequestKey external CHECKPRESENT k Nothing $ \resp -> go = handleRequestKey external CHECKPRESENT k Nothing $ \resp ->
case resp of case resp of
CHECKPRESENT_SUCCESS k' CHECKPRESENT_SUCCESS k'
| k' == k -> Just $ return $ Right True | k' == k -> result $ Right True
CHECKPRESENT_FAILURE k' CHECKPRESENT_FAILURE k'
| k' == k -> Just $ return $ Right False | k' == k -> result $ Right False
CHECKPRESENT_UNKNOWN k' errmsg CHECKPRESENT_UNKNOWN k' errmsg
| k' == k -> Just $ return $ Left errmsg | k' == k -> result $ Left errmsg
_ -> Nothing _ -> Nothing
whereisKeyM :: External -> Key -> Annex [String] whereisKeyM :: External -> Key -> Annex [String]
whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of
WHEREIS_SUCCESS s -> Just $ return [s] WHEREIS_SUCCESS s -> result [s]
WHEREIS_FAILURE -> Just $ return [] WHEREIS_FAILURE -> result []
UNSUPPORTED_REQUEST -> Just $ return [] UNSUPPORTED_REQUEST -> result []
_ -> Nothing _ -> Nothing
storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportM external f k loc p = safely $ storeExportM external f k loc p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of handleRequestExport external loc req k (Just p) $ \resp -> case resp of
TRANSFER_SUCCESS Upload k' | k == k' -> TRANSFER_SUCCESS Upload k' | k == k' -> result True
Just $ return True
TRANSFER_FAILURE Upload k' errmsg | k == k' -> TRANSFER_FAILURE Upload k' errmsg | k == k' ->
Just $ do Just $ do
warning errmsg warning errmsg
return False return (Result False)
UNSUPPORTED_REQUEST -> Just $ do UNSUPPORTED_REQUEST -> Just $ do
warning "TRANSFEREXPORT not implemented by external special remote" warning "TRANSFEREXPORT not implemented by external special remote"
return False return (Result False)
_ -> Nothing _ -> Nothing
where where
req sk = TRANSFEREXPORT Upload sk f req sk = TRANSFEREXPORT Upload sk f
@ -250,14 +250,14 @@ retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate
retrieveExportM external k loc d p = safely $ retrieveExportM external k loc d p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of handleRequestExport external loc req k (Just p) $ \resp -> case resp of
TRANSFER_SUCCESS Download k' TRANSFER_SUCCESS Download k'
| k == k' -> Just $ return True | k == k' -> result True
TRANSFER_FAILURE Download k' errmsg TRANSFER_FAILURE Download k' errmsg
| k == k' -> Just $ do | k == k' -> Just $ do
warning errmsg warning errmsg
return False return (Result False)
UNSUPPORTED_REQUEST -> Just $ do UNSUPPORTED_REQUEST -> Just $ do
warning "TRANSFEREXPORT not implemented by external special remote" warning "TRANSFEREXPORT not implemented by external special remote"
return False return (Result False)
_ -> Nothing _ -> Nothing
where where
req sk = TRANSFEREXPORT Download sk d req sk = TRANSFEREXPORT Download sk d
@ -267,12 +267,12 @@ checkPresentExportM external k loc = either giveup id <$> go
where where
go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
CHECKPRESENT_SUCCESS k' CHECKPRESENT_SUCCESS k'
| k' == k -> Just $ return $ Right True | k' == k -> result $ Right True
CHECKPRESENT_FAILURE k' CHECKPRESENT_FAILURE k'
| k' == k -> Just $ return $ Right False | k' == k -> result $ Right False
CHECKPRESENT_UNKNOWN k' errmsg CHECKPRESENT_UNKNOWN k' errmsg
| k' == k -> Just $ return $ Left errmsg | k' == k -> result $ Left errmsg
UNSUPPORTED_REQUEST -> Just $ return $ UNSUPPORTED_REQUEST -> result $
Left "CHECKPRESENTEXPORT not implemented by external special remote" Left "CHECKPRESENTEXPORT not implemented by external special remote"
_ -> Nothing _ -> Nothing
@ -280,22 +280,22 @@ removeExportM :: External -> Key -> ExportLocation -> Annex Bool
removeExportM external k loc = safely $ removeExportM external k loc = safely $
handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
REMOVE_SUCCESS k' REMOVE_SUCCESS k'
| k == k' -> Just $ return True | k == k' -> result True
REMOVE_FAILURE k' errmsg REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do | k == k' -> Just $ do
warning errmsg warning errmsg
return False return (Result False)
UNSUPPORTED_REQUEST -> Just $ do UNSUPPORTED_REQUEST -> Just $ do
warning "REMOVEEXPORT not implemented by external special remote" warning "REMOVEEXPORT not implemented by external special remote"
return False return (Result False)
_ -> Nothing _ -> Nothing
removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool
removeExportDirectoryM external dir = safely $ removeExportDirectoryM external dir = safely $
handleRequest external req Nothing $ \resp -> case resp of handleRequest external req Nothing $ \resp -> case resp of
REMOVEEXPORTDIRECTORY_SUCCESS -> Just $ return True REMOVEEXPORTDIRECTORY_SUCCESS -> result True
REMOVEEXPORTDIRECTORY_FAILURE -> Just $ return False REMOVEEXPORTDIRECTORY_FAILURE -> result False
UNSUPPORTED_REQUEST -> Just $ return True UNSUPPORTED_REQUEST -> result True
_ -> Nothing _ -> Nothing
where where
req = REMOVEEXPORTDIRECTORY dir req = REMOVEEXPORTDIRECTORY dir
@ -304,10 +304,10 @@ renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bo
renameExportM external k src dest = safely $ renameExportM external k src dest = safely $
handleRequestExport external src req k Nothing $ \resp -> case resp of handleRequestExport external src req k Nothing $ \resp -> case resp of
RENAMEEXPORT_SUCCESS k' RENAMEEXPORT_SUCCESS k'
| k' == k -> Just $ return True | k' == k -> result True
RENAMEEXPORT_FAILURE k' RENAMEEXPORT_FAILURE k'
| k' == k -> Just $ return False | k' == k -> result False
UNSUPPORTED_REQUEST -> Just $ return False UNSUPPORTED_REQUEST -> result False
_ -> Nothing _ -> Nothing
where where
req sk = RENAMEEXPORT sk dest req sk = RENAMEEXPORT sk dest
@ -333,12 +333,12 @@ safely a = go =<< tryNonAsync a
- May throw exceptions, for example on protocol errors, or - May throw exceptions, for example on protocol errors, or
- when the repository cannot be used. - when the repository cannot be used.
-} -}
handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest :: External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequest external req mp responsehandler = handleRequest external req mp responsehandler =
withExternalState external $ \st -> withExternalState external $ \st ->
handleRequest' st external req mp responsehandler handleRequest' st external req mp responsehandler
handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of
Right sk -> handleRequest external (mkreq sk) mp responsehandler Right sk -> handleRequest external (mkreq sk) mp responsehandler
Left e -> giveup e Left e -> giveup e
@ -346,14 +346,14 @@ handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of
{- Export location is first sent in an EXPORT message before {- Export location is first sent in an EXPORT message before
- the main request. This is done because the ExportLocation can - the main request. This is done because the ExportLocation can
- contain spaces etc. -} - contain spaces etc. -}
handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequestExport external loc mkreq k mp responsehandler = do handleRequestExport external loc mkreq k mp responsehandler = do
withExternalState external $ \st -> do withExternalState external $ \st -> do
checkPrepared st external checkPrepared st external
sendMessage st external (EXPORT loc) sendMessage st external (EXPORT loc)
handleRequestKey external mkreq k mp responsehandler handleRequestKey external mkreq k mp responsehandler
handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequest' st external req mp responsehandler handleRequest' st external req mp responsehandler
| needsPREPARE req = do | needsPREPARE req = do
checkPrepared st external checkPrepared st external
@ -449,6 +449,17 @@ sendMessage st external m = liftIO $ do
line = unwords $ formatMessage m line = unwords $ formatMessage m
h = externalSend st h = externalSend st
{- A response handler can yeild a result, or it can request that another
- message be consumed from the external result. -}
data ResponseHandlerResult a
= Result a
| GetNextMessage (ResponseHandler a)
type ResponseHandler a = Response -> Maybe (Annex (ResponseHandlerResult a))
result :: a -> Maybe (Annex (ResponseHandlerResult a))
result = Just . return . Result
{- Waits for a message from the external remote, and passes it to the {- Waits for a message from the external remote, and passes it to the
- apppropriate handler. - apppropriate handler.
- -
@ -456,7 +467,7 @@ sendMessage st external m = liftIO $ do
receiveMessage receiveMessage
:: ExternalState :: ExternalState
-> External -> External
-> (Response -> Maybe (Annex a)) -> ResponseHandler a
-> (RemoteRequest -> Maybe (Annex a)) -> (RemoteRequest -> Maybe (Annex a))
-> (AsyncMessage -> Maybe (Annex a)) -> (AsyncMessage -> Maybe (Annex a))
-> Annex a -> Annex a
@ -467,14 +478,21 @@ receiveMessage st external handleresponse handlerequest handleasync =
go (Just s) = do go (Just s) = do
liftIO $ protocolDebug external st False s liftIO $ protocolDebug external st False s
case parseMessage s :: Maybe Response of case parseMessage s :: Maybe Response of
Just resp -> maybe (protocolError True s) id (handleresponse resp) Just resp -> case handleresponse resp of
Nothing -> protocolError True s
Just callback -> callback >>= \case
Result a -> return a
GetNextMessage handleresponse' ->
receiveMessage st external handleresponse' handlerequest handleasync
Nothing -> case parseMessage s :: Maybe RemoteRequest of Nothing -> case parseMessage s :: Maybe RemoteRequest of
Just req -> maybe (protocolError True s) id (handlerequest req) Just req -> maybe (protocolError True s) id (handlerequest req)
Nothing -> case parseMessage s :: Maybe AsyncMessage of Nothing -> case parseMessage s :: Maybe AsyncMessage of
Just msg -> maybe (protocolError True s) id (handleasync msg) Just msg -> maybe (protocolError True s) id (handleasync msg)
Nothing -> protocolError False s Nothing -> protocolError False s
protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
if parsed then "(command not allowed at this time)" else "(unable to parse command)" if parsed
then "(command not allowed at this time)"
else "(unable to parse command)"
protocolDebug :: External -> ExternalState -> Bool -> String -> IO () protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
protocolDebug external st sendto line = debugM "external" $ unwords protocolDebug external st sendto line = debugM "external" $ unwords
@ -521,8 +539,8 @@ startExternal external = do
-- accepted. -- accepted.
receiveMessage st external receiveMessage st external
(\resp -> case resp of (\resp -> case resp of
EXTENSIONS_RESPONSE _ -> Just (return ()) EXTENSIONS_RESPONSE _ -> result ()
UNSUPPORTED_REQUEST -> Just (return ()) UNSUPPORTED_REQUEST -> result ()
_ -> Nothing _ -> Nothing
) )
(const Nothing) (const Nothing)
@ -603,8 +621,9 @@ checkPrepared st external = do
Unprepared -> Unprepared ->
handleRequest' st external PREPARE Nothing $ \resp -> handleRequest' st external PREPARE Nothing $ \resp ->
case resp of case resp of
PREPARE_SUCCESS -> Just $ PREPARE_SUCCESS -> Just $ do
setprepared Prepared setprepared Prepared
return (Result ())
PREPARE_FAILURE errmsg -> Just $ do PREPARE_FAILURE errmsg -> Just $ do
setprepared $ FailedPrepare errmsg setprepared $ FailedPrepare errmsg
giveup errmsg giveup errmsg
@ -617,17 +636,18 @@ checkPrepared st external = do
- external special remote every time time just to ask it what its - external special remote every time time just to ask it what its
- cost is. -} - cost is. -}
getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost
getCost external r gc = catchNonAsync (go =<< remoteCost' gc) (const defcst) getCost external r gc =
(go =<< remoteCost' gc) `catchNonAsync` const (pure defcst)
where where
go (Just c) = return c go (Just c) = return c
go Nothing = do go Nothing = do
c <- handleRequest external GETCOST Nothing $ \req -> case req of c <- handleRequest external GETCOST Nothing $ \req -> case req of
COST c -> Just $ return c COST c -> result c
UNSUPPORTED_REQUEST -> Just defcst UNSUPPORTED_REQUEST -> result defcst
_ -> Nothing _ -> Nothing
setRemoteCost r c setRemoteCost r c
return c return c
defcst = return expensiveRemoteCost defcst = expensiveRemoteCost
{- Caches the availability in the git config to avoid needing to start up an {- Caches the availability in the git config to avoid needing to start up an
- external special remote every time time just to ask it what its - external special remote every time time just to ask it what its
@ -638,35 +658,36 @@ getCost external r gc = catchNonAsync (go =<< remoteCost' gc) (const defcst)
-} -}
getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability
getAvailability external r gc = getAvailability external r gc =
maybe (catchNonAsync query (const defavail)) return (remoteAnnexAvailability gc) maybe (catchNonAsync query (const (pure defavail))) return
(remoteAnnexAvailability gc)
where where
query = do query = do
avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of
AVAILABILITY avail -> Just $ return avail AVAILABILITY avail -> result avail
UNSUPPORTED_REQUEST -> Just defavail UNSUPPORTED_REQUEST -> result defavail
_ -> Nothing _ -> Nothing
setRemoteAvailability r avail setRemoteAvailability r avail
return avail return avail
defavail = return GloballyAvailable defavail = GloballyAvailable
claimUrlM :: External -> URLString -> Annex Bool claimUrlM :: External -> URLString -> Annex Bool
claimUrlM external url = claimUrlM external url =
handleRequest external (CLAIMURL url) Nothing $ \req -> case req of handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
CLAIMURL_SUCCESS -> Just $ return True CLAIMURL_SUCCESS -> result True
CLAIMURL_FAILURE -> Just $ return False CLAIMURL_FAILURE -> result False
UNSUPPORTED_REQUEST -> Just $ return False UNSUPPORTED_REQUEST -> result False
_ -> Nothing _ -> Nothing
checkUrlM :: External -> URLString -> Annex UrlContents checkUrlM :: External -> URLString -> Annex UrlContents
checkUrlM external url = checkUrlM external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of handleRequest external (CHECKURL url) Nothing $ \req -> case req of
CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz CHECKURL_CONTENTS sz f -> result $ UrlContents sz $
(if null f then Nothing else Just $ mkSafeFilePath f) if null f then Nothing else Just $ mkSafeFilePath f
-- Treat a single item multi response specially to -- Treat a single item multi response specially to
-- simplify the external remote implementation. -- simplify the external remote implementation.
CHECKURL_MULTI ((_, sz, f):[]) -> CHECKURL_MULTI ((_, sz, f):[]) ->
Just $ return $ UrlContents sz $ Just $ mkSafeFilePath f result $ UrlContents sz $ Just $ mkSafeFilePath f
CHECKURL_MULTI l -> Just $ return $ UrlMulti $ map mkmulti l CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l
CHECKURL_FAILURE errmsg -> Just $ giveup errmsg CHECKURL_FAILURE errmsg -> Just $ giveup errmsg
UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote" UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"
_ -> Nothing _ -> Nothing
@ -689,3 +710,23 @@ getWebUrls :: Key -> Annex [URLString]
getWebUrls key = filter supported <$> getUrls key getWebUrls key = filter supported <$> getUrls key
where where
supported u = snd (getDownloader u) == WebDownloader supported u = snd (getDownloader u) == WebDownloader
externalInfo :: ExternalType -> Annex [(String, String)]
externalInfo et = return [("externaltype", et)]
getInfoM :: External -> Annex [(String, String)]
getInfoM external = (++)
<$> externalInfo (externalType external)
<*> handleRequest external GETINFO Nothing (collect [])
where
collect l req = case req of
INFOFIELD f -> Just $ return $
GetNextMessage $ collectvalue l f
INFOEND -> result (reverse l)
UNSUPPORTED_REQUEST -> result []
_ -> Nothing
collectvalue l f req = case req of
INFOVALUE v -> Just $ return $
GetNextMessage $ collect ((f, v) : l)
_ -> Nothing

View file

@ -2,7 +2,7 @@
- -
- Copyright 2013-2018 Joey Hess <id@joeyh.name> - Copyright 2013-2018 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
@ -127,6 +127,7 @@ data Request
| CHECKPRESENT SafeKey | CHECKPRESENT SafeKey
| REMOVE SafeKey | REMOVE SafeKey
| WHEREIS SafeKey | WHEREIS SafeKey
| GETINFO
| EXPORTSUPPORTED | EXPORTSUPPORTED
| EXPORT ExportLocation | EXPORT ExportLocation
| TRANSFEREXPORT Direction SafeKey FilePath | TRANSFEREXPORT Direction SafeKey FilePath
@ -162,6 +163,7 @@ instance Proto.Sendable Request where
[ "CHECKPRESENT", Proto.serialize key ] [ "CHECKPRESENT", Proto.serialize key ]
formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ] formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ] formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
formatMessage GETINFO = [ "GETINFO" ]
formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"] formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ] formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
formatMessage (TRANSFEREXPORT direction key file) = formatMessage (TRANSFEREXPORT direction key file) =
@ -205,6 +207,9 @@ data Response
| CHECKURL_FAILURE ErrorMsg | CHECKURL_FAILURE ErrorMsg
| WHEREIS_SUCCESS String | WHEREIS_SUCCESS String
| WHEREIS_FAILURE | WHEREIS_FAILURE
| INFOFIELD String
| INFOVALUE String
| INFOEND
| EXPORTSUPPORTED_SUCCESS | EXPORTSUPPORTED_SUCCESS
| EXPORTSUPPORTED_FAILURE | EXPORTSUPPORTED_FAILURE
| REMOVEEXPORTDIRECTORY_SUCCESS | REMOVEEXPORTDIRECTORY_SUCCESS
@ -236,6 +241,9 @@ instance Proto.Receivable Response where
parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD
parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE
parseCommand "INFOEND" = Proto.parse0 INFOEND
parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS
parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE
parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS

View file

@ -159,6 +159,11 @@ replying with `UNSUPPORTED-REQUEST` is acceptable.
network access. network access.
This is not needed when `SETURIPRESENT` is used, since such uris are This is not needed when `SETURIPRESENT` is used, since such uris are
automatically displayed by `git annex whereis`. automatically displayed by `git annex whereis`.
* `GETINFO`
Requests the remote to send some information describing its
configuration, for display by `git annex info`.
Reply with a series of `INFOFIELD` each followed by `INFOVALUE`,
and concluded with `INFOEND`.
* `EXPORTSUPPORTED` * `EXPORTSUPPORTED`
Used to check if a special remote supports exports. The remote Used to check if a special remote supports exports. The remote
responds with either `EXPORTSUPPORTED-SUCCESS` or responds with either `EXPORTSUPPORTED-SUCCESS` or
@ -282,6 +287,23 @@ while it's handling a request.
stored in the special remote. stored in the special remote.
* `WHEREIS-FAILURE` * `WHEREIS-FAILURE`
Indicates that no location is known for a key. Indicates that no location is known for a key.
* `INFOFIELD` / `INFOVALUE` / `INFOEND`
Reply to a GETINFO request. This can be used to add info about anything,
but things like an url to the remote, or details of the remote's
configuration are typical. It should not include any sensitive
information like passwords, since it will be displayed to the user's
screen.
There can be zero or more `INFOFIELD` messages, each containing the name of
a field, and each is immediately followed by an `INFOVALUE` message
containing its value. The sequence is concluded by `INFOEND`. For example:
INFOFIELD repository location
INFOVALUE http://example.com/repo/
INFOFIELD datacenter
INFOVALUE Antarctica
INFOEND
* `EXPORTSUPPORTED-SUCCESS` * `EXPORTSUPPORTED-SUCCESS`
Indicates that it makes sense to use this special remote as an export. Indicates that it makes sense to use this special remote as an export.
* `EXPORTSUPPORTED-FAILURE` * `EXPORTSUPPORTED-FAILURE`

View file

@ -285,6 +285,15 @@ while read line; do
fi fi
;; ;;
# This is optional, only provided as an example.
GETINFO)
echo INFOFIELD "repository location"
echo INFOVALUE "$mydirectory"
echo INFOFIELD "login"
echo INFOVALUE "$MYLOGIN"
echo INFOEND
;;
*) *)
echo UNSUPPORTED-REQUEST echo UNSUPPORTED-REQUEST
;; ;;