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