Default roles for repos and turn user/anon collab tables into proj/repo fields
* 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
parent
5cba838917
commit
c0965a4c47
28 changed files with 243 additions and 558 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
13
migrations/2019_01_28_project_collabs.model
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
ProjectRole
|
||||
|
||||
Project
|
||||
collabUser ProjectRoleId Maybe
|
||||
collabAnon ProjectRoleId Maybe
|
||||
|
||||
ProjectCollabAnon
|
||||
project ProjectId
|
||||
role ProjectRoleId
|
||||
|
||||
ProjectCollabUser
|
||||
project ProjectId
|
||||
role ProjectRoleId
|
||||
|
|
@ -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)
|
||||
status True = ObjectAccessAllowed
|
||||
status False = ObjectAccessDenied
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ data ProjectOperation
|
|||
| ProjOpUnassignTicket
|
||||
| ProjOpAddTicketDep
|
||||
| ProjOpRemoveTicketDep
|
||||
| ProjOpPush
|
||||
deriving (Eq, Show, Read, Enum, Bounded)
|
||||
|
||||
derivePersistField "ProjectOperation"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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…
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
@ -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>
|
||||
|
|
@ -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}
|
||||
|
|
@ -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}
|
||||
|
|
@ -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>
|
||||
Loading…
Reference in a new issue