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:
parent
e4d7156cbc
commit
72796a6bdc
12 changed files with 433 additions and 76 deletions
37
migrations/530_2022-11-01_join.model
Normal file
37
migrations/530_2022-11-01_join.model
Normal 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
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ->
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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")
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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…
|
||||||
|
|
38
th/models
38
th/models
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue