DB, UI: Prepare DB schema for Join flow + display deck collaborators & invites

migrations/508_2022-10-19_invite.model

@@ -0,0 +1,4 @@
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab

migrations/515_2022-10-19_inviter_local.model

@@ -0,0 +1,16 @@
+OutboxItemId
+
+Collab
+
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabInviterLocal
+    collab CollabId
+    collabNew CollabFulfillsInviteId
+    invite OutboxItemId
+
+    UniqueCollabInviterLocal       collab
+    UniqueCollabInviterLocalInvite invite

migrations/520_2022-10-19_inviter_remote.model

@@ -0,0 +1,18 @@
+RemoteActor
+RemoteActivity
+
+Collab
+
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabInviterRemote
+    collab CollabId
+    collabNew CollabFulfillsInviteId
+    actor  RemoteActorId
+    invite RemoteActivityId
+
+    UniqueCollabInviterRemote       collab
+    UniqueCollabInviterRemoteInvite invite

migrations/525_2022-10-19_collab_accept_local.model

@@ -0,0 +1,23 @@
+Person
+OutboxItem
+
+Collab
+
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabRecipLocal
+    collab CollabId
+    person PersonId
+
+    UniqueCollabRecipLocal collab
+
+CollabRecipLocalAccept
+    collab CollabRecipLocalId
+    invite CollabFulfillsInviteId
+    accept OutboxItemId
+
+    UniqueCollabRecipLocalAcceptCollab collab
+    UniqueCollabRecipLocalAcceptAccept accept

migrations/527_2022-10-20_collab_accept_remote.model

@@ -0,0 +1,23 @@
+RemoteActor
+RemoteActivity
+
+Collab
+
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabRecipRemote
+    collab CollabId
+    actor  RemoteActorId
+
+    UniqueCollabRecipRemote collab
+
+CollabRecipRemoteAccept
+    collab CollabRecipRemoteId
+    invite CollabFulfillsInviteId
+    accept RemoteActivityId
+
+    UniqueCollabRecipRemoteAcceptCollab collab
+    UniqueCollabRecipRemoteAcceptAccept accept

src/Vervis/API.hs

@@ -187,21 +187,22 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             case accepteeDB of
                 Left (actorByKey, actorEntity, itemID) -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID
+                        lift $ getValBy $ UniqueCollabInviterLocalInvite itemID
                     return $
-                        (,Left (actorByKey, actorEntity)) . collabFulfillsInviteLocalCollab <$> maybeSender
+                        (,Left (actorByKey, actorEntity)) . collabInviterLocalCollab <$> maybeSender
                 Right remoteActivityID -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
+                        lift $ getValBy $ UniqueCollabInviterRemoteInvite remoteActivityID
-                    for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do
+                    for maybeSender $ \ (CollabInviterRemote collab actorID _) -> do
                         actor <- lift $ getJust actorID
                         lift $
                             (collab,) . Right . (,remoteActorFollowers actor) <$>
                                 getRemoteActorURI actor
 
-        maybeCollabMore <- for maybeCollab $ \ (collabID, collabSender) -> do
+        maybeCollabMore <- for maybeCollab $ \ (fulfillsID, collabSender) -> do
 
             -- Verify that Accept sender is the Collab recipient
+            CollabFulfillsInvite collabID <- lift $ getJust fulfillsID
             recip <-
                 lift $
                 requireEitherAlt
@@ -227,12 +228,12 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 (verifyRemoteAddressed remoteRecips . fst)
                 collabSender
 
-            return (collabID, recipID, topic, collabSender)
+            return (collabID, fulfillsID, recipID, topic, collabSender)
 
         -- Record the Accept on the Collab
         acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        for_ maybeCollabMore $ \ (_, recipID, _, _) -> do
+        for_ maybeCollabMore $ \ (_, fulfillsID, recipID, _, _) -> do
-            maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
+            maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
             unless (isNothing maybeAccept) $ do
                 lift $ delete acceptID
                 throwE "This Collab already has an Accept by recip"
@@ -244,8 +245,8 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
         -- delivery for unavailable remote recipients
         deliverHttpAccept <- do
             sieve <- do
-                let maybeTopicActor = (\ (_, _, t, _) -> t) <$> maybeCollabMore
+                let maybeTopicActor = (\ (_, _, _, t, _) -> t) <$> maybeCollabMore
-                    maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore
+                    maybeCollabSender = (\ (_, _, _, _, s) -> s) <$> maybeCollabMore
                 maybeTopicHash <- traverse hashGrantResource maybeTopicActor
                 maybeSenderHash <-
                     case maybeCollabSender of
@@ -267,7 +268,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 localRecipsFinal remoteRecips fwdHosts acceptID action
 
         -- If resource is local, approve the Collab and deliver a Grant
-        deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, resource, sender) -> do
+        deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, _, resource, sender) -> do
 
             -- If resource is local, verify it has received the Accept
             resourceByEntity <- getGrantResource resource "getGrantResource"
@@ -2058,7 +2059,8 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 insert_ $ CollabTopicDeck collabID deckID
             GrantResourceLoom (Entity loomID _) ->
                 insert_ $ CollabTopicLoom collabID loomID
-        insert_ $ CollabFulfillsInviteLocal collabID inviteID
+        fulfillsID <- insert $ CollabFulfillsInvite collabID
+        insert_ $ CollabInviterLocal fulfillsID inviteID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
                 insert_ $ CollabRecipLocal collabID personID

src/Vervis/Federation/Collab.hs

@@ -300,6 +300,7 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do
 
     insertCollab resource recipient inviteID = do
         collabID <- insert Collab
+        fulfillsID <- insert $ CollabFulfillsInvite collabID
         case resource of
             GrantResourceRepo repoID ->
                 insert_ $ CollabTopicRepo collabID repoID
@@ -307,7 +308,8 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do
                 insert_ $ CollabTopicDeck collabID deckID
             GrantResourceLoom loomID ->
                 insert_ $ CollabTopicLoom collabID loomID
-        insert_ $ CollabFulfillsInviteRemote collabID (remoteAuthorId author) inviteID
+        let authorID = remoteAuthorId author
+        insert_ $ CollabInviterRemote fulfillsID authorID inviteID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
                 insert_ $ CollabRecipLocal collabID personID
@@ -347,23 +349,24 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
 
         -- See if the accepted activity is an Invite to a local resource,
         -- grabbing the Collab record from our DB
-        (collabID, inviteSender) <-
+        (fulfillsID, inviteSender) <-
             case accepteeDB of
                 Left (actorByKey, _actorEntity, itemID) -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID
+                        lift $ getValBy $ UniqueCollabInviterLocalInvite itemID
-                    (,Left actorByKey) . collabFulfillsInviteLocalCollab <$>
+                    (,Left actorByKey) . collabInviterLocalCollab <$>
                         fromMaybeE maybeSender "Accepted local activity isn't an Invite I'm aware of"
                 Right remoteActivityID -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
+                        lift $ getValBy $ UniqueCollabInviterRemoteInvite remoteActivityID
-                    CollabFulfillsInviteRemote collab actorID _ <-
+                    CollabInviterRemote collab actorID _ <-
                         fromMaybeE maybeSender "Accepted remote activity isn't an Invite I'm aware of"
                     actor <- lift $ getJust actorID
                     sender <- lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
                     return (collab, Right sender)
 
         -- Find the local resource and verify it's me
+        CollabFulfillsInvite collabID <- lift $ getJust fulfillsID
         topic <- lift $ getCollabTopic collabID
         unless (topicResource recipKey == topic) $
             throwE "Accept object is an Invite for some other resource"
@@ -389,7 +392,7 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
         -- Record the Accept on the Collab
         mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
         for mractid $ \ acceptID -> do
