From 72796a6bdc4416a846f5d5cb4e36639992b26eaf Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 14 Nov 2022 15:11:25 +0000 Subject: [PATCH] UI, S2S: Implement Join flow in S2S + deck devs page now lists join requests --- migrations/530_2022-11-01_join.model | 37 ++++ src/Vervis/Data/Collab.hs | 82 +++++---- src/Vervis/Federation/Collab.hs | 246 +++++++++++++++++++++++---- src/Vervis/Handler/Deck.hs | 11 +- src/Vervis/Handler/Loom.hs | 2 + src/Vervis/Handler/Repo.hs | 2 + src/Vervis/Migration.hs | 2 + src/Vervis/Migration/Entities.hs | 4 + src/Vervis/Persist/Collab.hs | 51 ++++++ src/Web/ActivityPub.hs | 21 +++ templates/deck/collab/list.hamlet | 13 ++ th/models | 38 +++++ 12 files changed, 433 insertions(+), 76 deletions(-) create mode 100644 migrations/530_2022-11-01_join.model diff --git a/migrations/530_2022-11-01_join.model b/migrations/530_2022-11-01_join.model new file mode 100644 index 0000000..da71dcb --- /dev/null +++ b/migrations/530_2022-11-01_join.model @@ -0,0 +1,37 @@ +CollabFulfillsJoin + collab CollabId + + UniqueCollabFulfillsJoin collab + +CollabApproverLocal + collab CollabFulfillsJoinId + accept OutboxItemId + + UniqueCollabApproverLocal collab + UniqueCollabApproverLocalAccept accept + +CollabApproverRemote + collab CollabFulfillsJoinId + actor RemoteActorId + accept RemoteActivityId + + UniqueCollabApproverRemote collab + UniqueCollabApproverRemoteAccept accept + +CollabRecipLocalJoin + collab CollabRecipLocalId + fulfills CollabFulfillsJoinId + join OutboxItemId + + UniqueCollabRecipLocalJoinCollab collab + UniqueCollabRecipLocalJoinFulfills fulfills + UniqueCollabRecipLocalJoinJoin join + +CollabRecipRemoteJoin + collab CollabRecipRemoteId + fulfills CollabFulfillsJoinId + join RemoteActivityId + + UniqueCollabRecipRemoteJoinCollab collab + UniqueCollabRecipRemoteJoinFulfills fulfills + UniqueCollabRecipRemoteJoinJoin join diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index fb98654..537febb 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -22,6 +22,7 @@ module Vervis.Data.Collab ( GrantRecipBy (..) , parseInvite + , parseJoin , parseGrant , parseAccept @@ -33,6 +34,7 @@ import Control.Monad import Control.Monad.Trans.Except import Data.Barbie import Data.Bifunctor +import Data.Bitraversable import Data.Functor.Identity import Data.Text (Text) import Database.Persist.Types @@ -54,6 +56,11 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model +parseGrantResource (RepoR r) = Just $ GrantResourceRepo r +parseGrantResource (DeckR d) = Just $ GrantResourceDeck d +parseGrantResource (LoomR l) = Just $ GrantResourceLoom l +parseGrantResource _ = Nothing + data GrantRecipBy f = GrantRecipPerson (f Person) deriving (Generic, FunctorB, TraversableB, ConstraintsB) @@ -74,6 +81,25 @@ unhashGrantRecip resource = do unhashGrantRecipE resource e = ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource +verifyRole (Left AP.RoleAdmin) = pure () +verifyRole (Right _) = + throwE "ForgeFed Admin is the only role allowed currently" + +parseTopic u = do + routeOrRemote <- parseFedURI u + bitraverse + (\ route -> do + resourceHash <- + fromMaybeE + (parseGrantResource route) + "Not a shared resource route" + unhashGrantResourceE + resourceHash + "Contains invalid hashid" + ) + pure + routeOrRemote + parseInvite :: Either PersonId FedURI -> AP.Invite URIMode @@ -83,57 +109,39 @@ parseInvite ) parseInvite sender (AP.Invite instrument object target) = do verifyRole instrument - (,) <$> parseTopic target - <*> parseRecipient object + (,) <$> nameExceptT "Invite target" (parseTopic target) + <*> nameExceptT "Invite object" (parseRecipient object) where - verifyRole (Left AP.RoleAdmin) = pure () - verifyRole (Right _) = - throwE "ForgeFed Admin is the only role allowed currently" - parseTopic u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Invite target isn't a valid route" - resourceHash <- - fromMaybeE - (parseGrantResource route) - "Invite target isn't a shared resource route" - unhashGrantResourceE - resourceHash - "Invite target contains invalid hashid" - else pure $ Right u - where - parseGrantResource (RepoR r) = Just $ GrantResourceRepo r - parseGrantResource (DeckR d) = Just $ GrantResourceDeck d - parseGrantResource (LoomR l) = Just $ GrantResourceLoom l - parseGrantResource _ = Nothing - parseRecipient u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Invite object isn't a valid route" + parseRecipient u = do + routeOrRemote <- parseFedURI u + bitraverse + (\ route -> do recipHash <- fromMaybeE (parseGrantRecip route) - "Invite object isn't a grant recipient route" + "Not a grant recipient route" recipKey <- unhashGrantRecipE recipHash - "Invite object contains invalid hashid" + "Contains invalid hashid" case recipKey of GrantRecipPerson p | Left p == sender -> throwE "Invite local sender and recipient are the same Person" _ -> return recipKey - else Right <$> do + ) + (\ u -> do when (Right u == sender) $ throwE "Invite remote sender and recipient are the same actor" return u + ) + routeOrRemote + +parseJoin + :: AP.Join URIMode + -> ExceptT Text Handler (Either (GrantResourceBy Key) FedURI) +parseJoin (AP.Join instrument object) = do + verifyRole instrument + nameExceptT "Join object" (parseTopic object) parseGrant :: AP.Grant URIMode diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index 21efb60..efc6038 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -19,6 +19,10 @@ module Vervis.Federation.Collab ( personInviteF , topicInviteF + , repoJoinF + , deckJoinF + , loomJoinF + , repoAcceptF , deckAcceptF , loomAcceptF @@ -27,6 +31,7 @@ module Vervis.Federation.Collab ) where +import Control.Applicative import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.IO.Class @@ -316,6 +321,118 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do Right remoteActorID -> insert_ $ CollabRecipRemote collabID remoteActorID +topicJoinF + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> ActorId) + -> (forall f. f topic -> GrantResourceBy f) + -> UTCTime + -> KeyHashid topic + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Join URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +topicJoinF topicActor topicResource now recipHash author body mfwd luJoin join = (,Nothing) <$> do + + -- Check input + recipKey <- decodeKeyHashid404 recipHash + verifyNothingE + (AP.activityCapability $ actbActivity body) + "Capability not needed" + resource <- parseJoin join + unless (resource == Left (topicResource recipKey)) $ + throwE "Join's object isn't me, don't need this Join" + + maybeHttp <- lift $ runDB $ do + + -- Find recipient topic in DB, returning 404 if doesn't exist because + -- we're in the topic's inbox post handler + (recipActorID, recipActor) <- do + topic <- get404 recipKey + let actorID = topicActor topic + (actorID,) <$> getJust actorID + + -- Insert the Join to topic's inbox + mractid <- insertToInbox now author body (actorInbox recipActor) luJoin False + for mractid $ \ joinID -> do + + -- Insert Collab record to DB + insertCollab (topicResource recipKey) joinID + + -- Forward the Join activity to relevant local stages, + -- and schedule delivery for unavailable remote members of + -- them + for mfwd $ \ (localRecips, sig) -> do + let recipByHash = + grantResourceLocalActor $ topicResource recipHash + sieve = + makeRecipientSet + [] + [localActorFollowers recipByHash] + forwardActivityDB + (actbBL body) localRecips sig recipActorID recipByHash + sieve joinID + + -- Launch asynchronous HTTP forwarding of the Join activity + case maybeHttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just maybeForward -> do + traverse_ (forkWorker "topicJoinF inbox-forwarding") maybeForward + return $ + case maybeForward of + Nothing -> "Inserted Collab to DB, no inbox-forwarding to do" + Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Join" + + where + + insertCollab topic joinID = do + collabID <- insert Collab + fulfillsID <- insert $ CollabFulfillsJoin collabID + case topic of + GrantResourceRepo repoID -> + insert_ $ CollabTopicRepo collabID repoID + GrantResourceDeck deckID -> + insert_ $ CollabTopicDeck collabID deckID + GrantResourceLoom loomID -> + insert_ $ CollabTopicLoom collabID loomID + let authorID = remoteAuthorId author + recipID <- insert $ CollabRecipRemote collabID authorID + insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID + +repoJoinF + :: UTCTime + -> KeyHashid Repo + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Join URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +repoJoinF = topicJoinF repoActor GrantResourceRepo + +deckJoinF + :: UTCTime + -> KeyHashid Deck + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Join URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +deckJoinF = topicJoinF deckActor GrantResourceDeck + +loomJoinF + :: UTCTime + -> KeyHashid Loom + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Join URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +loomJoinF = topicJoinF loomActor GrantResourceLoom + topicAcceptF :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) @@ -333,6 +450,14 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac -- Check input acceptee <- parseAccept accept + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCap <- + traverse + (nameExceptT "Accept capability" . parseActivityURI) + (AP.activityCapability $ actbActivity body) + -- Find recipient topic in DB, returning 404 if doesn't exist because -- we're in the topic's inbox post handler recipKey <- decodeKeyHashid404 recipHash @@ -347,55 +472,76 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac a <- getActivity acceptee fromMaybeE a "Can't find acceptee in DB" - -- See if the accepted activity is an Invite to a local resource, - -- grabbing the Collab record from our DB - (fulfillsID, inviteSender) <- - case accepteeDB of - Left (actorByKey, _actorEntity, itemID) -> do - maybeSender <- - 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 $ 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) + -- See if the accepted activity is an Invite or Join to a local + -- resource, grabbing the Collab record from our DB + collab <- do + maybeCollab <- + lift $ runMaybeT $ + Left <$> tryInvite accepteeDB <|> + Right <$> tryJoin accepteeDB + fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of" -- Find the local resource and verify it's me - CollabFulfillsInvite collabID <- lift $ getJust fulfillsID + collabID <- + lift $ case collab of + Left (fulfillsID, _) -> + collabFulfillsInviteCollab <$> getJust fulfillsID + Right (fulfillsID, _) -> + collabFulfillsJoinCollab <$> getJust fulfillsID topic <- lift $ getCollabTopic collabID unless (topicResource recipKey == topic) $ throwE "Accept object is an Invite for some other resource" - -- Find the Collab recipient and verify it's the sender of the Accept - recipID <- do - recip <- - lift $ - requireEitherAlt - (getBy $ UniqueCollabRecipLocal collabID) - (getBy $ UniqueCollabRecipRemote collabID) - "Found Collab with no recip" - "Found Collab with multiple recips" - case recip of - Right (Entity crrid crr) - | collabRecipRemoteActor crr == remoteAuthorId author -> return crrid - _ -> throwE "Accepting an Invite whose recipient is someone else" + idsForAccept <- + case collab of + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + Left (fulfillsID, _) -> Left <$> do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case recip of + Right (Entity crrid crr) + | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid) + _ -> throwE "Accepting an Invite whose recipient is someone else" + + -- If accepting a Join, verify accepter has permission + Right (fulfillsID, _) -> Right <$> do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability + capability + (Right $ remoteAuthorId author) + (topicResource recipKey) + return fulfillsID -- Verify the Collab isn't already validated maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite" + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" -- 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 fulfillsID acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID - throwE "This Invite already has an Accept by recip" + + case idsForAccept of + Left (fulfillsID, recipID) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Invite already has an Accept by recip" + Right fulfillsID -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Join already has an Accept" -- Forward the Accept activity to relevant local stages, and -- schedule delivery for unavailable remote members of them @@ -414,8 +560,9 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac lift $ insert_ $ CollabEnable collabID grantID -- Prepare a Grant activity and insert to topic's outbox + let inviterOrJoiner = either snd snd collab (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- - lift $ prepareGrant inviteSender + lift $ prepareGrant inviterOrJoiner let recipByKey = grantResourceLocalActor $ topicResource recipKey _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant @@ -440,6 +587,31 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac where + tryInvite (Left (actorByKey, _actorEntity, itemID)) = + (,Left actorByKey) . collabInviterLocalCollab <$> + MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) + tryInvite (Right remoteActivityID) = do + CollabInviterRemote collab actorID _ <- + MaybeT $ getValBy $ + UniqueCollabInviterRemoteInvite remoteActivityID + actor <- lift $ getJust actorID + sender <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collab, Right sender) + + tryJoin (Left (actorByKey, _actorEntity, itemID)) = + (,Left actorByKey) . collabRecipLocalJoinFulfills <$> + MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) + tryJoin (Right remoteActivityID) = do + CollabRecipRemoteJoin recipID fulfillsID _ <- + MaybeT $ getValBy $ + UniqueCollabRecipRemoteJoinJoin remoteActivityID + remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID + actor <- lift $ getJust remoteActorID + joiner <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (fulfillsID, Right joiner) + prepareGrant sender = do encodeRouteHome <- getEncodeRouteHome diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 73d24a1..c28b99d 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -201,6 +201,8 @@ postDeckInboxR recipDeckHash = deckFollowF now recipDeckHash author body mfwd luActivity follow AP.InviteActivity invite -> topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite + AP.JoinActivity join -> + deckJoinF now recipDeckHash author body mfwd luActivity join OfferActivity (Offer obj target) -> case obj of OfferTicket ticket -> @@ -404,7 +406,7 @@ getDeckStampR = servePerActorKey deckActor LocalActorDeck getDeckCollabsR :: KeyHashid Deck -> Handler Html getDeckCollabsR deckHash = do deckID <- decodeKeyHashid404 deckHash - (deck, actor, collabs, invites) <- runDB $ do + (deck, actor, collabs, invites, joins) <- runDB $ do deck <- get404 deckID actor <- getJust $ deckActor deck collabs <- do @@ -418,7 +420,12 @@ getDeckCollabsR deckHash = do <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <*> getPersonWidgetInfo recip <*> pure time - return (deck, actor, collabs, invites) + joins <- do + joins' <- + getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID + for joins' $ \ (recip, time) -> + (,time) <$> getPersonWidgetInfo recip + return (deck, actor, collabs, invites, joins) defaultLayout $(widgetFile "deck/collab/list") where grabPerson actorID = do diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 4f5c75b..c70acfa 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -164,6 +164,8 @@ postLoomInboxR recipLoomHash = loomFollowF now recipLoomHash author body mfwd luActivity follow AP.InviteActivity invite -> topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite + AP.JoinActivity join -> + loomJoinF now recipLoomHash author body mfwd luActivity join AP.OfferActivity (AP.Offer obj target) -> case obj of AP.OfferTicket ticket -> diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 4e79ae1..0306a4b 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -277,6 +277,8 @@ postRepoInboxR recipRepoHash = repoFollowF now recipRepoHash author body mfwd luActivity follow AP.InviteActivity invite -> topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity invite + AP.JoinActivity join -> + repoJoinF now recipRepoHash author body mfwd luActivity join {- OfferActivity (Offer obj target) -> case obj of diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 43689c7..8847dc8 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2933,6 +2933,8 @@ changes hLocal ctx = , addUnique' "CollabRecipRemoteAccept" "Invite" ["invite"] -- 529 , removeField "Ticket" "status" + -- 530 + , addEntities model_530_join ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 786a2aa..fdd78e0 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -59,6 +59,7 @@ module Vervis.Migration.Entities , model_494_mr_origin , model_497_sigkey , model_508_invite + , model_530_join ) where @@ -231,3 +232,6 @@ model_497_sigkey = $(schema "497_2022-09-29_sigkey") model_508_invite :: [Entity SqlBackend] model_508_invite = $(schema "508_2022-10-19_invite") + +model_530_join :: [Entity SqlBackend] +model_530_join = $(schema "530_2022-11-01_join") diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 07478d5..93baa32 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -18,6 +18,7 @@ module Vervis.Persist.Collab , getGrantRecip , getTopicGrants , getTopicInvites + , getTopicJoins ) where @@ -150,3 +151,53 @@ getTopicInvites topicCollabField topicActorField resourceID = (Just _, Just _) -> error "Multi recip" , time ) + +getTopicJoins + :: ( MonadIO m + , PersistRecordBackend topic SqlBackend + , PersistRecordBackend resource SqlBackend + ) + => EntityField topic CollabId + -> EntityField topic (Key resource) + -> Key resource + -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)] +getTopicJoins topicCollabField topicActorField resourceID = + fmap (map adapt) $ + E.select $ E.from $ + \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills + `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item) + `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity) + ) -> do + E.on $ joinR E.?. CollabRecipRemoteJoinJoin E.==. activity E.?. RemoteActivityId + E.on $ joinR E.?. CollabRecipRemoteJoinCollab E.==. recipR E.?. CollabRecipRemoteId + E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinR E.?. CollabRecipRemoteJoinFulfills + E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId + E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId + E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills + E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab + 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.^. CollabFulfillsJoinId] + return + ( recipL E.?. CollabRecipLocalPerson + , item E.?. OutboxItemPublished + , recipR E.?. CollabRecipRemoteActor + , activity E.?. RemoteActivityReceived + ) + where + adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR) = + let l = case (recipL, timeL) of + (Nothing, Nothing) -> Nothing + (Just r, Just t) -> Just (r, t) + _ -> error "Impossible" + r = case (recipR, timeR) of + (Nothing, Nothing) -> Nothing + (Just r, Just t) -> Just (r, t) + _ -> error "Impossible" + in case (l, r) of + (Nothing, Nothing) -> error "No recip" + (Just (personID, time), Nothing) -> (Left personID, time) + (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time) + (Just _, Just _) -> error "Multi recip" diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 938be7d..9db737b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -70,6 +70,7 @@ module Web.ActivityPub , Follow (..) , Grant (..) , Invite (..) + , Join (..) , OfferObject (..) , Offer (..) , Push (..) @@ -1568,6 +1569,22 @@ encodeInvite (Invite obj context target) <> "context" .= context <> "target" .= target +data Join u = Join + { joinInstrument :: Either Role (ObjURI u) + , joinObject :: ObjURI u + } + +parseJoin :: UriMode u => Object -> Parser (Join u) +parseJoin o = + Join + <$> o .:+ "instrument" + <*> o .: "object" + +encodeJoin :: UriMode u => Join u -> Series +encodeJoin (Join obj context) + = "object" .=+ obj + <> "context" .= context + data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u) instance ActivityPub OfferObject where @@ -1688,6 +1705,7 @@ data SpecificActivity u | FollowActivity (Follow u) | GrantActivity (Grant u) | InviteActivity (Invite u) + | JoinActivity (Join u) | OfferActivity (Offer u) | PushActivity (Push u) | RejectActivity (Reject u) @@ -1745,6 +1763,7 @@ instance ActivityPub Activity where "Follow" -> FollowActivity <$> parseFollow o "Grant" -> GrantActivity <$> parseGrant o "Invite" -> InviteActivity <$> parseInvite o + "Join" -> JoinActivity <$> parseJoin o "Offer" -> OfferActivity <$> parseOffer o a actor "Push" -> PushActivity <$> parsePush a o "Reject" -> RejectActivity <$> parseReject o @@ -1771,6 +1790,7 @@ instance ActivityPub Activity where activityType (FollowActivity _) = "Follow" activityType (GrantActivity _) = "Grant" activityType (InviteActivity _) = "Invite" + activityType (JoinActivity _) = "Join" activityType (OfferActivity _) = "Offer" activityType (PushActivity _) = "Push" activityType (RejectActivity _) = "Reject" @@ -1783,6 +1803,7 @@ instance ActivityPub Activity where encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (GrantActivity a) = encodeGrant a encodeSpecific _ _ (InviteActivity a) = encodeInvite a + encodeSpecific _ _ (JoinActivity a) = encodeJoin a encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h _ (PushActivity a) = encodePush h a encodeSpecific _ _ (RejectActivity a) = encodeReject a diff --git a/templates/deck/collab/list.hamlet b/templates/deck/collab/list.hamlet index 3482c64..10a7fd8 100644 --- a/templates/deck/collab/list.hamlet +++ b/templates/deck/collab/list.hamlet @@ -42,4 +42,17 @@ $# . Admin #{showDate time} +

