sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 02:04:53 +09:00
Code Issues Activity

Roles now under by sharers, i.e. now groups too

Browse source
This commit is contained in:
fr33domlover 2016-06-06 17:29:54 +00:00
parent 05e0d837fa
commit f2e4bb4291
10 changed files with 127 additions and 119 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
config/models
View file

@ -55,10 +55,10 @@ GroupMember
RepoRole RepoRole
ident RlIdent ident RlIdent
person PersonId sharer SharerId
desc Text desc Text
UniqueRepoRole person ident UniqueRepoRole sharer ident
RepoAccess RepoAccess
role RepoRoleId role RepoRoleId
@ -75,10 +75,10 @@ RepoCollab
ProjectRole ProjectRole
ident RlIdent ident RlIdent
person PersonId sharer SharerId
desc Text desc Text
UniqueProjectRole person ident UniqueProjectRole sharer ident
ProjectAccess ProjectAccess
role ProjectRoleId role ProjectRoleId

6
src/Vervis/Field/Project.hs
View file

@ -39,15 +39,15 @@ checkTemplate =
in checkBool identOk msg in checkBool identOk msg
checkUniqueCI :: SharerId -> Field Handler PrjIdent -> Field Handler PrjIdent checkUniqueCI :: SharerId -> Field Handler PrjIdent -> Field Handler PrjIdent
checkUniqueCI sid = checkM $ \ ident -> do checkUniqueCI sid = checkM $ \ prj -> do
sames <- runDB $ select $ from $ \ project -> do sames <- runDB $ select $ from $ \ project -> do
where_ $ where_ $
project ^. ProjectSharer ==. val sid &&. project ^. ProjectSharer ==. val sid &&.
lower_ (project ^. ProjectIdent) ==. lower_ (val ident) lower_ (project ^. ProjectIdent) ==. lower_ (val prj)
limit 1 limit 1
return () return ()
return $ if null sames return $ if null sames
then Right ident then Right prj
else Left ("You already have a project by that name" :: Text) else Left ("You already have a project by that name" :: Text)
projectIdentField :: Field Handler PrjIdent projectIdentField :: Field Handler PrjIdent

27
src/Vervis/Field/Role.hs
View file

@ -23,10 +23,6 @@ where
import Prelude import Prelude
-- import Control.Monad (void)
-- import Control.Monad.Trans.Maybe
-- import Data.Char (isDigit)
-- import Data.Maybe (isNothing, isJust)
import Data.Text (Text) import Data.Text (Text)
import Database.Esqueleto import Database.Esqueleto
import Yesod.Form.Fields (textField, selectField, optionsEnum) import Yesod.Form.Fields (textField, selectField, optionsEnum)
@ -34,9 +30,6 @@ import Yesod.Form.Functions (checkM, convertField)
import Yesod.Form.Types (Field) import Yesod.Form.Types (Field)
import Yesod.Persist.Core (runDB) import Yesod.Persist.Core (runDB)
-- import qualified Data.Text as T (null, all, find, split)
-- import Data.Char.Local (isAsciiLetter)
import Vervis.Foundation (Handler, AppDB) import Vervis.Foundation (Handler, AppDB)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text, text2rl) import Vervis.Model.Ident (RlIdent, rl2text, text2rl)
@ -45,14 +38,14 @@ import Vervis.Model.Role
roleIdentField :: Field Handler RlIdent roleIdentField :: Field Handler RlIdent
roleIdentField = convertField text2rl rl2text textField roleIdentField = convertField text2rl rl2text textField
newRepoRoleIdentField :: PersonId -> Field Handler RlIdent newRepoRoleIdentField :: SharerId -> Field Handler RlIdent
newRepoRoleIdentField pid = checkUniqueCI pid roleIdentField newRepoRoleIdentField sid = checkUniqueCI roleIdentField
where where
checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent checkUniqueCI :: Field Handler RlIdent -> Field Handler RlIdent
checkUniqueCI pid = checkM $ \ rl -> do checkUniqueCI = checkM $ \ rl -> do
sames <- runDB $ select $ from $ \ role -> do sames <- runDB $ select $ from $ \ role -> do
where_ $ where_ $
role ^. RepoRolePerson ==. val pid &&. role ^. RepoRoleSharer ==. val sid &&.
lower_ (role ^. RepoRoleIdent) ==. lower_ (val rl) lower_ (role ^. RepoRoleIdent) ==. lower_ (val rl)
limit 1 limit 1
return () return ()
@ -78,14 +71,14 @@ newRepoOpField getrid = checkOpNew getrid opField
Nothing -> Right op Nothing -> Right op
Just _ -> Left ("Role already has this operation" :: Text) Just _ -> Left ("Role already has this operation" :: Text)
newProjectRoleIdentField :: PersonId -> Field Handler RlIdent newProjectRoleIdentField :: SharerId -> Field Handler RlIdent
newProjectRoleIdentField pid = checkUniqueCI pid roleIdentField newProjectRoleIdentField sid = checkUniqueCI roleIdentField
where where
checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent checkUniqueCI :: Field Handler RlIdent -> Field Handler RlIdent
checkUniqueCI pid = checkM $ \ rl -> do checkUniqueCI = checkM $ \ rl -> do
sames <- runDB $ select $ from $ \ role -> do sames <- runDB $ select $ from $ \ role -> do
where_ $ where_ $
role ^. ProjectRolePerson ==. val pid &&. role ^. ProjectRoleSharer ==. val sid &&.
lower_ (role ^. ProjectRoleIdent) ==. lower_ (val rl) lower_ (role ^. ProjectRoleIdent) ==. lower_ (val rl)
limit 1 limit 1
return () return ()

