DB: Switch to more flexible collaborator model

config/models

@@ -1,6 +1,7 @@
 -- This file is part of Vervis.
 --
--- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+-- Written in 2016, 2018, 2019, 2020, 2022
+-- by fr33domlover <fr33domlover@riseup.net>.
 --
 -- ♡ 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

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

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

src/Vervis/Access.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 =
+    asCollab rid pid = do
-        fmap (maybe Developer RoleID . repoCollabRole . entityVal) <$>
+        fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do
-            getBy (UniqueRepoCollab rid pid)
+            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 =
+    asCollab jid pid = do
-        fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
+        fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do
-            getBy (UniqueProjectCollab jid pid)
+            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

src/Vervis/ActivityPub.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

src/Vervis/Field/Repo.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
+        from $ \ (person `InnerJoin` sharer `LeftOuterJoin` (recip `InnerJoin` topic)) -> do
-            on $ person ^. PersonIdent  ==. sharer ^. SharerId
+            on $ recip ^. CollabRecipLocalCollab ==. topic ^. CollabTopicLocalRepoCollab &&. topic ^. CollabTopicLocalRepoRepo ==. val rid
-            on $
+            on $ person ^. PersonId ==. recip ^. CollabRecipLocalPerson
-                collab ?. RepoCollabRepo   ==. just (val rid) &&.
+            on $ person ^. PersonIdent ==. sharer ^. SharerId
-                collab ?. RepoCollabPerson ==. just (person ^. PersonId)
+            where_ $ isNothing $ just $ recip ^. CollabRecipLocalId
-            where_ $ isNothing $ collab ?. RepoCollabId
             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`
+        \ (topic `InnerJoin` recip `InnerJoin` person `InnerJoin` sharer `LeftOuterJoin` (recipR `InnerJoin` topicR)) -> do
-            person  `LeftOuterJoin`
+            on $ recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab &&.
-            rcollab `InnerJoin`
+                 topicR ^. CollabTopicLocalRepoRepo ==. val rid
-            sharer
+            on $ person ^. PersonId ==. recipR ^. CollabRecipLocalPerson
-            ) -> do
             on $ person ^. PersonIdent ==. sharer ^. SharerId
-            on $
+            on $ recip ^. CollabRecipLocalPerson ==. person ^. PersonId
-                rcollab ?. RepoCollabRepo   ==. just (val rid) &&.
+            on $ topic ^. CollabTopicLocalProjectCollab ==. recip ^. CollabRecipLocalCollab &&.
-                rcollab ?. RepoCollabPerson ==. just (person ^. PersonId)
+                 topic ^. CollabTopicLocalProjectProject ==. val jid
-            on $
+            where_ $ isNothing $ just $ recipR ^. CollabRecipLocalId
-                pcollab ^. ProjectCollabProject ==. val jid &&.
-                pcollab ^. ProjectCollabPerson  ==. person ^. PersonId
-            where_ $ isNothing $ rcollab ?. RepoCollabId
             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
+        l <- runDB $ select $ from $ \ (recipR `InnerJoin` topicR `LeftOuterJoin` (recipJ `InnerJoin` topicJ)) -> do
-            on $
+            on $ topicJ ^. CollabTopicLocalProjectProject ==. val jid &&.
-                rc ^. RepoCollabRepo       ==. val rid        &&.
+                 recipJ ^. CollabRecipLocalCollab ==. topicJ ^. CollabTopicLocalProjectCollab
-                pc ?. ProjectCollabProject ==. just (val jid) &&.
+            on $ recipR ^. CollabRecipLocalPerson ==. recipJ ^. CollabRecipLocalPerson
-                pc ?. ProjectCollabPerson  ==. just (rc ^. RepoCollabPerson)
+            on $ topicR ^. CollabTopicLocalRepoRepo ==. val rid &&.
-            where_ $ isNothing $ pc ?. ProjectCollabId
+                 recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab
+            where_ $ isNothing $ just $ recipJ ^. CollabRecipLocalId
             limit 1
             return ()
         return $ if null l

src/Vervis/Field/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 &&.
+                topic ^. CollabTopicLocalProjectProject ==. val jid &&.
-                person ^. PersonId              !=. val pid
+                person ^. PersonId                      !=. val pid
             return (sharer ^. SharerIdent, person ^. PersonId)
     optionsPairs $ map (shr2text . unValue *** unValue) l
 

src/Vervis/Form/Project.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 $
+        l <- runDB $ E.select $
-            from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do
+            E.from $ \ (person `E.InnerJoin` sharer `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
-                on $ person ^. PersonIdent  E.==. sharer ^. SharerId
+                E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab E.&&.
-                on $
+                       topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
-                    collab ?. ProjectCollabProject E.==. just (val jid) &&.
+                E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
-                    collab ?. ProjectCollabPerson  E.==. just (person ^. PersonId)
+                E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
-                where_ $ E.isNothing $ collab ?. ProjectCollabId
+                E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
-                return (sharer ^. SharerIdent, person ^. PersonId)
+                return (sharer E.^. SharerIdent, person E.^. PersonId)
-        optionsPairs $ map (bimap (shr2text . unValue) unValue) l
+        optionsPairs $ map (bimap (shr2text . E.unValue) E.unValue) l
     selectRole =
         selectField $
         optionsPersistKey [RoleSharer ==. sid] [] $