-            maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID acceptID
+            maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
             unless (isNothing maybeAccept) $ do
                 lift $ delete acceptID
                 throwE "This Invite already has an Accept by recip"

src/Vervis/Foundation.hs

@@ -901,6 +901,8 @@ instance YesodBreadcrumbs App where
 
         DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d)
 
+        DeckCollabsR d -> ("Collaborators", Just $ DeckR d)
+
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
         TicketEventsR d t      -> ("Events", Just $ TicketR d t)

src/Vervis/Handler/Deck.hs

@@ -36,6 +36,8 @@ module Vervis.Handler.Deck
 
     , getDeckStampR
 
+    , getDeckCollabsR
+
 
 
 
@@ -45,7 +47,6 @@ module Vervis.Handler.Deck
     , getProjectsR
     , getProjectR
     , putProjectR
-    , getProjectDevsR
     , postProjectDevsR
     , getProjectDevNewR
     , getProjectDevR
@@ -59,6 +60,7 @@ where
 import Control.Monad
 import Control.Monad.Trans.Except
 import Data.Aeson
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Default.Class
 import Data.Foldable
@@ -108,10 +110,13 @@ import Vervis.Form.Tracker
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Paginate
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
+import Vervis.Time
 import Vervis.Web.Actor
 import Vervis.Widget.Person
 import Vervis.Widget.Ticket
@@ -399,6 +404,31 @@ postDeckUnfollowR _ = error "Temporarily disabled"
 getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
 getDeckStampR = servePerActorKey deckActor LocalActorDeck
 
+getDeckCollabsR :: KeyHashid Deck -> Handler Html
+getDeckCollabsR deckHash = do
+    deckID <- decodeKeyHashid404 deckHash
+    (deck, actor, collabs, invites) <- runDB $ do
+        deck <- get404 deckID
+        actor <- getJust $ deckActor deck
+        collabs <- do
+            grants <-
+                getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
+            traverse (bitraverse getPersonWidgetInfo pure) grants
+        invites <- do
+            invites' <-
+                getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
+            for invites' $ \ (inviter, recip, time) -> (,,)
+                <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+                <*> getPersonWidgetInfo recip
+                <*> pure time
+        return (deck, actor, collabs, invites)
+    defaultLayout $(widgetFile "deck/collab/list")
+    where
+    grabPerson actorID = do
+        actorByKey <- getLocalActor actorID
+        case actorByKey of
+            LocalActorPerson personID -> return personID
+            _ -> error "Surprise, local inviter actor isn't a Person"
 
 
 
@@ -435,23 +465,6 @@ getProjectsR ident = do
         return $ project ^. ProjectIdent
     defaultLayout $(widgetFile "project/list")
 
-getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
-getProjectDevsR shr prj = do
-    devs <- runDB $ do
-        jid <- do
-            Entity sid _ <- getBy404 $ UniqueSharer shr
-            Entity jid _ <- getBy404 $ UniqueProject prj sid
-            return jid
-        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, obid) <- runDB $ do

src/Vervis/Migration.hs

@@ -2805,6 +2805,132 @@ changes hLocal ctx =
         when (isNothing mw) $
             insert_ $
                 Workflow507 (text2wfl "dummy507") Nothing Nothing WSPublic
+      -- 508
+    , addEntities model_508_invite
+      -- 509
+    , renameEntity "CollabFulfillsInviteLocal" "CollabInviterLocal"
+      -- 510
+    , renameUnique
+        "CollabInviterLocal"
+        "UniqueCollabFulfillsInviteLocal"
+        "UniqueCollabInviterLocal"
+      -- 511
+    , renameUnique
+        "CollabInviterLocal"
+        "UniqueCollabFulfillsInviteLocalInvite"
+        "UniqueCollabInviterLocalInvite"
+      -- 512
+    , renameEntity "CollabFulfillsInviteRemote" "CollabInviterRemote"
+      -- 513
+    , renameUnique
+        "CollabInviterRemote"
+        "UniqueCollabFulfillsInviteRemote"
+        "UniqueCollabInviterRemote"
+      -- 514
+    , renameUnique
+        "CollabInviterRemote"
+        "UniqueCollabFulfillsInviteRemoteInvite"
+        "UniqueCollabInviterRemoteInvite"
+      -- 515
+    , addFieldRefRequired''
+        "CollabInviterLocal"
+        (do cid <- insert Collab515
+            insertEntity $ CollabFulfillsInvite515 cid
+        )
+        (Just $ \ (Entity cfiidTemp cfiTemp) -> do
+            cs <- selectList ([] :: [Filter CollabInviterLocal515]) []
+            for_ cs $ \ (Entity inviterID inviter) -> do
+                let collabID = collabInviterLocal515Collab inviter
+                fulfillsID <- insert $ CollabFulfillsInvite515 collabID
+                update inviterID [CollabInviterLocal515CollabNew =. fulfillsID]
+            delete cfiidTemp
+            delete $ collabFulfillsInvite515Collab cfiTemp
+        )
+        "collabNew"
+        "CollabFulfillsInvite"
+      -- 516
+    , removeUnique "CollabInviterLocal" "UniqueCollabInviterLocal"
+      -- 517
+    , removeField "CollabInviterLocal" "collab"
+      -- 518
+    , renameField "CollabInviterLocal" "collabNew" "collab"
+      -- 519
+    , addUnique' "CollabInviterLocal" "" ["collab"]
+      -- 520
+    , addFieldRefRequired''
+        "CollabInviterRemote"
+        (do cid <- insert Collab520
+            insertEntity $ CollabFulfillsInvite520 cid
+        )
+        (Just $ \ (Entity cfiidTemp cfiTemp) -> do
+            cs <- selectList ([] :: [Filter CollabInviterRemote520]) []
+            for_ cs $ \ (Entity inviterID inviter) -> do
+                let collabID = collabInviterRemote520Collab inviter
+                fulfillsID <- insert $ CollabFulfillsInvite520 collabID
+                update inviterID [CollabInviterRemote520CollabNew =. fulfillsID]
+            delete cfiidTemp
+            delete $ collabFulfillsInvite520Collab cfiTemp
+        )
+        "collabNew"
+        "CollabFulfillsInvite"
+      -- 521
+    , removeUnique "CollabInviterRemote" "UniqueCollabInviterRemote"
+      -- 522
+    , removeField "CollabInviterRemote" "collab"
+      -- 523
+    , renameField "CollabInviterRemote" "collabNew" "collab"
+      -- 524
+    , addUnique' "CollabInviterRemote" "" ["collab"]
+      -- 525
+    , addFieldRefRequired''
+        "CollabRecipLocalAccept"
+        (do cid <- insert Collab525
+            insertEntity $ CollabFulfillsInvite525 cid
+        )
+        (Just $ \ (Entity cfiidTemp cfiTemp) -> do
+            cs <- selectList ([] :: [Filter CollabRecipLocalAccept525]) []
+            for_ cs $ \ (Entity crlaID crla) -> do
+                crl <- getJust $ collabRecipLocalAccept525Collab crla
+                let cid = collabRecipLocal525Collab crl
+                cfiID <- do
+                    mcfi <- getBy $ UniqueCollabFulfillsInvite525 cid
+                    case mcfi of
+                        Nothing -> error "No FulfillsInvite for RecipAccept"
+                        Just ent -> pure $ entityKey ent
+                update crlaID [CollabRecipLocalAccept525Invite =. cfiID]
+
+            delete cfiidTemp
+            delete $ collabFulfillsInvite525Collab cfiTemp
+        )
+        "invite"
+        "CollabFulfillsInvite"
+      -- 526
+    , addUnique' "CollabRecipLocalAccept" "Invite" ["invite"]
+      -- 527
+    , addFieldRefRequired''
+        "CollabRecipRemoteAccept"
+        (do cid <- insert Collab527
+            insertEntity $ CollabFulfillsInvite527 cid
+        )
+        (Just $ \ (Entity cfiidTemp cfiTemp) -> do
+            cs <- selectList ([] :: [Filter CollabRecipRemoteAccept527]) []
+            for_ cs $ \ (Entity crlaID crla) -> do
+                crl <- getJust $ collabRecipRemoteAccept527Collab crla
+                let cid = collabRecipRemote527Collab crl
+                cfiID <- do
+                    mcfi <- getBy $ UniqueCollabFulfillsInvite527 cid
+                    case mcfi of
+                        Nothing -> error "No FulfillsInvite for RecipAccept"
+                        Just ent -> pure $ entityKey ent
+                update crlaID [CollabRecipRemoteAccept527Invite =. cfiID]
+
+            delete cfiidTemp
+            delete $ collabFulfillsInvite527Collab cfiTemp
+        )
+        "invite"
+        "CollabFulfillsInvite"
+      -- 528
+    , addUnique' "CollabRecipRemoteAccept" "Invite" ["invite"]
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -58,6 +58,7 @@ module Vervis.Migration.Entities
     , model_453_collab_receive
     , model_494_mr_origin
     , model_497_sigkey
+    , model_508_invite
     )
 where
 
@@ -227,3 +228,6 @@ model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")
 
 model_497_sigkey :: [Entity SqlBackend]
 model_497_sigkey = $(schema "497_2022-09-29_sigkey")
+
+model_508_invite :: [Entity SqlBackend]
+model_508_invite = $(schema "508_2022-10-19_invite")

src/Vervis/Migration/Model.hs

@@ -512,3 +512,15 @@ makeEntitiesMigration "504"
 
 makeEntitiesMigration "507"
     $(modelFile "migrations/507_2022-10-16_workflow.model")
+
+makeEntitiesMigration "515"
+    $(modelFile "migrations/515_2022-10-19_inviter_local.model")
+
+makeEntitiesMigration "520"
+    $(modelFile "migrations/520_2022-10-19_inviter_remote.model")
+
+makeEntitiesMigration "525"
+    $(modelFile "migrations/525_2022-10-19_collab_accept_local.model")
+
+makeEntitiesMigration "527"
+    $(modelFile "migrations/527_2022-10-20_collab_accept_remote.model")

src/Vervis/Persist/Actor.hs

@@ -22,6 +22,7 @@ module Vervis.Persist.Actor
     , insertActor
     , updateOutboxItem
     , fillPerActorKeys
+    , getPersonWidgetInfo
     )
 where
 
@@ -32,6 +33,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
 import Data.Barbie
+import Data.Bitraversable
 import Data.Text (Text)
 import Data.Traversable
 import Database.Persist
@@ -166,3 +168,20 @@ fillPerActorKeys = do
         runSiteDB $ insertMany_ keys
         logInfo $
             T.concat ["Filled ", T.pack (show $ length keys), " actor keys"]
+
+getPersonWidgetInfo
+    :: MonadIO m
+    => Either PersonId RemoteActorId
+    -> ReaderT SqlBackend m
+        (Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor))
+getPersonWidgetInfo = bitraverse getLocal getRemote
+    where
+    getLocal personID = do
+        person <- getJust personID
+        actor <- getJust $ personActor person
+        return (Entity personID person, actor)
+    getRemote remoteActorID = do
+        remoteActor <- getJust remoteActorID
+        remoteObject <- getJust $ remoteActorIdent remoteActor
+        inztance <- getJust $ remoteObjectInstance remoteObject
+        return (inztance, remoteObject, remoteActor)

src/Vervis/Persist/Collab.hs

@@ -16,13 +16,18 @@
 module Vervis.Persist.Collab
     ( getCollabTopic
     , getGrantRecip
+    , getTopicGrants
+    , getTopicInvites
     )
 where
 
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
+import Data.Time.Clock
 import Database.Persist.Sql
 
+import qualified Database.Esqueleto as E
+
 import Database.Persist.Local
 
 import Vervis.Access
@@ -47,3 +52,101 @@ getCollabTopic collabID = do
             _ -> error "Found Collab with multiple topics"
 
 getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
+
+getTopicGrants
+    :: ( MonadIO m
+       , PersistRecordBackend topic SqlBackend
+       , PersistRecordBackend resource SqlBackend
+       )
+    => EntityField topic CollabId
+    -> EntityField topic (Key resource)
+    -> Key resource
+    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)]
+getTopicGrants topicCollabField topicActorField resourceID =
+    fmap (map adapt) $
+    E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
+        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab
+        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab
+        E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
+        E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
+        E.where_ $ topic E.^. topicActorField E.==. E.val resourceID
+        E.orderBy [E.asc $ enable E.^. CollabEnableId]
+        return
+            ( recipL E.?. CollabRecipLocalPerson
+            , recipR E.?. CollabRecipRemoteActor
+            , grant E.^. OutboxItemPublished
+            )
+    where
+    adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value time) =
+        ( case (maybePersonID, maybeRemoteActorID) of
+            (Nothing, Nothing) -> error "No recip"
+            (Just personID, Nothing) -> Left personID
+            (Nothing, Just remoteActorID) -> Right remoteActorID
+            (Just _, Just _) -> error "Multi recip"
+        , time
+        )
+
+getTopicInvites
+    :: ( MonadIO m
+       , PersistRecordBackend topic SqlBackend
+       , PersistRecordBackend resource SqlBackend
+       )
+    => EntityField topic CollabId
+    -> EntityField topic (Key resource)
+    -> Key resource
+    -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime)]
+getTopicInvites topicCollabField topicActorField resourceID =
+    fmap (map adapt) $
+    E.select $ E.from $
+    \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
+      `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR
+      `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor)
+      `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity)
+      ) -> do
+        E.on $ inviterR E.?. CollabInviterRemoteInvite E.==. activity E.?. RemoteActivityId
+        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterR E.?. CollabInviterRemoteCollab
+        E.on $ item E.?. OutboxItemOutbox E.==. actor E.?. ActorOutbox
+        E.on $ inviterL E.?. CollabInviterLocalInvite E.==. item E.?. OutboxItemId
+        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterL E.?. CollabInviterLocalCollab
+        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab
+        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab
+        E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab
+        E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
+        E.where_ $
+            topic E.^. topicActorField E.==. E.val resourceID E.&&.
+            E.isNothing (enable E.?. CollabEnableId)
+        E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId]
+        return
+            ( actor E.?. ActorId
+            , item E.?. OutboxItemPublished
+            , inviterR E.?. CollabInviterRemoteActor
+            , activity E.?. RemoteActivityReceived
+            , recipL E.?. CollabRecipLocalPerson
+            , recipR E.?. CollabRecipRemoteActor
+            )
+    where
+    adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR) =
+        let l = case (inviterL, timeL) of
+                    (Nothing, Nothing) -> Nothing
+                    (Just i, Just t) -> Just (i, t)
+                    _ -> error "Impossible"
+            r = case (inviterR, timeR) of
+                    (Nothing, Nothing) -> Nothing
+                    (Just i, Just t) -> Just (i, t)
+                    _ -> error "Impossible"
+            (inviter, time) =
+                case (l, r) of
+                    (Nothing, Nothing) -> error "No inviter"
+                    (Just (actorID, time), Nothing) ->
+                        (Left actorID, time)
+                    (Nothing, Just (remoteActorID, time)) ->
+                        (Right remoteActorID, time)
+                    (Just _, Just _) -> error "Multi inviter"
+        in  ( inviter
+            , case (recipL, recipR) of
+                (Nothing, Nothing) -> error "No recip"
+                (Just personID, Nothing) -> Left personID
+                (Nothing, Just remoteActorID) -> Right remoteActorID
+                (Just _, Just _) -> error "Multi recip"
+            , time
+            )

templates/deck/collab/list.hamlet

@@ -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.
 $#
@@ -12,17 +12,34 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
+^{deckNavW (Entity deckID deck) actor}
+
+<h2>Collaborators
+
 <table>
   <tr>
     <th>Collaborator
     <th>Role
-  $forall (Entity _sid sharer, Value mrl) <- devs
+    <th>Since
+  $forall (person, since) <- collabs
     <tr>
-      <td>^{sharerLinkW sharer}
+      <td>^{personLinkFedW person}
-      <td>
+      <td>Admin
-        $maybe rl <- mrl
+      <td>#{showDate since}
-          #{rl2text rl}
-        $nothing
-          (Developer)
 
-<a href=@{ProjectDevNewR shr prj}>Add…
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Invitee
+    <th>Role
+    <th>Time
+  $forall (inviter, invitee, time) <- invites
+    <tr>
+      <td>^{personLinkFedW inviter}
+      <td>^{personLinkFedW invitee}
+      <td>Admin
+      <td>#{showDate time}
+
+$# <a href=@{ProjectDevNewR shr prj}>Add…

templates/deck/widget/nav.hamlet

@@ -28,7 +28,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <a href=@{DeckFollowersR deckHash}>
       [🐤 Followers]
   <span>
-    [🤝 Collaborators]
+    <a href=@{DeckCollabsR deckHash}>
+      [🤝 Collaborators]
   <span>
     <a href=@{DeckTicketsR deckHash}>
       [🐛 Tickets]

th/models

@@ -593,20 +593,25 @@ CollabFulfillsLocalTopicCreation
 
     UniqueCollabFulfillsLocalTopicCreation collab
 
-CollabFulfillsInviteLocal
+CollabFulfillsInvite
     collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabInviterLocal
+    collab CollabFulfillsInviteId
     invite OutboxItemId
 
-    UniqueCollabFulfillsInviteLocal       collab
+    UniqueCollabInviterLocal       collab
-    UniqueCollabFulfillsInviteLocalInvite invite
+    UniqueCollabInviterLocalInvite invite
 
-CollabFulfillsInviteRemote
+CollabInviterRemote
-    collab CollabId
+    collab CollabFulfillsInviteId
     actor  RemoteActorId
     invite RemoteActivityId
 
-    UniqueCollabFulfillsInviteRemote       collab
+    UniqueCollabInviterRemote       collab
-    UniqueCollabFulfillsInviteRemoteInvite invite
+    UniqueCollabInviterRemoteInvite invite
 
 -------------------------------- Collab topic --------------------------------
 
@@ -652,9 +657,11 @@ CollabRecipLocal
 
 CollabRecipLocalAccept
     collab CollabRecipLocalId
+    invite CollabFulfillsInviteId
     accept OutboxItemId
 
     UniqueCollabRecipLocalAcceptCollab collab
+    UniqueCollabRecipLocalAcceptInvite invite
     UniqueCollabRecipLocalAcceptAccept accept
 
 CollabRecipRemote
@@ -665,9 +672,11 @@ CollabRecipRemote
 
 CollabRecipRemoteAccept
     collab CollabRecipRemoteId
+    invite CollabFulfillsInviteId
     accept RemoteActivityId
 
     UniqueCollabRecipRemoteAcceptCollab collab
+    UniqueCollabRecipRemoteAcceptInvite invite
     UniqueCollabRecipRemoteAcceptAccept accept
 
 ------------------------------------------------------------------------------

th/routes

@@ -215,6 +215,8 @@
 
 /decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid     DeckStampR      GET
 
+/decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
+
 ---- Ticket ------------------------------------------------------------------
 
 /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid            TicketR            GET