diff --git a/config/models b/config/models index b367ca6..cb38de6 100644 --- a/config/models +++ b/config/models @@ -1,6 +1,7 @@ -- This file is part of Vervis. -- --- Written in 2016, 2018, 2019, 2020 by fr33domlover . +-- Written in 2016, 2018, 2019, 2020, 2022 +-- by fr33domlover . -- -- ♡ Copying is an act of love. Please copy, reuse and share. -- @@ -572,16 +573,67 @@ RemoteMessage UniqueRemoteMessage rest UniqueRemoteMessageCreate create -RepoCollab + +------------------------------------------------------------------------------ +-- Collaborators +------------------------------------------------------------------------------ + +Collab + +-------------------------------- Collab topic -------------------------------- + +CollabRoleLocal + collab CollabId + role RoleId + + UniqueCollabRoleLocal collab + +CollabTopicLocalRepo + collab CollabId repo RepoId - person PersonId - role RoleId Maybe - UniqueRepoCollab repo person + UniqueCollabTopicLocalRepo collab -ProjectCollab +CollabTopicLocalProject + collab CollabId project ProjectId - person PersonId - role RoleId Maybe - UniqueProjectCollab project person + UniqueCollabTopicLocalProject collab + +CollabTopicRemote + collab CollabId + topic RemoteObjectId + role LocalURI Maybe + + UniqueCollabTopicRemote collab + +-------------------------------- Collab sender ------------------------------- + +CollabSenderLocal + collab CollabId + activity OutboxItemId + + UniqueCollabSenderLocal collab + UniqueCollabSenderLocalActivity activity + +CollabSenderRemote + collab CollabId + actor RemoteActorId + activity RemoteActivityId + + UniqueCollabSenderRemote collab + UniqueCollabSenderRemoteActivity activity + +-------------------------------- Collab recipient ---------------------------- + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + +CollabRecipRemote + collab CollabId + actor RemoteActorId + + UniqueCollabRecipRemote collab diff --git a/migrations/2022_06_14_collab.model b/migrations/2022_06_14_collab.model new file mode 100644 index 0000000..a1f80a8 --- /dev/null +++ b/migrations/2022_06_14_collab.model @@ -0,0 +1,59 @@ +Collab + + + +CollabRoleLocal + collab CollabId + role RoleId + + UniqueCollabRoleLocal collab + +CollabTopicLocalRepo + collab CollabId + repo RepoId + + UniqueCollabTopicLocalRepo collab + +CollabTopicLocalProject + collab CollabId + project ProjectId + + UniqueCollabTopicLocalProject collab + +CollabTopicRemote + collab CollabId + topic RemoteObjectId + role LocalURI Maybe + + UniqueCollabTopicRemote collab + + + +CollabSenderLocal + collab CollabId + activity OutboxItemId + + UniqueCollabSenderLocal collab + UniqueCollabSenderLocalActivity activity + +CollabSenderRemote + collab CollabId + actor RemoteActorId + activity RemoteActivityId + + UniqueCollabSenderRemote collab + UniqueCollabSenderRemoteActivity activity + + + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + +CollabRecipRemote + collab CollabId + actor RemoteActorId + + UniqueCollabRecipRemote collab diff --git a/migrations/2022_06_14_collab_mig.model b/migrations/2022_06_14_collab_mig.model new file mode 100644 index 0000000..939ba28 --- /dev/null +++ b/migrations/2022_06_14_collab_mig.model @@ -0,0 +1,94 @@ +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Person + +Project + ident PrjIdent + sharer Int64 + name Text Maybe + desc Text Maybe + workflow Int64 + nextTicket Int + wiki RepoId Maybe + collabUser RoleId Maybe + collabAnon RoleId Maybe + inbox Int64 + outbox OutboxId + followers Int64 + +Repo + ident RpIdent + sharer Int64 + vcs VersionControlSystem + project ProjectId Maybe + desc Text Maybe + mainBranch Text + collabUser RoleId Maybe + collabAnon RoleId Maybe + inbox Int64 + outbox OutboxId + followers Int64 + +Role + + + +Collab + + + +CollabRoleLocal + collab CollabId + role RoleId + + UniqueCollabRoleLocal collab + +CollabTopicLocalRepo + collab CollabId + repo RepoId + + UniqueCollabTopicLocalRepo collab + +CollabTopicLocalProject + collab CollabId + project ProjectId + + UniqueCollabTopicLocalProject collab + + + +CollabSenderLocal + collab CollabId + activity OutboxItemId + + UniqueCollabSenderLocal collab + UniqueCollabSenderLocalActivity activity + + + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + + + +RepoCollab + repo RepoId + person PersonId + role RoleId Maybe + + UniqueRepoCollab repo person + +ProjectCollab + project ProjectId + person PersonId + role RoleId Maybe + + UniqueProjectCollab project person diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 68d0c7e..08c0a0e 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -63,11 +63,13 @@ import Control.Applicative ((<|>)) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe import Database.Persist.Class (getBy) import Database.Persist.Sql (SqlBackend) import Database.Persist.Types (Entity (..)) +import qualified Database.Esqueleto as E + import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Role @@ -132,9 +134,19 @@ checkRepoAccess mpid op shr rp = do Nothing -> pure $ fromMaybe Guest $ asAnon repo status <$> roleHasAccess role op where - asCollab rid pid = - fmap (maybe Developer RoleID . repoCollabRole . entityVal) <$> - getBy (UniqueRepoCollab rid pid) + asCollab rid pid = do + fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do + E.on $ E.just (topic E.^. CollabTopicLocalRepoCollab) E.==. role E.?. CollabRoleLocalCollab + E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&. + recip E.^. CollabRecipLocalPerson E.==. E.val pid + E.limit 1 + return + ( topic E.^. CollabTopicLocalRepoCollab + , role E.?. CollabRoleLocalRole + ) asUser = fmap RoleID . repoCollabUser asAnon = fmap RoleID . repoCollabAnon @@ -160,8 +172,18 @@ checkProjectAccess mpid op shr prj = do Nothing -> pure $ fromMaybe Guest $ asAnon project status <$> roleHasAccess role op where - asCollab jid pid = - fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$> - getBy (UniqueProjectCollab jid pid) + asCollab jid pid = do + fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do + E.on $ E.just (topic E.^. CollabTopicLocalProjectCollab) E.==. role E.?. CollabRoleLocalCollab + E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicLocalProjectProject E.==. E.val jid E.&&. + recip E.^. CollabRecipLocalPerson E.==. E.val pid + E.limit 1 + return + ( topic E.^. CollabTopicLocalProjectCollab + , role E.?. CollabRoleLocalRole + ) asUser = fmap RoleID . projectCollabUser asAnon = fmap RoleID . projectCollabAnon diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index a627005..6e5ceb3 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2021, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -1124,7 +1124,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts) ] jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] - pids <- map (projectCollabPerson . entityVal) <$> selectList [ProjectCollabProject <-. jids] [] + pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do + E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ topic E.^. CollabTopicLocalProjectProject `E.in_` E.valList jids + return $ recip E.^. CollabRecipLocalPerson map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] getRepoTeams sid repos = do let rps = @@ -1134,7 +1137,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) ] rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] [] - pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] [] + pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do + E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ topic E.^. CollabTopicLocalRepoRepo `E.in_` E.valList rids + return $ recip E.^. CollabRecipLocalPerson map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] -- | Given a list of local recipients, which may include actors and diff --git a/src/Vervis/Field/Repo.hs b/src/Vervis/Field/Repo.hs index 27279fd..a908631 100644 --- a/src/Vervis/Field/Repo.hs +++ b/src/Vervis/Field/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -72,12 +72,11 @@ mkIdentField sid = checkIdentUnique sid . checkIdentTemplate $ textField selectCollabFromAll :: RepoId -> Field Handler PersonId selectCollabFromAll rid = selectField $ do l <- runDB $ select $ - from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do - on $ person ^. PersonIdent ==. sharer ^. SharerId - on $ - collab ?. RepoCollabRepo ==. just (val rid) &&. - collab ?. RepoCollabPerson ==. just (person ^. PersonId) - where_ $ isNothing $ collab ?. RepoCollabId + from $ \ (person `InnerJoin` sharer `LeftOuterJoin` (recip `InnerJoin` topic)) -> do + on $ recip ^. CollabRecipLocalCollab ==. topic ^. CollabTopicLocalRepoCollab &&. topic ^. CollabTopicLocalRepoRepo ==. val rid + on $ person ^. PersonId ==. recip ^. CollabRecipLocalPerson + on $ person ^. PersonIdent ==. sharer ^. SharerId + where_ $ isNothing $ just $ recip ^. CollabRecipLocalId return (sharer ^. SharerIdent, person ^. PersonId) optionsPairs $ map (bimap (shr2text . unValue) unValue) l @@ -87,19 +86,15 @@ selectCollabFromAll rid = selectField $ do selectCollabFromProject :: ProjectId -> RepoId -> Field Handler PersonId selectCollabFromProject jid rid = selectField $ do l <- runDB $ select $ from $ - \ ( pcollab `InnerJoin` - person `LeftOuterJoin` - rcollab `InnerJoin` - sharer - ) -> do + \ (topic `InnerJoin` recip `InnerJoin` person `InnerJoin` sharer `LeftOuterJoin` (recipR `InnerJoin` topicR)) -> do + on $ recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab &&. + topicR ^. CollabTopicLocalRepoRepo ==. val rid + on $ person ^. PersonId ==. recipR ^. CollabRecipLocalPerson on $ person ^. PersonIdent ==. sharer ^. SharerId - on $ - rcollab ?. RepoCollabRepo ==. just (val rid) &&. - rcollab ?. RepoCollabPerson ==. just (person ^. PersonId) - on $ - pcollab ^. ProjectCollabProject ==. val jid &&. - pcollab ^. ProjectCollabPerson ==. person ^. PersonId - where_ $ isNothing $ rcollab ?. RepoCollabId + on $ recip ^. CollabRecipLocalPerson ==. person ^. PersonId + on $ topic ^. CollabTopicLocalProjectCollab ==. recip ^. CollabRecipLocalCollab &&. + topic ^. CollabTopicLocalProjectProject ==. val jid + where_ $ isNothing $ just $ recipR ^. CollabRecipLocalId return (sharer ^. SharerIdent, person ^. PersonId) optionsPairs $ map (bimap (shr2text . unValue) unValue) l @@ -126,12 +121,13 @@ selectProjectForExisting :: SharerId -> RepoId -> Field Handler ProjectId selectProjectForExisting sid rid = checkMembers $ selectProjectForNew sid where checkMembers = checkM $ \ jid -> do - l <- runDB $ select $ from $ \ (rc `LeftOuterJoin` pc) -> do - on $ - rc ^. RepoCollabRepo ==. val rid &&. - pc ?. ProjectCollabProject ==. just (val jid) &&. - pc ?. ProjectCollabPerson ==. just (rc ^. RepoCollabPerson) - where_ $ isNothing $ pc ?. ProjectCollabId + l <- runDB $ select $ from $ \ (recipR `InnerJoin` topicR `LeftOuterJoin` (recipJ `InnerJoin` topicJ)) -> do + on $ topicJ ^. CollabTopicLocalProjectProject ==. val jid &&. + recipJ ^. CollabRecipLocalCollab ==. topicJ ^. CollabTopicLocalProjectCollab + on $ recipR ^. CollabRecipLocalPerson ==. recipJ ^. CollabRecipLocalPerson + on $ topicR ^. CollabTopicLocalRepoRepo ==. val rid &&. + recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab + where_ $ isNothing $ just $ recipJ ^. CollabRecipLocalId limit 1 return () return $ if null l diff --git a/src/Vervis/Field/Ticket.hs b/src/Vervis/Field/Ticket.hs index 61316fd..7409fc6 100644 --- a/src/Vervis/Field/Ticket.hs +++ b/src/Vervis/Field/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2020 by fr33domlover . + - Written in 2016, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -43,12 +43,13 @@ import Vervis.Model.Ident (shr2text) selectAssigneeFromProject :: PersonId -> ProjectId -> Field Handler PersonId selectAssigneeFromProject pid jid = selectField $ do l <- runDB $ select $ from $ - \ (pcollab `InnerJoin` person `InnerJoin` sharer) -> do + \ (topic `InnerJoin` recip `InnerJoin` person `InnerJoin` sharer) -> do on $ person ^. PersonIdent ==. sharer ^. SharerId - on $ pcollab ^. ProjectCollabPerson ==. person ^. PersonId + on $ recip ^. CollabRecipLocalPerson ==. person ^. PersonId + on $ topic ^. CollabTopicLocalProjectCollab ==. recip ^. CollabRecipLocalCollab where_ $ - pcollab ^. ProjectCollabProject ==. val jid &&. - person ^. PersonId !=. val pid + topic ^. CollabTopicLocalProjectProject ==. val jid &&. + person ^. PersonId !=. val pid return (sharer ^. SharerIdent, person ^. PersonId) optionsPairs $ map (shr2text . unValue *** unValue) l diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index d88d3d1..3ab7264 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -94,15 +94,15 @@ newProjectCollabAForm sid jid = NewProjectCollab <*> aopt selectRole "Custom role" Nothing where selectPerson = selectField $ do - l <- runDB $ select $ - from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do - on $ person ^. PersonIdent E.==. sharer ^. SharerId - on $ - collab ?. ProjectCollabProject E.==. just (val jid) &&. - collab ?. ProjectCollabPerson E.==. just (person ^. PersonId) - where_ $ E.isNothing $ collab ?. ProjectCollabId - return (sharer ^. SharerIdent, person ^. PersonId) - optionsPairs $ map (bimap (shr2text . unValue) unValue) l + l <- runDB $ E.select $ + E.from $ \ (person `E.InnerJoin` sharer `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab E.&&. + topic E.^. CollabTopicLocalProjectProject E.==. E.val jid + E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson + E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId + E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId + return (sharer E.^. SharerIdent, person E.^. PersonId) + optionsPairs $ map (bimap (shr2text . E.unValue) E.unValue) l selectRole = selectField $ optionsPersistKey [RoleSharer ==. sid] [] $ diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 5f2ec75..2517aae 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -32,8 +32,11 @@ module Vervis.Handler.Project ) where +import Data.Foldable import Data.Maybe (fromMaybe) import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable import Database.Persist import Database.Esqueleto hiding (delete, (%), (==.)) import Text.Blaze.Html (Html) @@ -46,10 +49,12 @@ import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Database.Esqueleto as E +import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Project (..), Repo (..)) import Yesod.ActivityPub import Yesod.FedURI +import Yesod.MonadSite import qualified Web.ActivityPub as AP @@ -85,6 +90,8 @@ postProjectsR shr = do ((result, widget), enctype) <- runFormPost $ newProjectForm sid case result of FormSuccess np -> do + now <- liftIO getCurrentTime + host <- asksSite siteInstanceHost pid <- requireAuthId runDB $ do ibid <- insert Inbox @@ -105,12 +112,18 @@ postProjectsR shr = do , projectFollowers = fsid } jid <- insert project - let collab = ProjectCollab - { projectCollabProject = jid - , projectCollabPerson = pid - , projectCollabRole = npRole np - } - insert_ collab + + obiid <- + insert $ + OutboxItem + obid + (persistJSONObjectFromDoc $ Doc host emptyActivity) + now + cid <- insert Collab + for_ (npRole np) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid + insert_ $ CollabTopicLocalProject cid jid + insert_ $ CollabSenderLocal cid obiid + insert_ $ CollabRecipLocal cid pid setMessage "Project added." redirect $ ProjectR shr (npIdent np) FormMissing -> do @@ -212,33 +225,39 @@ getProjectDevsR shr prj = do Entity sid _ <- getBy404 $ UniqueSharer shr Entity jid _ <- getBy404 $ UniqueProject prj sid return jid - select $ from $ \ (collab `InnerJoin` - person `InnerJoin` - sharer `LeftOuterJoin` - role) -> do - on $ collab ^. ProjectCollabRole E.==. role ?. RoleId - on $ person ^. PersonIdent E.==. sharer ^. SharerId - on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId - where_ $ collab ^. ProjectCollabProject E.==. val jid - return (sharer, role ?. RoleIdent) + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do + E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId + E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab + E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId + E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId + E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ topic E.^. CollabTopicLocalProjectProject E.==. E.val jid + return (sharer, role E.?. RoleIdent) defaultLayout $(widgetFile "project/collab/list") postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html postProjectDevsR shr rp = do - (sid, jid) <- runDB $ do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity j _ <- getBy404 $ UniqueProject rp s - return (s, j) + (sid, jid, obid) <- runDB $ do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity jid j <- getBy404 $ UniqueProject rp sid + return (sid, jid, projectOutbox j) ((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid case result of FormSuccess nc -> do + now <- liftIO getCurrentTime + host <- asksSite siteInstanceHost runDB $ do - let collab = ProjectCollab - { projectCollabProject = jid - , projectCollabPerson = ncPerson nc - , projectCollabRole = ncRole nc - } - insert_ collab + obiid <- + insert $ + OutboxItem + obid + (persistJSONObjectFromDoc $ Doc host emptyActivity) + now + cid <- insert Collab + for_ (ncRole nc) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid + insert_ $ CollabTopicLocalProject cid jid + insert_ $ CollabSenderLocal cid obiid + insert_ $ CollabRecipLocal cid (ncPerson nc) setMessage "Collaborator added." redirect $ ProjectDevsR shr rp FormMissing -> do @@ -268,8 +287,20 @@ getProjectDevR shr prj dev = do Entity s _ <- getBy404 $ UniqueSharer dev Entity p _ <- getBy404 $ UniquePersonIdent s return p - Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid - fmap roleIdent <$> traverse getJust (projectCollabRole collab) + l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do + E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicLocalProjectProject E.==. E.val jid E.&&. + recip E.^. CollabRecipLocalPerson E.==. E.val pid + return $ recip E.^. CollabRecipLocalCollab + cid <- + case l of + [] -> notFound + [E.Value cid] -> return cid + _ -> error "Multiple collabs for project+person" + mcrole <- getValBy $ UniqueCollabRoleLocal cid + for mcrole $ + \ (CollabRoleLocal _cid rlid) -> roleIdent <$> getJust rlid defaultLayout $(widgetFile "project/collab/one") deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html @@ -283,7 +314,26 @@ deleteProjectDevR shr rp dev = do Entity s _ <- getBy404 $ UniqueSharer dev Entity p _ <- getBy404 $ UniquePersonIdent s return p - Entity cid _collab <- getBy404 $ UniqueProjectCollab jid pid + collabs <- E.select $ E.from $ \ (recip `E.InnerJoin` topic) -> do + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab + E.where_ $ + recip E.^. CollabRecipLocalPerson E.==. E.val pid E.&&. + topic E.^. CollabTopicLocalProjectProject E.==. E.val jid + return + ( recip E.^. CollabRecipLocalId + , topic E.^. CollabTopicLocalProjectId + , recip E.^. CollabRecipLocalCollab + ) + (E.Value crid, E.Value ctid, E.Value cid) <- + case collabs of + [] -> notFound + [c] -> return c + _ -> error "More than 1 collab for project+person" + deleteWhere [CollabRoleLocalCollab ==. cid] + delete ctid + deleteWhere [CollabSenderLocalCollab ==. cid] + deleteWhere [CollabSenderRemoteCollab ==. cid] + delete crid delete cid setMessage "Collaborator removed." redirect $ ProjectDevsR shr rp diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index e793f01..126bc60 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020 by fr33domlover . + - Written in 2016, 2018, 2019, 2020, 2022 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -47,6 +48,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (logWarn) import Control.Monad.Trans.Except import Data.Bifunctor +import Data.Foldable import Data.Git.Graph import Data.Git.Harder import Data.Git.Named (RefName (..)) @@ -61,6 +63,7 @@ import Data.List (inits) import Data.Text (Text, unpack) import Data.Text.Encoding import Data.Text.Encoding.Error (lenientDecode) +import Data.Time.Clock import Data.Traversable (for) import Database.Persist import Database.Persist.Sql @@ -87,6 +90,7 @@ import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import qualified Database.Esqueleto as E import Data.MediaType +import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Repo (..), Project) import Yesod.ActivityPub @@ -143,6 +147,7 @@ postReposR user = do ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing case result of FormSuccess nrp -> do + now <- liftIO getCurrentTime parent <- askSharerDir user liftIO $ createDirectoryIfMissing True parent let repoName = @@ -188,12 +193,18 @@ postReposR user = do , repoFollowers = fsid } rid <- insert repo - let collab = RepoCollab - { repoCollabRepo = rid - , repoCollabPerson = pid - , repoCollabRole = nrpRole nrp - } - insert_ collab + + obiid <- + insert $ + OutboxItem + obid + (persistJSONObjectFromDoc $ Doc host emptyActivity) + now + cid <- insert Collab + for_ (nrpRole nrp) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid + insert_ $ CollabTopicLocalRepo cid rid + insert_ $ CollabSenderLocal cid obiid + insert_ $ CollabRecipLocal cid pid setMessage "Repo added." redirect $ RepoR user (nrpIdent nrp) FormMissing -> do @@ -362,33 +373,39 @@ getRepoDevsR shr rp = do Entity s _ <- getBy404 $ UniqueSharer shr Entity r _ <- getBy404 $ UniqueRepo rp s return r - E.select $ E.from $ \ (collab `E.InnerJoin` - person `E.InnerJoin` - sharer `E.LeftOuterJoin` - role) -> do - E.on $ collab E.^. RepoCollabRole E.==. role E.?. RoleId - E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId - E.on $ collab E.^. RepoCollabPerson E.==. person E.^. PersonId - E.where_ $ collab E.^. RepoCollabRepo E.==. E.val rid + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do + E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId + E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab + E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId + E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId + E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid return (sharer, role E.?. RoleIdent) defaultLayout $(widgetFile "repo/collab/list") postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html postRepoDevsR shr rp = do - (sid, mjid, rid) <- runDB $ do + (sid, mjid, obid, rid) <- runDB $ do Entity s _ <- getBy404 $ UniqueSharer shr Entity r repository <- getBy404 $ UniqueRepo rp s - return (s, repoProject repository, r) + return (s, repoProject repository, repoOutbox repository, r) ((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid case result of FormSuccess nc -> do + now <- liftIO getCurrentTime + host <- asksSite siteInstanceHost runDB $ do - let collab = RepoCollab - { repoCollabRepo = rid - , repoCollabPerson = ncPerson nc - , repoCollabRole = ncRole nc - } - insert_ collab + obiid <- + insert $ + OutboxItem + obid + (persistJSONObjectFromDoc $ Doc host emptyActivity) + now + cid <- insert Collab + for_ (ncRole nc) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid + insert_ $ CollabTopicLocalRepo cid rid + insert_ $ CollabSenderLocal cid obiid + insert_ $ CollabRecipLocal cid (ncPerson nc) setMessage "Collaborator added." redirect $ RepoDevsR shr rp FormMissing -> do @@ -419,8 +436,20 @@ getRepoDevR shr rp dev = do Entity s _ <- getBy404 $ UniqueSharer dev Entity p _ <- getBy404 $ UniquePersonIdent s return p - Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid - fmap roleIdent <$> traverse getJust (repoCollabRole collab) + l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do + E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&. + recip E.^. CollabRecipLocalPerson E.==. E.val pid + return $ recip E.^. CollabRecipLocalCollab + cid <- + case l of + [] -> notFound + [E.Value cid] -> return cid + _ -> error "Multiple collabs for repo+person" + mcrole <- getValBy $ UniqueCollabRoleLocal cid + for mcrole $ + \ (CollabRoleLocal _cid rlid) -> roleIdent <$> getJust rlid defaultLayout $(widgetFile "repo/collab/one") deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html @@ -434,7 +463,26 @@ deleteRepoDevR shr rp dev = do Entity s _ <- getBy404 $ UniqueSharer dev Entity p _ <- getBy404 $ UniquePersonIdent s return p - Entity cid _collab <- getBy404 $ UniqueRepoCollab rid pid + collabs <- E.select $ E.from $ \ (recip `E.InnerJoin` topic) -> do + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalRepoCollab + E.where_ $ + recip E.^. CollabRecipLocalPerson E.==. E.val pid E.&&. + topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid + return + ( recip E.^. CollabRecipLocalId + , topic E.^. CollabTopicLocalRepoId + , recip E.^. CollabRecipLocalCollab + ) + (E.Value crid, E.Value ctid, E.Value cid) <- + case collabs of + [] -> notFound + [c] -> return c + _ -> error "More than 1 collab for repo+person" + deleteWhere [CollabRoleLocalCollab ==. cid] + delete ctid + deleteWhere [CollabSenderLocalCollab ==. cid] + deleteWhere [CollabSenderRemoteCollab ==. cid] + delete crid delete cid setMessage "Collaborator removed." redirect $ RepoDevsR shr rp diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 40318c7..5ce289c 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020 by fr33domlover . + - Written in 2016, 2018, 2019, 2020, 2021, 2022 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -1785,6 +1786,43 @@ changes hLocal ctx = update rid [Repo282Vcs =. vcs] -- 283 , addFieldPrimRequired "Patch" ("???" :: Text) "type" + -- 284 + , addEntities model_2022_06_14 + -- 285 + , unchecked $ lift $ do + rcs <- selectList ([] :: [Filter RepoCollab285]) [] + for_ rcs $ \ (Entity _ (RepoCollab285 rid pid mrlid)) -> do + cid <- insert Collab285 + for_ mrlid $ \ rlid -> insert_ $ CollabRoleLocal285 cid rlid + insert_ $ CollabTopicLocalRepo285 cid rid + obiid <- do + r <- getJust rid + insert $ + OutboxItem285 + (repo285Outbox r) + (persistJSONObjectFromDoc $ Doc hLocal emptyActivity) + defaultTime + insert_ $ CollabSenderLocal285 cid obiid + insert_ $ CollabRecipLocal285 cid pid + + jcs <- selectList ([] :: [Filter ProjectCollab285]) [] + for_ jcs $ \ (Entity _ (ProjectCollab285 jid pid mrlid)) -> do + cid <- insert Collab285 + for_ mrlid $ \ rlid -> insert_ $ CollabRoleLocal285 cid rlid + insert_ $ CollabTopicLocalProject285 cid jid + obiid <- do + j <- getJust jid + insert $ + OutboxItem285 + (project285Outbox j) + (persistJSONObjectFromDoc $ Doc hLocal emptyActivity) + defaultTime + insert_ $ CollabSenderLocal285 cid obiid + insert_ $ CollabRecipLocal285 cid pid + -- 286 + , removeEntity "RepoCollab" + -- 287 + , removeEntity "ProjectCollab" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 9fd7dd1..cf77838 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, 2019, 2020 by fr33domlover . + - Written in 2018, 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -245,6 +245,20 @@ module Vervis.Migration.Model , Patch280Generic (..) , Repo282 , Repo282Generic (..) + , model_2022_06_14 + , Collab285Generic (..) + , CollabRecipLocal285Generic (..) + , CollabRoleLocal285Generic (..) + , CollabSenderLocal285Generic (..) + , CollabTopicLocalProject285Generic (..) + , CollabTopicLocalRepo285Generic (..) + , OutboxItem285Generic (..) + , Project285Generic (..) + , ProjectCollab285 + , ProjectCollab285Generic (..) + , Repo285Generic (..) + , RepoCollab285 + , RepoCollab285Generic (..) ) where @@ -481,3 +495,9 @@ makeEntitiesMigration "280" makeEntitiesMigration "282" $(modelFile "migrations/2020_08_13_vcs.model") + +model_2022_06_14 :: [Entity SqlBackend] +model_2022_06_14 = $(schema "2022_06_14_collab") + +makeEntitiesMigration "285" + $(modelFile "migrations/2022_06_14_collab_mig.model") diff --git a/vervis.cabal b/vervis.cabal index 36a6647..828551e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -445,7 +445,7 @@ test-suite test TupleSections build-depends: base , vervis - , yesod-test >= 1.5.0.1 && < 1.6 + , yesod-test , yesod-core , yesod , persistent