diff --git a/config/models b/config/models index dca1b9a..c5b0cc1 100644 --- a/config/models +++ b/config/models @@ -73,6 +73,26 @@ RepoCollab UniqueRepoCollab repo person +ProjectRole + ident RlIdent + person PersonId + desc Text + + UniqueProjectRole person ident + +ProjectAccess + role ProjectRoleId + op ProjectOperation + + UniqueProjectAccess role op + +ProjectCollab + project ProjectId + person PersonId + role ProjectRoleId + + UniqueProjectCollab project person + ------------------------------------------------------------------------------- -- Projects ------------------------------------------------------------------------------- diff --git a/config/routes b/config/routes index ed0470b..bdbeb46 100644 --- a/config/routes +++ b/config/routes @@ -56,6 +56,12 @@ /rr/#RlIdent/a RepoRoleOpsR GET POST /rr/#RlIdent/a/!new RepoRoleOpNewR GET +/pr ProjectRolesR GET POST +/pr/!new ProjectRoleNewR GET +/pr/#RlIdent ProjectRoleR GET DELETE POST +/pr/#RlIdent/a ProjectRoleOpsR GET POST +/pr/#RlIdent/a/!new ProjectRoleOpNewR GET + -- ---------------------------------------------------------------------------- -- Projects -- ---------------------------------------------------------------------------- @@ -78,6 +84,9 @@ /s/#ShrIdent/p ProjectsR GET POST /s/#ShrIdent/p/!new ProjectNewR GET /s/#ShrIdent/p/#PrjIdent ProjectR GET +/s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST +/s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET +/s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST /s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST /s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET diff --git a/src/Vervis/Field/Role.hs b/src/Vervis/Field/Role.hs index 47db2eb..84676f8 100644 --- a/src/Vervis/Field/Role.hs +++ b/src/Vervis/Field/Role.hs @@ -16,6 +16,8 @@ module Vervis.Field.Role ( newRepoRoleIdentField , newRepoOpField + , newProjectRoleIdentField + , newProjectOpField ) where @@ -40,12 +42,12 @@ import Vervis.Model import Vervis.Model.Ident (RlIdent, rl2text, text2rl) import Vervis.Model.Role +roleIdentField :: Field Handler RlIdent +roleIdentField = convertField text2rl rl2text textField + newRepoRoleIdentField :: PersonId -> Field Handler RlIdent newRepoRoleIdentField pid = checkUniqueCI pid roleIdentField where - roleIdentField :: Field Handler RlIdent - roleIdentField = convertField text2rl rl2text textField - checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent checkUniqueCI pid = checkM $ \ rl -> do sames <- runDB $ select $ from $ \ role -> do @@ -75,3 +77,36 @@ newRepoOpField getrid = checkOpNew getrid opField return $ case ma of Nothing -> Right op Just _ -> Left ("Role already has this operation" :: Text) + +newProjectRoleIdentField :: PersonId -> Field Handler RlIdent +newProjectRoleIdentField pid = checkUniqueCI pid roleIdentField + where + checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent + checkUniqueCI pid = checkM $ \ rl -> do + sames <- runDB $ select $ from $ \ role -> do + where_ $ + role ^. ProjectRolePerson ==. val pid &&. + lower_ (role ^. ProjectRoleIdent) ==. lower_ (val rl) + limit 1 + return () + return $ if null sames + then Right rl + else Left ("This role name is already in use" :: Text) + +newProjectOpField :: AppDB ProjectRoleId -> Field Handler ProjectOperation +newProjectOpField getrid = checkOpNew getrid opField + where + opField :: Field Handler ProjectOperation + opField = selectField optionsEnum + + checkOpNew + :: AppDB ProjectRoleId + -> Field Handler ProjectOperation + -> Field Handler ProjectOperation + checkOpNew getrid = checkM $ \ op -> do + ma <- runDB $ do + rid <- getrid + getBy $ UniqueProjectAccess rid op + return $ case ma of + Nothing -> Right op + Just _ -> Left ("Role already has this operation" :: Text) diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 6e8ed88..b7c7932 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -15,13 +15,21 @@ module Vervis.Form.Project ( newProjectForm + , NewProjectCollab (..) + , newProjectCollabForm ) where -import Vervis.Import +import Vervis.Import hiding (on, isNothing) + +import Database.Esqueleto hiding ((==.)) + +import qualified Database.Esqueleto as E ((==.)) import Vervis.Field.Project -import Vervis.Model.Ident (text2prj) +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Model.Repo newProjectAForm :: SharerId -> AForm Handler Project newProjectAForm sid = Project @@ -33,3 +41,32 @@ newProjectAForm sid = Project newProjectForm :: SharerId -> Form Project newProjectForm = renderDivs . newProjectAForm + +data NewProjectCollab = NewProjectCollab + { ncPerson :: PersonId + , ncRole :: ProjectRoleId + } + +newProjectCollabAForm + :: PersonId -> ProjectId -> AForm Handler NewProjectCollab +newProjectCollabAForm pid rid = NewProjectCollab + <$> areq selectPerson "Person*" Nothing + <*> areq selectRole "Role*" Nothing + where + selectPerson = selectField $ do + l <- runDB $ select $ + from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do + on $ person ^. PersonIdent E.==. sharer ^. SharerId + on $ + collab ?. ProjectCollabProject E.==. just (val rid) &&. + collab ?. ProjectCollabPerson E.==. just (person ^. PersonId) + where_ $ isNothing $ collab ?. ProjectCollabId + return (sharer ^. SharerIdent, person ^. PersonId) + optionsPairs $ map (shr2text . unValue *** unValue) l + selectRole = + selectField $ + optionsPersistKey [ProjectRolePerson ==. pid] [] $ + rl2text . projectRoleIdent + +newProjectCollabForm :: PersonId -> ProjectId -> Form NewProjectCollab +newProjectCollabForm pid rid = renderDivs $ newProjectCollabAForm pid rid diff --git a/src/Vervis/Form/Role.hs b/src/Vervis/Form/Role.hs index fd25089..0d9f6c6 100644 --- a/src/Vervis/Form/Role.hs +++ b/src/Vervis/Form/Role.hs @@ -17,6 +17,9 @@ module Vervis.Form.Role ( NewRepoRole (..) , newRepoRoleForm , newRepoRoleOpForm + , NewProjectRole (..) + , newProjectRoleForm + , newProjectRoleOpForm ) where @@ -51,3 +54,23 @@ newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing newRepoRoleOpForm :: AppDB RepoRoleId -> Form RepoOperation newRepoRoleOpForm getrid = renderDivs $ newRepoRoleOpAForm getrid + +data NewProjectRole = NewProjectRole + { nprIdent :: RlIdent + , nprDesc :: Text + } + +newProjectRoleAForm :: PersonId -> AForm Handler NewProjectRole +newProjectRoleAForm pid = NewProjectRole + <$> areq (newProjectRoleIdentField pid) "Name*" Nothing + <*> areq textField "Description" Nothing + +newProjectRoleForm :: PersonId -> Form NewProjectRole +newProjectRoleForm pid = renderDivs $ newProjectRoleAForm pid + +newProjectRoleOpAForm :: AppDB ProjectRoleId -> AForm Handler ProjectOperation +newProjectRoleOpAForm getrid = + areq (newProjectOpField getrid) "Operation*" Nothing + +newProjectRoleOpForm :: AppDB ProjectRoleId -> Form ProjectOperation +newProjectRoleOpForm getrid = renderDivs $ newProjectRoleOpAForm getrid diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 11d3a22..3d045c8 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -135,6 +135,12 @@ instance Yesod App where (RepoRoleOpsR _rl , _ ) -> personAny (RepoRoleOpNewR _rl , _ ) -> personAny + (ProjectRolesR , _ ) -> personAny + (ProjectRoleNewR , _ ) -> personAny + (ProjectRoleR _rl , _ ) -> personAny + (ProjectRoleOpsR _rl , _ ) -> personAny + (ProjectRoleOpNewR _rl , _ ) -> personAny + (ReposR shar , True) -> person shar (RepoNewR user , _ ) -> person user (RepoR shar _ , True) -> person shar @@ -144,6 +150,9 @@ instance Yesod App where (ProjectsR shar , True) -> person shar (ProjectNewR user , _ ) -> person user + (ProjectDevsR shr _prj , _ ) -> person shr + (ProjectDevNewR shr _prj , _ ) -> person shr + (ProjectDevR shr _prj _dev , _ ) -> person shr (TicketsR shar _ , True) -> person shar (TicketNewR _ _ , _ ) -> personAny @@ -307,6 +316,12 @@ instance YesodBreadcrumbs App where RepoRoleOpsR rl -> ("Operations", Just $ RepoRoleR rl) RepoRoleOpNewR rl -> ("New", Just $ RepoRoleOpsR rl) + ProjectRolesR -> ("Project Roles", Just HomeR) + ProjectRoleNewR -> ("New", Just ProjectRolesR) + ProjectRoleR rl -> (rl2text rl, Just ProjectRolesR) + ProjectRoleOpsR rl -> ("Operations", Just $ ProjectRoleR rl) + ProjectRoleOpNewR rl -> ("New", Just $ ProjectRoleOpsR rl) + ReposR shar -> ("Repos", Just $ PersonR shar) RepoNewR shar -> ("New", Just $ ReposR shar) RepoR shar repo -> (rp2text repo, Just $ ReposR shar) @@ -320,7 +335,9 @@ instance YesodBreadcrumbs App where RepoChangesR shar repo ref -> ( ref , Just $ RepoHeadChangesR shar repo ) - RepoDevsR shr rp -> ("Team", Just $ RepoR shr rp) + RepoDevsR shr rp -> ( "Collaboratots" + , Just $ RepoR shr rp + ) RepoDevNewR shr rp -> ("New", Just $ RepoDevsR shr rp) RepoDevR shr rp dev -> ( shr2text dev , Just $ RepoDevsR shr rp @@ -335,6 +352,15 @@ instance YesodBreadcrumbs App where ProjectR shar proj -> ( prj2text proj , Just $ ProjectsR shar ) + ProjectDevsR shr prj -> ( "Collaborators" + , Just $ ProjectR shr prj + ) + ProjectDevNewR shr prj -> ( "New" + , Just $ ProjectDevsR shr prj + ) + ProjectDevR shr prj dev -> ( shr2text dev + , Just $ ProjectDevsR shr prj + ) TicketsR shar proj -> ( "Tickets" , Just $ ProjectR shar proj diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 0119534..7079519 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -18,6 +18,12 @@ module Vervis.Handler.Project , postProjectsR , getProjectNewR , getProjectR + , getProjectDevsR + , postProjectDevsR + , getProjectDevNewR + , getProjectDevR + , deleteProjectDevR + , postProjectDevR ) where @@ -26,10 +32,11 @@ import Prelude import Data.Maybe (fromMaybe) import Data.Text (Text) import Database.Persist +import Database.Esqueleto hiding (delete, (%), (==.)) import Text.Blaze.Html (Html) import Yesod.Auth (requireAuth) import Yesod.Core (defaultLayout) -import Yesod.Core.Handler (redirect, setMessage) +import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, getBy404) @@ -42,15 +49,16 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Settings +import Vervis.Widget.Sharer getProjectsR :: ShrIdent -> Handler Html getProjectsR ident = do - projects <- runDB $ E.select $ E.from $ \ (sharer, project) -> do - E.where_ $ - sharer E.^. SharerIdent E.==. E.val ident E.&&. - sharer E.^. SharerId E.==. project E.^. ProjectSharer - E.orderBy [E.asc $ project E.^. ProjectIdent] - return $ project E.^. ProjectIdent + projects <- runDB $ select $ from $ \ (sharer, project) -> do + where_ $ + sharer ^. SharerIdent E.==. val ident &&. + sharer ^. SharerId E.==. project ^. ProjectSharer + orderBy [asc $ project ^. ProjectIdent] + return $ project ^. ProjectIdent defaultLayout $(widgetFile "project/list") postProjectsR :: ShrIdent -> Handler Html @@ -85,3 +93,94 @@ getProjectR shar proj = do rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] return (p, rs) defaultLayout $(widgetFile "project/one") + +getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html +getProjectDevsR shr rp = do + devs <- runDB $ do + rid <- do + Entity s _ <- getBy404 $ UniqueSharer shr + Entity r _ <- getBy404 $ UniqueProject rp s + return r + select $ from $ \ (collab, person, sharer, role) -> do + where_ $ + collab ^. ProjectCollabProject E.==. val rid &&. + collab ^. ProjectCollabPerson E.==. person ^. PersonId &&. + person ^. PersonIdent E.==. sharer ^. SharerId &&. + collab ^. ProjectCollabRole E.==. role ^. ProjectRoleId + return (sharer, role ^. ProjectRoleIdent) + defaultLayout $(widgetFile "project/collab/list") + +postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html +postProjectDevsR shr rp = do + (pid, rid) <- runDB $ do + Entity s _ <- getBy404 $ UniqueSharer shr + Entity p _ <- getBy404 $ UniquePersonIdent s + Entity r _ <- getBy404 $ UniqueProject rp s + return (p, r) + ((result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid + case result of + FormSuccess nc -> do + runDB $ do + let collab = ProjectCollab + { projectCollabProject = rid + , projectCollabPerson = ncPerson nc + , projectCollabRole = ncRole nc + } + insert_ collab + setMessage "Collaborator added." + redirect $ ProjectDevsR shr rp + FormMissing -> do + setMessage "Field(s) missing" + defaultLayout $(widgetFile "project/collab/new") + FormFailure _l -> do + setMessage "Operation failed, see errors below" + defaultLayout $(widgetFile "project/collab/new") + +getProjectDevNewR :: ShrIdent -> PrjIdent -> Handler Html +getProjectDevNewR shr rp = do + (pid, rid) <- runDB $ do + Entity s _ <- getBy404 $ UniqueSharer shr + Entity p _ <- getBy404 $ UniquePersonIdent s + Entity r _ <- getBy404 $ UniqueProject rp s + return (p, r) + ((_result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid + defaultLayout $(widgetFile "project/collab/new") + +getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html +getProjectDevR shr rp dev = do + rl <- runDB $ do + rid <- do + Entity s _ <- getBy404 $ UniqueSharer shr + Entity r _ <- getBy404 $ UniqueProject rp s + return r + pid <- do + Entity s _ <- getBy404 $ UniqueSharer dev + Entity p _ <- getBy404 $ UniquePersonIdent s + return p + Entity _cid collab <- getBy404 $ UniqueProjectCollab rid pid + role <- getJust $ projectCollabRole collab + return $ projectRoleIdent role + defaultLayout $(widgetFile "project/collab/one") + +deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html +deleteProjectDevR shr rp dev = do + runDB $ do + rid <- do + Entity s _ <- getBy404 $ UniqueSharer shr + Entity r _ <- getBy404 $ UniqueProject rp s + return r + pid <- do + Entity s _ <- getBy404 $ UniqueSharer dev + Entity p _ <- getBy404 $ UniquePersonIdent s + return p + Entity cid _collab <- getBy404 $ UniqueProjectCollab rid pid + delete cid + setMessage "Collaborator removed." + redirect $ ProjectDevsR shr rp + +postProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html +postProjectDevR shr rp dev = do + mmethod <- lookupPostParam "_method" + case mmethod of + Just "DELETE" -> deleteProjectDevR shr rp dev + _ -> notFound diff --git a/src/Vervis/Handler/Role.hs b/src/Vervis/Handler/Role.hs index 675d9bf..323e653 100644 --- a/src/Vervis/Handler/Role.hs +++ b/src/Vervis/Handler/Role.hs @@ -23,6 +23,15 @@ module Vervis.Handler.Role , getRepoRoleOpsR , postRepoRoleOpsR , getRepoRoleOpNewR + , getProjectRolesR + , postProjectRolesR + , getProjectRoleNewR + , getProjectRoleR + , deleteProjectRoleR + , postProjectRoleR + , getProjectRoleOpsR + , postProjectRoleOpsR + , getProjectRoleOpNewR ) where @@ -135,3 +144,96 @@ getRepoRoleOpNewR rl = do let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl ((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid defaultLayout $(widgetFile "repo/role/op/new") + +getProjectRolesR :: Handler Html +getProjectRolesR = do + pid <- requireAuthId + roles <- runDB $ selectList [ProjectRolePerson ==. pid] [] + defaultLayout $(widgetFile "project/role/list") + +postProjectRolesR :: Handler Html +postProjectRolesR = do + pid <- requireAuthId + ((result, widget), enctype) <- runFormPost $ newProjectRoleForm pid + case result of + FormSuccess npr -> do + runDB $ do + let role = ProjectRole + { projectRoleIdent = nprIdent npr + , projectRolePerson = pid + , projectRoleDesc = nprDesc npr + } + insert_ role + redirect $ ProjectRolesR + FormMissing -> do + setMessage "Field(s) missing" + defaultLayout $(widgetFile "project/role/new") + FormFailure _l -> do + setMessage "Invalid input, see errors below" + defaultLayout $(widgetFile "project/role/new") + +getProjectRoleNewR :: Handler Html +getProjectRoleNewR = do + pid <- requireAuthId + ((_result, widget), enctype) <- runFormPost $ newProjectRoleForm pid + defaultLayout $(widgetFile "project/role/new") + +getProjectRoleR :: RlIdent -> Handler Html +getProjectRoleR rl = do + pid <- requireAuthId + Entity _rid role <- runDB $ getBy404 $ UniqueProjectRole pid rl + defaultLayout $(widgetFile "project/role/one") + +deleteProjectRoleR :: RlIdent -> Handler Html +deleteProjectRoleR rl = do + pid <- requireAuthId + runDB $ do + Entity rid _r <- getBy404 $ UniqueProjectRole pid rl + delete rid + setMessage "Role deleted." + redirect ProjectRolesR + +postProjectRoleR :: RlIdent -> Handler Html +postProjectRoleR rl = do + mmethod <- lookupPostParam "_method" + case mmethod of + Just "DELETE" -> deleteProjectRoleR rl + _ -> notFound + +getProjectRoleOpsR :: RlIdent -> Handler Html +getProjectRoleOpsR rl = do + pid <- requireAuthId + ops <- runDB $ do + Entity rid _r <- getBy404 $ UniqueProjectRole pid rl + as <- selectList [ProjectAccessRole ==. rid] [] + return $ map (projectAccessOp . entityVal) as + defaultLayout $(widgetFile "project/role/op/list") + +postProjectRoleOpsR :: RlIdent -> Handler Html +postProjectRoleOpsR rl = do + pid <- requireAuthId + let getrid = fmap entityKey $ getBy404 $ UniqueProjectRole pid rl + ((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid + case result of + FormSuccess op -> do + runDB $ do + rid <- getrid + let access = ProjectAccess + { projectAccessRole = rid + , projectAccessOp = op + } + insert_ access + redirect $ ProjectRoleOpsR rl + FormMissing -> do + setMessage "Field(s) missing" + defaultLayout $(widgetFile "project/role/op/new") + FormFailure _l -> do + setMessage "Invalid input, see errors below" + defaultLayout $(widgetFile "project/role/op/new") + +getProjectRoleOpNewR :: RlIdent -> Handler Html +getProjectRoleOpNewR rl = do + pid <- requireAuthId + let getrid = fmap entityKey $ getBy404 $ UniqueProjectRole pid rl + ((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid + defaultLayout $(widgetFile "project/role/op/new") diff --git a/templates/project/collab/list.hamlet b/templates/project/collab/list.hamlet new file mode 100644 index 0000000..fd54498 --- /dev/null +++ b/templates/project/collab/list.hamlet @@ -0,0 +1,22 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + + + + +
Collaborator + Role + $forall (Entity _sid sharer, Value rl) <- devs +
^{personLinkW sharer} + #{rl2text rl} diff --git a/templates/project/collab/new.hamlet b/templates/project/collab/new.hamlet new file mode 100644 index 0000000..839bca8 --- /dev/null +++ b/templates/project/collab/new.hamlet @@ -0,0 +1,17 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +
+ ^{widget} + diff --git a/templates/project/collab/one.hamlet b/templates/project/collab/one.hamlet new file mode 100644 index 0000000..d16edc6 --- /dev/null +++ b/templates/project/collab/one.hamlet @@ -0,0 +1,16 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +

+ Role: #{rl2text rl} diff --git a/templates/project/role/list.hamlet b/templates/project/role/list.hamlet new file mode 100644 index 0000000..a52b956 --- /dev/null +++ b/templates/project/role/list.hamlet @@ -0,0 +1,19 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +