From fdf6a83c40ef272dda65073f0960a127204d23a7 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 20 Oct 2022 12:53:54 +0000 Subject: [PATCH] DB, UI: Prepare DB schema for Join flow + display deck collaborators & invites --- migrations/508_2022-10-19_invite.model | 4 + migrations/515_2022-10-19_inviter_local.model | 16 +++ .../520_2022-10-19_inviter_remote.model | 18 +++ .../525_2022-10-19_collab_accept_local.model | 23 ++++ .../527_2022-10-20_collab_accept_remote.model | 23 ++++ src/Vervis/API.hs | 26 ++-- src/Vervis/Federation/Collab.hs | 17 ++- src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Deck.hs | 49 ++++--- src/Vervis/Migration.hs | 126 ++++++++++++++++++ src/Vervis/Migration/Entities.hs | 4 + src/Vervis/Migration/Model.hs | 12 ++ src/Vervis/Persist/Actor.hs | 19 +++ src/Vervis/Persist/Collab.hs | 103 ++++++++++++++ templates/deck/collab/list.hamlet | 35 +++-- templates/deck/widget/nav.hamlet | 3 +- th/models | 23 +++- th/routes | 2 + 18 files changed, 451 insertions(+), 54 deletions(-) create mode 100644 migrations/508_2022-10-19_invite.model create mode 100644 migrations/515_2022-10-19_inviter_local.model create mode 100644 migrations/520_2022-10-19_inviter_remote.model create mode 100644 migrations/525_2022-10-19_collab_accept_local.model create mode 100644 migrations/527_2022-10-20_collab_accept_remote.model diff --git a/migrations/508_2022-10-19_invite.model b/migrations/508_2022-10-19_invite.model new file mode 100644 index 0000000..46ac282 --- /dev/null +++ b/migrations/508_2022-10-19_invite.model @@ -0,0 +1,4 @@ +CollabFulfillsInvite + collab CollabId + + UniqueCollabFulfillsInvite collab diff --git a/migrations/515_2022-10-19_inviter_local.model b/migrations/515_2022-10-19_inviter_local.model new file mode 100644 index 0000000..badb782 --- /dev/null +++ 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 diff --git a/migrations/520_2022-10-19_inviter_remote.model b/migrations/520_2022-10-19_inviter_remote.model new file mode 100644 index 0000000..af7afcb --- /dev/null +++ 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 diff --git a/migrations/525_2022-10-19_collab_accept_local.model b/migrations/525_2022-10-19_collab_accept_local.model new file mode 100644 index 0000000..8973f97 --- /dev/null +++ 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 diff --git a/migrations/527_2022-10-20_collab_accept_remote.model b/migrations/527_2022-10-20_collab_accept_remote.model new file mode 100644 index 0000000..68ee5f8 --- /dev/null +++ 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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index bebe6ea..15ad4f2 100644 --- 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 diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index f6913fd..21efb60 100644 --- 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" diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f0f73f5..0e354c5 100644 --- 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) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 7cf7b4f..d01e133 100644 --- 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 3e1625e..b21a34f 100644 --- 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 diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index a3685d4..786a2aa 100644 --- 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") diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index d584965..7595ec1 100644 --- 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") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index a8726f7..4bfb01b 100644 --- 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) diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index cbf26f7..07478d5 100644 --- 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 + ) diff --git a/templates/deck/collab/list.hamlet b/templates/deck/collab/list.hamlet index 8d8a915..3482c64 100644 --- 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 . +$# Written in 2016, 2019, 2022 by fr33domlover . $# $# ♡ 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 $# . +^{deckNavW (Entity deckID deck) actor} + +

Collaborators + -
Collaborator Role - $forall (Entity _sid sharer, Value mrl) <- devs + Since + $forall (person, since) <- collabs
^{sharerLinkW sharer} - - $maybe rl <- mrl - #{rl2text rl} - $nothing - (Developer) + ^{personLinkFedW person} + Admin + #{showDate since} -Add… +

Invites + + + + +
Inviter + Invitee + Role + Time + $forall (inviter, invitee, time) <- invites +
^{personLinkFedW inviter} + ^{personLinkFedW invitee} + Admin + #{showDate time} + +$# Add… diff --git a/templates/deck/widget/nav.hamlet b/templates/deck/widget/nav.hamlet index 29f07aa..9af86d7 100644 --- a/templates/deck/widget/nav.hamlet +++ b/templates/deck/widget/nav.hamlet @@ -28,7 +28,8 @@ $# . [🐤 Followers] - [🤝 Collaborators] + + [🤝 Collaborators] [🐛 Tickets] diff --git a/th/models b/th/models index c78cfe6..bab60bf 100644 --- 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 ------------------------------------------------------------------------------ diff --git a/th/routes b/th/routes index f02f883..1c4c687 100644 --- 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