generalized ExternalState to not be limited to a ExternalAddonProcess

Idea is for ASYNC extension, it will instead contain methods that communicate
with the thread that handles all communication with the external process.
This commit is contained in:
Joey Hess 2020-08-12 12:30:45 -04:00
parent 5f4228dc2b
commit 3f8c808bd7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 48 additions and 33 deletions

View file

@ -12,7 +12,7 @@ module Remote.External (remote) where
import Remote.External.Types import Remote.External.Types
import qualified Annex import qualified Annex
import Annex.Common import Annex.Common
import Annex.ExternalAddonProcess import qualified Annex.ExternalAddonProcess as AddonProcess
import Types.Remote import Types.Remote
import Types.Export import Types.Export
import Types.CleanupActions import Types.CleanupActions
@ -504,13 +504,26 @@ handleRequest' st external req mp responsehandler
setDownloader (show uri) OtherDownloader setDownloader (show uri) OtherDownloader
sendMessage :: Sendable m => ExternalState -> m -> Annex () sendMessage :: Sendable m => ExternalState -> m -> Annex ()
sendMessage st m = liftIO $ do sendMessage st m = liftIO $ externalSend st line
protocolDebug (externalAddonProcess st) True line where
line = unwords $ formatMessage m
sendMessageAddonProcess :: AddonProcess.ExternalAddonProcess -> String -> IO ()
sendMessageAddonProcess p line = do
AddonProcess.protocolDebug p True line
hPutStrLn h line hPutStrLn h line
hFlush h hFlush h
where where
line = unwords $ formatMessage m h = AddonProcess.externalSend p
h = externalSend (externalAddonProcess st)
receiveMessageAddonProcess :: AddonProcess.ExternalAddonProcess -> IO (Maybe String)
receiveMessageAddonProcess p = do
v <- catchMaybeIO $ hGetLine $ AddonProcess.externalReceive p
maybe noop (AddonProcess.protocolDebug p False) v
return v
shutdownAddonProcess :: AddonProcess.ExternalAddonProcess -> Bool -> IO ()
shutdownAddonProcess = AddonProcess.externalShutdown
{- A response handler can yeild a result, or it can request that another {- A response handler can yeild a result, or it can request that another
- message be consumed from the external. -} - message be consumed from the external. -}
@ -535,12 +548,10 @@ receiveMessage
-> (ExceptionalMessage -> Maybe (Annex a)) -> (ExceptionalMessage -> Maybe (Annex a))
-> Annex a -> Annex a
receiveMessage st external handleresponse handlerequest handleexceptional = receiveMessage st external handleresponse handlerequest handleexceptional =
go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive $ externalAddonProcess st) go =<< liftIO (externalReceive st)
where where
go Nothing = protocolError False "" go Nothing = protocolError False ""
go (Just s) = do go (Just s) = case parseMessage s :: Maybe Response of
liftIO $ protocolDebug (externalAddonProcess st) False s
case parseMessage s :: Maybe Response of
Just resp -> case handleresponse resp of Just resp -> case handleresponse resp of
Nothing -> protocolError True s Nothing -> protocolError True s
Just callback -> callback >>= \case Just callback -> callback >>= \case
@ -571,7 +582,7 @@ receiveMessage st external handleresponse handlerequest handleexceptional =
withExternalState :: External -> (ExternalState -> Annex a) -> Annex a withExternalState :: External -> (ExternalState -> Annex a) -> Annex a
withExternalState external a = do withExternalState external a = do
st <- get st <- get
r <- a st `onException` liftIO (externalShutdown (externalAddonProcess st) True) r <- a st `onException` liftIO (externalShutdown st True)
put st -- only when no exception is thrown put st -- only when no exception is thrown
return r return r
where where
@ -597,9 +608,9 @@ startExternal external = do
n <- succ <$> readTVar (externalLastPid external) n <- succ <$> readTVar (externalLastPid external)
writeTVar (externalLastPid external) n writeTVar (externalLastPid external) n
return n return n
startExternalAddonProcess basecmd pid >>= \case AddonProcess.startExternalAddonProcess basecmd pid >>= \case
Left (ProgramFailure err) -> giveup err Left (AddonProcess.ProgramFailure err) -> giveup err
Left (ProgramNotInstalled err) -> Left (AddonProcess.ProgramNotInstalled err) ->
case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of
(Just rname, Just True) -> giveup $ unlines (Just rname, Just True) -> giveup $ unlines
[ err [ err
@ -614,7 +625,9 @@ startExternal external = do
ccv <- liftIO $ newTVarIO id ccv <- liftIO $ newTVarIO id
pv <- liftIO $ newTVarIO Unprepared pv <- liftIO $ newTVarIO Unprepared
let st = ExternalState let st = ExternalState
{ externalAddonProcess = p { externalSend = sendMessageAddonProcess p
, externalReceive = receiveMessageAddonProcess p
, externalShutdown = shutdownAddonProcess p
, externalPrepared = pv , externalPrepared = pv
, externalConfig = cv , externalConfig = cv
, externalConfigChanges = ccv , externalConfigChanges = ccv
@ -644,7 +657,7 @@ startExternal external = do
stopExternal :: External -> Annex () stopExternal :: External -> Annex ()
stopExternal external = liftIO $ do stopExternal external = liftIO $ do
l <- atomically $ swapTVar (externalState external) [] l <- atomically $ swapTVar (externalState external) []
mapM_ (flip (externalShutdown . externalAddonProcess) False) l mapM_ (flip externalShutdown False) l
checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ()) checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ())
checkVersion st (VERSION v) = Just $ checkVersion st (VERSION v) = Just $

View file

@ -34,7 +34,6 @@ module Remote.External.Types (
) where ) where
import Annex.Common import Annex.Common
import Annex.ExternalAddonProcess
import Types.StandardGroups (PreferredContentExpression) import Types.StandardGroups (PreferredContentExpression)
import Utility.Metered (BytesProcessed(..)) import Utility.Metered (BytesProcessed(..))
import Types.Transfer (Direction(..)) import Types.Transfer (Direction(..))
@ -75,8 +74,11 @@ newExternal externaltype u c gc rs = liftIO $ External
type ExternalType = String type ExternalType = String
data ExternalState = ExternalState data ExternalState
{ externalAddonProcess :: ExternalAddonProcess = ExternalState
{ externalSend :: String -> IO ()
, externalReceive :: IO (Maybe String)
, externalShutdown :: Bool -> IO ()
, externalPrepared :: TVar PrepareStatus , externalPrepared :: TVar PrepareStatus
, externalConfig :: TVar ParsedRemoteConfig , externalConfig :: TVar ParsedRemoteConfig
, externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig) , externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig)