Remote.Git retrieveKeyFile works with annex+http urls

This includes a bugfix to serveGet, it hung at the end.

P2P/Http/Client.hs

@@ -11,7 +11,10 @@
 {-# LANGUAGE DataKinds, TypeApplications #-}
 {-# LANGUAGE CPP #-}
 
-module P2P.Http.Client where
+module P2P.Http.Client (
+	module P2P.Http.Client,
+	Validity(..),
+) where
 
 import Types
 import Annex.Url
@@ -25,7 +28,9 @@ import P2P.Http.Url
 import Annex.Common
 import P2P.Protocol hiding (Offset, Bypass, auth)
 import Annex.Concurrent
+import Annex.Verify
 import Utility.Url (BasicAuth(..))
+import Utility.Metered
 import qualified Git.Credential as Git
 
 import Servant hiding (BasicAuthData(..))
@@ -140,42 +145,33 @@ runP2PHttpClient rmt fallback () = fallback
 
 #ifdef WITH_SERVANT
 clientGet
-	:: ClientEnv
-	-> ProtocolVersion
-	-> B64Key
-	-> B64UUID ServerSide
-	-> B64UUID ClientSide
-	-> [B64UUID Bypass]
-	-> Maybe B64FilePath
-	-> Maybe Auth
+	:: MeterUpdate
+	-> Maybe IncrementalVerifier
+	-> Key
+	-> AssociatedFile
 	-> RawFilePath
-	-> IO Validity
-clientGet clientenv (ProtocolVersion ver) k su cu bypass af auth dest = do
+	-> ClientAction Validity
+clientGet meterupdate iv k af dest clientenv (ProtocolVersion ver) su cu bypass auth = liftIO $ do
 	startsz <- tryWhenExists $ getFileSize dest
-	let mo = fmap (Offset . fromIntegral) startsz
-	withClientM (cli k cu bypass af mo auth) clientenv $ \case
-		Left err -> throwM err
-		Right respheaders -> do
-			b <- S.unSourceT (getResponse respheaders) gather
-			liftIO $ withBinaryFile (fromRawFilePath dest) WriteMode $ \h -> do
-				case startsz of
-					Just startsz' | startsz' /= 0 ->
-						hSeek h AbsoluteSeek startsz'
-					_ -> noop
-				len <- go 0 h (L.toChunks b)
+	let offset = fmap (Offset . fromIntegral) startsz
+	withClientM (cli (B64Key k) cu bypass baf offset auth) clientenv $ \case
+		Left err -> return (Left err)
+		Right respheaders ->
+			withBinaryFile (fromRawFilePath dest) ReadWriteMode $ \h -> do
+				meterupdate' <- case startsz of
+					Just startsz' ->
+						resumeVerifyFromOffset startsz' iv meterupdate h 
+					_ -> return meterupdate
+				b <- S.unSourceT (getResponse respheaders) gather
+				BytesProcessed len <- meteredWrite'
+					meterupdate'
+					(writeVerifyChunk iv h) b
 				let DataLength dl = case lookupResponseHeader @DataLengthHeader' respheaders of
 					Header hdr -> hdr
 					_ -> error "missing data length header"
-				if dl == len
-					then return Valid
-					else return Invalid
+				return $ Right $ 
+					if dl == len then Valid else Invalid
   where
-	go n _ [] = return n
-	go n h (b:bs) = do
-		let !n' = n + fromIntegral (B.length b)
-		B.hPut h b
-		go n' h bs
-
 	cli =case ver of
 		3 -> v3 su V3
 		2 -> v2 su V2
@@ -191,6 +187,10 @@ clientGet clientenv (ProtocolVersion ver) k su cu bypass af auth dest = do
 	gather' (S.Skip s) = gather' s
 	gather' (S.Effect ms) = ms >>= gather'
 	gather' (S.Yield v s) = LI.Chunk v <$> unsafeInterleaveIO (gather' s)
+	
+	baf = associatedFileToB64FilePath af
+#else
+clientGet _ _ _ = ()
 #endif
 
 clientCheckPresent :: Key -> ClientAction Bool

P2P/Http/Server.hs

@@ -175,6 +175,7 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
 				validity <- atomically $ takeTMVar validityv
 				sz <- takeMVar szv
 				atomically $ putTMVar finalv ()
+				atomically $ putTMVar endv ()
 				return $ case validity of
 					Nothing -> True
 					Just Valid -> True
@@ -198,11 +199,9 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
 		Just (Offset o) -> fromIntegral o
 		Nothing -> 0
 	
-	getreq offset = P2P.Protocol.GET offset (ProtoAssociatedFile af) k
+	getreq offset = P2P.Protocol.GET offset af k
 	
-	af = AssociatedFile $ case baf of
-		Just (B64FilePath f) -> Just f
-		Nothing -> Nothing
+	af = ProtoAssociatedFile $ b64FilePathToAssociatedFile baf
 
 serveCheckPresent
 	:: APIVersion v
@@ -345,9 +344,7 @@ servePut st resultmangle su apiver (DataLength len) (B64Key k) cu bypass baf mof
 		Just (Offset o) -> o
 		Nothing -> 0
 
-	af = AssociatedFile $ case baf of
-		Just (B64FilePath f) -> Just f
-		Nothing -> Nothing
+	af = b64FilePathToAssociatedFile baf
 
 	-- Streams the ByteString from the client. Avoids returning a longer
 	-- than expected ByteString by truncating to the expected length. 

P2P/Http/Types.hs

@@ -50,6 +50,14 @@ newtype B64Key = B64Key Key
 newtype B64FilePath = B64FilePath RawFilePath
 	deriving (Show)
 
+associatedFileToB64FilePath :: AssociatedFile -> Maybe B64FilePath
+associatedFileToB64FilePath (AssociatedFile Nothing) = Nothing
+associatedFileToB64FilePath (AssociatedFile (Just f)) = Just (B64FilePath f)
+
+b64FilePathToAssociatedFile :: Maybe B64FilePath -> AssociatedFile
+b64FilePathToAssociatedFile Nothing = AssociatedFile Nothing
+b64FilePathToAssociatedFile (Just (B64FilePath f)) = AssociatedFile (Just f)
+
 newtype B64UUID t = B64UUID { fromB64UUID :: UUID }
 	deriving (Show, Ord, Eq, Generic, NFData)