1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 15:14:50 +09:00

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

This commit is contained in:
fr33domlover 2022-11-14 15:11:25 +00:00
parent e4d7156cbc
commit 72796a6bdc
12 changed files with 433 additions and 76 deletions

View file

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

View file

@ -22,6 +22,7 @@ module Vervis.Data.Collab
( GrantRecipBy (..) ( GrantRecipBy (..)
, parseInvite , parseInvite
, parseJoin
, parseGrant , parseGrant
, parseAccept , parseAccept
@ -33,6 +34,7 @@ import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Barbie import Data.Barbie
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Identity import Data.Functor.Identity
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Types import Database.Persist.Types
@ -54,6 +56,11 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model 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) data GrantRecipBy f = GrantRecipPerson (f Person)
deriving (Generic, FunctorB, TraversableB, ConstraintsB) deriving (Generic, FunctorB, TraversableB, ConstraintsB)
@ -74,6 +81,25 @@ unhashGrantRecip resource = do
unhashGrantRecipE resource e = unhashGrantRecipE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource 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 parseInvite
:: Either PersonId FedURI :: Either PersonId FedURI
-> AP.Invite URIMode -> AP.Invite URIMode
@ -83,57 +109,39 @@ parseInvite
) )
parseInvite sender (AP.Invite instrument object target) = do parseInvite sender (AP.Invite instrument object target) = do
verifyRole instrument verifyRole instrument
(,) <$> parseTopic target (,) <$> nameExceptT "Invite target" (parseTopic target)
<*> parseRecipient object <*> nameExceptT "Invite object" (parseRecipient object)
where 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 <- recipHash <-
fromMaybeE fromMaybeE
(parseGrantRecip route) (parseGrantRecip route)
"Invite object isn't a grant recipient route" "Not a grant recipient route"
recipKey <- recipKey <-
unhashGrantRecipE unhashGrantRecipE
recipHash recipHash
"Invite object contains invalid hashid" "Contains invalid hashid"
case recipKey of case recipKey of
GrantRecipPerson p | Left p == sender -> GrantRecipPerson p | Left p == sender ->
throwE "Invite local sender and recipient are the same Person" throwE "Invite local sender and recipient are the same Person"
_ -> return recipKey _ -> return recipKey
else Right <$> do )
(\ u -> do
when (Right u == sender) $ when (Right u == sender) $
throwE "Invite remote sender and recipient are the same actor" throwE "Invite remote sender and recipient are the same actor"
return u 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 parseGrant
:: AP.Grant URIMode :: AP.Grant URIMode

View file

@ -19,6 +19,10 @@ module Vervis.Federation.Collab
( personInviteF ( personInviteF
, topicInviteF , topicInviteF
, repoJoinF
, deckJoinF
, loomJoinF
, repoAcceptF , repoAcceptF
, deckAcceptF , deckAcceptF
, loomAcceptF , loomAcceptF
@ -27,6 +31,7 @@ module Vervis.Federation.Collab
) )
where where
import Control.Applicative
import Control.Exception hiding (Handler) import Control.Exception hiding (Handler)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -316,6 +321,118 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do
Right remoteActorID -> Right remoteActorID ->
insert_ $ CollabRecipRemote collabID 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 topicAcceptF
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId) => (topic -> ActorId)
@ -333,6 +450,14 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
-- Check input -- Check input
acceptee <- parseAccept accept 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 -- Find recipient topic in DB, returning 404 if doesn't exist because
-- we're in the topic's inbox post handler -- we're in the topic's inbox post handler
recipKey <- decodeKeyHashid404 recipHash recipKey <- decodeKeyHashid404 recipHash
@ -347,32 +472,32 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
a <- getActivity acceptee a <- getActivity acceptee
fromMaybeE a "Can't find acceptee in DB" 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 -- 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 topic <- lift $ getCollabTopic collabID
unless (topicResource recipKey == topic) $ unless (topicResource recipKey == topic) $
throwE "Accept object is an Invite for some other resource" 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
-- If accepting an Invite, find the Collab recipient and verify
-- it's the sender of the Accept
Left (fulfillsID, _) -> Left <$> do
recip <- recip <-
lift $ lift $
requireEitherAlt requireEitherAlt
@ -382,20 +507,41 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
"Found Collab with multiple recips" "Found Collab with multiple recips"
case recip of case recip of
Right (Entity crrid crr) Right (Entity crrid crr)
| collabRecipRemoteActor crr == remoteAuthorId author -> return crrid | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid)
_ -> throwE "Accepting an Invite whose recipient is someone else" _ -> 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 -- Verify the Collab isn't already validated
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID 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 -- Record the Accept on the Collab
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
for mractid $ \ acceptID -> do for mractid $ \ acceptID -> do
case idsForAccept of
Left (fulfillsID, recipID) -> do
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
unless (isNothing maybeAccept) $ do unless (isNothing maybeAccept) $ do
lift $ delete acceptID lift $ delete acceptID
throwE "This Invite already has an Accept by recip" 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 -- Forward the Accept activity to relevant local stages, and
-- schedule delivery for unavailable remote members of them -- 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 lift $ insert_ $ CollabEnable collabID grantID
-- Prepare a Grant activity and insert to topic's outbox -- Prepare a Grant activity and insert to topic's outbox
let inviterOrJoiner = either snd snd collab
(actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
lift $ prepareGrant inviteSender lift $ prepareGrant inviterOrJoiner
let recipByKey = grantResourceLocalActor $ topicResource recipKey let recipByKey = grantResourceLocalActor $ topicResource recipKey
_luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant
@ -440,6 +587,31 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
where 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 prepareGrant sender = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome

View file

@ -201,6 +201,8 @@ postDeckInboxR recipDeckHash =
deckFollowF now recipDeckHash author body mfwd luActivity follow deckFollowF now recipDeckHash author body mfwd luActivity follow
AP.InviteActivity invite -> AP.InviteActivity invite ->
topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity 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) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferTicket ticket -> OfferTicket ticket ->
@ -404,7 +406,7 @@ getDeckStampR = servePerActorKey deckActor LocalActorDeck
getDeckCollabsR :: KeyHashid Deck -> Handler Html getDeckCollabsR :: KeyHashid Deck -> Handler Html
getDeckCollabsR deckHash = do getDeckCollabsR deckHash = do
deckID <- decodeKeyHashid404 deckHash deckID <- decodeKeyHashid404 deckHash
(deck, actor, collabs, invites) <- runDB $ do (deck, actor, collabs, invites, joins) <- runDB $ do
deck <- get404 deckID deck <- get404 deckID
actor <- getJust $ deckActor deck actor <- getJust $ deckActor deck
collabs <- do collabs <- do
@ -418,7 +420,12 @@ getDeckCollabsR deckHash = do
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
<*> getPersonWidgetInfo recip <*> getPersonWidgetInfo recip
<*> pure time <*> 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") defaultLayout $(widgetFile "deck/collab/list")
where where
grabPerson actorID = do grabPerson actorID = do

