implement serveRemove and send WWW-Authenticate header on auth failure

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index 1760fdc4ffc780f53d1e1eb5f7bce344a0e53646..8b25cf824674bb2fc8bb1fb4c48dde270b131cb8 100644 (file)
--- 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 2a48c93dbf028206fc385f2f9095ee56f7f7b2d3..5acf1f25f90d5748bbfa75371ed547cd7c30e6a6 100644 (file)
--- 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 da7b73469bca3070206a35eb134967ed95b8e31c..29d2351e2588ae1c5f487ac694c73bb87e0f89c3 100644 (file)
--- 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 41332d2f461f3307f38390b2c0b1a4200b23ffb1..891684c7698e21f353793099d104ce4337a87e66 100644 (file)
--- 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.