From 5f4228dc2b601fee4e7a0f59d88de2020e17efc8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 12 Aug 2020 12:04:12 -0400 Subject: [PATCH] types for async protocol extension renamed AsyncMessage to ExceptionalMessage to make way for this new extension. --- Backend/External.hs | 22 +++++++++++----------- Remote/External.hs | 14 +++++++------- Remote/External/Types.hs | 24 ++++++++++++++++++------ 3 files changed, 36 insertions(+), 24 deletions(-) diff --git a/Backend/External.hs b/Backend/External.hs index 6b2d062ecf..c4e7468b8e 100644 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -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 diff --git a/Remote/External.hs b/Remote/External.hs index 060843c475..dc97d440db 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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 diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 2619e7dc2b..1c3afaf3d8 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -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]