git-annex/Command/P2PStdIO.hs
Joey Hess 62750f0102
shut down RemoteSides cleanly
Before it just exited without actually shutting down the RemoteSides,
when the client hung up.
2024-06-28 13:19:57 -04:00

116 lines
3.7 KiB
Haskell

{- git-annex command
-
- Copyright 2018-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Command.P2PStdIO where
import Command
import P2P.IO
import P2P.Annex
import P2P.Proxy
import qualified P2P.Protocol as P2P
import qualified Annex
import Annex.Proxy
import Annex.UUID
import qualified CmdLine.GitAnnexShell.Checks as Checks
import Logs.Location
import Logs.Cluster
import Annex.Cluster
import qualified Remote
import System.IO.Error
cmd :: Command
cmd = noMessages $ command "p2pstdio" SectionPlumbing
"communicate in P2P protocol over stdio"
paramUUID (withParams seek)
seek :: CmdParams -> CommandSeek
seek [u] = commandAction $ start $ toUUID u
seek _ = giveup "missing UUID parameter"
start :: UUID -> CommandStart
start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do
servermode <- liftIO $ do
ro <- Checks.checkEnvSet Checks.readOnlyEnv
ao <- Checks.checkEnvSet Checks.appendOnlyEnv
return $ case (ro, ao) of
(True, _) -> P2P.ServeReadOnly
(False, True) -> P2P.ServeAppendOnly
(False, False) -> P2P.ServeReadWrite
Annex.getState Annex.proxyremote >>= \case
Nothing ->
performLocal theiruuid servermode
Just (Right r) ->
performProxy theiruuid servermode r
Just (Left clusteruuid) ->
performProxyCluster theiruuid clusteruuid servermode
performLocal :: UUID -> P2P.ServerMode -> CommandPerform
performLocal theiruuid servermode = do
myuuid <- getUUID
let conn = stdioP2PConnection Nothing
let server = do
P2P.net $ P2P.sendMessage (P2P.AUTH_SUCCESS myuuid)
P2P.serveAuthed servermode myuuid
runst <- liftIO $ mkRunState $ Serving theiruuid Nothing
p2pErrHandler noop (const p2pDone) (runFullProto runst conn server)
performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform
performProxy clientuuid servermode r = do
clientside <- proxyClientSide clientuuid
getClientProtocolVersion (Remote.uuid r) clientside
(withclientversion clientside)
(p2pErrHandler noop)
where
withclientversion clientside (Just (clientmaxversion, othermsg)) = do
remoteside <- proxyRemoteSide clientmaxversion mempty r
protocolversion <- either (const (min P2P.maxProtocolVersion clientmaxversion)) id
<$> runRemoteSide remoteside
(P2P.net P2P.getProtocolVersion)
concurrencyconfig <- noConcurrencyConfig
let closer = do
closeRemoteSide remoteside
p2pDone
let errhandler = p2pErrHandler (closeRemoteSide remoteside)
let runproxy othermsg' = proxy closer proxymethods
servermode clientside
(Remote.uuid r)
(singleProxySelector remoteside)
concurrencyconfig
protocolversion othermsg' errhandler
sendClientProtocolVersion clientside othermsg protocolversion
runproxy errhandler
withclientversion _ Nothing = p2pDone
proxymethods = ProxyMethods
{ removedContent = \u k -> logChange k u InfoMissing
, addedContent = \u k -> logChange k u InfoPresent
}
performProxyCluster :: UUID -> ClusterUUID -> P2P.ServerMode -> CommandPerform
performProxyCluster clientuuid clusteruuid servermode = do
clientside <- proxyClientSide clientuuid
proxyCluster clusteruuid p2pDone servermode clientside p2pErrHandler
proxyClientSide :: UUID -> Annex ClientSide
proxyClientSide clientuuid = do
clientrunst <- liftIO (mkRunState $ Serving clientuuid Nothing)
return $ ClientSide clientrunst (stdioP2PConnection Nothing)
p2pErrHandler :: Annex () -> (a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform
p2pErrHandler closeconn cont a = a >>= \case
-- Avoid displaying an error when the client hung up on us.
Left (ProtoFailureIOError e) | isEOFError e -> do
closeconn
p2pDone
Left e -> do
closeconn
giveup (describeProtoFailure e)
Right v -> cont v
p2pDone :: CommandPerform
p2pDone = next $ return True