diff --git a/config/models b/config/models
index 0b6c062..cef0f56 100644
--- a/config/models
+++ b/config/models
@@ -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
diff --git a/config/routes b/config/routes
index 1466955..a6b50d1 100644
--- a/config/routes
+++ b/config/routes
@@ -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
diff --git a/src/Vervis/Field/Repo.hs b/src/Vervis/Field/Repo.hs
index b02bab1..46aa34e 100644
--- a/src/Vervis/Field/Repo.hs
+++ b/src/Vervis/Field/Repo.hs
@@ -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)
diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs
index b19af4c..9d552e6 100644
--- a/src/Vervis/Form/Repo.hs
+++ b/src/Vervis/Form/Repo.hs
@@ -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
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index ed2ae4d..d8808aa 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -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"
diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs
index 47bb9a2..d577501 100644
--- a/src/Vervis/Handler/Home.hs
+++ b/src/Vervis/Handler/Home.hs
@@ -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")
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index 2507de3..e444e87 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@@ -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")
diff --git a/src/Vervis/Path.hs b/src/Vervis/Path.hs
index 7f84fe6..dd564cb 100644
--- a/src/Vervis/Path.hs
+++ b/src/Vervis/Path.hs
@@ -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
diff --git a/templates/project/project.hamlet b/templates/project/project.hamlet
index efb48c4..70902d7 100644
--- a/templates/project/project.hamlet
+++ b/templates/project/project.hamlet
@@ -38,4 +38,4 @@ $#
See
- repos.
+ repos.
diff --git a/templates/repo/commits.hamlet b/templates/repo/commits.hamlet
index f34537a..32afe2e 100644
--- a/templates/repo/commits.hamlet
+++ b/templates/repo/commits.hamlet
@@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$#