make serveKeepLocked check auth just to be safe

Command/P2PHttp.hs

@@ -138,7 +138,8 @@ testKeepLocked = do
 		(B64UUID (toUUID ("lck" :: String)))
 		(B64UUID (toUUID ("cu" :: String)))
 		(B64UUID (toUUID ("su" :: String)))
-		[] $ \keeplocked -> do
+		[] 
+		Nothing $ \keeplocked -> do
 			print "running, press enter to drop lock"
 			_ <- getLine
 			atomically $ writeTMVar keeplocked False

P2P/Http.hs

@@ -832,7 +832,7 @@ serveLockContent st su apiver (B64Key k) cu bypass sec auth = do
 			_ -> return Nothing
 	let unlock (annexworker, unlockv) = do
 		atomically $ putTMVar unlockv ()
-		wait annexworker
+		void $ wait annexworker
 		releaseP2PConnection conn
 	liftIO $ mkLocker lock unlock >>= \case
 		Just (locker, lockid) -> do
@@ -874,6 +874,8 @@ type KeepLockedAPI
 	= LockIDParam
 	:> CU Required
 	:> BypassUUIDs
+	:> IsSecure
+	:> AuthHeader
 	:> Header "Connection" ConnectionKeepAlive
 	:> Header "Keep-Alive" KeepAlive
 	:> StreamBody NewlineFraming JSON (SourceIO UnlockRequest)
@@ -887,13 +889,16 @@ serveKeepLocked
 	-> LockID
 	-> B64UUID ClientSide
 	-> [B64UUID Bypass]
+	-> IsSecure
+	-> Maybe Auth
 	-> Maybe ConnectionKeepAlive
 	-> Maybe KeepAlive
 	-> S.SourceT IO UnlockRequest
 	-> Handler LockResult
-serveKeepLocked st su apiver lckid cu _ _ _ unlockrequeststream = do
+serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do
-	_ <- liftIO $ S.unSourceT unlockrequeststream go
+	checkAuthActionClass st sec auth WriteAction $ \_ -> do
-	return (LockResult False Nothing)
+		_ <- liftIO $ S.unSourceT unlockrequeststream go
+		return (LockResult False Nothing)
   where
 	go S.Stop = dropLock lckid st
 	go (S.Error _err) = dropLock lckid st
@@ -909,15 +914,16 @@ clientKeepLocked
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
+	-> Maybe Auth
 	-> (TMVar Bool -> IO ())
 	-- ^ The TMVar can be filled any number of times with True to send
 	-- repeated keep locked requests, eg to keep a connection alive.
 	-- Once filled with False, the lock will be dropped.
 	-> IO ()
-clientKeepLocked clientenv (ProtocolVersion ver) lckid cu su bypass a = do
+clientKeepLocked clientenv (ProtocolVersion ver) lckid cu su bypass auth a = do
 	keeplocked <- newEmptyTMVarIO
 	tid <- async $ a keeplocked
-	let cli' = cli lckid cu bypass
+	let cli' = cli lckid cu bypass auth
 		(Just connectionKeepAlive) (Just keepAlive)
 		(S.fromStepT (unlocksender keeplocked))
 	withClientM cli' clientenv $ \case

P2P/Http/State.hs

@@ -104,13 +104,7 @@ getP2PConnection
 	-> (ConnectionParams -> ConnectionParams)
 	-> Handler P2PConnectionPair
 getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams =
-	case (getServerMode st sec auth, actionclass) of
+	checkAuthActionClass st sec auth actionclass go
-		(Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite
-		(Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403
-		(Just P2P.ServeAppendOnly, _) -> go P2P.ServeAppendOnly
-		(Just P2P.ServeReadOnly, ReadAction) -> go P2P.ServeReadOnly
-		(Just P2P.ServeReadOnly, _) -> throwError err403
-		(Nothing, _) -> throwError basicAuthRequired
   where
 	go servermode = liftIO (acquireP2PConnection st cp) >>= \case
 		Left (ConnectionFailed err) -> 
@@ -128,6 +122,22 @@ getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams =
 			, connectionWaitVar = True
 			}
 
+checkAuthActionClass
+	:: P2PHttpServerState
+	-> IsSecure
+	-> Maybe Auth
+	-> ActionClass
+	-> (P2P.ServerMode -> Handler a)
+	-> Handler a
+checkAuthActionClass st sec auth actionclass go =
+	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
+		(Just P2P.ServeReadOnly, ReadAction) -> go P2P.ServeReadOnly
+		(Just P2P.ServeReadOnly, _) -> throwError err403
+		(Nothing, _) -> throwError basicAuthRequired
+
 basicAuthRequired :: ServerError
 basicAuthRequired = err401 { errHeaders = [(h, v)] }
   where

doc/design/p2p_protocol_over_http/draft1.mdwn

@@ -234,6 +234,9 @@ If the connection is closed before the client sends `{"unlock": true},
 or even if the web server gets shut down, the content will remain
 locked for 10 minutes from the time it was first locked.
 
+Note that the common parameters bypass and clientuuid, while
+accepted, have no effect.
+
 ### POST /git-annex/$uuid/v2/keeplocked
 
 Identical to v3.

doc/todo/git-annex_proxies.mdwn

@@ -32,9 +32,6 @@ Planned schedule of work:
 
 * A Locker should expire the lock on its own after 10 minutes initially.
 
-* serveKeepLocked should check auth just to be safe, although added
-  security is probably minimal.
-
 * Make Remote.Git use http client when remote.name.annex-url is configured.
 
 * Make http server support proxies and clusters.