forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Display any file and dir in the repo, not just top level

Browse source
This commit is contained in:
fr33domlover 2016-04-12 10:06:21 +00:00
parent 3c9d1eb095
commit 3325a9d960
2 changed files with 46 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
config/routes
View file

@ -16,42 +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/s/#Text RepoSourceR 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/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

37
src/Vervis/Handler/Repo.hs
View file

@ -42,8 +42,9 @@ import Data.Git.Graph.Util
import Data.Git.Named (RefName (..)) import Data.Git.Named (RefName (..))
import Data.Git.Ref (toHex) import Data.Git.Ref (toHex)
import Data.Git.Repository import Data.Git.Repository
import Data.Git.Storage (withRepo) import Data.Git.Storage (withRepo, getObject_)
import Data.Git.Types (Commit (..), Person (..)) import Data.Git.Storage.Object (Object (..))
import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort import Data.Graph.Inductive.Query.Topsort
import Data.Text (unpack) import Data.Text (unpack)
@ -56,6 +57,7 @@ import System.Hourglass (dateCurrent)
import qualified Data.DList as D import qualified Data.DList as D
import qualified Data.Set as S (member) import qualified Data.Set as S (member)
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
import Data.ByteString.Char8.Local (takeLine) import Data.ByteString.Char8.Local (takeLine)
import Vervis.Form.Repo import Vervis.Form.Repo
@ -140,9 +142,11 @@ 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 :: Text -> Text -> Text -> Text -> [Text] -> Handler Html
getRepoSourceR user proj repo ref = do getRepoSourceR user proj repo ref dir = do
path <- askRepoDir user proj repo path <- askRepoDir user proj repo
let toText = decodeUtf8With lenientDecode
toTextL = L.decodeUtf8With lenientDecode
minfo <- liftIO $ withRepo (fromString path) $ \ git -> do minfo <- liftIO $ withRepo (fromString path) $ \ git -> do
branches <- branchList git branches <- branchList git
tags <- tagList git tags <- tagList git
@ -150,23 +154,36 @@ getRepoSourceR user proj repo ref = do
name' = RefName name name' = RefName name
if name' `S.member` branches || name' `S.member` tags if name' `S.member` branches || name' `S.member` tags
then do then do
oid <- resolveName git name tipOid <- resolveName git name
mtree <- resolveTreeish git $ unObjId oid mtree <- resolveTreeish git $ unObjId tipOid
case mtree of case mtree of
Nothing -> return Nothing Nothing -> return Nothing
Just tree -> do 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) return $ Just (branches, tags, view)
else return Nothing else return Nothing
case minfo of case minfo of
Nothing -> notFound Nothing -> notFound
Just (branches, tags, view) -> do Just (branches, tags, view) -> do
let toText = decodeUtf8With lenientDecode let mkrow (_perm, name, isTree) =
mkrow (_perm, name, isTree) =
( if isTree then "[D]" else "[F]" :: Text ( if isTree then "[D]" else "[F]" :: Text
, toText $ toBytes name , 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 defaultLayout $ do
setTitle $ toHtml $ intercalate " > " $ setTitle $ toHtml $ intercalate " > " $
["Vervis", "People", user, "Projects", proj, "Repos", repo] ["Vervis", "People", user, "Projects", proj, "Repos", repo]