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