forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Repos right under users, not under projects

Browse source
This commit is contained in:
fr33domlover 2016-04-12 17:37:31 +00:00
parent b6b493d3ef
commit ea71f30d96
14 changed files with 97 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
config/models
View file

@ -54,13 +54,14 @@ Project
Repo
ident Text --CI
project ProjectId
sharer SharerId
project ProjectId Maybe
desc Text Maybe
irc IrcChannelId Maybe
ml Text Maybe
mainBranch Text default='master'
UniqueRepo ident project
UniqueRepo ident sharer
PersonInGroup
person PersonId

13
config/routes
View file

@ -44,14 +44,11 @@
/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/+Texts RepoSourceR GET
/u/#Text/p/#Text/r/#Text/c RepoCommitsR GET
/u/#Text/r ReposR GET POST
/u/#Text/r/!new RepoNewR GET
/u/#Text/r/#Text RepoR GET
/u/#Text/r/#Text/s/#Text/+Texts RepoSourceR GET
/u/#Text/r/#Text/c RepoCommitsR GET
-- /u/#Text/p/#Text/t TicketsR GET
-- /u/#Text/p/#Text/t/#TicketId TicketR GET

20
src/Vervis/Field/Repo.hs
View file

@ -18,12 +18,11 @@ module Vervis.Field.Repo
)
where
import Vervis.Import hiding ((==.))
import Vervis.Import
import Data.Char (isDigit)
import Data.Char.Local (isAsciiLetter)
import Data.Text (split)
import Database.Esqueleto hiding (isNothing)
checkIdentTemplate :: Field Handler Text -> Field Handler Text
checkIdentTemplate =
@ -36,22 +35,11 @@ checkIdentTemplate =
\ASCII letters and digits."
in checkBool identOk msg
-- | Make sure the repo identifier is unique. The DB schema only requires that
-- a repo identifier is unique within its project, but I'd like to enforce a
-- stronger condition: A repo identifier must be unique within its sharer's
-- repos. I'm not yet sure it's a good thing, but it's much easier to maintain
-- now and relax later, than relax now and have problems later when there are
-- already conflicting names.
-- | Make sure the sharer doesn't already have a repo by the same name.
checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text
checkIdentUnique sid = checkM $ \ ident -> do
l <- runDB $ select $ from $ \ (project, repo) -> do
where_ $
project ^. ProjectSharer ==. val sid &&.
repo ^. RepoProject ==. project ^. ProjectId &&.
repo ^. RepoIdent ==. val ident
limit 1
return ()
return $ if isNothing $ listToMaybe l
mrepo <- runDB $ getBy $ UniqueRepo ident sid
return $ if isNothing mrepo
then Right ident
else Left ("You already have a repo by that name" :: Text)

11
src/Vervis/Form/Repo.hs
View file

@ -21,14 +21,15 @@ where
import Vervis.Import
import Vervis.Field.Repo
newRepoAForm :: SharerId -> ProjectId -> AForm Handler Repo
newRepoAForm sid pid = Repo
newRepoAForm :: SharerId -> AForm Handler Repo
newRepoAForm sid = Repo
<$> areq (mkIdentField sid) "Identifier*" Nothing
<*> pure pid
<*> pure sid
<*> pure Nothing
<*> aopt textField "Description" Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure "master"
newRepoForm :: SharerId -> ProjectId -> Form Repo
newRepoForm sid pid = renderDivs $ newRepoAForm sid pid
newRepoForm :: SharerId -> Form Repo
newRepoForm = renderDivs . newRepoAForm

2
src/Vervis/Foundation.hs
View file

@ -107,7 +107,7 @@ instance Yesod App where
-- Who can access which pages.
isAuthorized (ProjectNewR user) _ =
loggedInAs user "You can’t create projects for other users"
isAuthorized (RepoNewR user _proj) _ =
isAuthorized (RepoNewR user) _ =
loggedInAs user "You can’t create repos for other users"
isAuthorized (KeysR user) _ =
loggedInAs user "You can’t watch keys of other users"

40
src/Vervis/Handler/Home.hs
View file

