Git: Implement pack protocol negotiation upload-haves and ack

src/Data/Binary/Get/Local.hs

@@ -70,9 +70,15 @@ requireWord8 p = do
         then return w
         else fail "Word doesn't satisfy predicate"
 
+attemptWord8 :: (Word8 -> Bool) -> Get (Maybe Word8)
+attemptWord8 p = Just <$> requireWord8 p <|> pure Nothing
+
 requireSpace :: Get ()
 requireSpace = void $ requireWord8 (== 32)
 
+requireNewline :: Get ()
+requireNewline = void $ requireWord8 (== 10)
+
 attemptByteString :: ByteString -> Get Bool
 attemptByteString s = fmap isJust . lookAheadM $ do
     b <- getByteString $ length s

src/Network/Git/Local/Ack/Put.hs

@@ -0,0 +1,47 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.Ack.Put
+    ( putAckMulti
+    , putAck
+    , putNak
+    )
+where
+
+putAckStatus :: AckStatus -> Put
+putAckStatus AckContinue = putByteString "continue"
+putAckStatus AckCommon   = putByteString "common"
+putAckStatus AckReady    = putByteString "ready"
+
+lenAckStatus :: AckStatus -> Int
+lenAckStatus AckContinue = 8
+lenAckStatus AckCommon   = 6
+lenAckStatus AckReady    = 5
+
+putAckMulti :: ObjId -> AckStatus -> Put
+putAckMulti oid as = putDataPkt True (3 + 1 + 40 + lenAckStatus as) $ do
+    putByteString "ACK"
+    putSpace
+    putObjId oid
+    putAckStatus as
+
+putAck :: ObjId -> Put
+putAck oid = putDataPkt True (3 + 1 + 40) $ do
+    putByteString "ACK"
+    putSpace
+    putObjId oid
+
+putNak :: Put
+putNak = putDataPkt True 3 $ putByteString "NAK"

src/Network/Git/Local/Ack/Types.hs

@@ -0,0 +1,21 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.Ack.Types
+    ( AckStatus (..)
+    )
+where
+
+data AckStatus = AckContinue | AckCommon | AckReady

src/Network/Git/Local/Get.hs

@@ -41,6 +41,18 @@ getDataPkt getPayload = do
 getObjId :: Get ObjId
 getObjId = ObjId . fromHex <$> getByteString 40
 
+getTaggedObjId :: ByteString -> Get ObjId
+getTaggedObjId tag = getDataPkt $ \ len ->
+    let baselen = B.length tag + 1 + 40
+    in  if len < baselen || baselen + 1 < len
+            then fail "Tagged obj id of unexpected length"
+            else do
+                requireByteString tag
+                requireSpace
+                oid <- getObjId
+                when (len == baselen + 1) requireNewline
+                return oid
+
 getCapabilities :: Int -> Get [Capability]
 getCapabilities n = do
     getByteString n

src/Network/Git/Local/UploadHaves/Get.hs

@@ -0,0 +1,38 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.UploadHaves.Get
+    ( getUploadHaves
+    )
+where
+
+getHaves :: Get [ObjId]
+getHaves = many $ getTaggedObjId "have"
+
+requireDone :: Get ()
+requireDone = getDataPkt $ \ len ->
+    if len < 4 || len > 5
+        then fail "invalid pkt-len for a \"done\" line"
+        else do
+            requireByteString "done"
+            when (len == 5) requireNewline
+
+getUploadHaves :: Get UploadHaves
+getUploadHaves = do
+    haves <- getHaves
+    requireFlushPkt <|> requireDone
+    return UploadHaves
+        { uhHave = haves
+        }

src/Network/Git/Local/UploadHaves/Types.hs

@@ -0,0 +1,23 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.UploadHaves.Types
+    ( UploadHaves (..)
+    )
+where
+
+data UploadHaves = UploadHaves
+    { uhHave :: [ObjId]
+    }

src/Network/Git/Local/UploadRequest/Get.hs

@@ -26,20 +26,11 @@ getFirstWant = getDataPkt $ \ len -> do
     caps <- getCapabilities $ len - 45
     return (caps, oid)
 
-attemptTaggedObjId :: ByteString -> Get (Maybe ObjId)
-attemptTaggedObjId s = lookAheahM $ getDataPkt $ \ _len -> do
-    b <- getByteString $ length s
-    if b == s
-        then do
-            requireSpace
-            Just <$> getObjId
-        else return Nothing
-
 -- unfoldM is from the monad-loops package
 getWants :: Get ([Capability], [ObjId])
 getWants = do
     (caps, oid) <- getFirstWant
-    oids <- unfoldM $ attemptTaggedObjId "want"
+    oids <- many $ getTaggedObjId "want"
     return (caps, oid:oids)
 
 getShallows :: Get [ObjId]