58d8ba5a4f
Still need to implement GET and PUT, and will implement CONNECT and NOTIFYCHANGE for completeness. All ServerMode checking is implemented for the proxy. There are two possible approaches for how the proxy sends back messages from the remote to the client. One would be to have a background thread that reads messages and sends them back as they come in. The other, which is being implemented so far, is to read messages from the remote at points where it is expected to send them, and relay back to the client before reading the next message from the client. At this point, I'm unsure which approach would be better. The need for proxynoresponse to be used by UNLOCKCONTENT, for example, builds protocol knowledge into the proxy which it would not need with the other method.
89 lines
2.9 KiB
Haskell
89 lines
2.9 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.UUID
|
|
import qualified CmdLine.GitAnnexShell.Checks as Checks
|
|
import Remote.Helper.Ssh (openP2PSshConnection', closeP2PSshConnection)
|
|
|
|
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 r -> performProxy theiruuid servermode r
|
|
|
|
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
|
|
runFullProto runst conn server >>= \case
|
|
Right () -> done
|
|
-- Avoid displaying an error when the client hung up on us.
|
|
Left (ProtoFailureIOError e) | isEOFError e -> done
|
|
Left e -> giveup (describeProtoFailure e)
|
|
where
|
|
done = next $ return True
|
|
|
|
performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform
|
|
performProxy clientuuid servermode remote = do
|
|
clientside <- ClientSide
|
|
<$> liftIO (mkRunState $ Serving clientuuid Nothing)
|
|
<*> pure (stdioP2PConnection Nothing)
|
|
getClientProtocolVersion remote clientside
|
|
(withclientversion clientside)
|
|
protoerrhandler
|
|
where
|
|
withclientversion clientside (Just (clientmaxversion, othermsg)) =
|
|
connectremote clientmaxversion $ \remoteside ->
|
|
proxy done servermode clientside remoteside
|
|
othermsg protoerrhandler
|
|
withclientversion _ Nothing = done
|
|
|
|
-- FIXME: Support special remotes and non-ssh git remotes.
|
|
connectremote clientmaxversion cont =
|
|
openP2PSshConnection' remote clientmaxversion >>= \case
|
|
Just conn@(P2P.IO.OpenConnection (remoterunst, remoteconn, _)) ->
|
|
cont (RemoteSide remoterunst remoteconn)
|
|
`finally` liftIO (closeP2PSshConnection conn)
|
|
_ -> giveup "Unable to connect to remote."
|
|
|
|
protoerrhandler cont a = a >>= \case
|
|
-- Avoid displaying an error when the client hung up on us.
|
|
Left (ProtoFailureIOError e) | isEOFError e -> done
|
|
Left e -> giveup (describeProtoFailure e)
|
|
Right v -> cont v
|
|
|
|
done = next $ return True
|