@ -18,39 +18,41 @@ module Vervis.Handler.Home
)
where
import Vervis.Import
import Vervis.Import hiding (on)
import Database.Esqueleto hiding ((==.))
import Vervis.Git
import qualified Database.Esqueleto as E ((==.))
import Vervis.Path
intro :: Handler Html
intro = do
rows <- do
repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
where_ $
project ^. ProjectSharer E.==. sharer ^. SharerId &&.
repo ^. RepoProject E.==. project ^. ProjectId
orderBy
[ asc $ sharer ^. SharerIdent
, asc $ project ^. ProjectIdent
, asc $ repo ^. RepoIdent
]
return
( sharer ^. SharerIdent
, project ^. ProjectIdent
, repo ^. RepoIdent
)
root <- appRepoDir . appSettings <$> getYesod
liftIO $ forM repos $ \ (Value sharer, Value project, Value repo) -> do
repos <- runDB $ select $ from $
\ (repo `LeftOuterJoin` project `InnerJoin` sharer) -> do
on $ repo ^. RepoSharer E.==. sharer ^. SharerId
on $ repo ^. RepoProject E.==. project ?. ProjectId
orderBy
[ asc $ sharer ^. SharerIdent
, asc $ project ?. ProjectIdent
, asc $ repo ^. RepoIdent
]
return
( sharer ^. SharerIdent
, project ?. ProjectIdent
, repo ^. RepoIdent
)
root <- askRepoRootDir
liftIO $ forM repos $ \ (Value sharer, Value mproj, Value repo) -> do
let path =
root </> unpack sharer </> unpack project </> unpack repo
root </> unpack sharer </> unpack repo
mdt <- lastChange path
ago <- case mdt of
Nothing -> return "never"
Just dt -> timeAgo dt
return (sharer, project, repo, ago)
return (sharer, fromMaybe "(none)" mproj, repo, ago)
defaultLayout $ do
setTitle "Welcome to Vervis!"
$(widgetFile "homepage")

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

