From 19471d4ca29d96d1c84901243f42d57531ebdf31 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Fri, 22 Apr 2016 19:46:46 +0000
Subject: [PATCH] Smart HTTP ref discovery

---
 src/Vervis/Content.hs     | 42 +++++++++++++++++++++++++++++++++++++++
 src/Vervis/Handler/Git.hs | 23 ++++++++++++++++-----
 stack.yaml                |  2 ++
 vervis.cabal              |  3 ++-
 4 files changed, 64 insertions(+), 6 deletions(-)
 create mode 100644 src/Vervis/Content.hs

diff --git a/src/Vervis/Content.hs b/src/Vervis/Content.hs
new file mode 100644
index 0000000..229c6b8
--- /dev/null
+++ b/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
diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs
index b664cd3..6103faa 100644
--- a/src/Vervis/Handler/Git.hs
+++ b/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
diff --git a/stack.yaml b/stack.yaml
index 4f6a40d..44f14e1 100644
--- a/stack.yaml
+++ b/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
diff --git a/vervis.cabal b/vervis.cabal
index 64375c2..5424202 100644
--- a/vervis.cabal
+++ b/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