diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index 2f5eb11114..b3924d74be 100644 --- 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 fb93f23098..2a9e0ecb5e 100644 --- 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 c1d16bb339..047759c2e8 100644 --- 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.