diff --git a/config/routes b/config/routes index d6a8f71..7d0d450 100644 --- a/config/routes +++ b/config/routes @@ -16,41 +16,42 @@ -- 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 -- 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 -- independently of projects... -/u/#Text/p/#Text/r ReposR GET POST -/u/#Text/p/#Text/r/!new RepoNewR GET -/u/#Text/p/#Text/r/#Text RepoR GET -/u/#Text/p/#Text/r/#Text/c RepoCommitsR GET +/u/#Text/p/#Text/r ReposR GET POST +/u/#Text/p/#Text/r/!new RepoNewR GET +/u/#Text/p/#Text/r/#Text RepoR 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/#TicketId TicketR GET diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 0981a35..0f7d5f6 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -18,6 +18,7 @@ module Vervis.Handler.Repo , postReposR , getRepoNewR , getRepoR + , getRepoSourceR , getRepoCommitsR ) where @@ -38,8 +39,9 @@ import Yesod.Auth import Data.Byteable (toBytes) import Data.Git.Graph import Data.Git.Graph.Util +import Data.Git.Named (RefName (..)) import Data.Git.Ref (toHex) -import Data.Git.Repository (initRepo, getCommit, getTree) +import Data.Git.Repository import Data.Git.Storage (withRepo) import Data.Git.Types (Commit (..), Person (..)) import Data.Graph.Inductive.Graph (noNodes) @@ -53,6 +55,7 @@ import System.Directory (createDirectoryIfMissing) import System.Hourglass (dateCurrent) import qualified Data.DList as D +import qualified Data.Set as S (member) import Data.ByteString.Char8.Local (takeLine) import Vervis.Form.Repo @@ -137,6 +140,38 @@ getRepoR user proj repo = do ["Vervis", "People", user, "Projects", proj, "Repos", 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 user proj repo = do repository <- runDB $ do