From c26fb389cfc7481589c4dc21baeb8a90946a9006 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Wed, 27 Jul 2016 13:23:44 +0000
Subject: [PATCH] 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 | 43 +++++++++++++++++++++++++++++++++++++++
1 file changed, 43 insertions(+)
diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs
index 9dae75b..708d086 100644
--- a/src/Vervis/Handler/Git.hs
+++ b/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