diff --git a/config/models b/config/models index 9aef13e..4383c35 100644 --- a/config/models +++ b/config/models @@ -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 ------------------------------------------------------------------------------- @@ -143,11 +100,13 @@ ProjectCollabUser Project ident PrjIdent sharer SharerId - name Text Maybe - desc Text Maybe + name Text Maybe + desc Text Maybe workflow WorkflowId nextTicket Int - wiki RepoId Maybe + 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 diff --git a/config/routes b/config/routes index 4cd4fc7..153ed7a 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/migrations/2019_01_28_project_collabs.model b/migrations/2019_01_28_project_collabs.model new file mode 100644 index 0000000..0412627 --- /dev/null +++ b/migrations/2019_01_28_project_collabs.model @@ -0,0 +1,13 @@ +ProjectRole + +Project + collabUser ProjectRoleId Maybe + collabAnon ProjectRoleId Maybe + +ProjectCollabAnon + project ProjectId + role ProjectRoleId + +ProjectCollabUser + project ProjectId + role ProjectRoleId diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 9ecc750..137967a 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -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 = - fmap isJust . runMaybeT $ - MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) - status True = ObjectAccessAllowed - status False = ObjectAccessDenied + 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 diff --git a/src/Vervis/Field/Role.hs b/src/Vervis/Field/Role.hs index 918c952..e9d3300 100644 --- a/src/Vervis/Field/Role.hs +++ b/src/Vervis/Field/Role.hs @@ -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 diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index fcb3186..dcc47e4 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -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 diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index c796139..656d8b0 100644 --- a/src/Vervis/Form/Repo.hs +++ b/src/Vervis/Form/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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 + <$> areq (selectPerson mjid) "Person*" 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 - in case repoVcs repo of + <*> (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 diff --git a/src/Vervis/Form/Role.hs b/src/Vervis/Form/Role.hs index 4d60a0c..07cf802 100644 --- a/src/Vervis/Form/Role.hs +++ b/src/Vervis/Form/Role.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 156ad1c..cf3bbd5 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index e716bf1..4c776bd 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index f83a2f2..79c7207 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Handler/Role.hs b/src/Vervis/Handler/Role.hs index 2dfef58..32201de 100644 --- a/src/Vervis/Handler/Role.hs +++ b/src/Vervis/Handler/Role.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 444e154..5cbb703 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index f7bc848..b5b6be8 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018 by fr33domlover . + - Written in 2018, 2019 by fr33domlover . - - ♡ 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") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index c423252..3ce9f75 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -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 diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs index 87c0311..07c255a 100644 --- a/src/Vervis/Model/Role.hs +++ b/src/Vervis/Model/Role.hs @@ -39,6 +39,7 @@ data ProjectOperation | ProjOpUnassignTicket | ProjOpAddTicketDep | ProjOpRemoveTicketDep + | ProjOpPush deriving (Eq, Show, Read, Enum, Bounded) derivePersistField "ProjectOperation" diff --git a/src/Vervis/Query.hs b/src/Vervis/Query.hs index e41d5fa..6808337 100644 --- a/src/Vervis/Query.hs +++ b/src/Vervis/Query.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Role.hs b/src/Vervis/Role.hs index 5cb6869..d3feb2c 100644 --- a/src/Vervis/Role.hs +++ b/src/Vervis/Role.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index e137182..5cda862 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Widget/Role.hs b/src/Vervis/Widget/Role.hs index 78a36a5..fdb244a 100644 --- a/src/Vervis/Widget/Role.hs +++ b/src/Vervis/Widget/Role.hs @@ -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 diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 37a8350..a4398e8 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2018 by fr33domlover . +$# Written in 2016, 2018, 2019 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -31,10 +31,7 @@ $# . SSH keys
  • - Repository roles - -
  • - Project roles + Roles
  • Ticket claim requests diff --git a/templates/repo/collab/list.hamlet b/templates/repo/collab/list.hamlet index 06f6557..96f73a8 100644 --- a/templates/repo/collab/list.hamlet +++ b/templates/repo/collab/list.hamlet @@ -16,9 +16,13 @@ $# . Collaborator Role - $forall (Entity _sid sharer, Value rl) <- devs + $forall (Entity _sid sharer, Value mrl) <- devs ^{personLinkW sharer} - #{rl2text rl} + + $maybe rl <- mrl + #{rl2text rl} + $nothing + (Developer) Add… diff --git a/templates/repo/collab/one.hamlet b/templates/repo/collab/one.hamlet index d16edc6..13389ea 100644 --- a/templates/repo/collab/one.hamlet +++ b/templates/repo/collab/one.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2019 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -13,4 +13,7 @@ $# with this software. If not, see $# .

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

    - New… - -^{repoRoleGraphW shr graph} - -$#