git-annex p2phttp options
This commit is contained in:
parent
6a8a4d1775
commit
97d0fc9b65
5 changed files with 119 additions and 39 deletions
|
@ -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
|
||||
|
|
39
P2P/Http.hs
39
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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.
|
||||
|
||||
|
|
Loading…
Reference in a new issue