mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-28 10:54:54 +09:00
RepoSourceR, display file tree for given branch or tag
This commit is contained in:
parent
b312d41ef0
commit
100ba7511c
2 changed files with 55 additions and 19 deletions
|
@ -16,41 +16,42 @@
|
||||||
-- Yesod misc
|
-- Yesod misc
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
||||||
/static StaticR Static appStatic
|
/static StaticR Static appStatic
|
||||||
/favicon.ico FaviconR GET
|
/favicon.ico FaviconR GET
|
||||||
/robots.txt RobotsR GET
|
/robots.txt RobotsR GET
|
||||||
|
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
-- User login
|
-- User login
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
||||||
/auth AuthR Auth getAuth
|
/auth AuthR Auth getAuth
|
||||||
|
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
-- Everything else...
|
-- Everything else...
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
||||||
/ HomeR GET
|
/ HomeR GET
|
||||||
|
|
||||||
/u PeopleR GET POST
|
/u PeopleR GET POST
|
||||||
/u/!new PersonNewR GET
|
/u/!new PersonNewR GET
|
||||||
/u/#Text PersonR GET
|
/u/#Text PersonR GET
|
||||||
|
|
||||||
/u/#Text/k KeysR GET POST
|
/u/#Text/k KeysR GET POST
|
||||||
/u/#Text/k/!new KeyNewR GET
|
/u/#Text/k/!new KeyNewR GET
|
||||||
/u/#Text/k/#Text KeyR GET
|
/u/#Text/k/#Text KeyR GET
|
||||||
|
|
||||||
/u/#Text/p ProjectsR GET POST
|
/u/#Text/p ProjectsR GET POST
|
||||||
/u/#Text/p/!new ProjectNewR GET
|
/u/#Text/p/!new ProjectNewR GET
|
||||||
/u/#Text/p/#Text ProjectR GET
|
/u/#Text/p/#Text ProjectR GET
|
||||||
|
|
||||||
-- IDEA: if there's /u/john/p/proj/r/repo, then make /u/john/r/proj-repo
|
-- IDEA: if there's /u/john/p/proj/r/repo, then make /u/john/r/proj-repo
|
||||||
-- redirect there. consider having a clean way to refer to repos
|
-- redirect there. consider having a clean way to refer to repos
|
||||||
-- independently of projects...
|
-- independently of projects...
|
||||||
/u/#Text/p/#Text/r ReposR GET POST
|
/u/#Text/p/#Text/r ReposR GET POST
|
||||||
/u/#Text/p/#Text/r/!new RepoNewR GET
|
/u/#Text/p/#Text/r/!new RepoNewR GET
|
||||||
/u/#Text/p/#Text/r/#Text RepoR GET
|
/u/#Text/p/#Text/r/#Text RepoR GET
|
||||||
/u/#Text/p/#Text/r/#Text/c RepoCommitsR GET
|
/u/#Text/p/#Text/r/#Text/s/#Text RepoSourceR GET
|
||||||
|
/u/#Text/p/#Text/r/#Text/c RepoCommitsR GET
|
||||||
|
|
||||||
-- /u/#Text/p/#Text/t TicketsR GET
|
-- /u/#Text/p/#Text/t TicketsR GET
|
||||||
-- /u/#Text/p/#Text/t/#TicketId TicketR GET
|
-- /u/#Text/p/#Text/t/#TicketId TicketR GET
|
||||||
|
|
|
@ -18,6 +18,7 @@ module Vervis.Handler.Repo
|
||||||
, postReposR
|
, postReposR
|
||||||
, getRepoNewR
|
, getRepoNewR
|
||||||
, getRepoR
|
, getRepoR
|
||||||
|
, getRepoSourceR
|
||||||
, getRepoCommitsR
|
, getRepoCommitsR
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -38,8 +39,9 @@ import Yesod.Auth
|
||||||
import Data.Byteable (toBytes)
|
import Data.Byteable (toBytes)
|
||||||
import Data.Git.Graph
|
import Data.Git.Graph
|
||||||
import Data.Git.Graph.Util
|
import Data.Git.Graph.Util
|
||||||
|
import Data.Git.Named (RefName (..))
|
||||||
import Data.Git.Ref (toHex)
|
import Data.Git.Ref (toHex)
|
||||||
import Data.Git.Repository (initRepo, getCommit, getTree)
|
import Data.Git.Repository
|
||||||
import Data.Git.Storage (withRepo)
|
import Data.Git.Storage (withRepo)
|
||||||
import Data.Git.Types (Commit (..), Person (..))
|
import Data.Git.Types (Commit (..), Person (..))
|
||||||
import Data.Graph.Inductive.Graph (noNodes)
|
import Data.Graph.Inductive.Graph (noNodes)
|
||||||
|
@ -53,6 +55,7 @@ import System.Directory (createDirectoryIfMissing)
|
||||||
import System.Hourglass (dateCurrent)
|
import System.Hourglass (dateCurrent)
|
||||||
|
|
||||||
import qualified Data.DList as D
|
import qualified Data.DList as D
|
||||||
|
import qualified Data.Set as S (member)
|
||||||
|
|
||||||
import Data.ByteString.Char8.Local (takeLine)
|
import Data.ByteString.Char8.Local (takeLine)
|
||||||
import Vervis.Form.Repo
|
import Vervis.Form.Repo
|
||||||
|
@ -137,6 +140,38 @@ getRepoR user proj repo = do
|
||||||
["Vervis", "People", user, "Projects", proj, "Repos", repo]
|
["Vervis", "People", user, "Projects", proj, "Repos", repo]
|
||||||
$(widgetFile "repo/repo")
|
$(widgetFile "repo/repo")
|
||||||
|
|
||||||
|
getRepoSourceR :: Text -> Text -> Text -> Text -> Handler Html
|
||||||
|
getRepoSourceR user proj repo ref = do
|
||||||
|
path <- askRepoDir user proj repo
|
||||||
|
minfo <- liftIO $ withRepo (fromString path) $ \ git -> do
|
||||||
|
branches <- branchList git
|
||||||
|
tags <- tagList git
|
||||||
|
let name = unpack ref
|
||||||
|
name' = RefName name
|
||||||
|
if name' `S.member` branches || name' `S.member` tags
|
||||||
|
then do
|
||||||
|
oid <- resolveName git name
|
||||||
|
mtree <- resolveTreeish git $ unObjId oid
|
||||||
|
case mtree of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just tree -> do
|
||||||
|
view <- viewTree git tree
|
||||||
|
return $ Just (branches, tags, view)
|
||||||
|
else return Nothing
|
||||||
|
case minfo of
|
||||||
|
Nothing -> notFound
|
||||||
|
Just (branches, tags, view) -> do
|
||||||
|
let toText = decodeUtf8With lenientDecode
|
||||||
|
mkrow (_perm, name, isTree) =
|
||||||
|
( if isTree then "[D]" else "[F]" :: Text
|
||||||
|
, toText $ toBytes name
|
||||||
|
)
|
||||||
|
rows = map mkrow view
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle $ toHtml $ intercalate " > " $
|
||||||
|
["Vervis", "People", user, "Projects", proj, "Repos", repo]
|
||||||
|
$(widgetFile "repo/source")
|
||||||
|
|
||||||
getRepoCommitsR :: Text -> Text -> Text -> Handler Html
|
getRepoCommitsR :: Text -> Text -> Text -> Handler Html
|
||||||
getRepoCommitsR user proj repo = do
|
getRepoCommitsR user proj repo = do
|
||||||
repository <- runDB $ do
|
repository <- runDB $ do
|
||||||
|
|
Loading…
Reference in a new issue