1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 18:24:51 +09:00

Smart HTTP ref discovery

This commit is contained in:
fr33domlover 2016-04-22 19:46:46 +00:00
parent 8856bd2344
commit 19471d4ca2
4 changed files with 64 additions and 6 deletions

42
src/Vervis/Content.hs Normal file
View file

@ -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

View file

@ -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"
[("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

View file

@ -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

View file

@ -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