forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Make all role-related code repo-specific

Browse source
This commit is contained in:
fr33domlover 2016-06-01 07:35:22 +00:00
parent 13bf3e1953
commit 10c27464dd
15 changed files with 188 additions and 177 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
config/models
View file

@ -53,25 +53,25 @@ GroupMember
UniqueGroupMember person group
Role
RepoRole
ident RlIdent
person PersonId
desc Text
UniqueRole person ident
UniqueRepoRole person ident
Access
role RoleId
op Operation
RepoAccess
role RepoRoleId
op RepoOperation
UniqueAccess role op
UniqueRepoAccess role op
Collab
RepoCollab
repo RepoId
person PersonId
role RoleId
role RepoRoleId
UniqueCollab repo person
UniqueRepoCollab repo person
-------------------------------------------------------------------------------
-- Projects

10
config/routes
View file

@ -50,11 +50,11 @@
/k/!new KeyNewR GET
/k/#KyIdent KeyR GET DELETE POST
/r RolesR GET POST
/r/!new RoleNewR GET
/r/#RlIdent RoleR GET DELETE POST
/r/#RlIdent/a RoleOpsR GET POST
/r/#RlIdent/a/!new RoleOpNewR GET
/rr RepoRolesR GET POST
/rr/!new RepoRoleNewR GET
/rr/#RlIdent RepoRoleR GET DELETE POST
/rr/#RlIdent/a RepoRoleOpsR GET POST
/rr/#RlIdent/a/!new RepoRoleOpNewR GET
-- ----------------------------------------------------------------------------
-- Projects

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

@ -14,8 +14,8 @@
-}
module Vervis.Field.Role
( newRoleIdentField
, newOpField
( newRepoRoleIdentField
, newRepoOpField
)
where
@ -40,36 +40,38 @@ import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text, text2rl)
import Vervis.Model.Role
checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent
checkUniqueCI pid = checkM $ \ rl -> do
sames <- runDB $ select $ from $ \ role -> do
where_ $
role ^. RolePerson ==. val pid &&.
lower_ (role ^. RoleIdent) ==. lower_ (val rl)
limit 1
return ()
return $ if null sames
then Right rl
else Left ("This role name is already in use" :: Text)
newRepoRoleIdentField :: PersonId -> Field Handler RlIdent
newRepoRoleIdentField pid = checkUniqueCI pid roleIdentField
where
roleIdentField :: Field Handler RlIdent
roleIdentField = convertField text2rl rl2text textField
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
where_ $
role ^. RepoRolePerson ==. val pid &&.
lower_ (role ^. RepoRoleIdent) ==. lower_ (val rl)
limit 1
return ()
return $ if null sames
then Right rl
else Left ("This role name is already in use" :: Text)
newRoleIdentField :: PersonId -> Field Handler RlIdent
newRoleIdentField pid = checkUniqueCI pid roleIdentField
newRepoOpField :: AppDB RepoRoleId -> Field Handler RepoOperation
newRepoOpField getrid = checkOpNew getrid opField
where
opField :: Field Handler RepoOperation
opField = selectField optionsEnum
opField :: Field Handler Operation
opField = selectField optionsEnum
checkOpNew
:: AppDB RoleId -> Field Handler Operation -> Field Handler Operation
checkOpNew getrid = checkM $ \ op -> do
ma <- runDB $ do
rid <- getrid
getBy $ UniqueAccess rid op
return $ case ma of
Nothing -> Right op
Just _ -> Left ("Role already has this operation" :: Text)
newOpField :: AppDB RoleId -> Field Handler Operation
newOpField getrid = checkOpNew getrid opField
checkOpNew
:: AppDB RepoRoleId
-> Field Handler RepoOperation
-> Field Handler RepoOperation
checkOpNew getrid = checkM $ \ op -> do
ma <- runDB $ do
rid <- getrid
getBy $ UniqueRepoAccess rid op
return $ case ma of
Nothing -> Right op
Just _ -> Left ("Role already has this operation" :: Text)

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

