forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Default roles for repos and turn user/anon collab tables into proj/repo fields

Browse source 
* Repo collab now supports basic default roles developer/user/guest like
  project collab does
* User/Anon collab for repos and projects are now stored as fields instead of
  in dedicated tables, there was never a need for dedicated tables but I didn't
  see that before
* Repo push op is now part of `ProjectOperation`
* `RepoRole` and related code has been entirely removed, only project roles
  remain and they're used for both repos and projects
* This is the first not-totally-trivial DB migration in Vervis, it's automatic
  but please be careful and report errors
This commit is contained in:
fr33domlover 2019-01-29 22:24:32 +00:00
parent 5cba838917
commit c0965a4c47
28 changed files with 243 additions and 558 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
config/models
View file

@ -60,44 +60,13 @@ GroupMember
UniqueGroupMember person group
RepoRole
ident RlIdent
sharer SharerId
desc Text
UniqueRepoRole sharer ident
RepoRoleInherit
parent RepoRoleId
child RepoRoleId
UniqueRepoRoleInherit parent child
RepoAccess
role RepoRoleId
op RepoOperation
UniqueRepoAccess role op
RepoCollab
repo RepoId
person PersonId
role RepoRoleId
role ProjectRoleId Maybe
UniqueRepoCollab repo person
RepoCollabAnon
repo RepoId
role RepoRoleId
UniqueRepoCollabAnon repo
RepoCollabUser
repo RepoId
role RepoRoleId
UniqueRepoCollabUser repo
ProjectRole
ident RlIdent
sharer SharerId
@ -124,18 +93,6 @@ ProjectCollab
UniqueProjectCollab project person
ProjectCollabAnon
project ProjectId
role ProjectRoleId
UniqueProjectCollabAnon project
ProjectCollabUser
project ProjectId
role ProjectRoleId
UniqueProjectCollabUser project
-------------------------------------------------------------------------------
-- Projects
-------------------------------------------------------------------------------
@ -148,6 +105,8 @@ Project
workflow WorkflowId
nextTicket Int
wiki RepoId Maybe
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
UniqueProject ident sharer
@ -158,6 +117,8 @@ Repo
project ProjectId Maybe
desc Text Maybe
mainBranch Text
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
UniqueRepo ident sharer

6
config/routes
View file

@ -61,12 +61,6 @@
/g/#ShrIdent/m/!new GroupMemberNewR GET
/g/#ShrIdent/m/#ShrIdent GroupMemberR GET DELETE POST
/s/#ShrIdent/rr RepoRolesR GET POST
/s/#ShrIdent/rr/!new RepoRoleNewR GET
/s/#ShrIdent/rr/#RlIdent RepoRoleR GET DELETE POST
/s/#ShrIdent/rr/#RlIdent/a RepoRoleOpsR GET POST
/s/#ShrIdent/rr/#RlIdent/a/!new RepoRoleOpNewR GET
/s/#ShrIdent/pr ProjectRolesR GET POST
/s/#ShrIdent/pr/!new ProjectRoleNewR GET
/s/#ShrIdent/pr/#RlIdent ProjectRoleR GET DELETE POST

13
migrations/2019_01_28_project_collabs.model Normal file
View file

@ -0,0 +1,13 @@
ProjectRole
Project
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
ProjectCollabAnon
project ProjectId
role ProjectRoleId
ProjectCollabUser
project ProjectId
role ProjectRoleId

145
src/Vervis/Access.hs
View file

@ -79,84 +79,16 @@ data ObjectAccessStatus =
NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
deriving Eq
checkRepoAccess
:: MonadIO m
=> Maybe PersonId
-> RepoOperation
-> ShrIdent
-> RpIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op shr rp = do
mrid <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
return rid
case mrid of
Nothing -> return NoSuchObject
Just rid -> do
mra <- runMaybeT $ do
rlid <- do
case mpid of
Just pid ->
MaybeT (asCollab rid pid)
<|> MaybeT (asUser rid)
<|> MaybeT (asAnon rid)
Nothing -> MaybeT $ asAnon rid
MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
return $
case mra of
Nothing -> ObjectAccessDenied
Just _ -> ObjectAccessAllowed
where
asCollab rid pid =
fmap (repoCollabRole . entityVal) <$>
getBy (UniqueRepoCollab rid pid)
asUser rid =
fmap (repoCollabUserRole . entityVal) <$>
getBy (UniqueRepoCollabUser rid)
asAnon rid =
fmap (repoCollabAnonRole . entityVal) <$>
getBy (UniqueRepoCollabAnon rid)
roleHas role operation = getBy $ UniqueRepoAccess role operation
ancestorHas = flip getRepoRoleAncestorWithOpQ
data PersonRole = Developer | User | Guest | RoleID ProjectRoleId
checkProjectAccess
roleHasAccess
:: MonadIO m
=> Maybe PersonId
=> PersonRole
-> ProjectOperation
-> ShrIdent
-> PrjIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkProjectAccess mpid op shr prj = do
mjid <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
Entity jid _project <- MaybeT $ getBy $ UniqueProject prj sid
return jid
case mjid of
Nothing -> return NoSuchObject
Just jid -> do
role <- do
case mpid of
Just pid -> fmap (fromMaybe User) $ runMaybeT
$ MaybeT (asCollab jid pid)
<|> MaybeT (asUser jid)
<|> MaybeT (asAnon jid)
Nothing -> fromMaybe Guest <$> asAnon jid
status <$> hasAccess role op
-> ReaderT SqlBackend m Bool
roleHasAccess Developer _ = pure True
roleHasAccess User op = pure $ userAccess op
where
asCollab jid pid =
fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
getBy (UniqueProjectCollab jid pid)
asUser jid =
fmap (RoleID . projectCollabUserRole . entityVal) <$>
getBy (UniqueProjectCollabUser jid)
asAnon jid =
fmap (RoleID . projectCollabAnonRole . entityVal) <$>
getBy (UniqueProjectCollabAnon jid)
roleHas role operation = getBy $ UniqueProjectAccess role operation
ancestorHas = flip getProjectRoleAncestorWithOpQ
userAccess ProjOpOpenTicket = True
userAccess ProjOpAcceptTicket = False
userAccess ProjOpCloseTicket = False
@ -168,11 +100,70 @@ checkProjectAccess mpid op shr prj = do
userAccess ProjOpUnassignTicket = False
userAccess ProjOpAddTicketDep = False
userAccess ProjOpRemoveTicketDep = False
hasAccess Developer _ = pure True
hasAccess User op = pure $ userAccess op
hasAccess Guest _ = pure False
hasAccess (RoleID rlid) op =
userAccess ProjOpPush = False
roleHasAccess Guest _ = pure False
roleHasAccess (RoleID rlid) op =
fmap isJust . runMaybeT $
MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
where
roleHas role operation = getBy $ UniqueProjectAccess role operation
ancestorHas = flip getProjectRoleAncestorWithOpQ
status :: Bool -> ObjectAccessStatus
status True = ObjectAccessAllowed
status False = ObjectAccessDenied
checkRepoAccess
:: MonadIO m
=> Maybe PersonId
-> ProjectOperation
-> ShrIdent
-> RpIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op shr rp = do
mer <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid
case mer of
Nothing -> return NoSuchObject
Just (Entity rid repo) -> do
role <- do
case mpid of
Just pid ->
fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
Nothing -> pure $ fromMaybe Guest $ asAnon repo
status <$> roleHasAccess role op
where
asCollab rid pid =
fmap (maybe Developer RoleID . repoCollabRole . entityVal) <$>
getBy (UniqueRepoCollab rid pid)
asUser = fmap RoleID . repoCollabUser
asAnon = fmap RoleID . repoCollabAnon
checkProjectAccess
:: MonadIO m
=> Maybe PersonId
-> ProjectOperation
-> ShrIdent
-> PrjIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkProjectAccess mpid op shr prj = do
mej <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid
case mej of
Nothing -> return NoSuchObject
Just (Entity jid project) -> do
role <- do
case mpid of
Just pid ->
fromMaybe User . (<|> asUser project) <$>
asCollab jid pid
Nothing -> pure $ fromMaybe Guest $ asAnon project
status <$> roleHasAccess role op
where
asCollab jid pid =
fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
getBy (UniqueProjectCollab jid pid)
asUser = fmap RoleID . projectCollabUser
asAnon = fmap RoleID . projectCollabAnon

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

