From 188905f9aa9c5a5b999bdb27f077063d491c673a Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Wed, 27 Jul 2016 15:17:03 +0000
Subject: [PATCH] Git clone over HTTP(S) using git binary

---
 config/routes             |  4 ++--
 src/Vervis/Handler/Git.hs | 40 +++++++++++++++++++++++++++++++++++++--
 2 files changed, 40 insertions(+), 4 deletions(-)

diff --git a/config/routes b/config/routes
index 9c5f9f6..2629f29 100644
--- a/config/routes
+++ b/config/routes
@@ -81,8 +81,8 @@
 
 /s/#ShrIdent/r/#RpIdent/_darcs/+Texts        DarcsDownloadR        GET
 
-/s/#ShrIdent/r/#RpIdent/git/info/refs        GitRefDiscoverR       GET
---/s/#ShrIdent/r/#RpIdent/git/git-upload-pack  GitUploadRequestR POST
+/s/#ShrIdent/r/#RpIdent/info/refs            GitRefDiscoverR       GET
+/s/#ShrIdent/r/#RpIdent/git-upload-pack      GitUploadRequestR     POST
 
 /s/#ShrIdent/p                               ProjectsR             GET POST
 /s/#ShrIdent/p/!new                          ProjectNewR           GET
diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs
index 708d086..a2f021c 100644
--- a/src/Vervis/Handler/Git.hs
+++ b/src/Vervis/Handler/Git.hs
@@ -15,12 +15,13 @@
 
 module Vervis.Handler.Git
     ( getGitRefDiscoverR
-    --, postGitUploadRequestR
+    , postGitUploadRequestR
     )
 where
 
 import Prelude
 
+import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Binary.Put
 import Data.Git.Harder (ObjId (..))
@@ -34,11 +35,15 @@ import Network.Git.Get (parseService)
 import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Network.Git.Transport.HTTP.Fetch.UploadRequest
 import Network.Git.Types
+import Network.Wai (strictRequestBody)
+import System.IO (hClose)
 import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
 import Yesod.Core.Content
 import Yesod.Core.Handler
 
-import qualified Data.ByteString as B (hGetContents)
+import qualified Data.ByteString as B (null, hGetContents, hGet)
+import qualified Data.ByteString.Lazy as BL (hPut)
+import qualified Data.ByteString.Lazy.Internal as BLI (defaultChunkSize)
 
 import Vervis.BinaryBody (decodeRequestBody)
 import Vervis.Content
@@ -103,6 +108,37 @@ getGitRefDiscoverR shar repo = do
         else notFound
 -}
 
+postGitUploadRequestR :: ShrIdent -> RpIdent -> Handler TypedContent
+postGitUploadRequestR shr rp = do
+    let typ = "application/x-git-upload-pack-result"
+    path <- askRepoDir shr rp
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
+    if seemsThere
+        then do
+            getBody <- strictRequestBody <$> waiRequest
+            body <- liftIO getBody
+            let settings =
+                    ( proc "git"
+                        [ "upload-pack"
+                        , "--stateless-rpc"
+                        , path
+                        ]
+                    )
+                    { std_in  = CreatePipe
+                    , std_out = CreatePipe
+                    }
+            (Just hin, Just hout, _, _) <- liftIO $ createProcess settings
+            liftIO $ BL.hPut hin body >> hClose hin
+            setHeader "Cache-Control" "no-cache"
+            let loop = do
+                    b <- liftIO $ B.hGet hout BLI.defaultChunkSize
+                    unless (B.null b) $ do
+                        sendChunkBS b
+                        loop
+            respondSource typ loop
+        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
  - that. Maybe dive deep into what happens under the hood in 'hit', or make a