serveGet invalidation

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index 2f5eb11114770f099e916ff9e5368f1abf74021d..b3924d74bee4b98b3fbaf91de49b7a3d80d39650 100644 (file)
--- a/Command/P2PHttp.hs
+++ b/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

diff --git a/P2P/Http.hs b/P2P/Http.hs
index fb93f23098358db8f57badcc3c332f1859fda4b9..2a9e0ecb5e65cbe70d27eae80d8a9447431c4911 100644 (file)
--- a/P2P/Http.hs
+++ b/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
                        )
        

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index c1d16bb339872c72d1a84b433a87461d3de15e40..047759c2e845fd4b9af0fcc08d7e3615601a39e9 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/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.