src/Vervis/Handler/Project.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
+                obiid <-
-                        , projectCollabPerson  = pid
+                    insert $
-                        , projectCollabRole    = npRole np
+                        OutboxItem
-                        }
+                            obid
-                insert_ collab
+                            (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`
+        E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
-                           person `InnerJoin`
+            E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
-                           sharer `LeftOuterJoin`
+            E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
-                           role) -> do
+            E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
-            on $ collab ^. ProjectCollabRole    E.==. role ?. RoleId
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
-            on $ person ^. PersonIdent          E.==. sharer ^. SharerId
+            E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
-            on $ collab ^. ProjectCollabPerson  E.==. person ^. PersonId
+            E.where_ $ topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
-            where_ $ collab ^. ProjectCollabProject E.==. val jid
+            return (sharer, role E.?. RoleIdent)
-            return (sharer, role ?. RoleIdent)
     defaultLayout $(widgetFile "project/collab/list")
 
 postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
 postProjectDevsR shr rp = do
-    (sid, jid) <- runDB $ do
+    (sid, jid, obid) <- runDB $ do
-        Entity s _ <- getBy404 $ UniqueSharer shr
+        Entity sid _ <- getBy404 $ UniqueSharer shr
-        Entity j _ <- getBy404 $ UniqueProject rp s
+        Entity jid j <- getBy404 $ UniqueProject rp sid
-        return (s, j)
+        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
+                obiid <-
-                        { projectCollabProject = jid
+                    insert $
-                        , projectCollabPerson  = ncPerson nc
+                        OutboxItem
-                        , projectCollabRole    = ncRole nc
+                            obid
-                        }
+                            (persistJSONObjectFromDoc $ Doc host emptyActivity)
-                insert_ collab
+                            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
+        l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
-        fmap roleIdent <$> traverse getJust (projectCollabRole collab)
+            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

src/Vervis/Handler/Repo.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
+                obiid <-
-                        , repoCollabPerson = pid
+                    insert $
-                        , repoCollabRole   = nrpRole nrp
+                        OutboxItem
-                        }
+                            obid
-                insert_ collab
+                            (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`
+        E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
-                               person `E.InnerJoin`
+            E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
-                               sharer `E.LeftOuterJoin`
+            E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
-                               role) -> do
+            E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
-            E.on $ collab E.^. RepoCollabRole     E.==. role E.?. RoleId
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
-            E.on $ person E.^. PersonIdent        E.==. sharer E.^. SharerId
+            E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
-            E.on $ collab E.^. RepoCollabPerson   E.==. person E.^. PersonId
+            E.where_ $ topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid
-            E.where_ $ collab E.^. RepoCollabRepo 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
+                obiid <-
-                        { repoCollabRepo   = rid
+                    insert $
-                        , repoCollabPerson = ncPerson nc
+                        OutboxItem
-                        , repoCollabRole   = ncRole nc
+                            obid
-                        }
+                            (persistJSONObjectFromDoc $ Doc host emptyActivity)
-                insert_ collab
+                            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
+        l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
-        fmap roleIdent <$> traverse getJust (repoCollabRole collab)
+            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

src/Vervis/Migration.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2021, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

src/Vervis/Migration/Model.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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")

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