git-annex p2phttp options

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
+	, unauthReadOnlyOption :: Bool
-	, appendOnlyOption :: Bool
+	, unauthAppendOnlyOption :: Bool
 	, wideOpenOption :: Bool
 	}
 
-seek :: CmdParams -> CommandSeek
+optParser :: CmdParamsDesc -> Parser Options
-seek ["server"] = startConcurrency commandStages $
+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
+		authenv <- getAuthEnv
-		Warp.run 8080 (p2pHttpApp st)
+		st <- mkP2PHttpServerState acquireconn $
-seek ["client"] = testCheckPresent
+			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

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
+serveCheckPresent st apiver (B64Key k) cu su bypass sec auth = do
-	res <- withP2PConnection apiver st cu su bypass auth ReadAction
+	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
+clientCheckPresent clientenv (ProtocolVersion ver) key cu su bypass auth =
-	let cli = clientCheckPresent' protover key cu su bypass auth
+	withClientM (cli key cu su bypass auth) clientenv $ \case
-	withClientM cli 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

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 =
+withP2PConnection apiver st cu su bypass sec auth actionclass connaction =
-	case (getServerMode st auth, actionclass) of
+	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

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)

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.