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.
This commit is contained in:
fr33domlover 2016-07-27 13:23:44 +00:00
parent d1e1f3c0f7
commit c26fb389cf

View file

@ -22,6 +22,7 @@ where
import Prelude import Prelude
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Binary.Put
import Data.Git.Harder (ObjId (..)) import Data.Git.Harder (ObjId (..))
import Data.Git.Harder.Pack import Data.Git.Harder.Pack
import Data.Git.Repository (getCommit) import Data.Git.Repository (getCommit)
@ -32,14 +33,55 @@ import Data.Text.Encoding (encodeUtf8)
import Network.Git.Get (parseService) import Network.Git.Get (parseService)
import Network.Git.Transport.HTTP.Fetch.RefDiscovery import Network.Git.Transport.HTTP.Fetch.RefDiscovery
import Network.Git.Transport.HTTP.Fetch.UploadRequest 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 Yesod.Core.Handler
import qualified Data.ByteString as B (hGetContents)
import Vervis.BinaryBody (decodeRequestBody) import Vervis.BinaryBody (decodeRequestBody)
import Vervis.Content import Vervis.Content
import Vervis.Foundation (Handler) import Vervis.Foundation (Handler)
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Path (askRepoDir) 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 :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
getGitRefDiscoverR shar repo = do getGitRefDiscoverR shar repo = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
@ -59,6 +101,7 @@ getGitRefDiscoverR shar repo = do
Nothing -> permissionDenied "Service not supported" Nothing -> permissionDenied "Service not supported"
_ -> notFound _ -> notFound
else notFound else notFound
-}
{- This is commented out for now because it doesn't work. The 'collectObjIds' {- 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 - function file descriptor exhaustion. I don't know whether and how I can fix