git-annex p2phttp options

This commit is contained in:
Joey Hess 2024-07-09 23:44:40 -04:00
parent 6a8a4d1775
commit 97d0fc9b65
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 119 additions and 39 deletions

View file

@ -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