Joins + + + + +
Joiner + Role + Time + $forall (joiner, time) <- joins +
^{personLinkFedW joiner} + Admin + #{showDate time} + $# Add… diff --git a/th/models b/th/models index 47f0910..b28f13d 100644 --- a/th/models +++ b/th/models @@ -612,6 +612,44 @@ CollabInviterRemote UniqueCollabInviterRemote collab UniqueCollabInviterRemoteInvite invite +CollabFulfillsJoin + collab CollabId + + UniqueCollabFulfillsJoin collab + +CollabApproverLocal + collab CollabFulfillsJoinId + accept OutboxItemId + + UniqueCollabApproverLocal collab + UniqueCollabApproverLocalAccept accept + +CollabApproverRemote + collab CollabFulfillsJoinId + actor RemoteActorId + accept RemoteActivityId + + UniqueCollabApproverRemote collab + UniqueCollabApproverRemoteAccept accept + +CollabRecipLocalJoin + collab CollabRecipLocalId + fulfills CollabFulfillsJoinId + join OutboxItemId + + UniqueCollabRecipLocalJoinCollab collab + UniqueCollabRecipLocalJoinFulfills fulfills + UniqueCollabRecipLocalJoinJoin join + +CollabRecipRemoteJoin + collab CollabRecipRemoteId + fulfills CollabFulfillsJoinId + join RemoteActivityId + + UniqueCollabRecipRemoteJoinCollab collab + UniqueCollabRecipRemoteJoinFulfills fulfills + UniqueCollabRecipRemoteJoinJoin join + -------------------------------- Collab topic -------------------------------- -- Removed for now, until I figure out whether/how to federate custom roles