Send raw pack as git-upload-pack-result

src/Vervis/Content.hs

@@ -28,6 +28,8 @@ import Network.Git.Put (serializeService)
 import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Yesod.Core.Content
 
+import qualified Data.ByteString.Lazy as BL (ByteString)
+
 newtype GitRefDiscovery = GitRefDiscovery { unGRD :: RefDiscover }
 
 instance ToContent GitRefDiscovery where
@@ -40,7 +42,7 @@ instance ToTypedContent GitRefDiscovery where
             c = toContent grd
         in  TypedContent t c
 
-newtype GitUploadPackResult = GitUploadPackResult { unGUPR :: () }
+newtype GitUploadPackResult = GitUploadPackResult { unGUPR :: BL.ByteString }
 
 instance ToContent GitUploadPackResult where
     toContent = toContent . unGUPR

src/Vervis/Handler/Git.hs

@@ -22,6 +22,9 @@ where
 import Prelude
 
 import Control.Monad.IO.Class (liftIO)
+import Data.Git.Harder (ObjId (..))
+import Data.Git.Harder.Pack
+import Data.Git.Repository (getCommit)
 import Data.Git.Storage (isRepo, withRepo)
 import Data.String (fromString)
 import Data.Text (Text)
@@ -66,5 +69,29 @@ postGitUploadRequestR sharer repo = do
             ereq <- decodeRequestBody getUploadRequest
             case ereq of
                 Left _   -> invalidArgs ["UploadRequest"]
-                Right ur -> return $ GitUploadPackResult ()
+                Right ur -> do
+                    -- We need to handle /have/ lines and verify the /want/ed
+                    -- refs appear in the ref discovery we sent. But we for now
+                    -- ignore these things. Suppose the client didn't send an
+                    -- /have/s, what's next? It seems we now need to build and
+                    -- send a pack.
+                    --
+                    -- We just send a full pack with all the ancestors of the
+                    -- wants.
+                    --
+                    -- IDEA: abstract away the HTTP request part by:
+                    --
+                    -- (1) Read the request body in chunks and use Get to read
+                    -- (2) Use a Put to create the response, possibly send in
+                    -- chunks, or instead first make LBS and then send?
+
+                    -- TODO currently the code assumes all of these are commits
+                    -- but they can also be tags (are there other options?)
+                    let oids = urWants ur
+                    lbs <- liftIO $ withRepo pathG $ \ git -> do
+                        let getC oid = (oid,) <$> getCommit git (unObjId oid)
+                        pairs <- traverse getC oids
+                        oidset <- collectObjIds git pairs
+                        serializePack git oidset
+                    return $ GitUploadPackResult lbs
         else notFound

stack.yaml

@@ -10,6 +10,7 @@ packages:
   - '.'
   - '../../../other-work/ssh'
   - '../hit-graph'
+  - '../hit-harder'
   - '../hit-network'
 
 # Packages to be pulled from upstream that are not in the resolver (e.g.,
@@ -17,7 +18,9 @@ packages:
 extra-deps:
   - highlighter2-0.2.5
   - hit-graph-0.1
+  - hit-harder-0.1
   - hit-network-0.1
+  - monad-hash-0.1
   - SimpleAES-0.4.2
 #  - ssh-0.3.2
   # Required for M.alter used in hit-graph

vervis.cabal

@@ -118,6 +118,7 @@ library
                      , highlighting-kate
                      , hit
                      , hit-graph >= 0.1
+                     , hit-harder >= 0.1
                      , hit-network >= 0.1
                      , hjsmin
                      , hourglass