22
src/Vervis/Form/Project.hs
View file

@ -40,8 +40,8 @@ data NewProject = NewProject
, npRole :: ProjectRoleId , npRole :: ProjectRoleId
} }
newProjectAForm :: PersonId -> SharerId -> AForm Handler NewProject newProjectAForm :: SharerId -> AForm Handler NewProject
newProjectAForm pid sid = NewProject newProjectAForm sid = NewProject
<$> areq (newProjectIdentField sid) "Identifier*" Nothing <$> areq (newProjectIdentField sid) "Identifier*" Nothing
<*> aopt textField "Name" Nothing <*> aopt textField "Name" Nothing
<*> aopt textField "Description" Nothing <*> aopt textField "Description" Nothing
@ -49,11 +49,11 @@ newProjectAForm pid sid = NewProject
where where
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [ProjectRolePerson ==. pid] [] $ optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent rl2text . projectRoleIdent
newProjectForm :: PersonId -> SharerId -> Form NewProject newProjectForm :: SharerId -> Form NewProject
newProjectForm pid sid = renderDivs $ newProjectAForm pid sid newProjectForm sid = renderDivs $ newProjectAForm sid
data NewProjectCollab = NewProjectCollab data NewProjectCollab = NewProjectCollab
{ ncPerson :: PersonId { ncPerson :: PersonId
@ -61,8 +61,8 @@ data NewProjectCollab = NewProjectCollab
} }
newProjectCollabAForm newProjectCollabAForm
:: PersonId -> ProjectId -> AForm Handler NewProjectCollab :: SharerId -> ProjectId -> AForm Handler NewProjectCollab
newProjectCollabAForm pid rid = NewProjectCollab newProjectCollabAForm sid jid = NewProjectCollab
<$> areq selectPerson "Person*" Nothing <$> areq selectPerson "Person*" Nothing
<*> areq selectRole "Role*" Nothing <*> areq selectRole "Role*" Nothing
where where
@ -71,18 +71,18 @@ newProjectCollabAForm pid rid = NewProjectCollab
from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId on $ person ^. PersonIdent E.==. sharer ^. SharerId
on $ on $
collab ?. ProjectCollabProject E.==. just (val rid) &&. collab ?. ProjectCollabProject E.==. just (val jid) &&.
collab ?. ProjectCollabPerson E.==. just (person ^. PersonId) collab ?. ProjectCollabPerson E.==. just (person ^. PersonId)
where_ $ isNothing $ collab ?. ProjectCollabId where_ $ isNothing $ collab ?. ProjectCollabId
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (shr2text . unValue *** unValue) l optionsPairs $ map (shr2text . unValue *** unValue) l
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [ProjectRolePerson ==. pid] [] $ optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent rl2text . projectRoleIdent
newProjectCollabForm :: PersonId -> ProjectId -> Form NewProjectCollab newProjectCollabForm :: SharerId -> ProjectId -> Form NewProjectCollab
newProjectCollabForm pid rid = renderDivs $ newProjectCollabAForm pid rid newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid
editProjectAForm :: Entity Project -> AForm Handler Project editProjectAForm :: Entity Project -> AForm Handler Project
editProjectAForm (Entity jid project) = Project editProjectAForm (Entity jid project) = Project

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

