From 97d0fc9b6518ae7af7123934bff2e466bfe54526 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 9 Jul 2024 23:44:40 -0400 Subject: [PATCH] git-annex p2phttp options --- Command/P2PHttp.hs | 98 ++++++++++++++++++++++++++++++++++---- P2P/Http.hs | 39 +++++++-------- P2P/Http/State.hs | 7 +-- P2P/Http/Types.hs | 4 +- doc/git-annex-p2phttp.mdwn | 10 ++-- 5 files changed, 119 insertions(+), 39 deletions(-) diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index d384084793..1760fdc4ff 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -15,11 +15,15 @@ import Command import P2P.Http import qualified P2P.Protocol as P2P import Annex.Url +import Utility.Env import qualified Network.Wai.Handler.Warp as Warp +import Servant import Servant.Client.Streaming import Control.Concurrent import Control.Concurrent.STM +import Network.Socket (PortNumber) +import qualified Data.Map as M cmd :: Command cmd = command "p2phttp" SectionPlumbing @@ -27,20 +31,97 @@ cmd = command "p2phttp" SectionPlumbing paramNothing (seek <$$> optParser) data Options = Options - { cmdParams :: CmdParams + { portOption :: Maybe PortNumber , authEnvOption :: Bool , authEnvHttpOption :: Bool - , readOnlyOption :: Bool - , appendOnlyOption :: Bool + , unauthReadOnlyOption :: Bool + , unauthAppendOnlyOption :: Bool , wideOpenOption :: Bool } -seek :: CmdParams -> CommandSeek -seek ["server"] = startConcurrency commandStages $ +optParser :: CmdParamsDesc -> Parser Options +optParser _ = Options + <$> optional (option auto + ( long "port" <> metavar paramNumber + <> help "specify port to listen on" + )) + <*> switch + ( long "authenv" + <> help "authenticate users from environment (https only)" + ) + <*> switch + ( long "authenv-http" + <> help "authenticate users from environment (including http)" + ) + <*> switch + ( long "unauth-readonly" + <> help "allow unauthenticated users to read the repository" + ) + <*> switch + ( long "unauth-appendonly" + <> help "allow unauthenticated users to read and append to the repository" + ) + <*> switch + ( long "wideopen" + <> help "give unauthenticated users full read+write access" + ) + +seek :: Options -> CommandSeek +seek o = startConcurrency commandStages $ withLocalP2PConnections $ \acquireconn -> liftIO $ do - st <- mkP2PHttpServerState acquireconn - Warp.run 8080 (p2pHttpApp st) -seek ["client"] = testCheckPresent + authenv <- getAuthEnv + st <- mkP2PHttpServerState acquireconn $ + mkGetServerMode authenv o + Warp.run (fromIntegral port) (p2pHttpApp st) + where + port = fromMaybe 80 (portOption o) + +mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode +mkGetServerMode _ o _ Nothing + | wideOpenOption o = Just P2P.ServeReadWrite + | unauthAppendOnlyOption o = Just P2P.ServeAppendOnly + | unauthReadOnlyOption o = Just P2P.ServeReadOnly + | otherwise = Nothing +mkGetServerMode authenv o issecure (Just auth) = + case (issecure, authEnvOption o, authEnvHttpOption o) of + (Secure, True, _) -> checkauth + (NotSecure, _, True) -> checkauth + _ -> noauth + where + checkauth = case M.lookup auth authenv of + Just servermode -> Just servermode + Nothing -> noauth + noauth = mkGetServerMode authenv o issecure Nothing + +getAuthEnv :: IO (M.Map Auth P2P.ServerMode) +getAuthEnv = do + environ <- getEnvironment + let permmap = M.fromList (mapMaybe parseperms environ) + return $ M.fromList $ + map (addperms permmap) $ + mapMaybe parseusername environ + where + parseperms (k, v) = case deprefix "GIT_ANNEX_P2PHTTP_PERMISSIONS_" k of + Nothing -> Nothing + Just username -> case v of + "readonly" -> Just + (encodeBS username, P2P.ServeReadOnly) + "appendonly" -> Just + (encodeBS username, P2P.ServeAppendOnly) + _ -> Nothing + + parseusername (k, v) = case deprefix "GIT_ANNEX_P2PHTTP_PASSWORD_" k of + Nothing -> Nothing + Just username -> Just $ Auth (encodeBS username) (encodeBS v) + + deprefix prefix s + | prefix `isPrefixOf` s = Just (drop (length prefix) s) + | otherwise = Nothing + + addperms permmap auth@(Auth user _) = + case M.lookup user permmap of + Nothing -> (auth, P2P.ServeReadWrite) + Just perms -> (auth, perms) testKeepLocked = do mgr <- httpManager <$> getUrlOptions @@ -67,4 +148,5 @@ testCheckPresent = do (B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) [] + Nothing liftIO $ print res diff --git a/P2P/Http.hs b/P2P/Http.hs index ff477e3f7e..2a48c93dbf 100644 --- a/P2P/Http.hs +++ b/P2P/Http.hs @@ -161,6 +161,7 @@ type CheckPresentAPI :> ClientUUID Required :> ServerUUID Required :> BypassUUIDs + :> IsSecure :> AuthHeader :> Post '[JSON] CheckPresentResult @@ -172,10 +173,11 @@ serveCheckPresent -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> IsSecure -> Maybe Auth -> Handler CheckPresentResult -serveCheckPresent st apiver (B64Key k) cu su bypass auth = do - res <- withP2PConnection apiver st cu su bypass auth ReadAction +serveCheckPresent st apiver (B64Key k) cu su bypass sec auth = do + res <- withP2PConnection apiver st cu su bypass sec auth ReadAction $ \runst conn -> liftIO $ runNetProto runst conn $ checkPresent k case res of @@ -183,24 +185,6 @@ serveCheckPresent st apiver (B64Key k) cu su bypass auth = do Right (Left err) -> throwError $ err500 { errBody = encodeBL err } Left err -> throwError $ err500 { errBody = encodeBL (describeProtoFailure err) } -clientCheckPresent' - :: ProtocolVersion - -> B64Key - -> B64UUID ClientSide - -> B64UUID ServerSide - -> [B64UUID Bypass] - -> Maybe Auth - -> ClientM CheckPresentResult -clientCheckPresent' (ProtocolVersion ver) = case ver of - 3 -> v3 V3 - 2 -> v2 V2 - 1 -> v1 V1 - 0 -> v0 V0 - _ -> error "unsupported protocol version" - where - _ :<|> _ :<|> _ :<|> _ :<|> - v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI - clientCheckPresent :: ClientEnv -> ProtocolVersion @@ -210,11 +194,20 @@ clientCheckPresent -> [B64UUID Bypass] -> Maybe Auth -> IO Bool -clientCheckPresent clientenv protover key cu su bypass auth = do - let cli = clientCheckPresent' protover key cu su bypass auth - withClientM cli clientenv $ \case +clientCheckPresent clientenv (ProtocolVersion ver) key cu su bypass auth = + withClientM (cli key cu su bypass auth) clientenv $ \case Left err -> throwM err Right (CheckPresentResult res) -> return res + where + cli = case ver of + 3 -> v3 V3 + 2 -> v2 V2 + 1 -> v1 V1 + 0 -> v0 V0 + _ -> error "unsupported protocol version" + + _ :<|> _ :<|> _ :<|> _ :<|> + v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI type RemoveAPI result = KeyParam diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index 0ab28250de..da7b73469b 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -46,12 +46,13 @@ withP2PConnection -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] + -> IsSecure -> Maybe Auth -> ActionClass -> (RunState -> P2PConnection -> Handler a) -> Handler a -withP2PConnection apiver st cu su bypass auth actionclass connaction = - case (getServerMode st auth, actionclass) of +withP2PConnection apiver st cu su bypass sec auth actionclass connaction = + case (getServerMode st sec auth, actionclass) of (Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite (Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403 (Just P2P.ServeAppendOnly, _) -> go P2P.ServeAppendOnly @@ -77,7 +78,7 @@ withP2PConnection apiver st cu su bypass auth actionclass connaction = } -- Nothing when the server is not allowed to serve any requests. -type GetServerMode = Maybe Auth -> Maybe P2P.ServerMode +type GetServerMode = IsSecure -> Maybe Auth -> Maybe P2P.ServerMode data ConnectionParams = ConnectionParams { connectionProtocolVersion :: P2P.ProtocolVersion diff --git a/P2P/Http/Types.hs b/P2P/Http/Types.hs index b56f5c7553..7ddbc56615 100644 --- a/P2P/Http/Types.hs +++ b/P2P/Http/Types.hs @@ -100,11 +100,11 @@ data LockResult = LockResult Bool (Maybe LockID) newtype UnlockRequest = UnlockRequest Bool deriving (Show, Generic, NFData) --- Not using servant's build-in basic authentication support, +-- Not using servant's built-in basic authentication support, -- because whether authentication is needed depends on server -- configuration. data Auth = Auth B.ByteString B.ByteString - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Eq, Ord) instance ToHttpApiData Auth where toHeader (Auth u p) = "Basic " <> toB64 (u <> ":" <> p) diff --git a/doc/git-annex-p2phttp.mdwn b/doc/git-annex-p2phttp.mdwn index f192bef51b..0e58e18665 100644 --- a/doc/git-annex-p2phttp.mdwn +++ b/doc/git-annex-p2phttp.mdwn @@ -14,6 +14,10 @@ a repository over HTTP with write access for authenticated users. # OPTIONS +* `--port=N` + + Port to listen on. Default is port 80. + * `--authenv` Allows users to be authenticated with a username and password. @@ -35,19 +39,19 @@ a repository over HTTP with write access for authenticated users. over HTTP. This is not secure, since HTTP basic authentication is not encrypted. -* `--readonly` +* `--unauth-readonly` Allows unauthenticated users to read the repository, but not make modifications to it. -* `--appendonly` +* `--unauth-appendonly` Allows unauthenticated users to read the repository, and store data in it, but not remove data from it. * `--wideopen` - Gives unauthenticated users full access to the repository. + Gives unauthenticated users full read+write access to the repository. Please think carefully before enabling this option.