Git over HTTP: Add initial always-denying ref discovery handler

This commit is contained in:
fr33domlover 2016-04-21 00:32:22 +00:00
parent 4c3371beda
commit 8856bd2344
4 changed files with 65 additions and 19 deletions

View file

@ -16,39 +16,41 @@
-- Yesod misc
-- ----------------------------------------------------------------------------
/static StaticR Static appStatic
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/static StaticR Static appStatic
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
-- ----------------------------------------------------------------------------
-- User login
-- ----------------------------------------------------------------------------
/auth AuthR Auth getAuth
/auth AuthR Auth getAuth
-- ----------------------------------------------------------------------------
-- Everything else...
-- ----------------------------------------------------------------------------
/ HomeR GET
/ HomeR GET
/u PeopleR GET POST
/u/!new PersonNewR GET
/u/#Text PersonR GET
/u PeopleR GET POST
/u/!new PersonNewR GET
/u/#Text PersonR GET
/u/#Text/k KeysR GET POST
/u/#Text/k/!new KeyNewR GET
/u/#Text/k/#Text KeyR GET
/u/#Text/k KeysR GET POST
/u/#Text/k/!new KeyNewR GET
/u/#Text/k/#Text KeyR GET
/u/#Text/p ProjectsR GET POST
/u/#Text/p/!new ProjectNewR GET
/u/#Text/p/#Text ProjectR GET
/u/#Text/p ProjectsR GET POST
/u/#Text/p/!new ProjectNewR GET
/u/#Text/p/#Text ProjectR GET
/u/#Text/r ReposR GET POST
/u/#Text/r/!new RepoNewR GET
/u/#Text/r/#Text RepoR GET
/u/#Text/r/#Text/s/#Text/+Texts RepoSourceR GET
/u/#Text/r/#Text/c RepoCommitsR GET
/u/#Text/r ReposR GET POST
/u/#Text/r/!new RepoNewR GET
/u/#Text/r/#Text RepoR GET
/u/#Text/r/#Text/s/#Text/+Texts RepoSourceR GET
/u/#Text/r/#Text/c RepoCommitsR GET
/u/#Text/r/#Text/git/info/refs GitRefDiscoverR GET
-- /u/#Text/p/#Text/t TicketsR GET
-- /u/#Text/p/#Text/t/#TicketId TicketR GET

View file

@ -52,6 +52,7 @@ import Yesod.Default.Main (LogFunc)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Vervis.Handler.Common
import Vervis.Handler.Git
import Vervis.Handler.Home
import Vervis.Handler.Key
import Vervis.Handler.Person

42
src/Vervis/Handler/Git.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/>.
-}
module Vervis.Handler.Git
( getGitRefDiscoverR
)
where
import Prelude
import Control.Monad.IO.Class (liftIO)
import Data.Git.Storage (isRepo)
import Data.String (fromString)
import Data.Text (Text)
import Yesod.Core.Handler
import Vervis.Foundation (Handler)
import Vervis.Path (askRepoDir)
getGitRefDiscoverR :: Text -> Text -> Handler Text
getGitRefDiscoverR sharer repo = do
path <- askRepoDir sharer repo
seemsThere <- liftIO $ isRepo $ fromString path
if seemsThere
then do
rq <- getRequest
case reqGetParams rq of
[("service", _)] -> permissionDenied "Service not supported"
_ -> notFound
else notFound

View file

@ -60,6 +60,7 @@ library
Vervis.Settings
Vervis.Settings.StaticFiles
Vervis.Handler.Common
Vervis.Handler.Git
Vervis.Handler.Home
Vervis.Handler.Key
Vervis.Handler.Person