From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 10 Jul 2024 13:13:01 +0000 (-0400)
Subject: implement serveRemove and send WWW-Authenticate header on auth failure
X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~1^2~21^2~228^2~132
X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=48f76cb3e8695c82916b4c3ac9be5339b4ce25c1;p=git-annex.git

implement serveRemove and send WWW-Authenticate header on auth failure
---

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index 1760fdc4ff..8b25cf8246 100644
--- a/Command/P2PHttp.hs
+++ b/Command/P2PHttp.hs
@@ -67,7 +67,12 @@ optParser _ = Options
 		)
 
 seek :: Options -> CommandSeek
-seek o = startConcurrency commandStages $
+seek o = startConcurrency commandStages $ do
+	-- XXX remove this
+	when (isNothing (portOption o)) $ do
+		liftIO $ putStrLn "test begins"
+		testCheckPresent
+		giveup "TEST DONE" 
 	withLocalP2PConnections $ \acquireconn -> liftIO $ do
 		authenv <- getAuthEnv
 		st <- mkP2PHttpServerState acquireconn $
diff --git a/P2P/Http.hs b/P2P/Http.hs
index 2a48c93dbf..5acf1f25f9 100644
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -21,7 +21,7 @@ module P2P.Http (
 import Annex.Common
 import P2P.Http.Types
 import P2P.Http.State
-import P2P.Protocol hiding (Offset, Bypass)
+import P2P.Protocol hiding (Offset, Bypass, auth)
 import P2P.IO
 
 import Servant
@@ -181,9 +181,8 @@ serveCheckPresent st apiver (B64Key k) cu su bypass sec auth = do
 		$ \runst conn ->
 			liftIO $ runNetProto runst conn $ checkPresent k
 	case res of
-		Right (Right b) -> return (CheckPresentResult b)
-		Right (Left err) -> throwError $ err500 { errBody = encodeBL err }
-		Left err -> throwError $ err500 { errBody = encodeBL (describeProtoFailure err) }
+		Right b -> return (CheckPresentResult b)
+		Left err -> throwError $ err500 { errBody = encodeBL err }
 
 clientCheckPresent
 	:: ClientEnv
@@ -214,6 +213,7 @@ type RemoveAPI result
 	:> ClientUUID Required
 	:> ServerUUID Required
 	:> BypassUUIDs
+	:> IsSecure
 	:> AuthHeader
 	:> Post '[JSON] result
 	
@@ -226,9 +226,18 @@ serveRemove
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
+	-> IsSecure
 	-> Maybe Auth
 	-> Handler t
-serveRemove = undefined
+serveRemove st resultmangle apiver (B64Key k) cu su bypass sec auth = do
+	res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction
+		$ \runst conn ->
+			liftIO $ runNetProto runst conn $ remove Nothing k
+	case res of
+		(Right b, plus) -> return $ resultmangle $ 
+			RemoveResultPlus b (map B64UUID (fromMaybe [] plus))
+		(Left err, _) -> throwError $
+			err500 { errBody = encodeBL err }
 
 clientRemove
 	:: ProtocolVersion
@@ -248,7 +257,7 @@ clientRemove (ProtocolVersion ver) k cu su bypass auth = case ver of
 	_ :<|> _ :<|> _ :<|> _ :<|>
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
-	
+
 type RemoveBeforeAPI
 	= KeyParam
 	:> ClientUUID Required
diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs
index da7b73469b..29d2351e25 100644
--- a/P2P/Http/State.hs
+++ b/P2P/Http/State.hs
@@ -8,6 +8,7 @@
  -}
 
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module P2P.Http.State where
 
@@ -49,7 +50,7 @@ withP2PConnection
 	-> IsSecure
 	-> Maybe Auth
 	-> ActionClass
-	-> (RunState -> P2PConnection -> Handler a)
+	-> (RunState -> P2PConnection -> Handler (Either ProtoFailure a))
 	-> Handler a
 withP2PConnection apiver st cu su bypass sec auth actionclass connaction =
 	case (getServerMode st sec auth, actionclass) of
@@ -58,7 +59,7 @@ withP2PConnection apiver st cu su bypass sec auth actionclass connaction =
 		(Just P2P.ServeAppendOnly, _) -> go P2P.ServeAppendOnly
 		(Just P2P.ServeReadOnly, ReadAction) -> go P2P.ServeReadOnly
 		(Just P2P.ServeReadOnly, _) -> throwError err403
-		(Nothing, _) -> throwError err401
+		(Nothing, _) -> throwError basicAuthRequired
   where
 	go servermode = liftIO (acquireP2PConnection st cp) >>= \case
 		Left (ConnectionFailed err) -> 
@@ -66,7 +67,7 @@ withP2PConnection apiver st cu su bypass sec auth actionclass connaction =
 		Left TooManyConnections ->
 			throwError err503
 		Right (runst, conn, releaseconn) ->
-			connaction runst conn
+			connaction' runst conn
 				`finally` liftIO releaseconn
 	  where
 		cp = ConnectionParams
@@ -76,6 +77,17 @@ withP2PConnection apiver st cu su bypass sec auth actionclass connaction =
 			, connectionBypass = map fromB64UUID bypass
 			, connectionServerMode = servermode
 			}
+	
+	connaction' runst conn = connaction runst conn >>= \case
+		Right r -> return r
+		Left err -> throwError $
+			err500 { errBody = encodeBL (describeProtoFailure err) }
+
+basicAuthRequired :: ServerError
+basicAuthRequired = err401 { errHeaders = [(h, v)] }
+  where
+	h = "WWW-Authenticate"
+	v = "Basic realm=\"git-annex\", charset=\"UTF-8\""
 
 -- Nothing when the server is not allowed to serve any requests.
 type GetServerMode = IsSecure -> Maybe Auth -> Maybe P2P.ServerMode
diff --git a/doc/design/p2p_protocol_over_http/draft1.mdwn b/doc/design/p2p_protocol_over_http/draft1.mdwn
index 41332d2f46..891684c769 100644
--- a/doc/design/p2p_protocol_over_http/draft1.mdwn
+++ b/doc/design/p2p_protocol_over_http/draft1.mdwn
@@ -24,7 +24,7 @@ configuration of the HTTP server. When a request needs authentication,
 it will fail with 401 Unauthorized.
 
 Authentication is done using HTTP basic auth. The realm to use when
-authenticating is "git-annex".
+authenticating is "git-annex". The charset is UTF-8.
 
 When authentication is successful but does not allow a request to be
 performed, it will fail with 403 Forbidden.