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

stack.yaml

@@ -10,12 +10,14 @@ packages:
   - '.'
   - '../../../other-work/ssh'
   - '../hit-graph'
+  - '../hit-network'
 
 # Packages to be pulled from upstream that are not in the resolver (e.g.,
 # acme-missiles-0.3)
 extra-deps:
   - highlighter2-0.2.5
   - hit-graph-0.1
+  - hit-network-0.1
   - SimpleAES-0.4.2
 #  - ssh-0.3.2
   # Required for M.alter used in hit-graph

vervis.cabal

@@ -41,6 +41,7 @@ library
                        Network.SSH.Local
                        Text.FilePath.Local
                        Vervis.Application
+                       Vervis.Content
                        Vervis.Field.Key
                        Vervis.Field.Person
                        Vervis.Field.Project
@@ -91,7 +92,6 @@ library
                      , attoparsec
                      , base
                      , base64-bytestring
-                     , binary
                      , blaze-html
                      , byteable
                      , bytestring
@@ -114,6 +114,7 @@ library
                      , highlighting-kate
                      , hit
                      , hit-graph >= 0.1
+                     , hit-network >= 0.1
                      , hjsmin
                      , hourglass
                      , http-conduit