f452bd448a
For clusters, the timestamps have to be translated, since each node can have its own idea about what time it is. To translate a timestamp, the proxy remembers what time it asked the node for a timestamp in GETTIMESTAMP, and applies the delta as an offset in REMOVE-BEFORE. This does mean that a remove from a cluster has to call GETTIMESTAMP on every node before dropping from nodes. Not very efficient. Although currently it tries to drop from every single node anyway, which is also not very efficient. I thought about caching the GETTIMESTAMP from the nodes on the first call. That would improve efficiency. But, since monotonic clocks on !Linux don't advance when the computer is suspended, consider what might happen if one node was suspended for a while, then came back. Its monotonic timestamp would end up behind where the proxying expects it to be. Would that result in removing when it shouldn't, or refusing to remove when it should? Have not thought it through. Either way, a cluster behaving strangly for an extended period of time because one of its nodes was briefly asleep doesn't seem like good behavior.
118 lines
3.8 KiB
Haskell
118 lines
3.8 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)
|
|
proxystate <- liftIO mkProxyState
|
|
let runproxy othermsg' = proxy closer
|
|
proxymethods proxystate
|
|
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)
|
|
ClientSide clientrunst <$> liftIO (stdioP2PConnectionDupped 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
|