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 . + - + - ♡ 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 + - . + -} + +-- | 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