From 6a8a4d17755faafa58fbd391a354ec08d6b5c285 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 9 Jul 2024 20:52:56 -0400 Subject: [PATCH] authentication is implemented just need to make Command.P2PHttp generate a GetServerMode from options --- P2P/Http.hs | 28 +++++++++------ P2P/Http/State.hs | 36 +++++++++++++------ doc/design/p2p_protocol_over_http/draft1.mdwn | 3 ++ 3 files changed, 46 insertions(+), 21 deletions(-) diff --git a/P2P/Http.hs b/P2P/Http.hs index ff91e6e284..ff477e3f7e 100644 --- a/P2P/Http.hs +++ b/P2P/Http.hs @@ -161,6 +161,7 @@ type CheckPresentAPI :> ClientUUID Required :> ServerUUID Required :> BypassUUIDs + :> AuthHeader :> Post '[JSON] CheckPresentResult serveCheckPresent @@ -171,10 +172,12 @@ serveCheckPresent -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth -> Handler CheckPresentResult -serveCheckPresent st apiver (B64Key k) cu su bypass = do - res <- withP2PConnection apiver st cu su bypass $ \runst conn -> - liftIO $ runNetProto runst conn $ checkPresent k +serveCheckPresent st apiver (B64Key k) cu su bypass auth = do + res <- withP2PConnection apiver st cu su bypass auth ReadAction + $ \runst conn -> + liftIO $ runNetProto runst conn $ checkPresent k case res of Right (Right b) -> return (CheckPresentResult b) Right (Left err) -> throwError $ err500 { errBody = encodeBL err } @@ -186,6 +189,7 @@ clientCheckPresent' -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth -> ClientM CheckPresentResult clientCheckPresent' (ProtocolVersion ver) = case ver of 3 -> v3 V3 @@ -204,9 +208,10 @@ clientCheckPresent -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth -> IO Bool -clientCheckPresent clientenv protover key cu su bypass = do - let cli = clientCheckPresent' protover key cu su bypass +clientCheckPresent clientenv protover key cu su bypass auth = do + let cli = clientCheckPresent' protover key cu su bypass auth withClientM cli clientenv $ \case Left err -> throwM err Right (CheckPresentResult res) -> return res @@ -216,6 +221,7 @@ type RemoveAPI result :> ClientUUID Required :> ServerUUID Required :> BypassUUIDs + :> AuthHeader :> Post '[JSON] result serveRemove @@ -227,6 +233,7 @@ serveRemove -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth -> Handler t serveRemove = undefined @@ -236,12 +243,13 @@ clientRemove -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth -> ClientM RemoveResultPlus -clientRemove (ProtocolVersion ver) k cu su bypass = case ver of - 3 -> v3 V3 k cu su bypass - 2 -> v2 V2 k cu su bypass - 1 -> plus <$> v1 V1 k cu su bypass - 0 -> plus <$> v0 V0 k cu su bypass +clientRemove (ProtocolVersion ver) k cu su bypass auth = case ver of + 3 -> v3 V3 k cu su bypass auth + 2 -> v2 V2 k cu su bypass auth + 1 -> plus <$> v1 V1 k cu su bypass auth + 0 -> plus <$> v0 V0 k cu su bypass auth _ -> error "unsupported protocol version" where _ :<|> _ :<|> _ :<|> _ :<|> diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index c076e91505..0ab28250de 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -36,6 +36,9 @@ mkP2PHttpServerState acquireconn getservermode = P2PHttpServerState <*> pure getservermode <*> newTMVarIO mempty +data ActionClass = ReadAction | WriteAction | RemoveAction + deriving (Eq) + withP2PConnection :: APIVersion v => v @@ -43,10 +46,20 @@ withP2PConnection -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> Maybe Auth + -> ActionClass -> (RunState -> P2PConnection -> Handler a) -> Handler a -withP2PConnection apiver st cu su bypass connaction = do - liftIO (acquireP2PConnection st cp) >>= \case +withP2PConnection apiver st cu su bypass auth actionclass connaction = + case (getServerMode st auth, actionclass) of + (Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite + (Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403 + (Just P2P.ServeAppendOnly, _) -> go P2P.ServeAppendOnly + (Just P2P.ServeReadOnly, ReadAction) -> go P2P.ServeReadOnly + (Just P2P.ServeReadOnly, _) -> throwError err403 + (Nothing, _) -> throwError err401 + where + go servermode = liftIO (acquireP2PConnection st cp) >>= \case Left (ConnectionFailed err) -> throwError err502 { errBody = encodeBL err } Left TooManyConnections -> @@ -54,16 +67,17 @@ withP2PConnection apiver st cu su bypass connaction = do Right (runst, conn, releaseconn) -> connaction runst conn `finally` liftIO releaseconn - where - cp = ConnectionParams - { connectionProtocolVersion = protocolVersion apiver - , connectionServerUUID = fromB64UUID su - , connectionClientUUID = fromB64UUID cu - , connectionBypass = map fromB64UUID bypass - , connectionServerMode = P2P.ServeReadWrite -- XXX auth - } + where + cp = ConnectionParams + { connectionProtocolVersion = protocolVersion apiver + , connectionServerUUID = fromB64UUID su + , connectionClientUUID = fromB64UUID cu + , connectionBypass = map fromB64UUID bypass + , connectionServerMode = servermode + } -type GetServerMode = IsSecure -> Maybe BasicAuthData -> Maybe P2P.ServerMode +-- Nothing when the server is not allowed to serve any requests. +type GetServerMode = Maybe Auth -> Maybe P2P.ServerMode data ConnectionParams = ConnectionParams { connectionProtocolVersion :: P2P.ProtocolVersion diff --git a/doc/design/p2p_protocol_over_http/draft1.mdwn b/doc/design/p2p_protocol_over_http/draft1.mdwn index 24dccea7c0..41332d2f46 100644 --- a/doc/design/p2p_protocol_over_http/draft1.mdwn +++ b/doc/design/p2p_protocol_over_http/draft1.mdwn @@ -26,6 +26,9 @@ it will fail with 401 Unauthorized. Authentication is done using HTTP basic auth. The realm to use when authenticating is "git-annex". +When authentication is successful but does not allow a request to be +performed, it will fail with 403 Forbidden. + Note that HTTP basic auth is not encrypted so is only secure when used over HTTPS.