@ -42,12 +42,11 @@ data NewRepo = NewRepo
, nrpRole :: RepoRoleId , nrpRole :: RepoRoleId
} }
newRepoAForm newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo
:: PersonId -> SharerId -> Maybe ProjectId -> AForm Handler NewRepo newRepoAForm sid mjid = NewRepo
newRepoAForm pid sid mpid = NewRepo
<$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing) <$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
<*> areq (selectFieldList vcsList) "Version control system*" Nothing <*> areq (selectFieldList vcsList) "Version control system*" Nothing
<*> aopt (selectProjectForNew sid) "Project" (Just mpid) <*> aopt (selectProjectForNew sid) "Project" (Just mjid)
<*> aopt textField "Description" Nothing <*> aopt textField "Description" Nothing
<*> areq selectRole "Your role*" Nothing <*> areq selectRole "Your role*" Nothing
where where
@ -58,11 +57,11 @@ newRepoAForm pid sid mpid = NewRepo
] ]
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [RepoRolePerson ==. pid] [] $ optionsPersistKey [RepoRoleSharer ==. sid] [] $
rl2text . repoRoleIdent rl2text . repoRoleIdent
newRepoForm :: PersonId -> SharerId -> Maybe ProjectId -> Form NewRepo newRepoForm :: SharerId -> Maybe ProjectId -> Form NewRepo
newRepoForm pid sid mpid = renderDivs $ newRepoAForm pid sid mpid newRepoForm sid mjid = renderDivs $ newRepoAForm sid mjid
data NewRepoCollab = NewRepoCollab data NewRepoCollab = NewRepoCollab
{ ncPerson :: PersonId { ncPerson :: PersonId
@ -70,8 +69,8 @@ data NewRepoCollab = NewRepoCollab
} }
newRepoCollabAForm newRepoCollabAForm
:: PersonId -> Maybe ProjectId -> RepoId -> AForm Handler NewRepoCollab :: SharerId -> Maybe ProjectId -> RepoId -> AForm Handler NewRepoCollab
newRepoCollabAForm pid mjid rid = NewRepoCollab newRepoCollabAForm sid mjid rid = NewRepoCollab
<$> areq (selectPerson mjid) "Person*" Nothing <$> areq (selectPerson mjid) "Person*" Nothing
<*> areq selectRole "Role*" Nothing <*> areq selectRole "Role*" Nothing
where where
@ -79,12 +78,12 @@ newRepoCollabAForm pid mjid rid = NewRepoCollab
selectPerson (Just jid) = selectCollabFromProject jid rid selectPerson (Just jid) = selectCollabFromProject jid rid
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [RepoRolePerson ==. pid] [] $ optionsPersistKey [RepoRoleSharer ==. sid] [] $
rl2text . repoRoleIdent rl2text . repoRoleIdent
newRepoCollabForm newRepoCollabForm
:: PersonId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab :: SharerId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab
newRepoCollabForm pid mjid rid = renderDivs $ newRepoCollabAForm pid mjid rid newRepoCollabForm sid mjid rid = renderDivs $ newRepoCollabAForm sid mjid rid
editRepoAForm :: Entity Repo -> AForm Handler Repo editRepoAForm :: Entity Repo -> AForm Handler Repo
editRepoAForm (Entity rid repo) = Repo editRepoAForm (Entity rid repo) = Repo

20
src/Vervis/Form/Role.hs
View file

