Reimplement git ref discovery using git binary :-/

My implementation in Haskell does work, but ref discovery also includes
capabilities. Since I'm going to use the git binary for the next steps,
I need the git binary to specify here which capabilities it supports.

src/Vervis/Handler/Git.hs

@@ -22,6 +22,7 @@ where
 import Prelude
 
 import Control.Monad.IO.Class (liftIO)
+import Data.Binary.Put
 import Data.Git.Harder (ObjId (..))
 import Data.Git.Harder.Pack
 import Data.Git.Repository (getCommit)
@@ -32,14 +33,55 @@ import Data.Text.Encoding (encodeUtf8)
 import Network.Git.Get (parseService)
 import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Network.Git.Transport.HTTP.Fetch.UploadRequest
+import Network.Git.Types
+import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
+import Yesod.Core.Content
 import Yesod.Core.Handler
 
+import qualified Data.ByteString as B (hGetContents)
+
 import Vervis.BinaryBody (decodeRequestBody)
 import Vervis.Content
 import Vervis.Foundation (Handler)
 import Vervis.Model.Ident
 import Vervis.Path (askRepoDir)
 
+getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler TypedContent
+getGitRefDiscoverR shr rp = do
+    let typ = "application/x-git-upload-pack-advertisement"
+    path <- askRepoDir shr rp
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
+    if seemsThere
+        then do
+            rq <- getRequest
+            case reqGetParams rq of
+                [("service", serv)] ->
+                    if serv == "git-upload-pack"
+                        then do
+                            let settings =
+                                    ( proc "git"
+                                        [ "upload-pack"
+                                        , "--stateless-rpc"
+                                        , "--advertise-refs"
+                                        , path
+                                        ]
+                                    )
+                                    { std_out = CreatePipe
+                                    }
+                            (_, Just h, _, _) <-
+                                liftIO $ createProcess settings
+                            refs <- liftIO $ B.hGetContents h
+                            let content = runPut $ do
+                                    putService UploadPack
+                                    putByteString refs
+                            setHeader "Cache-Control" "no-cache"
+                            return $ TypedContent typ $ toContent content
+                        else permissionDenied "Service not supported"
+                _ -> notFound
+        else notFound
+
+{-
 getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
 getGitRefDiscoverR shar repo = do
     path <- askRepoDir shar repo
@@ -59,6 +101,7 @@ getGitRefDiscoverR shar repo = do
                         Nothing -> permissionDenied "Service not supported"
                 _ -> notFound
         else notFound
+-}
 
 {- This is commented out for now because it doesn't work. The 'collectObjIds'
  - function file descriptor exhaustion. I don't know whether and how I can fix