types for async protocol extension

renamed AsyncMessage to ExceptionalMessage to make way for this new
extension.

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
+						receiveResponse p handleresponse' handleexceptional
-			Nothing -> case Proto.parseMessage s :: Maybe AsyncMessage of
+			Nothing -> case Proto.parseMessage s :: Maybe ExceptionalMessage of
-				Just msg -> maybe (protocolError True s) id (handleasync msg)
+				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

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
+				Nothing -> case parseMessage s :: Maybe ExceptionalMessage of
-					Just msg -> maybe (protocolError True s) id (handleasync msg)
+					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

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]