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