From 4649625f0421a707aa344ee3253b2eb7dfe5c93e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Aug 2018 18:08:54 -0400 Subject: [PATCH] small improvement to packet flushing --- Git/Protocol/LongRunningProcess.hs | 11 +++++++---- Git/Protocol/PktLine.hs | 5 +++++ 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/Git/Protocol/LongRunningProcess.hs b/Git/Protocol/LongRunningProcess.hs index 27f02da665..26097acbef 100644 --- a/Git/Protocol/LongRunningProcess.hs +++ b/Git/Protocol/LongRunningProcess.hs @@ -79,7 +79,8 @@ handshake selectrole selectcapability input output = case selectrole role of Left e -> return (Left e) Right myrole -> sendpkt rolePkt myrole $ - sendpkt versionPkt (Version "2") $ + sendpkt versionPkt (Version "2") $ do + hFlush output exchangecaps $ \mycaps -> return $ Right (myrole, mycaps) where @@ -87,13 +88,15 @@ handshake selectrole selectcapability input output = sendpkt f v cnt = case f v of Just pkt -> do - hPutBuilder output $ encodePktLine pkt - hFlush output + writePktLine output pkt cnt Nothing -> return $ Left $ "failed constructing pkt-line packet for: " ++ show v - sendpkts _ [] cnt = sendpkt Just flushPkt cnt + sendpkts _ [] cnt = do + writePktLine output flushPkt + hFlush output + cnt sendpkts f (v:vs) cnt = sendpkt f v $ sendpkts f vs cnt getpkt parser cnt = readPktLine input >>= \case diff --git a/Git/Protocol/PktLine.hs b/Git/Protocol/PktLine.hs index a7e591b70e..5ec4777727 100644 --- a/Git/Protocol/PktLine.hs +++ b/Git/Protocol/PktLine.hs @@ -19,6 +19,7 @@ module Git.Protocol.PktLine ( decodePktLine, splitPktLine, readPktLine, + writePktLine, ) where import qualified Data.ByteString as S @@ -156,3 +157,7 @@ readPktLine h = do body <- S.hGet h (len - 4) let parser = parsePktLine' len <* endOfInput return $ Just $ parseOnly parser body + +-- | Sends a packet to the Handle. Does not flush the Handle. +writePktLine :: Handle -> PktLine -> IO () +writePktLine h = hPutBuilder h . encodePktLine