@ -16,8 +16,8 @@
module Vervis.Form.Repo
( NewRepo (..)
, newRepoForm
, NewCollab (..)
, newCollabForm
, NewRepoCollab (..)
, newRepoCollabForm
)
where
@ -38,7 +38,7 @@ data NewRepo = NewRepo
, nrpVcs :: VersionControlSystem
, nrpProj :: Maybe ProjectId
, nrpDesc :: Maybe Text
, nrpRole :: RoleId
, nrpRole :: RepoRoleId
}
newRepoAForm
@ -61,19 +61,19 @@ newRepoAForm pid sid mpid = NewRepo
prj2text . projectIdent
selectRole =
selectField $
optionsPersistKey [RolePerson ==. pid] [] $
rl2text . roleIdent
optionsPersistKey [RepoRolePerson ==. pid] [] $
rl2text . repoRoleIdent
newRepoForm :: PersonId -> SharerId -> Maybe ProjectId -> Form NewRepo
newRepoForm pid sid mpid = renderDivs $ newRepoAForm pid sid mpid
data NewCollab = NewCollab
data NewRepoCollab = NewRepoCollab
{ ncPerson :: PersonId
, ncRole :: RoleId
, ncRole :: RepoRoleId
}
newCollabAForm :: PersonId -> RepoId -> AForm Handler NewCollab
newCollabAForm pid rid = NewCollab
newRepoCollabAForm :: PersonId -> RepoId -> AForm Handler NewRepoCollab
newRepoCollabAForm pid rid = NewRepoCollab
<$> areq selectPerson "Person*" Nothing
<*> areq selectRole "Role*" Nothing
where
@ -82,15 +82,15 @@ newCollabAForm pid rid = NewCollab
from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId
on $
collab ?. CollabRepo E.==. just (val rid) &&.
collab ?. CollabPerson E.==. just (person ^. PersonId)
where_ $ isNothing $ collab ?. CollabId
collab ?. RepoCollabRepo E.==. just (val rid) &&.
collab ?. RepoCollabPerson E.==. just (person ^. PersonId)
where_ $ isNothing $ collab ?. RepoCollabId
return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (shr2text . unValue *** unValue) l
selectRole =
selectField $
optionsPersistKey [RolePerson ==. pid] [] $
rl2text . roleIdent
optionsPersistKey [RepoRolePerson ==. pid] [] $
rl2text . repoRoleIdent
newCollabForm :: PersonId -> RepoId -> Form NewCollab
newCollabForm pid rid = renderDivs $ newCollabAForm pid rid
newRepoCollabForm :: PersonId -> RepoId -> Form NewRepoCollab
newRepoCollabForm pid rid = renderDivs $ newRepoCollabAForm pid rid

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

@ -14,9 +14,9 @@
-}
module Vervis.Form.Role
( NewRole (..)
, newRoleForm
, newRoleOpForm
( NewRepoRole (..)
, newRepoRoleForm
, newRepoRoleOpForm
)
where
@ -33,21 +33,21 @@ import Vervis.Model
import Vervis.Model.Ident (RlIdent)
import Vervis.Model.Role
data NewRole = NewRole
{ nrIdent :: RlIdent
, nrDesc :: Text
data NewRepoRole = NewRepoRole
{ nrrIdent :: RlIdent
, nrrDesc :: Text
}
newRoleAForm :: PersonId -> AForm Handler NewRole
newRoleAForm pid = NewRole
<$> areq (newRoleIdentField pid) "Name*" Nothing
<*> areq textField "Description" Nothing
newRepoRoleAForm :: PersonId -> AForm Handler NewRepoRole
newRepoRoleAForm pid = NewRepoRole
<$> areq (newRepoRoleIdentField pid) "Name*" Nothing
<*> areq textField "Description" Nothing
newRoleForm :: PersonId -> Form NewRole
newRoleForm pid = renderDivs $ newRoleAForm pid
newRepoRoleForm :: PersonId -> Form NewRepoRole
newRepoRoleForm pid = renderDivs $ newRepoRoleAForm pid
newRoleOpAForm :: AppDB RoleId -> AForm Handler Operation
newRoleOpAForm getrid = areq (newOpField getrid) "Operation*" Nothing
newRepoRoleOpAForm :: AppDB RepoRoleId -> AForm Handler RepoOperation
newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing
newRoleOpForm :: AppDB RoleId -> Form Operation
newRoleOpForm getrid = renderDivs $ newRoleOpAForm getrid
newRepoRoleOpForm :: AppDB RepoRoleId -> Form RepoOperation
newRepoRoleOpForm getrid = renderDivs $ newRepoRoleOpAForm getrid

20
src/Vervis/Foundation.hs
View file

@ -129,11 +129,11 @@ instance Yesod App where
(KeyR _key , _ ) -> personAny
(KeyNewR , _ ) -> personAny
(RolesR , _ ) -> personAny
(RoleNewR , _ ) -> personAny
(RoleR _rl , _ ) -> personAny
(RoleOpsR _rl , _ ) -> personAny
(RoleOpNewR _rl , _ ) -> personAny
(RepoRolesR , _ ) -> personAny
(RepoRoleNewR , _ ) -> personAny
(RepoRoleR _rl , _ ) -> personAny
(RepoRoleOpsR _rl , _ ) -> personAny
(RepoRoleOpNewR _rl , _ ) -> personAny
(ReposR shar , True) -> person shar
(RepoNewR user , _ ) -> person user
@ -301,11 +301,11 @@ instance YesodBreadcrumbs App where
KeyNewR -> ("New", Just KeysR)
KeyR key -> (ky2text key, Just KeysR)
RolesR -> ("Roles", Just HomeR)
RoleNewR -> ("New", Just RolesR)
RoleR rl -> (rl2text rl, Just RolesR)
RoleOpsR rl -> ("Operations", Just $ RoleR rl)
RoleOpNewR rl -> ("New", Just $ RoleOpsR rl)
RepoRolesR -> ("Repo Roles", Just HomeR)
RepoRoleNewR -> ("New", Just RepoRolesR)
RepoRoleR rl -> (rl2text rl, Just RepoRolesR)
RepoRoleOpsR rl -> ("Operations", Just $ RepoRoleR rl)
RepoRoleOpNewR rl -> ("New", Just $ RepoRoleOpsR rl)
ReposR shar -> ("Repos", Just $ PersonR shar)
RepoNewR shar -> ("New", Just $ ReposR shar)

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

@ -133,10 +133,10 @@ postReposR user = do
, repoMainBranch = "master"
}
rid <- insert repo
let collab = Collab
{ collabRepo = rid
, collabPerson = pid
, collabRole = nrpRole nrp
let collab = RepoCollab
{ repoCollabRepo = rid
, repoCollabPerson = pid
, repoCollabRole = nrpRole nrp
}
insert_ collab
setMessage "Repo added."
@ -228,11 +228,11 @@ getRepoDevsR shr rp = do
return r
select $ from $ \ (collab, person, sharer, role) -> do
where_ $
collab ^. CollabRepo ==. val rid &&.
collab ^. CollabPerson ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId &&.
collab ^. CollabRole ==. role ^. RoleId
return (sharer, role ^. RoleIdent)
collab ^. RepoCollabRepo ==. val rid &&.
collab ^. RepoCollabPerson ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId &&.
collab ^. RepoCollabRole ==. role ^. RepoRoleId
return (sharer, role ^. RepoRoleIdent)
defaultLayout $(widgetFile "repo/collab/list")
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
@ -242,14 +242,14 @@ postRepoDevsR shr rp = do
Entity p _ <- getBy404 $ UniquePersonIdent s
Entity r _ <- getBy404 $ UniqueRepo rp s
return (p, r)
((result, widget), enctype) <- runFormPost $ newCollabForm pid rid
((result, widget), enctype) <- runFormPost $ newRepoCollabForm pid rid
case result of
FormSuccess nc -> do
runDB $ do
let collab = Collab
{ collabRepo = rid
, collabPerson = ncPerson nc
, collabRole = ncRole nc
let collab = RepoCollab
{ repoCollabRepo = rid
, repoCollabPerson = ncPerson nc
, repoCollabRole = ncRole nc
}
insert_ collab
setMessage "Collaborator added."
@ -268,7 +268,7 @@ getRepoDevNewR shr rp = do
Entity p _ <- getBy404 $ UniquePersonIdent s
Entity r _ <- getBy404 $ UniqueRepo rp s
return (p, r)
((_result, widget), enctype) <- runFormPost $ newCollabForm pid rid
((_result, widget), enctype) <- runFormPost $ newRepoCollabForm pid rid
defaultLayout $(widgetFile "repo/collab/new")
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
@ -282,9 +282,9 @@ getRepoDevR shr rp dev = do
Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
Entity _cid collab <- getBy404 $ UniqueCollab rid pid
role <- getJust $ collabRole collab
return $ roleIdent role
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid
role <- getJust $ repoCollabRole collab
return $ repoRoleIdent role
defaultLayout $(widgetFile "repo/collab/one")
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
@ -298,7 +298,7 @@ deleteRepoDevR shr rp dev = do
Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
Entity cid _collab <- getBy404 $ UniqueCollab rid pid
Entity cid _collab <- getBy404 $ UniqueRepoCollab rid pid
delete cid
setMessage "Collaborator removed."
redirect $ RepoDevsR shr rp

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

@ -14,15 +14,15 @@
-}
module Vervis.Handler.Role
( getRolesR
, postRolesR
, getRoleNewR
, getRoleR
, deleteRoleR
, postRoleR
, getRoleOpsR
, postRoleOpsR
, getRoleOpNewR
( getRepoRolesR
, postRepoRolesR
, getRepoRoleNewR
, getRepoRoleR
, deleteRepoRoleR
, postRepoRoleR
, getRepoRoleOpsR
, postRepoRoleOpsR
, getRepoRoleOpNewR
)
where
@ -43,94 +43,95 @@ import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text)
import Vervis.Settings (widgetFile)
getRolesR :: Handler Html
getRolesR = do
getRepoRolesR :: Handler Html
getRepoRolesR = do
pid <- requireAuthId
roles <- runDB $ selectList [RolePerson ==. pid] []
defaultLayout $(widgetFile "role/list")
roles <- runDB $ selectList [RepoRolePerson ==. pid] []
defaultLayout $(widgetFile "repo/role/list")
postRolesR :: Handler Html
postRolesR = do
postRepoRolesR :: Handler Html
postRepoRolesR = do
pid <- requireAuthId
((result, widget), enctype) <- runFormPost $ newRoleForm pid
((result, widget), enctype) <- runFormPost $ newRepoRoleForm pid
case result of
FormSuccess nr -> do
FormSuccess nrr -> do
runDB $ do
let role = Role
{ roleIdent = nrIdent nr
, rolePerson = pid
, roleDesc = nrDesc nr
let role = RepoRole
{ repoRoleIdent = nrrIdent nrr
, repoRolePerson = pid
, repoRoleDesc = nrrDesc nrr
}
insert_ role
redirect $ RolesR
redirect $ RepoRolesR
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "role/new")
defaultLayout $(widgetFile "repo/role/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "role/new")
defaultLayout $(widgetFile "repo/role/new")
getRoleNewR :: Handler Html
getRoleNewR = do
getRepoRoleNewR :: Handler Html
getRepoRoleNewR = do
pid <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newRoleForm pid
defaultLayout $(widgetFile "role/new")
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm pid
defaultLayout $(widgetFile "repo/role/new")
getRoleR :: RlIdent -> Handler Html
getRoleR rl = do
getRepoRoleR :: RlIdent -> Handler Html
getRepoRoleR rl = do
pid <- requireAuthId
Entity _rid role <- runDB $ getBy404 $ UniqueRole pid rl
defaultLayout $(widgetFile "role/one")
Entity _rid role <- runDB $ getBy404 $ UniqueRepoRole pid rl
defaultLayout $(widgetFile "repo/role/one")
deleteRoleR :: RlIdent -> Handler Html
deleteRoleR rl = do
deleteRepoRoleR :: RlIdent -> Handler Html
deleteRepoRoleR rl = do
pid <- requireAuthId
runDB $ do
Entity rid _r <- getBy404 $ UniqueRole pid rl
Entity rid _r <- getBy404 $ UniqueRepoRole pid rl
delete rid
setMessage "Role deleted."
redirect RolesR
redirect RepoRolesR
postRoleR :: RlIdent -> Handler Html
postRoleR rl = do
postRepoRoleR :: RlIdent -> Handler Html
postRepoRoleR rl = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteRoleR rl
Just "DELETE" -> deleteRepoRoleR rl
_ -> notFound
getRoleOpsR :: RlIdent -> Handler Html
getRoleOpsR rl = do
getRepoRoleOpsR :: RlIdent -> Handler Html
getRepoRoleOpsR rl = do
pid <- requireAuthId
ops <- runDB $ do
Entity rid _r <- getBy404 $ UniqueRole pid rl
map (accessOp . entityVal) <$> selectList [AccessRole ==. rid] []
defaultLayout $(widgetFile "role/op/list")
Entity rid _r <- getBy404 $ UniqueRepoRole pid rl
as <- selectList [RepoAccessRole ==. rid] []
return $ map (repoAccessOp . entityVal) as
defaultLayout $(widgetFile "repo/role/op/list")
postRoleOpsR :: RlIdent -> Handler Html
postRoleOpsR rl = do
postRepoRoleOpsR :: RlIdent -> Handler Html
postRepoRoleOpsR rl = do
pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl
((result, widget), enctype) <- runFormPost $ newRoleOpForm getrid
let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of
FormSuccess op -> do
runDB $ do
rid <- getrid
let access = Access
{ accessRole = rid
, accessOp = op
let access = RepoAccess
{ repoAccessRole = rid
, repoAccessOp = op
}
insert_ access
redirect $ RoleOpsR rl
redirect $ RepoRoleOpsR rl
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "role/op/new")
defaultLayout $(widgetFile "repo/role/op/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "role/op/new")
defaultLayout $(widgetFile "repo/role/op/new")
getRoleOpNewR :: RlIdent -> Handler Html
getRoleOpNewR rl = do
getRepoRoleOpNewR :: RlIdent -> Handler Html
getRepoRoleOpNewR rl = do
pid <- requireAuthId
let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl
((_result, widget), enctype) <- runFormPost $ newRoleOpForm getrid
defaultLayout $(widgetFile "role/op/new")
let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new")

14
src/Vervis/Model/Role.hs
View file

@ -14,7 +14,8 @@
-}
module Vervis.Model.Role
( Operation (..)
( RepoOperation (..)
, ProjectOperation (..)
)
where
@ -22,6 +23,13 @@ import Prelude
import Database.Persist.TH
data Operation = OpRepoPush deriving (Eq, Show, Read, Enum, Bounded)
data RepoOperation = RepoOpPush deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "Operation"
derivePersistField "RepoOperation"
data ProjectOperation
= ProjOpAskToClaimTicket
| ProjOpClaimTicket
deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "ProjectOperation"

4
src/Vervis/Ssh.hs
View file

@ -226,8 +226,8 @@ canPushTo shr' rp' = do
ma <- runChanDB $ runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
Entity _cid collab <- MaybeT $ getBy $ UniqueCollab rid pid
MaybeT $ getBy $ UniqueAccess (collabRole collab) OpRepoPush
Entity _cid collab <- MaybeT $ getBy $ UniqueRepoCollab rid pid
MaybeT $ getBy $ UniqueRepoAccess (repoCollabRole collab) RepoOpPush
return $ isJust ma
runAction :: FilePath -> Bool -> Action -> Channel ActionResult

2
templates/role/list.hamlet → templates/repo/role/list.hamlet
View file

@ -15,4 +15,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul>
$forall Entity _rid role <- roles
<li>
<a href=@{RoleR $ roleIdent role}>#{rl2text $ roleIdent role}
<a href=@{RepoRoleR $ repoRoleIdent role}>#{rl2text $ repoRoleIdent role}

2
templates/role/new.hamlet → templates/repo/role/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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/>.
<form method=POST action=@{RolesR} enctype=#{enctype}>
<form method=POST action=@{RepoRolesR} enctype=#{enctype}>
^{widget}
<input type=submit>

6
templates/role/one.hamlet → templates/repo/role/one.hamlet
View file

@ -13,12 +13,12 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
<form method=POST action=@{RoleR rl}>
<form method=POST action=@{RepoRoleR rl}>
<input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this role">
<p>
<a href=@{RoleOpsR rl}>Operations
<a href=@{RepoRoleOpsR rl}>Operations
<p>
#{roleDesc role}
#{repoRoleDesc role}

0
templates/role/op/list.hamlet → templates/repo/role/op/list.hamlet
View file

2
templates/role/op/new.hamlet → templates/repo/role/op/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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/>.
<form method=POST action=@{RoleOpsR rl} enctype=#{enctype}>
<form method=POST action=@{RepoRoleOpsR rl} enctype=#{enctype}>
^{widget}
<input type=submit>