@ -73,29 +73,27 @@ import Vervis.Model
import Vervis.Settings
import Vervis.Style
getReposR :: Text -> Text -> Handler Html
getReposR user proj = do
repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
getReposR :: Text -> Handler Html
getReposR user = do
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
where_ $
sharer ^. SharerIdent ==. val user &&.
sharer ^. SharerId ==. project ^. ProjectSharer &&.
repo ^. RepoProject ==. project ^. ProjectId
sharer ^. SharerId ==. repo ^. RepoSharer
orderBy [asc $ repo ^. RepoIdent]
return $ repo ^. RepoIdent
defaultLayout $ do
setTitle $ toHtml $ mconcat
["Vervis > People > ", user, " > Projects > ", proj, " Repos"]
setTitle $ toHtml $ intercalate " > "
["Vervis", "People", user, "Repos"]
$(widgetFile "repo/repos")
postReposR :: Text -> Text -> Handler Html
postReposR user proj = do
postReposR :: Text -> Handler Html
postReposR user = do
Entity _pid person <- requireAuth
let sid = personIdent person
Entity pid _project <- runDB $ getBy404 $ UniqueProject proj sid
((result, widget), enctype) <- runFormPost $ newRepoForm sid pid
((result, widget), enctype) <- runFormPost $ newRepoForm sid
case result of
FormSuccess repo -> do
parent <- askProjectDir user proj
parent <- askSharerDir user
let path = parent </> unpack (repoIdent repo)
liftIO $ createDirectoryIfMissing True parent
liftIO $ initRepo $ fromString path
@ -109,29 +107,26 @@ postReposR user proj = do
setMessage $ toHtml $ intercalate "; " l
defaultLayout $(widgetFile "repo/repo-new")
getRepoNewR :: Text -> Text -> Handler Html
getRepoNewR user proj = do
getRepoNewR :: Text -> Handler Html
getRepoNewR user = do
Entity _pid person <- requireAuth
let sid = personIdent person
Entity pid _project <- runDB $ getBy404 $ UniqueProject proj sid
((_result, widget), enctype) <- runFormPost $ newRepoForm sid pid
((_result, widget), enctype) <- runFormPost $ newRepoForm sid
defaultLayout $ do
setTitle $ toHtml $ mconcat
["Vervis > People > ", user, " > Projects > ", proj, " > New Repo"]
setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
$(widgetFile "repo/repo-new")
instance ResultList D.DList where
emptyList = D.empty
appendItem = flip D.snoc
getRepoR :: Text -> Text -> Text -> Handler Html
getRepoR user proj repo = do
getRepoR :: Text -> Text -> Handler Html
getRepoR user repo = do
repository <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent user
Entity pid _p <- getBy404 $ UniqueProject proj sid
Entity _rid r <- getBy404 $ UniqueRepo repo pid
Entity _rid r <- getBy404 $ UniqueRepo repo sid
return r
path <- askRepoDir user proj repo
path <- askRepoDir user repo
view <- liftIO $ withRepo (fromString path) $ \ git -> do
oid <- resolveName git $ unpack $ repoMainBranch repository
commit <- getCommit git $ unObjId oid
@ -144,13 +139,13 @@ getRepoR user proj repo = do
)
rows = map mkrow view
defaultLayout $ do
setTitle $ toHtml $ intercalate " > " $
["Vervis", "People", user, "Projects", proj, "Repos", repo]
setTitle $ toHtml $ intercalate " > "
["Vervis", "People", user, "Repos", repo]
$(widgetFile "repo/repo")
getRepoSourceR :: Text -> Text -> Text -> Text -> [Text] -> Handler Html
getRepoSourceR user proj repo ref dir = do
path <- askRepoDir user proj repo
getRepoSourceR :: Text -> Text -> Text -> [Text] -> Handler Html
getRepoSourceR user repo ref dir = do
path <- askRepoDir user repo
let toText = decodeUtf8With lenientDecode
toTextL = L.decodeUtf8With lenientDecode
minfo <- liftIO $ withRepo (fromString path) $ \ git -> do
@ -211,17 +206,16 @@ getRepoSourceR user proj repo ref dir = do
Right v -> return $ Right $ map mkrow v
defaultLayout $ do
setTitle $ toHtml $ intercalate " > " $
["Vervis", "People", user, "Projects", proj, "Repos", repo]
["Vervis", "People", user, "Repos", repo]
$(widgetFile "repo/source")
getRepoCommitsR :: Text -> Text -> Text -> Handler Html
getRepoCommitsR user proj repo = do
getRepoCommitsR :: Text -> Text -> Handler Html
getRepoCommitsR user repo = do
repository <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent user
Entity pid _p <- getBy404 $ UniqueProject proj sid
Entity _rid r <- getBy404 $ UniqueRepo repo pid
Entity _rid r <- getBy404 $ UniqueRepo repo sid
return r
path <- askRepoDir user proj repo
path <- askRepoDir user repo
pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
oid <- resolveName git $ unpack $ repoMainBranch repository
graph <- loadCommitGraphPT git [oid]
@ -240,6 +234,6 @@ getRepoCommitsR user proj repo = do
)
rows = map (uncurry mkrow) pairs
defaultLayout $ do
setTitle $ toHtml $ intercalate " > " $
["Vervis", "People", user, "Projects", proj, "Repos", repo, "Commits"]
setTitle $ toHtml $ intercalate " > "
["Vervis", "People", user, "Repos", repo, "Commits"]
$(widgetFile "repo/commits")

34
src/Vervis/Path.hs
View file

