types for async protocol extension
renamed AsyncMessage to ExceptionalMessage to make way for this new extension.
This commit is contained in:
Joey Hess
parent
482422b9c5
commit
5f4228dc2b
3 changed files with 36 additions and 24 deletions
|
|
@ -132,13 +132,13 @@ handleRequest st req whenunavail responsehandler =
|
|||
withExternalAddon st whenunavail $ \p -> do
|
||||
sendMessage p req
|
||||
let loop = receiveResponse p responsehandler
|
||||
(Just . handleAsyncMessage loop)
|
||||
(Just . handleExceptionalMessage loop)
|
||||
loop
|
||||
where
|
||||
handleAsyncMessage _ (ERROR err) = do
|
||||
handleExceptionalMessage _ (ERROR err) = do
|
||||
warning ("external special remote error: " ++ err)
|
||||
whenunavail
|
||||
handleAsyncMessage loop (DEBUG msg) = do
|
||||
handleExceptionalMessage loop (DEBUG msg) = do
|
||||
liftIO $ debugM "external" msg
|
||||
loop
|
||||
|
||||
|
|
@ -174,9 +174,9 @@ result = Just . return . Result
|
|||
receiveResponse
|
||||
:: ExternalAddonProcess
|
||||
-> ResponseHandler a
|
||||
-> (AsyncMessage -> Maybe (Annex a))
|
||||
-> (ExceptionalMessage -> Maybe (Annex a))
|
||||
-> Annex a
|
||||
receiveResponse p handleresponse handleasync =
|
||||
receiveResponse p handleresponse handleexceptional =
|
||||
go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive p)
|
||||
where
|
||||
go Nothing = protocolError False ""
|
||||
|
|
@ -188,9 +188,9 @@ receiveResponse p handleresponse handleasync =
|
|||
Just callback -> callback >>= \case
|
||||
Result a -> return a
|
||||
GetNextMessage handleresponse' ->
|
||||
receiveResponse p handleresponse' handleasync
|
||||
Nothing -> case Proto.parseMessage s :: Maybe AsyncMessage of
|
||||
Just msg -> maybe (protocolError True s) id (handleasync msg)
|
||||
receiveResponse p handleresponse' handleexceptional
|
||||
Nothing -> case Proto.parseMessage s :: Maybe ExceptionalMessage of
|
||||
Just msg -> maybe (protocolError True s) id (handleexceptional msg)
|
||||
Nothing -> protocolError False s
|
||||
|
||||
protocolError parsed s = giveup $ "external backend protocol error, unexpectedly received \"" ++ s ++ "\" " ++
|
||||
|
|
@ -321,7 +321,7 @@ data Response
|
|||
| PROGRESS BytesProcessed
|
||||
deriving (Show)
|
||||
|
||||
data AsyncMessage
|
||||
data ExceptionalMessage
|
||||
= ERROR ErrorMsg
|
||||
| DEBUG String
|
||||
deriving (Show)
|
||||
|
|
@ -338,11 +338,11 @@ instance Proto.Serializable ProtocolVersion where
|
|||
serialize (ProtocolVersion n) = show n
|
||||
deserialize = ProtocolVersion <$$> readish
|
||||
|
||||
instance Proto.Sendable AsyncMessage where
|
||||
instance Proto.Sendable ExceptionalMessage where
|
||||
formatMessage (ERROR err) = ["ERROR", Proto.serialize err]
|
||||
formatMessage (DEBUG msg) = ["DEBUG", Proto.serialize msg]
|
||||
|
||||
instance Proto.Receivable AsyncMessage where
|
||||
instance Proto.Receivable ExceptionalMessage where
|
||||
parseCommand "ERROR" = Proto.parse1 ERROR
|
||||
parseCommand "DEBUG" = Proto.parse1 DEBUG
|
||||
parseCommand _ = Proto.parseFail
|
||||
|
|
|
|||
|
|
@ -396,7 +396,7 @@ handleRequest' st external req mp responsehandler
|
|||
loop
|
||||
loop = receiveMessage st external responsehandler
|
||||
(\rreq -> Just $ handleRemoteRequest rreq >> loop)
|
||||
(\msg -> Just $ handleAsyncMessage msg >> loop)
|
||||
(\msg -> Just $ handleExceptionalMessage msg >> loop)
|
||||
|
||||
handleRemoteRequest (PROGRESS bytesprocessed) =
|
||||
maybe noop (\a -> liftIO $ a bytesprocessed) mp
|
||||
|
|
@ -487,7 +487,7 @@ handleRequest' st external req mp responsehandler
|
|||
handleRemoteRequest (INFO msg) = showInfo msg
|
||||
handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"
|
||||
|
||||
handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err
|
||||
handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err
|
||||
|
||||
send = sendMessage st
|
||||
senderror = sendMessage st . ERROR
|
||||
|
|
@ -532,9 +532,9 @@ receiveMessage
|
|||
-> External
|
||||
-> ResponseHandler a
|
||||
-> (RemoteRequest -> Maybe (Annex a))
|
||||
-> (AsyncMessage -> Maybe (Annex a))
|
||||
-> (ExceptionalMessage -> Maybe (Annex a))
|
||||
-> Annex a
|
||||
receiveMessage st external handleresponse handlerequest handleasync =
|
||||
receiveMessage st external handleresponse handlerequest handleexceptional =
|
||||
go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive $ externalAddonProcess st)
|
||||
where
|
||||
go Nothing = protocolError False ""
|
||||
|
|
@ -546,11 +546,11 @@ receiveMessage st external handleresponse handlerequest handleasync =
|
|||
Just callback -> callback >>= \case
|
||||
Result a -> return a
|
||||
GetNextMessage handleresponse' ->
|
||||
receiveMessage st external handleresponse' handlerequest handleasync
|
||||
receiveMessage st external handleresponse' handlerequest handleexceptional
|
||||
Nothing -> case parseMessage s :: Maybe RemoteRequest of
|
||||
Just req -> maybe (protocolError True s) id (handlerequest req)
|
||||
Nothing -> case parseMessage s :: Maybe AsyncMessage of
|
||||
Just msg -> maybe (protocolError True s) id (handleasync msg)
|
||||
Nothing -> case parseMessage s :: Maybe ExceptionalMessage of
|
||||
Just msg -> maybe (protocolError True s) id (handleexceptional msg)
|
||||
Nothing -> protocolError False s
|
||||
protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
|
||||
if parsed
|
||||
|
|
|
|||
24
Remote/External/Types.hs
vendored
24
Remote/External/Types.hs
vendored
|
|
@ -25,7 +25,7 @@ module Remote.External.Types (
|
|||
Response(..),
|
||||
RemoteRequest(..),
|
||||
RemoteResponse(..),
|
||||
AsyncMessage(..),
|
||||
ExceptionalMessage(..),
|
||||
ErrorMsg,
|
||||
Setting,
|
||||
Description,
|
||||
|
|
@ -88,9 +88,8 @@ type PID = Int
|
|||
newtype ExtensionList = ExtensionList [String]
|
||||
deriving (Show)
|
||||
|
||||
-- When adding a new RemoteRequest, also add it to the list here.
|
||||
supportedExtensionList :: ExtensionList
|
||||
supportedExtensionList = ExtensionList ["INFO"]
|
||||
supportedExtensionList = ExtensionList ["INFO", "ASYNC"]
|
||||
|
||||
data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
|
||||
|
||||
|
|
@ -323,17 +322,29 @@ instance Proto.Sendable RemoteResponse where
|
|||
formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ]
|
||||
|
||||
-- Messages that can be sent at any time by either git-annex or the remote.
|
||||
data AsyncMessage
|
||||
data ExceptionalMessage
|
||||
= ERROR ErrorMsg
|
||||
deriving (Show)
|
||||
|
||||
instance Proto.Sendable AsyncMessage where
|
||||
instance Proto.Sendable ExceptionalMessage where
|
||||
formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ]
|
||||
|
||||
instance Proto.Receivable AsyncMessage where
|
||||
instance Proto.Receivable ExceptionalMessage where
|
||||
parseCommand "ERROR" = Proto.parse1 ERROR
|
||||
parseCommand _ = Proto.parseFail
|
||||
|
||||
-- Messages used by the async protocol extension.
|
||||
data AsyncMessage
|
||||
= START_ASYNC JobId
|
||||
| END_ASYNC JobId
|
||||
| UPDATE_ASYNC JobId
|
||||
|
||||
instance Proto.Receivable AsyncMessage where
|
||||
parseCommand "START-ASYNC" = Proto.parse1 START_ASYNC
|
||||
parseCommand "END-ASYNC" = Proto.parse1 END_ASYNC
|
||||
parseCommand "UPDATE-ASYNC" = Proto.parse1 UPDATE_ASYNC
|
||||
parseCommand _ = Proto.parseFail
|
||||
|
||||
-- Data types used for parameters when communicating with the remote.
|
||||
-- All are serializable.
|
||||
type ErrorMsg = String
|
||||
|
|
@ -341,6 +352,7 @@ type Setting = String
|
|||
type Description = String
|
||||
type ProtocolVersion = Int
|
||||
type Size = Maybe Integer
|
||||
type JobId = String
|
||||
|
||||
supportedProtocolVersions :: [ProtocolVersion]
|
||||
supportedProtocolVersions = [1]
|
||||
|
|
|
|||
Loading…
Reference in a new issue