UI, S2S: Implement Join flow in S2S + deck devs page now lists join requests

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

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
+    (,) <$> nameExceptT "Invite target" (parseTopic target)
-        <*> parseRecipient object
+        <*> nameExceptT "Invite object" (parseRecipient object)
     where
-    verifyRole (Left AP.RoleAdmin) = pure ()
+    parseRecipient u = do
-    verifyRole (Right _) =
+        routeOrRemote <- parseFedURI u
-        throwE "ForgeFed Admin is the only role allowed currently"
+        bitraverse
-    parseTopic u@(ObjURI h lu) = do
+            (\ route -> 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"
                 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

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,
+        -- See if the accepted activity is an Invite or Join to a local
-        -- grabbing the Collab record from our DB
+        -- resource, grabbing the Collab record from our DB
-        (fulfillsID, inviteSender) <-
+        collab <- do
-            case accepteeDB of
+            maybeCollab <-
-                Left (actorByKey, _actorEntity, itemID) -> do
+                lift $ runMaybeT $
-                    maybeSender <-
+                    Left <$> tryInvite accepteeDB <|>
-                        lift $ getValBy $ UniqueCollabInviterLocalInvite itemID
+                    Right <$> tryJoin accepteeDB
-                    (,Left actorByKey) . collabInviterLocalCollab <$>
+            fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
-                        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)
 
         -- 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
+        idsForAccept <-
-        recipID <- do
+            case collab of
-            recip <-
+
-                lift $
+                -- If accepting an Invite, find the Collab recipient and verify
-                requireEitherAlt
+                -- it's the sender of the Accept
-                    (getBy $ UniqueCollabRecipLocal collabID)
+                Left (fulfillsID, _) -> Left <$> do
-                    (getBy $ UniqueCollabRecipRemote collabID)
+                    recip <-
-                    "Found Collab with no recip"
+                        lift $
-                    "Found Collab with multiple recips"
+                        requireEitherAlt
-            case recip of
+                            (getBy $ UniqueCollabRecipLocal collabID)
-                Right (Entity crrid crr)
+                            (getBy $ UniqueCollabRecipRemote collabID)
-                    | collabRecipRemoteActor crr == remoteAuthorId author -> return crrid
+                            "Found Collab with no recip"
-                _ -> throwE "Accepting an Invite whose recipient is someone else"
+                            "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
+            case idsForAccept of
-                lift $ delete acceptID
+                Left (fulfillsID, recipID) -> do
-                throwE "This Invite already has an Accept by recip"
+                    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
 

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

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 ->

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

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

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")

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"

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

templates/deck/collab/list.hamlet

@@ -42,4 +42,17 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>Admin
       <td>#{showDate time}
 
+<h2>Joins
+
+<table>
+  <tr>
+    <th>Joiner
+    <th>Role
+    <th>Time
+  $forall (joiner, time) <- joins
+    <tr>
+      <td>^{personLinkFedW joiner}
+      <td>Admin
+      <td>#{showDate time}
+
 $# <a href=@{ProjectDevNewR shr prj}>Add…

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