Git upload-pack request handler, parses it but returns nothing

src/Vervis/Content.hs

@@ -16,27 +16,35 @@
 -- | Custom HTTP response content types.
 module Vervis.Content
     ( GitRefDiscovery (..)
+    , GitUploadPackResult (..)
     )
 where
 
 import Prelude
 
+import Data.ByteString (ByteString)
 import Data.Monoid ((<>))
+import Network.Git.Put (serializeService)
+import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Yesod.Core.Content
 
-import qualified Data.ByteString as B
+newtype GitRefDiscovery = GitRefDiscovery { unGRD :: RefDiscover }
-import qualified Data.ByteString.Lazy as BL
-
-data GitRefDiscovery = GitRefDiscovery
-    { grdContent :: BL.ByteString
-    , grdService :: B.ByteString
-    }
 
 instance ToContent GitRefDiscovery where
-    toContent (GitRefDiscovery c _) = toContent c
+    toContent = toContent . serializeRefDiscover . unGRD
 
 instance ToTypedContent GitRefDiscovery where
-    toTypedContent grd@(GitRefDiscovery _ s) =
+    toTypedContent grd =
-        let t = "application/x-" <> s <> "-advertisement"
+        let serv = rdService $ unGRD grd
+            t = "application/x-" <> serializeService serv <> "-advertisement"
             c = toContent grd
         in  TypedContent t c
+
+newtype GitUploadPackResult = GitUploadPackResult { unGUPR :: () }
+
+instance ToContent GitUploadPackResult where
+    toContent = toContent . unGUPR
+
+instance ToTypedContent GitUploadPackResult where
+    toTypedContent gupr =
+        TypedContent "application/x-git-upload-pack-result" (toContent gupr)

src/Vervis/Handler/Git.hs

@@ -25,10 +25,14 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Git.Storage (isRepo, withRepo)
 import Data.String (fromString)
 import Data.Text (Text)
+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 Yesod.Core.Handler
 
-import Vervis.Content (GitRefDiscovery (..))
+import Vervis.BinaryBody (decodeRequestBody)
+import Vervis.Content
 import Vervis.Foundation (Handler)
 import Vervis.Path (askRepoDir)
 
@@ -41,19 +45,26 @@ getGitRefDiscoverR sharer repo = do
         then do
             rq <- getRequest
             case reqGetParams rq of
-                [("service", serv)] ->
+                [("service", servT)] ->
-                    if serv == "git-upload-pack"
+                    case parseService $ encodeUtf8 servT of
-                        then do
+                        Just serv -> do
                             rd <- liftIO $ withRepo pathG $
-                                flip buildRefDiscover' "git-upload-pack"
+                                flip buildRefDiscover' serv
                             setHeader "Cache-Control" "no-cache"
-                            return GitRefDiscovery
+                            return $ GitRefDiscovery rd
-                                { grdContent = serializeRefDiscover rd
+                        Nothing -> permissionDenied "Service not supported"
-                                , grdService = "git-upload-pack"
-                                }
-                        else permissionDenied "Service not supported"
                 _ -> notFound
         else notFound
 
-postGitUploadRequestR :: Text -> Text -> Handler Text
+postGitUploadRequestR :: Text -> Text -> Handler GitUploadPackResult
-postGitUploadRequestR sharer repo = notFound
+postGitUploadRequestR sharer repo = do
+    path <- askRepoDir sharer repo
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
+    if seemsThere
+        then do
+            ereq <- decodeRequestBody getUploadRequest
+            case ereq of
+                Left _   -> invalidArgs ["UploadRequest"]
+                Right ur -> return $ GitUploadPackResult ()
+        else notFound