@ -41,13 +41,13 @@ data NewRepoRole = NewRepoRole
, nrrDesc :: Text , nrrDesc :: Text
} }
newRepoRoleAForm :: PersonId -> AForm Handler NewRepoRole newRepoRoleAForm :: SharerId -> AForm Handler NewRepoRole
newRepoRoleAForm pid = NewRepoRole newRepoRoleAForm sid = NewRepoRole
<$> areq (newRepoRoleIdentField pid) "Name*" Nothing <$> areq (newRepoRoleIdentField sid) "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description" Nothing
newRepoRoleForm :: PersonId -> Form NewRepoRole newRepoRoleForm :: SharerId -> Form NewRepoRole
newRepoRoleForm pid = renderDivs $ newRepoRoleAForm pid newRepoRoleForm sid = renderDivs $ newRepoRoleAForm sid
newRepoRoleOpAForm :: AppDB RepoRoleId -> AForm Handler RepoOperation newRepoRoleOpAForm :: AppDB RepoRoleId -> AForm Handler RepoOperation
newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing
@ -60,13 +60,13 @@ data NewProjectRole = NewProjectRole
, nprDesc :: Text , nprDesc :: Text
} }
newProjectRoleAForm :: PersonId -> AForm Handler NewProjectRole newProjectRoleAForm :: SharerId -> AForm Handler NewProjectRole
newProjectRoleAForm pid = NewProjectRole newProjectRoleAForm sid = NewProjectRole
<$> areq (newProjectRoleIdentField pid) "Name*" Nothing <$> areq (newProjectRoleIdentField sid) "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description" Nothing
newProjectRoleForm :: PersonId -> Form NewProjectRole newProjectRoleForm :: SharerId -> Form NewProjectRole
newProjectRoleForm pid = renderDivs $ newProjectRoleAForm pid newProjectRoleForm sid = renderDivs $ newProjectRoleAForm sid
newProjectRoleOpAForm :: AppDB ProjectRoleId -> AForm Handler ProjectOperation newProjectRoleOpAForm :: AppDB ProjectRoleId -> AForm Handler ProjectOperation
newProjectRoleOpAForm getrid = newProjectRoleOpAForm getrid =

43
src/Vervis/Handler/Project.hs
View file