@ -14,9 +14,7 @@
-}
module Vervis.Field.Role
( newRepoRoleIdentField
, newRepoOpField
, newProjectRoleIdentField
( newProjectRoleIdentField
, newProjectOpField
)
where
@ -38,39 +36,6 @@ import Vervis.Model.Role
roleIdentField :: Field Handler RlIdent
roleIdentField = convertField text2rl rl2text textField
newRepoRoleIdentField :: SharerId -> Field Handler RlIdent
newRepoRoleIdentField sid = checkUniqueCI roleIdentField
where
checkUniqueCI :: Field Handler RlIdent -> Field Handler RlIdent
checkUniqueCI = checkM $ \ rl -> do
sames <- runDB $ select $ from $ \ role -> do
where_ $
role ^. RepoRoleSharer ==. val sid &&.
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)
newRepoOpField :: AppDB RepoRoleId -> Field Handler RepoOperation
newRepoOpField getrid = checkOpNew getrid opField
where
opField :: Field Handler RepoOperation
opField = selectField optionsEnum
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)
newProjectRoleIdentField :: SharerId -> Field Handler RlIdent
newProjectRoleIdentField sid = checkUniqueCI roleIdentField
where

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

@ -104,8 +104,8 @@ newProjectCollabAForm sid jid = NewProjectCollab
newProjectCollabForm :: SharerId -> ProjectId -> Form NewProjectCollab
newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid
editProjectAForm :: Entity Project -> AForm Handler Project
editProjectAForm (Entity jid project) = Project
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
editProjectAForm sid (Entity jid project) = Project
<$> pure (projectIdent project)
<*> pure (projectSharer project)
<*> aopt textField "Name" (Just $ projectName project)
@ -113,11 +113,17 @@ editProjectAForm (Entity jid project) = Project
<*> pure (projectWorkflow project)
<*> pure (projectNextTicket project)
<*> aopt selectWiki "Wiki" (Just $ projectWiki project)
<*> aopt selectRole "User role" (Just $ projectCollabUser project)
<*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
where
selectWiki =
selectField $
optionsPersistKey [RepoProject ==. Just jid] [] $
rp2text . repoIdent
selectRole =
selectField $
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
editProjectForm :: Entity Project -> Form Project
editProjectForm p = renderDivs $ editProjectAForm p
editProjectForm :: SharerId -> Entity Project -> Form Project
editProjectForm s j = renderDivs $ editProjectAForm s j

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -39,7 +39,7 @@ data NewRepo = NewRepo
, nrpVcs :: VersionControlSystem
, nrpProj :: Maybe ProjectId
, nrpDesc :: Maybe Text
, nrpRole :: RepoRoleId
, nrpRole :: Maybe ProjectRoleId
}
newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo
@ -48,7 +48,7 @@ newRepoAForm sid mjid = NewRepo
<*> areq (selectFieldList vcsList) "Version control system*" Nothing
<*> aopt (selectProjectForNew sid) "Project" (Just mjid)
<*> aopt textField "Description" Nothing
<*> areq selectRole "Your role*" Nothing
<*> aopt selectRole "Custom role" Nothing
where
vcsList :: [(Text, VersionControlSystem)]
vcsList =
@ -57,47 +57,54 @@ newRepoAForm sid mjid = NewRepo
]
selectRole =
selectField $
optionsPersistKey [RepoRoleSharer ==. sid] [] $
rl2text . repoRoleIdent
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
newRepoForm :: SharerId -> Maybe ProjectId -> Form NewRepo
newRepoForm sid mjid = renderDivs $ newRepoAForm sid mjid
data NewRepoCollab = NewRepoCollab
{ ncPerson :: PersonId
, ncRole :: RepoRoleId
, ncRole :: Maybe ProjectRoleId
}
newRepoCollabAForm
:: SharerId -> Maybe ProjectId -> RepoId -> AForm Handler NewRepoCollab
newRepoCollabAForm sid mjid rid = NewRepoCollab
<$> areq (selectPerson mjid) "Person*" Nothing
<*> areq selectRole "Role*" Nothing
<*> aopt selectRole "Custom role" Nothing
where
selectPerson Nothing = selectCollabFromAll rid
selectPerson (Just jid) = selectCollabFromProject jid rid
selectRole =
selectField $
optionsPersistKey [RepoRoleSharer ==. sid] [] $
rl2text . repoRoleIdent
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
newRepoCollabForm
:: SharerId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab
newRepoCollabForm sid mjid rid = renderDivs $ newRepoCollabAForm sid mjid rid
editRepoAForm :: Entity Repo -> AForm Handler Repo
editRepoAForm (Entity rid repo) = Repo
editRepoAForm :: SharerId -> Entity Repo -> AForm Handler Repo
editRepoAForm sid (Entity rid repo) = Repo
<$> pure (repoIdent repo)
<*> pure (repoSharer repo)
<*> pure (repoVcs repo)
<*> aopt selectProject' "Project" (Just $ repoProject repo)
<*> aopt textField "Description" (Just $ repoDesc repo)
<*> let b = repoMainBranch repo
<*> (let b = repoMainBranch repo
in case repoVcs repo of
VCSDarcs -> pure b
VCSGit -> areq textField "Main branch*" (Just b)
)
<*> aopt selectRole "User role" (Just $ repoCollabUser repo)
<*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo)
where
selectProject' = selectProjectForExisting (repoSharer repo) rid
selectRole =
selectField $
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
editRepoForm :: Entity Repo -> Form Repo
editRepoForm r = renderDivs $ editRepoAForm r
editRepoForm :: SharerId -> Entity Repo -> Form Repo
editRepoForm s r = renderDivs $ editRepoAForm s r

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

