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:
parent
8856bd2344
commit
19471d4ca2
4 changed files with 64 additions and 6 deletions
42
src/Vervis/Content.hs
Normal file
42
src/Vervis/Content.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue