From 3325a9d960a6816800352fce9bcca5e8a78c45a9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 12 Apr 2016 10:06:21 +0000 Subject: [PATCH] Display any file and dir in the repo, not just top level --- config/routes | 38 +++++++++++++++++++------------------- src/Vervis/Handler/Repo.hs | 37 +++++++++++++++++++++++++++---------- 2 files changed, 46 insertions(+), 29 deletions(-) diff --git a/config/routes b/config/routes index 7d0d450..1466955 100644 --- a/config/routes +++ b/config/routes @@ -16,42 +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/s/#Text RepoSourceR 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/+Texts 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 0f7d5f6..7fdfd64 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -42,8 +42,9 @@ import Data.Git.Graph.Util import Data.Git.Named (RefName (..)) import Data.Git.Ref (toHex) import Data.Git.Repository -import Data.Git.Storage (withRepo) -import Data.Git.Types (Commit (..), Person (..)) +import Data.Git.Storage (withRepo, getObject_) +import Data.Git.Storage.Object (Object (..)) +import Data.Git.Types (Blob (..), Commit (..), Person (..), entName) import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Query.Topsort import Data.Text (unpack) @@ -56,6 +57,7 @@ import System.Hourglass (dateCurrent) import qualified Data.DList as D import qualified Data.Set as S (member) +import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import Data.ByteString.Char8.Local (takeLine) import Vervis.Form.Repo @@ -140,9 +142,11 @@ 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 +getRepoSourceR :: Text -> Text -> Text -> Text -> [Text] -> Handler Html +getRepoSourceR user proj repo ref dir = do path <- askRepoDir user proj repo + let toText = decodeUtf8With lenientDecode + toTextL = L.decodeUtf8With lenientDecode minfo <- liftIO $ withRepo (fromString path) $ \ git -> do branches <- branchList git tags <- tagList git @@ -150,23 +154,36 @@ getRepoSourceR user proj repo ref = do name' = RefName name if name' `S.member` branches || name' `S.member` tags then do - oid <- resolveName git name - mtree <- resolveTreeish git $ unObjId oid + tipOid <- resolveName git name + mtree <- resolveTreeish git $ unObjId tipOid case mtree of Nothing -> return Nothing Just tree -> do - view <- viewTree git tree + let dir' = map (entName . encodeUtf8) dir + mRootOid <- resolveTreePath git tree dir' + target <- case mRootOid of + Nothing -> return $ Right tree + Just oid -> do + obj <- getObject_ git (unObjId oid) True + case obj of + ObjTree t -> return $ Right t + ObjBlob b -> return $ Left b + _ -> error "expected tree or blob" + view <- case target of + Left b -> Left <$> return b + Right t -> Right <$> viewTree git t 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) = + let mkrow (_perm, name, isTree) = ( if isTree then "[D]" else "[F]" :: Text , toText $ toBytes name ) - rows = map mkrow view + display = case view of + Left b -> Left $ toTextL $ blobGetContent b + Right v -> Right $ map mkrow v defaultLayout $ do setTitle $ toHtml $ intercalate " > " $ ["Vervis", "People", user, "Projects", proj, "Repos", repo]