Smart HTTP ref discovery

src/Vervis/Content.hs

@@ -0,0 +1,42 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Custom HTTP response content types.
+module Vervis.Content
+    ( GitRefDiscovery (..)
+    )
+where
+
+import Prelude
+
+import Data.Monoid ((<>))
+import Yesod.Core.Content
+
+import qualified Data.ByteString as B
+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
+
+instance ToTypedContent GitRefDiscovery where
+    toTypedContent grd@(GitRefDiscovery _ s) =
+        let t = "application/x-" <> s <> "-advertisement"
+            c = toContent grd
+        in  TypedContent t c

src/Vervis/Handler/Git.hs

@@ -21,22 +21,35 @@ where
 import Prelude
 
 import Control.Monad.IO.Class (liftIO)
-import Data.Git.Storage (isRepo)
+import Data.Git.Storage (isRepo, withRepo)
 import Data.String (fromString)
 import Data.Text (Text)
+import Network.Git.Fetch.RefDiscovery
 import Yesod.Core.Handler
 
+import Vervis.Content (GitRefDiscovery (..))
 import Vervis.Foundation (Handler)
 import Vervis.Path (askRepoDir)
 
-getGitRefDiscoverR :: Text -> Text -> Handler Text
+getGitRefDiscoverR :: Text -> Text -> Handler GitRefDiscovery
 getGitRefDiscoverR sharer repo = do
     path <- askRepoDir sharer repo
-    seemsThere <- liftIO $ isRepo $ fromString path
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
     if seemsThere
         then do
             rq <- getRequest
             case reqGetParams rq of
-                [("service", _)] -> permissionDenied "Service not supported"
-                _                -> notFound
+                [("service", serv)] ->
+                    if serv == "git-upload-pack"
+                        then do
+                            rd <- liftIO $ withRepo pathG $
+                                flip buildRefDiscover' $ Just "git-upload-pack"
+                            setHeader "Cache-Control" "no-cache"
+                            return GitRefDiscovery
+                                { grdContent = serializeRefDiscover rd
+                                , grdService = "git-upload-pack"
+                                }
+                        else permissionDenied "Service not supported"
+                _ -> notFound
         else notFound