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