@ -14,10 +14,7 @@
-}
module Vervis.Form.Role
( NewRepoRole (..)
, newRepoRoleForm
, newRepoRoleOpForm
, NewProjectRole (..)
( NewProjectRole (..)
, newProjectRoleForm
, newProjectRoleOpForm
)
@ -36,25 +33,6 @@ import Vervis.Model
import Vervis.Model.Ident (RlIdent)
import Vervis.Model.Role
data NewRepoRole = NewRepoRole
{ nrrIdent :: RlIdent
, nrrDesc :: Text
}
newRepoRoleAForm :: SharerId -> AForm Handler NewRepoRole
newRepoRoleAForm sid = NewRepoRole
<$> areq (newRepoRoleIdentField sid) "Name*" Nothing
<*> areq textField "Description" Nothing
newRepoRoleForm :: SharerId -> Form NewRepoRole
newRepoRoleForm sid = renderDivs $ newRepoRoleAForm sid
newRepoRoleOpAForm :: AppDB RepoRoleId -> AForm Handler RepoOperation
newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing
newRepoRoleOpForm :: AppDB RepoRoleId -> Form RepoOperation
newRepoRoleOpForm getrid = renderDivs $ newRepoRoleOpAForm getrid
data NewProjectRole = NewProjectRole
{ nprIdent :: RlIdent
, nprDesc :: Text

17
src/Vervis/Foundation.hs
View file

@ -186,12 +186,6 @@ instance Yesod App where
(ClaimRequestsPersonR , _ ) -> personAny
(RepoRolesR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleNewR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRolesR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr
@ -244,7 +238,6 @@ instance Yesod App where
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
(ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
(ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
(TicketDiscussionR _ _ _ , True) -> personAny
(TicketMessageR _ _ _ _ , True) -> personAny
(TicketTopReplyR _ _ _ , _ ) -> personAny
@ -641,6 +634,7 @@ instance YesodBreadcrumbs App where
PeopleR -> ("People", Just HomeR)
PersonNewR -> ("New", Just PeopleR)
PersonR shar -> (shr2text shar, Just PeopleR)
PersonActivitiesR shr -> ("Activities", Just $ PersonR shr)
GroupsR -> ("Groups", Just HomeR)
GroupNewR -> ("New", Just GroupsR)
@ -659,14 +653,6 @@ instance YesodBreadcrumbs App where
, Just HomeR
)
RepoRolesR shr -> ("Repo Roles", Just $ SharerR shr)
RepoRoleNewR shr -> ("New", Just $ RepoRolesR shr)
RepoRoleR shr rl -> (rl2text rl, Just $ RepoRolesR shr)
RepoRoleOpsR shr rl -> ( "Operations"
, Just $ RepoRoleR shr rl
)
RepoRoleOpNewR shr rl -> ("New", Just $ RepoRoleOpsR shr rl)
ProjectRolesR shr -> ( "Project Roles"
, Just $ SharerR shr
)
@ -709,6 +695,7 @@ instance YesodBreadcrumbs App where
DarcsDownloadR _ _ _ -> ("", Nothing)
GitRefDiscoverR _ _ -> ("", Nothing)
GitUploadRequestR _ _ -> ("", Nothing)
ProjectsR shar -> ("Projects", Just $ PersonR shar)
ProjectNewR shar -> ("New", Just $ ProjectsR shar)

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

@ -81,6 +81,8 @@ postProjectsR shr = do
, projectWorkflow = npWflow np
, projectNextTicket = 1
, projectWiki = Nothing
, projectCollabAnon = Nothing
, projectCollabUser = Nothing
}
jid <- insert project
let collab = ProjectCollab
@ -120,10 +122,11 @@ getProjectR shar proj = do
putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do
ep@(Entity jid project) <- runDB $ do
(sid, ep@(Entity jid _)) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProject prj sid
((result, widget), enctype) <- runFormPost $ editProjectForm ep
eproj <- getBy404 $ UniqueProject prj sid
return (sid, eproj)
((result, widget), enctype) <- runFormPost $ editProjectForm sid ep
case result of
FormSuccess project' -> do
runDB $ replace jid project'
@ -145,10 +148,11 @@ postProjectR shr prj = do
getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html
getProjectEditR shr prj = do
ep <- runDB $ do
(sid, ep) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProject prj sid
((_result, widget), enctype) <- runFormPost $ editProjectForm ep
ep <- getBy404 $ UniqueProject prj sid
return (sid, ep)
((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
defaultLayout $(widgetFile "project/edit")
getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -134,6 +134,8 @@ postReposR user = do
, repoProject = nrpProj nrp
, repoDesc = nrpDesc nrp
, repoMainBranch = "master"
, repoCollabUser = Nothing
, repoCollabAnon = Nothing
}
rid <- insert repo
let collab = RepoCollab
@ -182,13 +184,13 @@ putRepoR shr rp = do
return $ (== rid) <$> projectWiki project
return $ case mwiki of
Just (Just True) -> Nothing
_ -> Just er
_ -> Just (sid, er)
case mer of
Nothing -> do
setMessage "Repo used as a wiki, can't move between projects."
redirect $ RepoR shr rp
Just er@(Entity rid _) -> do
((result, widget), enctype) <- runFormPost $ editRepoForm er
Just (sid, er@(Entity rid _)) -> do
((result, widget), enctype) <- runFormPost $ editRepoForm sid er
case result of
FormSuccess repository' -> do
runDB $ replace rid repository'
@ -230,10 +232,11 @@ postRepoR shar repo = do
getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
getRepoEditR shr rp = do
er <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueRepo rp s
((_result, widget), enctype) <- runFormPost $ editRepoForm er
(sid, er) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
er <- getBy404 $ UniqueRepo rp sid
return (sid, er)
((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
defaultLayout $(widgetFile "repo/edit")
getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
@ -273,13 +276,15 @@ getRepoDevsR shr rp = do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueRepo rp s
return r
select $ from $ \ (collab, person, sharer, role) -> do
where_ $
collab ^. RepoCollabRepo ==. val rid &&.
collab ^. RepoCollabPerson ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId &&.
collab ^. RepoCollabRole ==. role ^. RepoRoleId
return (sharer, role ^. RepoRoleIdent)
select $ from $ \ (collab `InnerJoin`
person `InnerJoin`
sharer `LeftOuterJoin`
role) -> do
on $ collab ^. RepoCollabRole ==. role ?. ProjectRoleId
on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ collab ^. RepoCollabPerson ==. person ^. PersonId
where_ $ collab ^. RepoCollabRepo ==. val rid
return (sharer, role ?. ProjectRoleIdent)
defaultLayout $(widgetFile "repo/collab/list")
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
@ -319,7 +324,7 @@ getRepoDevNewR shr rp = do
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
getRepoDevR shr rp dev = do
rl <- runDB $ do
mrl <- runDB $ do
rid <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueRepo rp s
@ -329,8 +334,7 @@ getRepoDevR shr rp dev = do
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid
role <- getJust $ repoCollabRole collab
return $ repoRoleIdent role
fmap projectRoleIdent <$> traverse getJust (repoCollabRole collab)
defaultLayout $(widgetFile "repo/collab/one")
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -14,16 +14,7 @@
-}
module Vervis.Handler.Role
( getRepoRolesR
, postRepoRolesR
, getRepoRoleNewR
, getRepoRoleR
, deleteRepoRoleR
, postRepoRoleR
, getRepoRoleOpsR
, postRepoRoleOpsR
, getRepoRoleOpNewR
, getProjectRolesR
( getProjectRolesR
, postProjectRolesR
, getProjectRoleNewR
, getProjectRoleR
@ -56,106 +47,6 @@ import Vervis.Settings (widgetFile)
import Vervis.Widget (buttonW)
import Vervis.Widget.Role
getRepoRolesR :: ShrIdent -> Handler Html
getRepoRolesR shr = do
--roles <- runDB $ do
-- Entity sid _ <- getBy404 $ UniqueSharer shr
-- selectList [RepoRoleSharer ==. sid] []
graph <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
getRepoRoleGraph sid
defaultLayout $(widgetFile "repo/role/graph")
postRepoRolesR :: ShrIdent -> Handler Html
postRepoRolesR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
case result of
FormSuccess nrr -> do
runDB $ do
let role = RepoRole
{ repoRoleIdent = nrrIdent nrr
, repoRoleSharer = sid
, repoRoleDesc = nrrDesc nrr
}
insert_ role
redirect $ RepoRolesR shr
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/new")
getRepoRoleNewR :: ShrIdent -> Handler Html
getRepoRoleNewR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
defaultLayout $(widgetFile "repo/role/new")
getRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleR shr rl = do
Entity _rid role <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueRepoRole sid rl
defaultLayout $(widgetFile "repo/role/one")
deleteRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteRepoRoleR shr rl = do
runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
delete rid
setMessage "Role deleted."
redirect $ RepoRolesR shr
postRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleR shr rl = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteRepoRoleR shr rl
_ -> notFound
getRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpsR shr rl = do
ops <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
as <- selectList [RepoAccessRole ==. rid] []
return $ map (repoAccessOp . entityVal) as
defaultLayout $(widgetFile "repo/role/op/list")
postRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleOpsR shr rl = do
let getrid = do
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of
FormSuccess op -> do
runDB $ do
rid <- getrid
let access = RepoAccess
{ repoAccessRole = rid
, repoAccessOp = op
}
insert_ access
redirect $ RepoRoleOpsR shr rl
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/op/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/op/new")
getRepoRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpNewR shr rl = do
let getrid = do
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new")
getProjectRolesR :: ShrIdent -> Handler Html
getProjectRolesR shr = do
--roles <- runDB $ do

51
src/Vervis/Migration.hs
View file

@ -45,6 +45,7 @@ import Database.Persist.Sql (SqlBackend, toSqlKey)
import Text.Email.Validate (unsafeEmailAddress)
import Web.PathPieces (toPathPiece)
import qualified Database.Esqueleto as E
import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault)
import Vervis.Migration.Model
@ -136,6 +137,56 @@ changes =
, addFieldPrimRequired "Person" ("" :: Text) "about"
-- 26
, setFieldMaybe "ProjectCollab" "role"
-- 27
, removeField "RepoCollab" "role"
-- 28
, addFieldRefOptional "RepoCollab" Nothing "role" "ProjectRole"
-- 29
, removeEntity "RepoCollabAnon"
-- 30
, removeEntity "RepoCollabUser"
-- 31
, addFieldRefOptional "Repo" Nothing "collabUser" "ProjectRole"
-- 32
, addFieldRefOptional "Repo" Nothing "collabAnon" "ProjectRole"
-- 33
, addFieldRefOptional "Project" Nothing "collabUser" "ProjectRole"
-- 34
, addFieldRefOptional "Project" Nothing "collabAnon" "ProjectRole"
-- 35
, unchecked $ lift $ do
l <- E.select $ E.from $ \ (j `E.LeftOuterJoin`
jcu `E.LeftOuterJoin`
jca) -> do
E.on $
E.just (j E.^. Project2018Id) E.==.
jca E.?. ProjectCollabAnon2018Project
E.on $
E.just (j E.^. Project2018Id) E.==.
jcu E.?. ProjectCollabUser2018Project
E.where_ $ E.not_ $
E.isNothing (jcu E.?. ProjectCollabUser2018Project) E.&&.
E.isNothing (jca E.?. ProjectCollabAnon2018Project)
return
( j E.^. Project2018Id
, jca E.?. ProjectCollabAnon2018Role
, jcu E.?. ProjectCollabUser2018Role
)
for_ l $ \ (E.Value jid, E.Value malid, E.Value mulid) ->
update jid
[ Project2018CollabAnon =. malid
, Project2018CollabUser =. mulid
]
-- 36
, removeEntity "ProjectCollabAnon"
-- 37
, removeEntity "ProjectCollabUser"
-- 38
, removeEntity "RepoAccess"
-- 39
, removeEntity "RepoRoleInherit"
-- 40
, removeEntity "RepoRole"
]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

9
src/Vervis/Migration/Model.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -14,7 +14,8 @@
-}
module Vervis.Migration.Model
( model_2016_08_04
( EntityField (..)
, model_2016_08_04
, model_2016_09_01_just_workflow
, Workflow2016Generic (..)
, Workflow2016
@ -27,6 +28,7 @@ import Prelude
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time (UTCTime)
import Database.Persist.Class (EntityField)
import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL ()
import Database.Persist.Sql (SqlBackend)
@ -52,3 +54,6 @@ makeEntitiesMigration "2016"
model_2016_09_01_rest :: [Entity SqlBackend]
model_2016_09_01_rest = $(schema "2016_09_01_rest")
makeEntitiesMigration "2018"
$(modelFile "migrations/2019_01_28_project_collabs.model")

5
src/Vervis/Model.hs
View file

@ -64,11 +64,6 @@ instance Hashable MessageId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey
-- "Vervis.Role" uses a 'HashMap' where the key type is 'RepoRoleId'
instance Hashable RepoRoleId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey
-- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId'
instance Hashable ProjectRoleId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey

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

@ -39,6 +39,7 @@ data ProjectOperation
| ProjOpUnassignTicket
| ProjOpAddTicketDep
| ProjOpRemoveTicketDep
| ProjOpPush
deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "ProjectOperation"

44
src/Vervis/Query.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -18,8 +18,7 @@
-- helps identify patterns and commonly needed but missing tools, which can
-- then be implemented and simplify the queries.
module Vervis.Query
( getRepoRoleAncestorWithOpQ
, getProjectRoleAncestorWithOpQ
( getProjectRoleAncestorWithOpQ
)
where
@ -41,45 +40,6 @@ import Database.Persist.Graph.SQL
import Vervis.Model
import Vervis.Model.Role
-- | Given a repo role and a repo operation, find an ancestor role which
-- has access to the operation.
getRepoRoleAncestorWithOpQ
:: MonadIO m
=> RepoOperation
-> RepoRoleId
-> ReaderT SqlBackend m (Maybe (Entity RepoAccess))
getRepoRoleAncestorWithOpQ op role = do
conn <- ask
let dbname = connEscapeName conn
eAcc = entityDef $ dummyFromField RepoAccessId
tAcc = dbname $ entityDB eAcc
qcols =
T.intercalate ", " $
map ((tAcc <>) . ("." <>)) $
entityColumnNames eAcc conn
field :: PersistEntity record => EntityField record typ -> Text
field = dbname . fieldDB . persistFieldDef
listToMaybe <$>
rawSqlWithGraph
Ancestors
role
RepoRoleInheritParent
RepoRoleInheritChild
(\ temp -> mconcat
[ "SELECT ??"
, " FROM ", dbname temp, " INNER JOIN ", tAcc
, " ON "
, dbname temp, ".", field RepoRoleInheritParent
, " = "
, tAcc, ".", field RepoAccessRole
, " WHERE "
, tAcc, ".", field RepoAccessOp
, " = ?"
, " LIMIT 1"
]
)
[toPersistValue op]
-- | Given a project role and a project operation, find an ancestor role which
-- has access to the operation.
getProjectRoleAncestorWithOpQ

31
src/Vervis/Role.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -14,8 +14,7 @@
-}
module Vervis.Role
( getRepoRoleGraph
, getProjectRoleGraph
( getProjectRoleGraph
)
where
@ -35,32 +34,6 @@ import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
getRepoRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getRepoRoleGraph sid = do
(roles, inhs) <- do
rrs <- P.selectList [RepoRoleSharer P.==. sid] []
rrhs <- select $ from $ \ (rr `InnerJoin` rrh) -> do
on $ rr ^. RepoRoleId ==. rrh ^. RepoRoleInheritParent
where_ $ rr ^. RepoRoleSharer ==. val sid
return rrh
return (rrs, rrhs)
let numbered = zip [1..] roles
nodes = map (second $ repoRoleIdent . entityVal) numbered
nodeMap = M.fromList $ map (swap . second entityKey) numbered
rridToNode rrid =
case M.lookup rrid nodeMap of
Nothing -> error "Role graph: Node not found in node map"
Just n -> n
edges =
map
( (\ (c, p) -> (c, p, ()))
. (rridToNode *** rridToNode)
. (repoRoleInheritChild &&& repoRoleInheritParent)
. entityVal
)
inhs
return $ mkGraph nodes edges
getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getProjectRoleGraph sid = do
(roles, inhs) <- do

4
src/Vervis/Ssh.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -233,7 +233,7 @@ whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
canPushTo :: ShrIdent -> RpIdent -> Channel Bool
canPushTo shr rp = do
pid <- authId <$> askAuthDetails
oas <- runChanDB $ checkRepoAccess (Just pid) RepoOpPush shr rp
oas <- runChanDB $ checkRepoAccess (Just pid) ProjOpPush shr rp
return $
case oas of
ObjectAccessAllowed -> True

6
src/Vervis/Widget/Role.hs
View file

@ -14,8 +14,7 @@
-}
module Vervis.Widget.Role
( repoRoleGraphW
, projectRoleGraphW
( projectRoleGraphW
)
where
@ -59,8 +58,5 @@ roleGraph link shr g = do
svg = renderDia SVG opts dia
toWidget $ preEscapedToHtml $ renderText svg
repoRoleGraphW :: Graph g => ShrIdent -> g RlIdent () -> Widget
repoRoleGraphW = roleGraph RepoRoleR
projectRoleGraphW :: Graph g => ShrIdent -> g RlIdent () -> Widget
projectRoleGraphW = roleGraph ProjectRoleR

7
templates/personal-overview.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -31,10 +31,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{KeysR}>SSH keys
<li>
<a href=@{RepoRolesR ident}>Repository roles
<li>
<a href=@{ProjectRolesR ident}>Project roles
<a href=@{ProjectRolesR ident}>Roles
<li>
<a href=@{ClaimRequestsPersonR}>Ticket claim requests

8
templates/repo/collab/list.hamlet
View file

@ -16,9 +16,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<tr>
<th>Collaborator
<th>Role
$forall (Entity _sid sharer, Value rl) <- devs
$forall (Entity _sid sharer, Value mrl) <- devs
<tr>
<td>^{personLinkW sharer}
<td>#{rl2text rl}
<td>
$maybe rl <- mrl
#{rl2text rl}
$nothing
(Developer)
<a href=@{RepoDevNewR shr rp}>Add…

5
templates/repo/collab/one.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -13,4 +13,7 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
$maybe rl <- mrl
Role: #{rl2text rl}
$nothing
Role: (Developer)

24
templates/repo/role/graph.hamlet
View file

@ -1,24 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
<a href=@{RepoRoleNewR shr}>New…
^{repoRoleGraphW shr graph}
$#<ul>
$# $forall Entity _rid role <- roles
$# <li>
$# <a href=@{RepoRoleR shr $ repoRoleIdent role}>
$# #{rl2text $ repoRoleIdent role}

17
templates/repo/role/new.hamlet
View file

@ -1,17 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{RepoRolesR shr} enctype=#{enctype}>
^{widget}
<input type=submit>

22
templates/repo/role/one.hamlet
View file

@ -1,22 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
^{buttonW DELETE "Delete this role" (RepoRoleR shr rl)}
<p>
<a href=@{RepoRoleOpsR shr rl}>Operations
<p>
#{repoRoleDesc role}

21
templates/repo/role/op/list.hamlet
View file

@ -1,21 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
<a href=@{RepoRoleOpNewR shr rl}>New…
<ul>
$forall op <- ops
<li>
#{show op}

17
templates/repo/role/op/new.hamlet
View file

@ -1,17 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{RepoRoleOpsR shr rl} enctype=#{enctype}>
^{widget}
<input type=submit>