serveGet invalidation

Command/P2PHttp.hs

@@ -164,8 +164,8 @@ testGet = do
 	res <- liftIO $ clientGet (mkClientEnv mgr burl)
 		(P2P.ProtocolVersion 3)
 		(B64Key (fromJust $ deserializeKey ("SHA256E-s1048576000--e3b67ce72aa2571c799d6419e3e36828461ac1c78f8ef300c7f9c8ae671c517f" :: String)))
-		(B64UUID (toUUID ("cu" :: String)))
 		(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
+		(B64UUID (toUUID ("cu" :: String)))
 		[]
 		Nothing
 		Nothing

P2P/Http.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
 
 module P2P.Http (
 	module P2P.Http,
@@ -188,38 +189,45 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
 	void $ liftIO $ forkIO $ waitfinal endv finalv conn annexworker
 	(Len len, bs) <- liftIO $ atomically $ takeTMVar bsv
 	bv <- liftIO $ newMVar (L.toChunks bs)
+	szv <- liftIO $ newMVar 0
 	let streamer = S.SourceT $ \s -> s =<< return 
-		(stream (bv, endv, validityv, finalv))
+		(stream (bv, szv, len, endv, validityv, finalv))
  	return $ addHeader len streamer
   where
-	stream (bv, endv, validityv, finalv) =
+	stream (bv, szv, len, endv, validityv, finalv) =
 		S.fromActionStep B.null $
-			modifyMVar bv $ nextchunk $
-				checkvalidity (endv, validityv, finalv)
+			modifyMVar bv $ nextchunk szv $
+				checkvalidity szv len endv validityv finalv
 	
-	nextchunk atend (b:bs)
-		| not (B.null b) = return (bs, b)
-		| otherwise = nextchunk atend bs
-	nextchunk atend [] = do
+	nextchunk szv atend (b:bs)
+		| not (B.null b) = do
+			modifyMVar szv $ \sz ->
+				let !sz' = sz + fromIntegral (B.length b)
+				in return (sz', ())
+			return (bs, b)
+		| otherwise = nextchunk szv atend bs
+	nextchunk _szv atend [] = do
 		endbit <- atend
 		return ([], endbit)
 
-	checkvalidity (endv, validityv, finalv) =
+	checkvalidity szv len endv validityv finalv =
 		ifM (atomically $ isEmptyTMVar endv)
 			( do
 				atomically $ putTMVar endv ()
 				validity <- atomically $ takeTMVar validityv
+				sz <- takeMVar szv
 				atomically $ putTMVar finalv ()
 				-- When the key's content is invalid,
 				-- indicate that to the client by padding
-				-- the response, so it is not the same
-				-- length indicated by the DataLengthHeader.
+				-- the response if necessary, so it is not
+				-- the same length indicated by the
+				-- DataLengthHeader.
 				return $ case validity of
 					Nothing -> mempty
 					Just Valid -> mempty
-					Just Invalid -> "XXXXXXX"
-					-- FIXME: need to count bytes and emit
-					-- something to make it invalid
+					Just Invalid
+						| sz == len -> "X"
+						| otherwise -> mempty
 			, pure mempty
 			)
 	

doc/todo/git-annex_proxies.mdwn

@@ -31,8 +31,6 @@ Planned schedule of work:
 * http server and client are working, remaining 
   server API endpoints need wiring up and testing. 
 
-* serveGet needs to handle invalidation
-
 * I have a file `servant.hs` in the httpproto branch that works through some
   of the bytestring streaming issues.