@ -66,11 +66,11 @@ getProjectsR ident = do
postProjectsR :: ShrIdent -> Handler Html postProjectsR :: ShrIdent -> Handler Html
postProjectsR shr = do postProjectsR shr = do
pid <- requireAuthId
Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
((result, widget), enctype) <- runFormPost $ newProjectForm pid sid ((result, widget), enctype) <- runFormPost $ newProjectForm sid
case result of case result of
FormSuccess np -> do FormSuccess np -> do
pid <- requireAuthId
runDB $ do runDB $ do
let project = Project let project = Project
{ projectIdent = npIdent np { projectIdent = npIdent np
@ -98,9 +98,8 @@ postProjectsR shr = do
getProjectNewR :: ShrIdent -> Handler Html getProjectNewR :: ShrIdent -> Handler Html
getProjectNewR shr = do getProjectNewR shr = do
pid <- requireAuthId
Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
((_result, widget), enctype) <- runFormPost $ newProjectForm pid sid ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
defaultLayout $(widgetFile "project/new") defaultLayout $(widgetFile "project/new")
getProjectR :: ShrIdent -> PrjIdent -> Handler Html getProjectR :: ShrIdent -> PrjIdent -> Handler Html
@ -163,17 +162,16 @@ getProjectDevsR shr rp = do
postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectDevsR shr rp = do postProjectDevsR shr rp = do
(pid, rid) <- runDB $ do (sid, jid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniquePersonIdent s Entity j _ <- getBy404 $ UniqueProject rp s
Entity r _ <- getBy404 $ UniqueProject rp s return (s, j)
return (p, r) ((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
((result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid
case result of case result of
FormSuccess nc -> do FormSuccess nc -> do
runDB $ do runDB $ do
let collab = ProjectCollab let collab = ProjectCollab
{ projectCollabProject = rid { projectCollabProject = jid
, projectCollabPerson = ncPerson nc , projectCollabPerson = ncPerson nc
, projectCollabRole = ncRole nc , projectCollabRole = ncRole nc
} }
@ -189,26 +187,25 @@ postProjectDevsR shr rp = do
getProjectDevNewR :: ShrIdent -> PrjIdent -> Handler Html getProjectDevNewR :: ShrIdent -> PrjIdent -> Handler Html
getProjectDevNewR shr rp = do getProjectDevNewR shr rp = do
(pid, rid) <- runDB $ do (sid, jid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniquePersonIdent s Entity j _ <- getBy404 $ UniqueProject rp s
Entity r _ <- getBy404 $ UniqueProject rp s return (s, j)
return (p, r) ((_result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
((_result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid
defaultLayout $(widgetFile "project/collab/new") defaultLayout $(widgetFile "project/collab/new")
getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
getProjectDevR shr rp dev = do getProjectDevR shr rp dev = do
rl <- runDB $ do rl <- runDB $ do
rid <- do jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueProject rp s Entity j _ <- getBy404 $ UniqueProject rp s
return r return j
pid <- do pid <- do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity _cid collab <- getBy404 $ UniqueProjectCollab rid pid Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid
role <- getJust $ projectCollabRole collab role <- getJust $ projectCollabRole collab
return $ projectRoleIdent role return $ projectRoleIdent role
defaultLayout $(widgetFile "project/collab/one") defaultLayout $(widgetFile "project/collab/one")
@ -216,15 +213,15 @@ getProjectDevR shr rp dev = do
deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
deleteProjectDevR shr rp dev = do deleteProjectDevR shr rp dev = do
runDB $ do runDB $ do
rid <- do jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueProject rp s Entity j _ <- getBy404 $ UniqueProject rp s
return r return j
pid <- do pid <- do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity cid _collab <- getBy404 $ UniqueProjectCollab rid pid Entity cid _collab <- getBy404 $ UniqueProjectCollab jid pid
delete cid delete cid
setMessage "Collaborator removed." setMessage "Collaborator removed."
redirect $ ProjectDevsR shr rp redirect $ ProjectDevsR shr rp

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

@ -113,9 +113,8 @@ getReposR user = do
postReposR :: ShrIdent -> Handler Html postReposR :: ShrIdent -> Handler Html
postReposR user = do postReposR user = do
Entity pid person <- requireAuth
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
((result, widget), enctype) <- runFormPost $ newRepoForm pid sid Nothing ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
case result of case result of
FormSuccess nrp -> do FormSuccess nrp -> do
parent <- askSharerDir user parent <- askSharerDir user
@ -126,6 +125,7 @@ postReposR user = do
case nrpVcs nrp of case nrpVcs nrp of
VCSDarcs -> D.createRepo parent repoName VCSDarcs -> D.createRepo parent repoName
VCSGit -> G.createRepo parent repoName VCSGit -> G.createRepo parent repoName
Entity pid person <- requireAuth
runDB $ do runDB $ do
let repo = Repo let repo = Repo
{ repoIdent = nrpIdent nrp { repoIdent = nrpIdent nrp
@ -153,9 +153,8 @@ postReposR user = do
getRepoNewR :: ShrIdent -> Handler Html getRepoNewR :: ShrIdent -> Handler Html
getRepoNewR user = do getRepoNewR user = do
Entity pid person <- requireAuth
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
((_result, widget), enctype) <- runFormPost $ newRepoForm pid sid Nothing ((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
defaultLayout $(widgetFile "repo/new") defaultLayout $(widgetFile "repo/new")
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
@ -278,12 +277,11 @@ getRepoDevsR shr rp = do
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
postRepoDevsR shr rp = do postRepoDevsR shr rp = do
(pid, mjid, rid) <- runDB $ do (sid, mjid, rid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniquePersonIdent s
Entity r repository <- getBy404 $ UniqueRepo rp s Entity r repository <- getBy404 $ UniqueRepo rp s
return (p, repoProject repository, r) return (s, repoProject repository, r)
((result, widget), enctype) <- runFormPost $ newRepoCollabForm pid mjid rid ((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid
case result of case result of
FormSuccess nc -> do FormSuccess nc -> do
runDB $ do runDB $ do
@ -304,13 +302,12 @@ postRepoDevsR shr rp = do
getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html
getRepoDevNewR shr rp = do getRepoDevNewR shr rp = do
(pid, mjid, rid) <- runDB $ do (sid, mjid, rid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniquePersonIdent s
Entity r repository <- getBy404 $ UniqueRepo rp s Entity r repository <- getBy404 $ UniqueRepo rp s
return (p, repoProject repository, r) return (s, repoProject repository, r)
((_result, widget), enctype) <- ((_result, widget), enctype) <-
runFormPost $ newRepoCollabForm pid mjid rid runFormPost $ newRepoCollabForm sid mjid rid
defaultLayout $(widgetFile "repo/collab/new") defaultLayout $(widgetFile "repo/collab/new")
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html

60
src/Vervis/Handler/Role.hs
View file

@ -55,19 +55,22 @@ import Vervis.Settings (widgetFile)
getRepoRolesR :: Handler Html getRepoRolesR :: Handler Html
getRepoRolesR = do getRepoRolesR = do
pid <- requireAuthId pid <- requireAuthId
roles <- runDB $ selectList [RepoRolePerson ==. pid] [] roles <- runDB $ do
person <- getJust pid
selectList [RepoRoleSharer ==. personIdent person] []
defaultLayout $(widgetFile "repo/role/list") defaultLayout $(widgetFile "repo/role/list")
postRepoRolesR :: Handler Html postRepoRolesR :: Handler Html
postRepoRolesR = do postRepoRolesR = do
pid <- requireAuthId pid <- requireAuthId
((result, widget), enctype) <- runFormPost $ newRepoRoleForm pid sid <- fmap personIdent $ runDB $ getJust pid
((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
case result of case result of
FormSuccess nrr -> do FormSuccess nrr -> do
runDB $ do runDB $ do
let role = RepoRole let role = RepoRole
{ repoRoleIdent = nrrIdent nrr { repoRoleIdent = nrrIdent nrr
, repoRolePerson = pid , repoRoleSharer = sid
, repoRoleDesc = nrrDesc nrr , repoRoleDesc = nrrDesc nrr
} }
insert_ role insert_ role
@ -82,20 +85,24 @@ postRepoRolesR = do
getRepoRoleNewR :: Handler Html getRepoRoleNewR :: Handler Html
getRepoRoleNewR = do getRepoRoleNewR = do
pid <- requireAuthId pid <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm pid sid <- fmap personIdent $ runDB $ getJust pid
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
defaultLayout $(widgetFile "repo/role/new") defaultLayout $(widgetFile "repo/role/new")
getRepoRoleR :: RlIdent -> Handler Html getRepoRoleR :: RlIdent -> Handler Html
getRepoRoleR rl = do getRepoRoleR rl = do
pid <- requireAuthId pid <- requireAuthId
Entity _rid role <- runDB $ getBy404 $ UniqueRepoRole pid rl sid <- fmap personIdent $ runDB $ getJust pid
Entity _rid role <- runDB $ getBy404 $ UniqueRepoRole sid rl
defaultLayout $(widgetFile "repo/role/one") defaultLayout $(widgetFile "repo/role/one")
deleteRepoRoleR :: RlIdent -> Handler Html deleteRepoRoleR :: RlIdent -> Handler Html
deleteRepoRoleR rl = do deleteRepoRoleR rl = do
pid <- requireAuthId pid <- requireAuthId
runDB $ do runDB $ do
Entity rid _r <- getBy404 $ UniqueRepoRole pid rl person <- getJust pid
let sid = personIdent person
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
delete rid delete rid
setMessage "Role deleted." setMessage "Role deleted."
redirect RepoRolesR redirect RepoRolesR
@ -111,7 +118,8 @@ getRepoRoleOpsR :: RlIdent -> Handler Html
getRepoRoleOpsR rl = do getRepoRoleOpsR rl = do
pid <- requireAuthId pid <- requireAuthId
ops <- runDB $ do ops <- runDB $ do
Entity rid _r <- getBy404 $ UniqueRepoRole pid rl sid <- personIdent <$> getJust pid
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
as <- selectList [RepoAccessRole ==. rid] [] as <- selectList [RepoAccessRole ==. rid] []
return $ map (repoAccessOp . entityVal) as return $ map (repoAccessOp . entityVal) as
defaultLayout $(widgetFile "repo/role/op/list") defaultLayout $(widgetFile "repo/role/op/list")
@ -119,7 +127,9 @@ getRepoRoleOpsR rl = do
postRepoRoleOpsR :: RlIdent -> Handler Html postRepoRoleOpsR :: RlIdent -> Handler Html
postRepoRoleOpsR rl = do postRepoRoleOpsR rl = do
pid <- requireAuthId pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl let getrid = do
sid <- personIdent <$> getJust pid
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid ((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of case result of
FormSuccess op -> do FormSuccess op -> do
@ -141,26 +151,31 @@ postRepoRoleOpsR rl = do
getRepoRoleOpNewR :: RlIdent -> Handler Html getRepoRoleOpNewR :: RlIdent -> Handler Html
getRepoRoleOpNewR rl = do getRepoRoleOpNewR rl = do
pid <- requireAuthId pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl let getrid = do
sid <- personIdent <$> getJust pid
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid ((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new") defaultLayout $(widgetFile "repo/role/op/new")
getProjectRolesR :: Handler Html getProjectRolesR :: Handler Html
getProjectRolesR = do getProjectRolesR = do
pid <- requireAuthId pid <- requireAuthId
roles <- runDB $ selectList [ProjectRolePerson ==. pid] [] roles <- runDB $ do
person <- getJust pid
selectList [ProjectRoleSharer ==. personIdent person] []
defaultLayout $(widgetFile "project/role/list") defaultLayout $(widgetFile "project/role/list")
postProjectRolesR :: Handler Html postProjectRolesR :: Handler Html
postProjectRolesR = do postProjectRolesR = do
pid <- requireAuthId pid <- requireAuthId
((result, widget), enctype) <- runFormPost $ newProjectRoleForm pid sid <- fmap personIdent $ runDB $ getJust pid
((result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
case result of case result of
FormSuccess npr -> do FormSuccess npr -> do
runDB $ do runDB $ do
let role = ProjectRole let role = ProjectRole
{ projectRoleIdent = nprIdent npr { projectRoleIdent = nprIdent npr
, projectRolePerson = pid , projectRoleSharer = sid
, projectRoleDesc = nprDesc npr , projectRoleDesc = nprDesc npr
} }
insert_ role insert_ role
@ -175,20 +190,24 @@ postProjectRolesR = do
getProjectRoleNewR :: Handler Html getProjectRoleNewR :: Handler Html
getProjectRoleNewR = do getProjectRoleNewR = do
pid <- requireAuthId pid <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newProjectRoleForm pid sid <- fmap personIdent $ runDB $ getJust pid
((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
defaultLayout $(widgetFile "project/role/new") defaultLayout $(widgetFile "project/role/new")
getProjectRoleR :: RlIdent -> Handler Html getProjectRoleR :: RlIdent -> Handler Html
getProjectRoleR rl = do getProjectRoleR rl = do
pid <- requireAuthId pid <- requireAuthId
Entity _rid role <- runDB $ getBy404 $ UniqueProjectRole pid rl Entity _rid role <- runDB $ do
sid <- personIdent <$> getJust pid
getBy404 $ UniqueProjectRole sid rl
defaultLayout $(widgetFile "project/role/one") defaultLayout $(widgetFile "project/role/one")
deleteProjectRoleR :: RlIdent -> Handler Html deleteProjectRoleR :: RlIdent -> Handler Html
deleteProjectRoleR rl = do deleteProjectRoleR rl = do
pid <- requireAuthId pid <- requireAuthId
runDB $ do runDB $ do
Entity rid _r <- getBy404 $ UniqueProjectRole pid rl sid <- personIdent <$> getJust pid
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
delete rid delete rid
setMessage "Role deleted." setMessage "Role deleted."
redirect ProjectRolesR redirect ProjectRolesR
@ -204,7 +223,8 @@ getProjectRoleOpsR :: RlIdent -> Handler Html
getProjectRoleOpsR rl = do getProjectRoleOpsR rl = do
pid <- requireAuthId pid <- requireAuthId
ops <- runDB $ do ops <- runDB $ do
Entity rid _r <- getBy404 $ UniqueProjectRole pid rl sid <- personIdent <$> getJust pid
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
as <- selectList [ProjectAccessRole ==. rid] [] as <- selectList [ProjectAccessRole ==. rid] []
return $ map (projectAccessOp . entityVal) as return $ map (projectAccessOp . entityVal) as
defaultLayout $(widgetFile "project/role/op/list") defaultLayout $(widgetFile "project/role/op/list")
@ -212,7 +232,9 @@ getProjectRoleOpsR rl = do
postProjectRoleOpsR :: RlIdent -> Handler Html postProjectRoleOpsR :: RlIdent -> Handler Html
postProjectRoleOpsR rl = do postProjectRoleOpsR rl = do
pid <- requireAuthId pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueProjectRole pid rl let getrid = do
sid <- personIdent <$> getJust pid
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid ((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
case result of case result of
FormSuccess op -> do FormSuccess op -> do
@ -234,6 +256,8 @@ postProjectRoleOpsR rl = do
getProjectRoleOpNewR :: RlIdent -> Handler Html getProjectRoleOpNewR :: RlIdent -> Handler Html
getProjectRoleOpNewR rl = do getProjectRoleOpNewR rl = do
pid <- requireAuthId pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueProjectRole pid rl let getrid = do
sid <- personIdent <$> getJust pid
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid ((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
defaultLayout $(widgetFile "project/role/op/new") defaultLayout $(widgetFile "project/role/op/new")

2
templates/repo/new.hamlet
View file

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