View file

@ -164,6 +164,8 @@ postLoomInboxR recipLoomHash =
loomFollowF now recipLoomHash author body mfwd luActivity follow loomFollowF now recipLoomHash author body mfwd luActivity follow
AP.InviteActivity invite -> AP.InviteActivity invite ->
topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity 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) -> AP.OfferActivity (AP.Offer obj target) ->
case obj of case obj of
AP.OfferTicket ticket -> AP.OfferTicket ticket ->

View file

@ -277,6 +277,8 @@ postRepoInboxR recipRepoHash =
repoFollowF now recipRepoHash author body mfwd luActivity follow repoFollowF now recipRepoHash author body mfwd luActivity follow
AP.InviteActivity invite -> AP.InviteActivity invite ->
topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity 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) -> OfferActivity (Offer obj target) ->
case obj of case obj of

View file

@ -2933,6 +2933,8 @@ changes hLocal ctx =
, addUnique' "CollabRecipRemoteAccept" "Invite" ["invite"] , addUnique' "CollabRecipRemoteAccept" "Invite" ["invite"]
-- 529 -- 529
, removeField "Ticket" "status" , removeField "Ticket" "status"
-- 530
, addEntities model_530_join
] ]
migrateDB migrateDB

View file

@ -59,6 +59,7 @@ module Vervis.Migration.Entities
, model_494_mr_origin , model_494_mr_origin
, model_497_sigkey , model_497_sigkey
, model_508_invite , model_508_invite
, model_530_join
) )
where where
@ -231,3 +232,6 @@ model_497_sigkey = $(schema "497_2022-09-29_sigkey")
model_508_invite :: [Entity SqlBackend] model_508_invite :: [Entity SqlBackend]
model_508_invite = $(schema "508_2022-10-19_invite") model_508_invite = $(schema "508_2022-10-19_invite")
model_530_join :: [Entity SqlBackend]
model_530_join = $(schema "530_2022-11-01_join")

