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:
parent
8397151b2b
commit
c3c28f7617
6 changed files with 149 additions and 67 deletions
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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+
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
10
Remote/External/Types.hs
vendored
10
Remote/External/Types.hs
vendored
|
@ -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
|
||||||
|
|
|
@ -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`
|
||||||
|
|
9
doc/special_remotes/external/example.sh
vendored
9
doc/special_remotes/external/example.sh
vendored
|
@ -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
|
||||||
;;
|
;;
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue