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

2022-10-20 12:53:54 +00:00 · 2022-10-20 12:53:54 +00:00 · fdf6a83c40
commit fdf6a83c40
parent eb342b47ed
18 changed files with 451 additions and 54 deletions
--- a/migrations/508_2022-10-19_invite.model
+++ b/migrations/508_2022-10-19_invite.model
@ -0,0 +1,4 @@
+CollabFulfillsInvite
+    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
--- a/migrations/515_2022-10-19_inviter_local.model
+++ b/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
--- a/migrations/520_2022-10-19_inviter_remote.model
+++ b/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
--- a/migrations/525_2022-10-19_collab_accept_local.model
+++ b/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
--- a/migrations/527_2022-10-20_collab_accept_remote.model
+++ b/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
--- a/src/Vervis/API.hs
+++ b/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
-                    for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do
+                        lift $ getValBy $ UniqueCollabInviterRemoteInvite remoteActivityID
+                    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
-            maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
+        for_ maybeCollabMore $ \ (_, fulfillsID, recipID, _, _) -> do
+            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
-                    maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore
+                let maybeTopicActor = (\ (_, _, _, t, _) -> t) <$> 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
--- a/src/Vervis/Federation/Collab.hs
+++ b/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
-                    (,Left actorByKey) . collabFulfillsInviteLocalCollab <$>
+                        lift $ getValBy $ UniqueCollabInviterLocalInvite itemID
+                    (,Left actorByKey) . collabInviterLocalCollab <$>
                        fromMaybeE maybeSender "Accepted local activity isn't an Invite I'm aware of"
                Right remoteActivityID -> do
                    maybeSender <-
-                        lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
-                    CollabFulfillsInviteRemote collab actorID _ <-
+                        lift $ getValBy $ UniqueCollabInviterRemoteInvite remoteActivityID
+                    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"
--- a/src/Vervis/Foundation.hs
+++ b/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)
--- a/src/Vervis/Handler/Deck.hs
+++ b/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
--- a/src/Vervis/Migration.hs
+++ b/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
--- a/src/Vervis/Migration/Entities.hs
+++ b/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")
--- a/src/Vervis/Migration/Model.hs
+++ b/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")
--- a/src/Vervis/Persist/Actor.hs
+++ b/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)
--- a/src/Vervis/Persist/Collab.hs
+++ b/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
+            )
--- a/templates/deck/collab/list.hamlet
+++ b/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>
-        $maybe rl <- mrl
-          #{rl2text rl}
-        $nothing
-          (Developer)
+      <td>^{personLinkFedW person}
+      <td>Admin
+      <td>#{showDate since}

-<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…
--- a/templates/deck/widget/nav.hamlet
+++ b/templates/deck/widget/nav.hamlet
@ -28,6 +28,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
    <a href=@{DeckFollowersR deckHash}>
      [🐤 Followers]
  <span>
+    <a href=@{DeckCollabsR deckHash}>
      [🤝 Collaborators]
  <span>
    <a href=@{DeckTicketsR deckHash}>
--- a/th/models
+++ b/th/models
@ -593,20 +593,25 @@ CollabFulfillsLocalTopicCreation

    UniqueCollabFulfillsLocalTopicCreation collab

-CollabFulfillsInviteLocal
+CollabFulfillsInvite
    collab CollabId
+
+    UniqueCollabFulfillsInvite collab
+
+CollabInviterLocal
+    collab CollabFulfillsInviteId
    invite OutboxItemId

-    UniqueCollabFulfillsInviteLocal       collab
-    UniqueCollabFulfillsInviteLocalInvite invite
+    UniqueCollabInviterLocal       collab
+    UniqueCollabInviterLocalInvite invite

-CollabFulfillsInviteRemote
-    collab CollabId
+CollabInviterRemote
+    collab CollabFulfillsInviteId
    actor  RemoteActorId
    invite RemoteActivityId

-    UniqueCollabFulfillsInviteRemote       collab
-    UniqueCollabFulfillsInviteRemoteInvite invite
+    UniqueCollabInviterRemote       collab
+    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

 ------------------------------------------------------------------------------
--- a/th/routes
+++ b/th/routes
@ -215,6 +215,8 @@

 /decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid     DeckStampR      GET

+/decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
+
 ---- Ticket ------------------------------------------------------------------

 /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid            TicketR            GET