@ -15,10 +15,8 @@
module Vervis.Path
( askRepoRootDir
, personDir
, askPersonDir
, projectDir
, askProjectDir
, sharerDir
, askSharerDir
, repoDir
, askRepoDir
)
@ -36,26 +34,18 @@ import Vervis.Settings
askRepoRootDir :: Handler FilePath
askRepoRootDir = appRepoDir . appSettings <$> getYesod
personDir :: FilePath -> Text -> FilePath
personDir root user = root </> unpack user
sharerDir :: FilePath -> Text -> FilePath
sharerDir root sharer = root </> unpack sharer
askPersonDir :: Text -> Handler FilePath
askPersonDir user = do
askSharerDir :: Text -> Handler FilePath
askSharerDir sharer = do
root <- askRepoRootDir
return $ personDir root user
return $ sharerDir root sharer
projectDir :: FilePath -> Text -> Text -> FilePath
projectDir root user proj = root </> unpack user </> unpack proj
repoDir :: FilePath -> Text -> Text -> FilePath
repoDir root sharer repo = sharerDir root sharer </> unpack repo
askProjectDir :: Text -> Text -> Handler FilePath
askProjectDir user proj = do
askRepoDir :: Text -> Text -> Handler FilePath
askRepoDir sharer repo = do
root <- askRepoRootDir
return $ projectDir root user proj
repoDir :: FilePath -> Text -> Text -> Text -> FilePath
repoDir root user proj repo = projectDir root user proj </> unpack repo
askRepoDir :: Text -> Text -> Text -> Handler FilePath
askRepoDir user proj repo = do
root <- askRepoRootDir
return $ repoDir root user proj repo
return $ repoDir root sharer repo

2
templates/project/project.hamlet
View file

@ -38,4 +38,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
See
<a href=@{ReposR user proj}>repos</a>.
<a href=@{ReposR user}>repos</a>.

2
templates/repo/commits.hamlet
View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h1>Vervis > People > #{user} > Projects > #{proj} > Repos > #{repo} > Commits
<h1>Vervis > People > #{user} > Repos > #{repo} > Commits
<h2>History
<table>

4
templates/repo/repo-new.hamlet
View file

@ -12,10 +12,10 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h1>Vervis > People > #{user} > Projects > #{proj} > New Repo
<h1>Vervis > People > #{user} > New Repo
Enter your details and click "Submit" to create a new repo.
<form method=POST action=@{ReposR user proj} enctype=#{enctype}>
<form method=POST action=@{ReposR user} enctype=#{enctype}>
^{widget}
<input type=submit>

7
templates/repo/repo.hamlet
View file

@ -12,12 +12,11 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h1>Vervis > People > #{user} > Projects > #{proj} > Repos > #{repo}
<h1>Vervis > People > #{user} > Repos > #{repo}
<h2>About
<p>
This is the repo page for <b>#{repo}</b>, which is part of project
<b>#{proj}</b>, shared by user <b>#{user}</b>.
This is the repo page for <b>#{repo}</b>, shared by user <b>#{user}</b>.
<h2>Details
<table>
@ -31,7 +30,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h2>Commits
<p>
See <a href=@{RepoCommitsR user proj repo}>commits</a>.
See <a href=@{RepoCommitsR user repo}>commits</a>.
<h2>Files
<table>

8
templates/repo/repos.hamlet
View file

@ -12,13 +12,13 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h1>Vervis > People > #{user} > Projects > #{proj} > Repos
<h1>Vervis > People > #{user} > Repos
<p>These are the repositories of project #{proj} shared by #{user}.
<p>These are the repositories shared by #{user}.
<ul>
$forall Value repo <- repos
<li>
<a href=@{RepoR user proj repo}>#{repo}
<a href=@{RepoR user repo}>#{repo}
<li>
<a href=@{RepoNewR user proj}>Create new…
<a href=@{RepoNewR user}>Create new…

8
templates/repo/source.hamlet
View file

@ -12,19 +12,19 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h1>Vervis > People > #{user} > Projects > #{proj} > Repos > #{repo}
<h1>Vervis > People > #{user} > Repos > #{repo}
<h2>Branches
<ul>
$forall RefName branch <- branches
<li>
<a href=@{RepoSourceR user proj repo (pack branch) []}>#{branch}
<a href=@{RepoSourceR user repo (pack branch) []}>#{branch}
<h2>Tags
<ul>
$forall RefName tag <- tags
<li>
<a href=@{RepoSourceR user proj repo (pack tag) []}>#{tag}
<a href=@{RepoSourceR user repo (pack tag) []}>#{tag}
<h2>Files for #{ref}
$case display
@ -42,5 +42,5 @@ $case display
<tr>
<td>#{type'}
<td>
<a href=@{RepoSourceR user proj repo ref (dir ++ [name])}>
<a href=@{RepoSourceR user repo ref (dir ++ [name])}>
#{name}