Display any file and dir in the repo, not just top level
This commit is contained in:
fr33domlover
parent
3c9d1eb095
commit
3325a9d960
2 changed files with 46 additions and 29 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in a new issue