View file

@ -18,6 +18,7 @@ module Vervis.Persist.Collab
, getGrantRecip , getGrantRecip
, getTopicGrants , getTopicGrants
, getTopicInvites , getTopicInvites
, getTopicJoins
) )
where where
@ -150,3 +151,53 @@ getTopicInvites topicCollabField topicActorField resourceID =
(Just _, Just _) -> error "Multi recip" (Just _, Just _) -> error "Multi recip"
, time , 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"

View file

@ -70,6 +70,7 @@ module Web.ActivityPub
, Follow (..) , Follow (..)
, Grant (..) , Grant (..)
, Invite (..) , Invite (..)
, Join (..)
, OfferObject (..) , OfferObject (..)
, Offer (..) , Offer (..)
, Push (..) , Push (..)
@ -1568,6 +1569,22 @@ encodeInvite (Invite obj context target)
<> "context" .= context <> "context" .= context
<> "target" .= target <> "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) data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
instance ActivityPub OfferObject where instance ActivityPub OfferObject where
@ -1688,6 +1705,7 @@ data SpecificActivity u
| FollowActivity (Follow u) | FollowActivity (Follow u)
| GrantActivity (Grant u) | GrantActivity (Grant u)
| InviteActivity (Invite u) | InviteActivity (Invite u)
| JoinActivity (Join u)
| OfferActivity (Offer u) | OfferActivity (Offer u)
| PushActivity (Push u) | PushActivity (Push u)
| RejectActivity (Reject u) | RejectActivity (Reject u)
@ -1745,6 +1763,7 @@ instance ActivityPub Activity where
"Follow" -> FollowActivity <$> parseFollow o "Follow" -> FollowActivity <$> parseFollow o
"Grant" -> GrantActivity <$> parseGrant o "Grant" -> GrantActivity <$> parseGrant o
"Invite" -> InviteActivity <$> parseInvite o "Invite" -> InviteActivity <$> parseInvite o
"Join" -> JoinActivity <$> parseJoin o
"Offer" -> OfferActivity <$> parseOffer o a actor "Offer" -> OfferActivity <$> parseOffer o a actor
"Push" -> PushActivity <$> parsePush a o "Push" -> PushActivity <$> parsePush a o
"Reject" -> RejectActivity <$> parseReject o "Reject" -> RejectActivity <$> parseReject o
@ -1771,6 +1790,7 @@ instance ActivityPub Activity where
activityType (FollowActivity _) = "Follow" activityType (FollowActivity _) = "Follow"
activityType (GrantActivity _) = "Grant" activityType (GrantActivity _) = "Grant"
activityType (InviteActivity _) = "Invite" activityType (InviteActivity _) = "Invite"
activityType (JoinActivity _) = "Join"
activityType (OfferActivity _) = "Offer" activityType (OfferActivity _) = "Offer"
activityType (PushActivity _) = "Push" activityType (PushActivity _) = "Push"
activityType (RejectActivity _) = "Reject" activityType (RejectActivity _) = "Reject"
@ -1783,6 +1803,7 @@ instance ActivityPub Activity where
encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (FollowActivity a) = encodeFollow a
encodeSpecific _ _ (GrantActivity a) = encodeGrant a encodeSpecific _ _ (GrantActivity a) = encodeGrant a
encodeSpecific _ _ (InviteActivity a) = encodeInvite a encodeSpecific _ _ (InviteActivity a) = encodeInvite a
encodeSpecific _ _ (JoinActivity a) = encodeJoin a
encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h u (OfferActivity a) = encodeOffer h u a
encodeSpecific h _ (PushActivity a) = encodePush h a encodeSpecific h _ (PushActivity a) = encodePush h a
encodeSpecific _ _ (RejectActivity a) = encodeReject a encodeSpecific _ _ (RejectActivity a) = encodeReject a

View file

@ -42,4 +42,17 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<td>Admin <td>Admin
<td>#{showDate time} <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… $# <a href=@{ProjectDevNewR shr prj}>Add…

View file

@ -612,6 +612,44 @@ CollabInviterRemote
UniqueCollabInviterRemote collab UniqueCollabInviterRemote collab
UniqueCollabInviterRemoteInvite invite 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 -------------------------------- -------------------------------- Collab topic --------------------------------
-- Removed for now, until I figure out whether/how to federate custom roles -- Removed for now, until I figure out whether/how to federate custom roles