Switch to converged handlers than handle both local and remote activities
I was writing a topicLocalInvite handler when I realized how cumbersome it's becoming, to have separate handlers for local activities. While it allows me to pick custom specific message names and parameters (which is why I took that approach in the first place), it causes a lot of duplication and complexity (because I have to write the remote-activity handlers anyway; adding local ones doesn't reduce complexity). So this commit switches the entire system to communicate only using AP/FF activities, including between local actors.
This commit is contained in:
Pere Lev
parent
d5d6b0af61
commit
d33f272ede
26 changed files with 871 additions and 760 deletions
8
migrations/531_2023-06-15_follow_request.model
Normal file
8
migrations/531_2023-06-15_follow_request.model
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
FollowRequest
|
||||
actor ActorId
|
||||
target FollowerSetId
|
||||
public Bool
|
||||
follow OutboxItemId
|
||||
|
||||
UniqueFollowRequest actor target
|
||||
UniqueFollowRequestFollow follow
|
||||
|
|
@ -1838,6 +1838,19 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
}
|
||||
}
|
||||
|
||||
-- Meaning: The human wants to invite someone A to a resource R
|
||||
-- Behavior:
|
||||
-- * Some basic sanity checks
|
||||
-- * Parse the Invite
|
||||
-- * Make sure not inviting myself
|
||||
-- * Verify that a capability is specified
|
||||
-- * If resource is local, verify it exists in DB
|
||||
-- * Verify the target A and resource R are addressed in the Invite
|
||||
-- * Insert Invite to my inbox
|
||||
-- * Asynchrnously:
|
||||
-- * Deliver a request to the resource
|
||||
-- * Deliver a notification to the target
|
||||
-- * Deliver a notification to my followers
|
||||
inviteC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
@ -1853,11 +1866,11 @@ inviteC
|
|||
-> AP.Invite URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do
|
||||
error "Temporarily disabled due to switch to new actor system"
|
||||
error "Disabled for actor refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
(resource, recipient) <- parseInvite (Left senderPersonID) invite
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
_capID <- fromMaybeE maybeCap "No capability provided"
|
||||
|
||||
-- If resource is remote, HTTP GET it and its managing actor, and insert to
|
||||
-- our DB. If resource is local, find it in our DB.
|
||||
|
|
@ -1866,7 +1879,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
(runDBExcept . flip getGrantResource "Grant context not found in DB")
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . show) <$>
|
||||
fetchRemoteResource instanceID h lu
|
||||
|
|
@ -1888,7 +1901,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor instanceID h lu
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Recipient @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
|
|
@ -1910,27 +1923,25 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
now <- liftIO getCurrentTime
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
|
||||
? <- withDBExcept $ do
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(obiidInvite, deliverHttpInvite) <- runDBExcept $ do
|
||||
|
||||
-- If resource is local, verify the specified capability gives relevant
|
||||
-- access to it.
|
||||
case resourceDB of
|
||||
Left r -> do
|
||||
capability <-
|
||||
case capID of
|
||||
Left (actor, _, item) -> return (actor, item)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic"
|
||||
verifyCapability capability (Left senderPersonID) (bmap entityKey r)
|
||||
Right _ -> pure ()
|
||||
|
||||
-- Insert new Collab to DB
|
||||
-- Insert the Invite activity to author's outbox
|
||||
inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
case resourceDB of
|
||||
Left localResource ->
|
||||
lift $ insertCollab localResource recipientDB inviteID
|
||||
Right _ -> pure ()
|
||||
|
||||
-- Insert the Grant activity to author's outbox
|
||||
_luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action
|
||||
|
||||
-- Deliver the Invite activity to local recipients, and schedule
|
||||
|
|
@ -1986,6 +1997,22 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return (inviteID, deliverHttpInvite)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- Notify the resource
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- Launch asynchronous HTTP delivery of the Grant activity
|
||||
lift $ do
|
||||
forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
|
||||
|
|
@ -1995,20 +2022,20 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
where
|
||||
|
||||
fetchRemoteResource instanceID host localURI = do
|
||||
maybeActor <- runSiteDB $ runMaybeT $ do
|
||||
maybeActor <- withDB $ runMaybeT $ do
|
||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
|
||||
MaybeT $ getBy $ UniqueRemoteActor roid
|
||||
case maybeActor of
|
||||
Just actor -> return $ Right $ Left actor
|
||||
Nothing -> do
|
||||
manager <- asksSite getHttpManager
|
||||
manager <- asksEnv getHttpManager
|
||||
errorOrResource <- fetchResource manager host localURI
|
||||
case errorOrResource of
|
||||
Left maybeError ->
|
||||
return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
|
||||
Right resource -> do
|
||||
case resource of
|
||||
ResourceActor (AP.Actor local detail) -> runSiteDB $ do
|
||||
ResourceActor (AP.Actor local detail) -> withDB $ do
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
|
||||
let ra = RemoteActor
|
||||
{ remoteActorIdent = roid
|
||||
|
|
@ -2020,8 +2047,8 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
}
|
||||
Right . Left . either id id <$> insertByEntity' ra
|
||||
ResourceChild luId luManager -> do
|
||||
roid <- runSiteDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
|
||||
result <- fetchRemoteActor instanceID host luManager
|
||||
roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
|
||||
result <- fetchRemoteActor' instanceID host luManager
|
||||
return $
|
||||
case result of
|
||||
Left e -> Left $ ResultSomeException e
|
||||
|
|
@ -2038,23 +2065,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
routes <- lookup p $ recipPeople localRecips
|
||||
guard $ routePerson routes
|
||||
|
||||
insertCollab resource recipient inviteID = do
|
||||
collabID <- insert Collab
|
||||
case resource of
|
||||
GrantResourceRepo (Entity repoID _) ->
|
||||
insert_ $ CollabTopicRepo collabID repoID
|
||||
GrantResourceDeck (Entity deckID _) ->
|
||||
insert_ $ CollabTopicDeck collabID deckID
|
||||
GrantResourceLoom (Entity loomID _) ->
|
||||
insert_ $ CollabTopicLoom collabID loomID
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
case recipient of
|
||||
Left (GrantRecipPerson (Entity personID _)) ->
|
||||
insert_ $ CollabRecipLocal collabID personID
|
||||
Right (remoteActorID, _) ->
|
||||
insert_ $ CollabRecipRemote collabID remoteActorID
|
||||
|
||||
hashGrantRecip (GrantRecipPerson k) =
|
||||
GrantRecipPerson <$> encodeKeyHashid k
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -77,6 +77,7 @@ module Vervis.Access
|
|||
, grantResourceLocalActor
|
||||
|
||||
, verifyCapability
|
||||
, verifyCapability'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -89,6 +90,8 @@ import Control.Monad.Trans.Maybe
|
|||
import Control.Monad.Trans.Reader
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Database.Persist
|
||||
|
|
@ -99,6 +102,7 @@ import Yesod.Core.Handler
|
|||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Network.FedURI
|
||||
import Web.Actor.Persist (stageHashidsContext)
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
|
@ -107,6 +111,7 @@ import Control.Monad.Trans.Except.Local
|
|||
import Data.Either.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Role
|
||||
|
|
@ -383,3 +388,23 @@ verifyCapability (capActor, capItem) actor resource = do
|
|||
-- Since there are currently no roles, and grants allow only the "Admin"
|
||||
-- role that supports every operation, we don't need to check role access
|
||||
return ()
|
||||
|
||||
verifyCapability'
|
||||
:: MonadIO m
|
||||
=> (LocalActorBy Key, OutboxItemId)
|
||||
-> Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> GrantResourceBy Key
|
||||
-> ExceptT Text (ReaderT SqlBackend m) ()
|
||||
verifyCapability' cap actor resource = do
|
||||
actorP <- processActor actor
|
||||
verifyCapability cap actorP resource
|
||||
where
|
||||
processActor = bitraverse processLocal processRemote
|
||||
where
|
||||
processLocal (actorByKey, _, _) =
|
||||
case actorByKey of
|
||||
LocalActorPerson personID -> return personID
|
||||
_ -> throwE "Non-person local actors can't get Grants at the moment"
|
||||
processRemote (author, _, _) = pure $ remoteAuthorId author
|
||||
|
|
|
|||
|
|
@ -55,11 +55,12 @@ module Vervis.Actor
|
|||
-- * AP system base types
|
||||
, RemoteAuthor (..)
|
||||
, ActivityBody (..)
|
||||
, VerseRemote (..)
|
||||
--, VerseRemote (..)
|
||||
, Verse (..)
|
||||
|
||||
-- * Behavior utility types
|
||||
, Verse
|
||||
, Event (..)
|
||||
--, Verse
|
||||
--, Event (..)
|
||||
, Env (..)
|
||||
, Act
|
||||
, ActE
|
||||
|
|
@ -87,6 +88,7 @@ import Control.Monad.Trans.Maybe
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
|
|
@ -290,6 +292,27 @@ data ActivityBody = ActivityBody
|
|||
, actbActivity :: AP.Activity URIMode
|
||||
}
|
||||
|
||||
data Verse = Verse
|
||||
{ verseSource :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
, verseBody :: ActivityBody
|
||||
--, verseLocalRecips :: RecipientRoutes
|
||||
}
|
||||
|
||||
instance Message Verse where
|
||||
summarize (Verse (Left (actor, _, itemID)) body) =
|
||||
let typ = AP.activityType $ AP.activitySpecific $ actbActivity body
|
||||
in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID]
|
||||
summarize (Verse (Right (author, luAct, _)) body) =
|
||||
let ObjURI h _ = remoteAuthorURI author
|
||||
typ = AP.activityType $ AP.activitySpecific $ actbActivity body
|
||||
in T.concat [typ, " ", renderObjURI $ ObjURI h luAct]
|
||||
refer (Verse (Left (actor, _, itemID)) _body) =
|
||||
T.concat [T.pack $ show actor, " ", T.pack $ show itemID]
|
||||
refer (Verse (Right (author, luAct, _)) _body) =
|
||||
let ObjURI h _ = remoteAuthorURI author
|
||||
in renderObjURI $ ObjURI h luAct
|
||||
|
||||
{-
|
||||
data VerseRemote = VerseRemote
|
||||
{ verseAuthor :: RemoteAuthor
|
||||
, verseBody :: ActivityBody
|
||||
|
|
@ -341,6 +364,14 @@ data Event
|
|||
| EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId
|
||||
-- ^ A remote actor asked to Join a local topic, and the local topic is
|
||||
-- forwarding the Join to me because I'm following the topic
|
||||
| EventTopicHandleLocalInvite PersonId OutboxItemId BL.ByteString ByteString FedURI (Either (GrantRecipBy Key) FedURI)
|
||||
-- ^ I'm a resource and a local Person has published an invite-for-me.
|
||||
-- Params: Sender person, Invite ID, Invite activity body, forwarding
|
||||
-- signature header, capability URI, invite target.
|
||||
| EventLocalInviteLocalTopicFwdToFollower OutboxItemId
|
||||
-- ^ An authorized local actor sent an Invite-to-a-local-topic, and the
|
||||
-- local topic is forwarding the Invite to me because I'm following the
|
||||
-- topic
|
||||
| EventUnknown
|
||||
deriving Show
|
||||
|
||||
|
|
@ -356,6 +387,7 @@ instance Message Verse where
|
|||
refer (Right (VerseRemote author _body _fwd uri)) =
|
||||
let ObjURI h _ = remoteAuthorURI author
|
||||
in renderObjURI $ ObjURI h uri
|
||||
-}
|
||||
|
||||
type YesodRender y = Route y -> [(Text, Text)] -> Text
|
||||
|
||||
|
|
@ -470,22 +502,24 @@ data RemoteRecipient = RemoteRecipient
|
|||
-- This function reads the follower sets and remote recipient data from the
|
||||
-- PostgreSQL database. Don't use it inside a database transaction.
|
||||
sendToLocalActors
|
||||
:: Event
|
||||
-- ^ Event to send to local live actors
|
||||
:: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)
|
||||
-- ^ Author of the activity being sent
|
||||
-> ActivityBody
|
||||
-- ^ Activity to send
|
||||
-> Bool
|
||||
-- ^ Whether to deliver to collection only if owner actor is addressed
|
||||
-> Maybe (LocalActorBy Key)
|
||||
-- ^ An actor whose collections are excluded from requiring an owner, i.e.
|
||||
-- even if owner is required, this actor's collections will be delivered
|
||||
-- to, even if this actor isn't addressed. This is meant to be the
|
||||
-- activity's author.
|
||||
-- activity's sender.
|
||||
-> Maybe (LocalActorBy Key)
|
||||
-- ^ An actor whose inbox to exclude from delivery, even if this actor is
|
||||
-- listed in the recipient set. This is meant to be the activity's
|
||||
-- author.
|
||||
-- sender.
|
||||
-> RecipientRoutes
|
||||
-> Act [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
sendToLocalActors event requireOwner mauthor maidAuthor recips = do
|
||||
sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
||||
|
||||
-- Unhash actor and work item hashids
|
||||
people <- unhashKeys $ recipPeople recips
|
||||
|
|
@ -608,7 +642,9 @@ sendToLocalActors event requireOwner mauthor maidAuthor recips = do
|
|||
in case maidAuthor of
|
||||
Nothing -> s
|
||||
Just a -> HS.delete a s
|
||||
sendMany liveRecips $ Left event
|
||||
authorAndId' =
|
||||
second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId
|
||||
sendMany liveRecips $ Verse authorAndId' body
|
||||
|
||||
-- Return remote followers, to whom we need to deliver via HTTP
|
||||
return remoteFollowers
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ module Vervis.Actor.Common
|
|||
, topicAccept
|
||||
, topicReject
|
||||
, topicInvite
|
||||
--, topicHandleLocalInvite
|
||||
, topicJoin
|
||||
)
|
||||
where
|
||||
|
|
@ -33,6 +34,7 @@ import Control.Monad.Trans.Class
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -92,13 +94,10 @@ actorFollow
|
|||
-> (a -> Act [Aud URIMode])
|
||||
-> UTCTime
|
||||
-> Key r
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Follow URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do
|
||||
actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do
|
||||
|
||||
-- Check input
|
||||
followee <- nameExceptT "Follow object" $ do
|
||||
|
|
@ -107,6 +106,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
case routeOrRemote of
|
||||
Left route -> pure route
|
||||
Right _ -> throwE "Remote, so definitely not me/mine"
|
||||
-- Verify the followee is me or a subobject of mine
|
||||
parseFollowee route
|
||||
verifyNothingE
|
||||
(AP.activityCapability $ actbActivity body)
|
||||
|
|
@ -114,28 +114,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
|
||||
maybeFollow <- withDBExcept $ do
|
||||
|
||||
-- Find recipient actor in DB
|
||||
-- Find me in DB
|
||||
recip <- lift $ getJust recipID
|
||||
let recipActorID = grabActor recip
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Insert the Follow to actor's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread
|
||||
for mractid $ \ followID -> do
|
||||
-- Insert the Follow to my inbox
|
||||
maybeFollowDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) unread
|
||||
for maybeFollowDB $ \ followDB -> do
|
||||
|
||||
-- Find followee in DB
|
||||
followerSetID <- getFollowee recipActor followee
|
||||
|
||||
-- Verify not already following us
|
||||
-- Verify not already following me
|
||||
case followDB of
|
||||
Left (_, followerID, followID) -> do
|
||||
maybeFollow <- lift $ getBy $ UniqueFollow followerID followerSetID
|
||||
verifyNothingE maybeFollow "You're already following this object"
|
||||
Right (author, _, followID) -> do
|
||||
let followerID = remoteAuthorId author
|
||||
maybeFollow <-
|
||||
lift $ getBy $ UniqueRemoteFollow followerID followerSetID
|
||||
maybeFollow <- lift $ getBy $ UniqueRemoteFollow followerID followerSetID
|
||||
verifyNothingE maybeFollow "You're already following this object"
|
||||
|
||||
-- Record the new follow in DB
|
||||
acceptID <-
|
||||
lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID
|
||||
lift $ case followDB of
|
||||
Left (_actorByKey, actorID, followID) ->
|
||||
insert_ $ Follow actorID followerSetID (not hide) followID acceptID
|
||||
Right (author, _luFollow, followID) -> do
|
||||
let authorID = remoteAuthorId author
|
||||
insert_ $ RemoteFollow authorID followerSetID (not hide) followID acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to actor's outbox
|
||||
accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
|
|
@ -143,20 +152,15 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
_luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept
|
||||
|
||||
sieve <- lift $ getSieve followee
|
||||
return (recipActorID, followID, acceptID, sieve, accept)
|
||||
return (recipActorID, acceptID, sieve, accept)
|
||||
|
||||
case maybeFollow of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) ->
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig actorID
|
||||
(makeLocalActor recipID) sieve
|
||||
(EventRemoteFollowLocalRecipFwdToFollower followID)
|
||||
Just (actorID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
forwardActivity authorIdMsig body (makeLocalActor recipID) actorID sieve
|
||||
lift $ sendActivity
|
||||
(makeLocalActor recipID) actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID
|
||||
EventAcceptRemoteFollow actionAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Recorded Follow and published Accept"
|
||||
|
||||
where
|
||||
|
|
@ -164,14 +168,8 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
prepareAccept followee = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audSender <- makeAudSenderWithFollowers authorIdMsig
|
||||
uFollow <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
audsRecip <- lift $ makeAudience followee
|
||||
|
||||
|
|
@ -185,7 +183,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luFollow
|
||||
{ AP.acceptObject = uFollow
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
|
@ -198,13 +196,10 @@ topicAccept
|
|||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicAccept topicActor topicResource now recipKey author body mfwd luAccept accept = do
|
||||
topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
|
@ -219,7 +214,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient deck from DB
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
|
|
@ -263,9 +258,13 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
(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)
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||
| collabRecipLocalPerson crl == personID ->
|
||||
return (fulfillsID, Left crlid)
|
||||
(Right (Entity crrid crr), Right (author, _, _))
|
||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
||||
return (fulfillsID, Right crrid)
|
||||
_ -> throwE "Accepting an Invite whose recipient is someone else"
|
||||
|
||||
-- If accepting a Join, verify accepter has permission
|
||||
|
|
@ -275,9 +274,9 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
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
|
||||
verifyCapability'
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
authorIdMsig
|
||||
(topicResource recipKey)
|
||||
return fulfillsID
|
||||
|
||||
|
|
@ -285,27 +284,33 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
||||
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
|
||||
for mractid $ \ acceptID -> do
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
-- Record the Accept on the Collab
|
||||
case idsForAccept of
|
||||
Left (fulfillsID, recipID) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
unless (isNothing maybeAccept) $ do
|
||||
lift $ delete acceptID
|
||||
case (idsForAccept, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isNothing maybeAccept) $
|
||||
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
|
||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
_ -> error "topicAccept impossible"
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
isInvite = isLeft collab
|
||||
|
||||
grantInfo <- do
|
||||
|
||||
|
|
@ -315,29 +320,23 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
let inviterOrJoiner = either snd snd collab
|
||||
isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
lift $ prepareGrant isInvite inviterOrJoiner
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
return (recipActorID, isInvite, acceptID, sieve, grantInfo)
|
||||
return (recipActorID, sieve, grantInfo)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, isInvite, acceptID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
|
||||
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) -> do
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig recipActorID recipByID sieve
|
||||
(if isInvite
|
||||
then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID
|
||||
else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID
|
||||
)
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID
|
||||
(EventGrantAfterRemoteAccept grantID) actionGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Forwarded the Accept and published a Grant"
|
||||
|
||||
where
|
||||
|
|
@ -371,12 +370,15 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
accepter <- getJust $ remoteAuthorId author
|
||||
audAccepter <- makeAudSenderWithFollowers authorIdMsig
|
||||
audApprover <- lift $ makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
|
||||
uAccepter <- lift $ getActorURI authorIdMsig
|
||||
|
||||
let audience =
|
||||
if isInvite
|
||||
then
|
||||
|
|
@ -385,9 +387,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
Left actor -> AudLocal [actor] []
|
||||
Right (ObjURI h lu, _followers) ->
|
||||
AudRemote h [lu] []
|
||||
audAccepter =
|
||||
let ObjURI h lu = remoteAuthorURI author
|
||||
in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audInviter, audAccepter, audTopic]
|
||||
else
|
||||
|
|
@ -396,9 +395,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
Left actor -> AudLocal [actor] [localActorFollowers actor]
|
||||
Right (ObjURI h lu, followers) ->
|
||||
AudRemote h [lu] (maybeToList followers)
|
||||
audApprover =
|
||||
let ObjURI h lu = remoteAuthorURI author
|
||||
in AudRemote h [lu] []
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audJoiner, audApprover, audTopic]
|
||||
|
||||
|
|
@ -417,7 +413,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
|
|||
encodeRouteLocal $ renderLocalActor topicByHash
|
||||
, AP.grantTarget =
|
||||
if isInvite
|
||||
then remoteAuthorURI author
|
||||
then uAccepter
|
||||
else case senderHash of
|
||||
Left actor ->
|
||||
encodeRouteHome $ renderLocalActor actor
|
||||
|
|
@ -438,13 +434,10 @@ topicReject
|
|||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicReject topicActor topicResource now recipKey author body mfwd luReject reject = do
|
||||
topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reject = do
|
||||
|
||||
-- Check input
|
||||
rejectee <- parseReject reject
|
||||
|
|
@ -459,7 +452,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient deck from DB
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
|
|
@ -503,9 +496,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
(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, deleteInviter)
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||
| collabRecipLocalPerson crl == personID ->
|
||||
return (fulfillsID, Left crlid, deleteInviter)
|
||||
(Right (Entity crrid crr), Right (author, _, _))
|
||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
||||
return (fulfillsID, Right crrid, deleteInviter)
|
||||
_ -> throwE "Rejecting an Invite whose recipient is someone else"
|
||||
|
||||
-- If rejecting a Join, verify accepter has permission
|
||||
|
|
@ -515,9 +512,9 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
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
|
||||
verifyCapability'
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
authorIdMsig
|
||||
(topicResource recipKey)
|
||||
return (fulfillsID, deleteRecipJoin, deleteRecip)
|
||||
|
||||
|
|
@ -527,7 +524,11 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
|
||||
-- Verify the Collab isn't already accepted/approved
|
||||
case idsForReject of
|
||||
Left (_fulfillsID, recipID, _) -> do
|
||||
Left (_fulfillsID, Left recipID, _) -> do
|
||||
mval <-
|
||||
lift $ getBy $ UniqueCollabRecipLocalAcceptCollab recipID
|
||||
verifyNothingE mval "Invite is already accepted"
|
||||
Left (_fulfillsID, Right recipID, _) -> do
|
||||
mval <-
|
||||
lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID
|
||||
verifyNothingE mval "Invite is already accepted"
|
||||
|
|
@ -537,13 +538,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
unless (isNothing mval1 && isNothing mval2) $
|
||||
throwE "Join is already approved"
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False
|
||||
for mractid $ \ rejectID -> do
|
||||
maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeRejectDB $ \ rejectDB -> do
|
||||
|
||||
-- Delete the whole Collab record
|
||||
case idsForReject of
|
||||
Left (fulfillsID, recipID, deleteInviter) -> lift $ do
|
||||
delete recipID
|
||||
bitraverse_ delete delete recipID
|
||||
deleteTopic
|
||||
deleteInviter
|
||||
delete fulfillsID
|
||||
|
|
@ -558,36 +559,29 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
isInvite = isLeft collab
|
||||
|
||||
newRejectInfo <- do
|
||||
|
||||
-- Prepare a Reject activity and insert to my outbox
|
||||
newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
let inviterOrJoiner = either (view _2) (view _2) collab
|
||||
isInvite = isLeft collab
|
||||
newReject@(actionReject, _, _, _) <-
|
||||
lift $ prepareReject isInvite inviterOrJoiner
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
|
||||
return (newRejectID, newReject)
|
||||
|
||||
return (recipActorID, isInvite, rejectID, sieve, newRejectInfo)
|
||||
return (recipActorID, sieve, newRejectInfo)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, isInvite, rejectID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
|
||||
Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) -> do
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig recipActorID recipByID sieve
|
||||
(if isInvite
|
||||
then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID
|
||||
else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID
|
||||
)
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecips
|
||||
remoteRecips fwdHosts newRejectID
|
||||
(EventRejectAfterRemoteReject newRejectID) action
|
||||
remoteRecips fwdHosts newRejectID action
|
||||
done "Forwarded the Reject and published my own Reject"
|
||||
|
||||
where
|
||||
|
|
@ -623,12 +617,15 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
rejecter <- getJust $ remoteAuthorId author
|
||||
audRejecter <- makeAudSenderWithFollowers authorIdMsig
|
||||
audForbidder <- lift $ makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
|
||||
uReject <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let audience =
|
||||
if isInvite
|
||||
then
|
||||
|
|
@ -637,9 +634,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
Left actor -> AudLocal [actor] []
|
||||
Right (ObjURI h lu, _followers) ->
|
||||
AudRemote h [lu] []
|
||||
audRejecter =
|
||||
let ObjURI h lu = remoteAuthorURI author
|
||||
in AudRemote h [lu] (maybeToList $ remoteActorFollowers rejecter)
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audInviter, audRejecter, audTopic]
|
||||
else
|
||||
|
|
@ -648,9 +642,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
Left actor -> AudLocal [actor] [localActorFollowers actor]
|
||||
Right (ObjURI h lu, followers) ->
|
||||
AudRemote h [lu] (maybeToList followers)
|
||||
audForbidder =
|
||||
let ObjURI h lu = remoteAuthorURI author
|
||||
in AudRemote h [lu] []
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audJoiner, audForbidder, audTopic]
|
||||
|
||||
|
|
@ -662,10 +653,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
|
|||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills =
|
||||
[ let ObjURI h _ = remoteAuthorURI author
|
||||
in ObjURI h luReject
|
||||
]
|
||||
, AP.actionFulfills = [uReject]
|
||||
, AP.actionSpecific = AP.RejectActivity AP.Reject
|
||||
{ AP.rejectObject = AP.rejectObject reject
|
||||
}
|
||||
|
|
@ -684,13 +672,10 @@ topicInvite
|
|||
-> (CollabId -> Key topic -> ct)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luInvite invite = do
|
||||
topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
|
@ -713,8 +698,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
|
||||
-- Check invite
|
||||
targetByKey <- do
|
||||
(resource, recipient) <-
|
||||
parseInvite (Right $ remoteAuthorURI author) invite
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(resource, recipient) <- parseInvite author invite
|
||||
unless (Left (topicResource topicKey) == resource) $
|
||||
throwE "Invite topic isn't me"
|
||||
return recipient
|
||||
|
|
@ -747,17 +732,14 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab topic from DB
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust topicKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
(topicResource topicKey)
|
||||
verifyCapability' capability authorIdMsig (topicResource topicKey)
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
existingCollabIDs <-
|
||||
|
|
@ -785,11 +767,11 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
[_] -> throwE "I already have a Collab for the target"
|
||||
_ -> error "Multiple collabs found for target"
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luInvite False
|
||||
lift $ for mractid $ \ inviteID -> do
|
||||
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||
lift $ for maybeInviteDB $ \ inviteDB -> do
|
||||
|
||||
-- Insert Collab record to DB
|
||||
insertCollab targetDB inviteID
|
||||
insertCollab targetDB inviteDB
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
sieve <- do
|
||||
|
|
@ -797,24 +779,25 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
let topicByHash =
|
||||
grantResourceLocalActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
return (topicActorID, inviteID, sieve)
|
||||
return (topicActorID, sieve)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, inviteID, sieve) -> do
|
||||
Just (topicActorID, sieve) -> do
|
||||
let topicByID = grantResourceLocalActor $ topicResource topicKey
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) -> do
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig topicActorID topicByID sieve
|
||||
(EventRemoteInviteLocalTopicFwdToFollower inviteID)
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
done "Recorded and forwarded the Invite"
|
||||
|
||||
where
|
||||
|
||||
insertCollab recipient inviteID = do
|
||||
insertCollab recipient inviteDB = do
|
||||
collabID <- insert Collab
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID
|
||||
insert_ $ collabTopicCtor collabID topicKey
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
Right (author, _, inviteID) -> do
|
||||
let authorID = remoteAuthorId author
|
||||
insert_ $ CollabInviterRemote fulfillsID authorID inviteID
|
||||
case recipient of
|
||||
|
|
@ -834,13 +817,10 @@ topicJoin
|
|||
-> (CollabId -> Key topic -> ct)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luJoin join = do
|
||||
topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do
|
||||
|
||||
-- Check input
|
||||
resource <- parseJoin join
|
||||
|
|
@ -849,14 +829,26 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab topic from DB
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust topicKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
existingCollabIDs <- lift $ do
|
||||
existingCollabIDs <- lift $
|
||||
case authorIdMsig of
|
||||
Left (LocalActorPerson personID, _, _) ->
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
Left (_, _, _) -> pure []
|
||||
Right (author, _, _) -> do
|
||||
let targetID = remoteAuthorId author
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
|
|
@ -871,36 +863,47 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
[_] -> throwE "I already have a Collab for the target"
|
||||
_ -> error "Multiple collabs found for target"
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luJoin False
|
||||
lift $ for mractid $ \ joinID -> do
|
||||
maybeJoinDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||
for maybeJoinDB $ \ joinDB -> do
|
||||
|
||||
-- Insert Collab record to DB
|
||||
insertCollab joinID
|
||||
joinDB' <-
|
||||
bitraverse
|
||||
(\ (authorByKey, _, joinID) ->
|
||||
case authorByKey of
|
||||
LocalActorPerson personID -> pure (personID, joinID)
|
||||
_ -> throwE "Non-person local actors can't get Grants currently"
|
||||
)
|
||||
pure
|
||||
joinDB
|
||||
lift $ insertCollab joinDB'
|
||||
|
||||
-- Prepare forwarding Join to my followers
|
||||
sieve <- do
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid topicKey
|
||||
let topicByHash =
|
||||
grantResourceLocalActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
return (topicActorID, joinID, sieve)
|
||||
return (topicActorID, sieve)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, joinID, sieve) -> do
|
||||
Just (topicActorID, sieve) -> do
|
||||
let topicByID = grantResourceLocalActor $ topicResource topicKey
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) -> do
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig topicActorID topicByID sieve
|
||||
(EventRemoteJoinLocalTopicFwdToFollower joinID)
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
done "Recorded and forwarded the Join"
|
||||
|
||||
where
|
||||
|
||||
insertCollab joinID = do
|
||||
insertCollab joinDB = do
|
||||
collabID <- insert Collab
|
||||
fulfillsID <- insert $ CollabFulfillsJoin collabID
|
||||
insert_ $ collabTopicCtor collabID topicKey
|
||||
case joinDB of
|
||||
Left (personID, joinID) -> do
|
||||
recipID <- insert $ CollabRecipLocal collabID personID
|
||||
insert_ $ CollabRecipLocalJoin recipID fulfillsID joinID
|
||||
Right (author, _, joinID) -> do
|
||||
let authorID = remoteAuthorId author
|
||||
recipID <- insert $ CollabRecipRemote collabID authorID
|
||||
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
|
||||
|
|
|
|||
|
|
@ -82,13 +82,10 @@ import Vervis.Ticket
|
|||
deckFollow
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Follow URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckFollow now recipDeckID author body mfwd luFollow follow = do
|
||||
deckFollow now recipDeckID verse follow = do
|
||||
recipDeckHash <- encodeKeyHashid recipDeckID
|
||||
actorFollow
|
||||
(\case
|
||||
|
|
@ -111,13 +108,13 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
|
|||
(\ _ -> pure $ makeRecipientSet [] [])
|
||||
LocalActorDeck
|
||||
(\ _ -> pure [])
|
||||
now recipDeckID author body mfwd luFollow follow
|
||||
now recipDeckID verse follow
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Access
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Meaning: A remote actor accepted something
|
||||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * If it's on an Invite where I'm the resource:
|
||||
-- * Verify the Accept is by the Invite target
|
||||
|
|
@ -135,15 +132,12 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
|
|||
deckAccept
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckAccept = topicAccept deckActor GrantResourceDeck
|
||||
|
||||
-- Meaning: A remote actor rejected something
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
-- * If it's on an Invite where I'm the resource:
|
||||
-- * Verify the Reject is by the Invite target
|
||||
|
|
@ -163,15 +157,12 @@ deckAccept = topicAccept deckActor GrantResourceDeck
|
|||
deckReject
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckReject = topicReject deckActor GrantResourceDeck
|
||||
|
||||
-- Meaning: A remote actor A invited someone B to a resource
|
||||
-- Meaning: An actor A invited actor B to a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is me
|
||||
-- * Verify A isn't inviting themselves
|
||||
|
|
@ -182,10 +173,7 @@ deckReject = topicReject deckActor GrantResourceDeck
|
|||
deckInvite
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckInvite =
|
||||
|
|
@ -193,7 +181,7 @@ deckInvite =
|
|||
deckActor GrantResourceDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
|
||||
|
||||
-- Meaning: A remote actor A asked to join a resource
|
||||
-- Meaning: An actor A asked to join a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is me
|
||||
-- * Verify A doesn't already have an invite/join/grant for me
|
||||
|
|
@ -202,10 +190,7 @@ deckInvite =
|
|||
deckJoin
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckJoin =
|
||||
|
|
@ -217,7 +202,7 @@ deckJoin =
|
|||
-- Ambiguous: Following/Resolving
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Meaning: A remote actor is undoing some previous action
|
||||
-- Meaning: An actor is undoing some previous action
|
||||
-- Behavior:
|
||||
-- * If they're undoing their Following of me, or a ticket of mine:
|
||||
-- * Record it in my DB
|
||||
|
|
@ -231,13 +216,10 @@ deckJoin =
|
|||
deckUndo
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Undo URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
||||
deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||
|
||||
-- Check input
|
||||
undone <-
|
||||
|
|
@ -255,14 +237,14 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient deck from DB
|
||||
-- Grab me from DB
|
||||
(deckRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipDeckID
|
||||
(p,) <$> getJust (deckActor p)
|
||||
|
||||
-- Insert the Undo to deck's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False
|
||||
for mractid $ \ undoID -> do
|
||||
-- Insert the Undo to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
for mractid $ \ _undoDB -> do
|
||||
|
||||
maybeUndo <- runMaybeT $ do
|
||||
|
||||
|
|
@ -271,7 +253,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
|
||||
let followers = actorFollowers actorRecip
|
||||
asum
|
||||
[ tryUnfollow followers undoneDB
|
||||
[ tryUnfollow followers undoneDB authorIdMsig
|
||||
, tryUnresolve maybeCapability undoneDB
|
||||
]
|
||||
|
||||
|
|
@ -285,28 +267,43 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
|
||||
_luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept
|
||||
|
||||
return (deckActor deckRecip, undoID, sieve, acceptID, accept)
|
||||
return (deckActor deckRecip, sieve, acceptID, accept)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, undoID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
lift $ for_ mfwd $ \ (localRecips, sig) -> do
|
||||
Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
forwardActivity
|
||||
(actbBL body) localRecips sig actorID
|
||||
(LocalActorDeck recipDeckID) sieve
|
||||
(EventRemoteUnresolveLocalResourceFwdToFollower undoID)
|
||||
authorIdMsig body (LocalActorDeck recipDeckID) actorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorDeck recipDeckID) actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID
|
||||
EventAcceptRemoteFollow actionAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done
|
||||
"Undid the Follow/Resolve, forwarded the Undo and published \
|
||||
\Accept"
|
||||
|
||||
where
|
||||
|
||||
tryUnfollow _ (Left _) = mzero
|
||||
tryUnfollow deckFollowersID (Right remoteActivityID) = do
|
||||
verifyTargetTicket followerSetID = do
|
||||
ticketID <-
|
||||
MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
|
||||
TicketDeck _ d <-
|
||||
MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
|
||||
guard $ d == recipDeckID
|
||||
|
||||
tryUnfollow deckFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do
|
||||
Entity followID follow <-
|
||||
MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
|
||||
let followerID = followActor follow
|
||||
followerSetID = followTarget follow
|
||||
verifyTargetMe followerSetID <|> verifyTargetTicket followerSetID
|
||||
unless (followerID == actorID) $
|
||||
lift $ throwE "You're trying to Undo someone else's Follow"
|
||||
lift $ lift $ delete followID
|
||||
audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
|
||||
return (makeRecipientSet [] [], [audSenderOnly])
|
||||
where
|
||||
verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID
|
||||
tryUnfollow deckFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
|
|
@ -315,17 +312,11 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
unless (followerID == remoteAuthorId author) $
|
||||
lift $ throwE "You're trying to Undo someone else's Follow"
|
||||
lift $ lift $ delete remoteFollowID
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
audSenderOnly = AudRemote hAuthor [luAuthor] []
|
||||
audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
|
||||
return (makeRecipientSet [] [], [audSenderOnly])
|
||||
where
|
||||
verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID
|
||||
verifyTargetTicket followerSetID = do
|
||||
ticketID <-
|
||||
MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
|
||||
TicketDeck _ d <-
|
||||
MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
|
||||
guard $ d == recipDeckID
|
||||
tryUnfollow _ _ _ = mzero
|
||||
|
||||
tryUnresolve maybeCapability undone = do
|
||||
(deleteFromDB, ticketID) <- findTicket undone
|
||||
|
|
@ -343,22 +334,16 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
Left c -> pure c
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
|
||||
lift $
|
||||
verifyCapability
|
||||
verifyCapability'
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
authorIdMsig
|
||||
(GrantResourceDeck recipDeckID)
|
||||
|
||||
lift $ lift deleteFromDB
|
||||
|
||||
recipDeckHash <- encodeKeyHashid recipDeckID
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
audSender <- lift $ do
|
||||
ra <- lift $ getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
return $
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audSender <- lift $ lift $ makeAudSenderWithFollowers authorIdMsig
|
||||
return
|
||||
( makeRecipientSet
|
||||
[]
|
||||
|
|
@ -399,8 +384,8 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
prepareAccept audience = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let ObjURI hAuthor _ = remoteAuthorURI author
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
uUndo <- getActivityURI authorIdMsig
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
|
@ -410,7 +395,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luUndo
|
||||
{ AP.acceptObject = uUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
|
@ -421,27 +406,15 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
|
|||
-- Main behavior function
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
deckBehavior
|
||||
:: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next)
|
||||
deckBehavior _now _deckID (Left event) =
|
||||
case event of
|
||||
EventRemoteFwdLocalActivity _ _ ->
|
||||
throwE "Got a forwarded local activity, I don't need those"
|
||||
_ -> throwE $ "Unsupported event for Deck: " <> T.pack (show event)
|
||||
deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
|
||||
deckBehavior :: UTCTime -> DeckId -> Verse -> ActE (Text, Act (), Next)
|
||||
deckBehavior now deckID verse@(Verse _authorIdMsig body) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept ->
|
||||
deckAccept now deckID author body mfwd luActivity accept
|
||||
AP.FollowActivity follow ->
|
||||
deckFollow now deckID author body mfwd luActivity follow
|
||||
AP.InviteActivity invite ->
|
||||
deckInvite now deckID author body mfwd luActivity invite
|
||||
AP.JoinActivity join ->
|
||||
deckJoin now deckID author body mfwd luActivity join
|
||||
AP.RejectActivity reject ->
|
||||
deckReject now deckID author body mfwd luActivity reject
|
||||
AP.UndoActivity undo ->
|
||||
deckUndo now deckID author body mfwd luActivity undo
|
||||
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
||||
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||
AP.JoinActivity join -> deckJoin now deckID verse join
|
||||
AP.RejectActivity reject -> deckReject now deckID verse reject
|
||||
AP.UndoActivity undo -> deckUndo now deckID verse undo
|
||||
_ -> throwE "Unsupported activity type for Deck"
|
||||
|
||||
instance VervisActor Deck where
|
||||
|
|
|
|||
|
|
@ -52,14 +52,8 @@ import Vervis.Model
|
|||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
groupBehavior
|
||||
:: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next)
|
||||
groupBehavior now groupID (Left event) =
|
||||
case event of
|
||||
EventRemoteFwdLocalActivity _ _ ->
|
||||
throwE "Got a forwarded local activity, I don't need those"
|
||||
_ -> throwE $ "Unsupported event for Group: " <> T.pack (show event)
|
||||
groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) =
|
||||
groupBehavior :: UTCTime -> GroupId -> Verse -> ActE (Text, Act (), Next)
|
||||
groupBehavior now groupID _verse@(Verse _authorIdMsig body) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
_ -> throwE "Unsupported activity type for Group"
|
||||
|
||||
|
|
|
|||
|
|
@ -52,14 +52,8 @@ import Vervis.Model
|
|||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
loomBehavior
|
||||
:: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next)
|
||||
loomBehavior now loomID (Left event) =
|
||||
case event of
|
||||
EventRemoteFwdLocalActivity _ _ ->
|
||||
throwE "Got a forwarded local activity, I don't need those"
|
||||
_ -> throwE $ "Unsupported event for Loom: " <> T.pack (show event)
|
||||
loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) =
|
||||
loomBehavior :: UTCTime -> LoomId -> Verse -> ActE (Text, Act (), Next)
|
||||
loomBehavior now loomID _verse@(Verse _authorIdMsig body) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
_ -> throwE "Unsupported activity type for Loom"
|
||||
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ import Data.Time.Clock
|
|||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Optics.Core
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -60,6 +61,7 @@ import Vervis.Cloth
|
|||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.Data.Follow
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Foundation
|
||||
|
|
@ -68,6 +70,7 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
|
|||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Persist.Follow
|
||||
import Vervis.Ticket
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -82,13 +85,10 @@ import Vervis.Ticket
|
|||
personFollow
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Follow URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personFollow now recipPersonID author body mfwd luFollow follow = do
|
||||
personFollow now recipPersonID verse follow = do
|
||||
recipPersonHash <- encodeKeyHashid recipPersonID
|
||||
actorFollow
|
||||
(\case
|
||||
|
|
@ -103,9 +103,9 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
|
|||
(\ () -> pure $ makeRecipientSet [] [])
|
||||
LocalActorPerson
|
||||
(\ () -> pure [])
|
||||
now recipPersonID author body mfwd luFollow follow
|
||||
now recipPersonID verse follow
|
||||
|
||||
-- Meaning: A remote actor is undoing some previous action
|
||||
-- Meaning: Someone is undoing some previous action
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
-- * If they're undoing their Following of me:
|
||||
|
|
@ -114,13 +114,10 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
|
|||
personUndo
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Undo URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
||||
personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||
|
||||
-- Check input
|
||||
undone <-
|
||||
|
|
@ -129,14 +126,14 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
|||
|
||||
maybeUndo <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
-- Insert the Undo to person's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False
|
||||
for mractid $ \ undoID -> do
|
||||
maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
for maybeUndoDB $ \ undoDB -> do
|
||||
|
||||
maybeUndo <- runMaybeT $ do
|
||||
|
||||
|
|
@ -144,7 +141,7 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
|||
undoneDB <- MaybeT $ getActivity undone
|
||||
|
||||
let followers = actorFollowers actorRecip
|
||||
tryUnfollow followers undoneDB
|
||||
tryUnfollow followers undoneDB undoDB
|
||||
|
||||
for maybeUndo $ \ () -> do
|
||||
|
||||
|
|
@ -161,14 +158,12 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
|||
Just (Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept))) -> do
|
||||
lift $ sendActivity
|
||||
(LocalActorPerson recipPersonID) actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID
|
||||
EventAcceptRemoteFollow actionAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Undid the Follow and published Accept"
|
||||
|
||||
where
|
||||
|
||||
tryUnfollow _ (Left _) = mzero
|
||||
tryUnfollow personFollowersID (Right remoteActivityID) = do
|
||||
tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
|
|
@ -177,13 +172,23 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
|||
unless (followerID == remoteAuthorId author) $
|
||||
lift $ throwE "You're trying to Undo someone else's Follow"
|
||||
lift $ lift $ delete remoteFollowID
|
||||
tryUnfollow personFollowersID (Left (_, _, outboxItemID)) (Left (_, actorID, _)) = do
|
||||
Entity followID follow <-
|
||||
MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
|
||||
let followerID = followActor follow
|
||||
followerSetID = followTarget follow
|
||||
guard $ followerSetID == personFollowersID
|
||||
unless (followerID == actorID) $
|
||||
lift $ throwE "You're trying to Undo someone else's Follow"
|
||||
lift $ lift $ delete followID
|
||||
tryUnfollow _ _ _ = mzero
|
||||
|
||||
prepareAccept = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
audSender = AudRemote hAuthor [luAuthor] []
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
audSender <- makeAudSenderOnly authorIdMsig
|
||||
uUndo <- getActivityURI authorIdMsig
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
|
@ -193,47 +198,44 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
|
|||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luUndo
|
||||
{ AP.acceptObject = uUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: A remote actor accepted something
|
||||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
-- * If it's a Follow I sent to them, add to my following list in DB
|
||||
personAccept
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personAccept now recipPersonID author body _mfwd luAccept accept = do
|
||||
personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
||||
maybeAccept <- withDBExcept $ do
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luAccept True
|
||||
for mractid $ \ acceptID -> runMaybeT $ do
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for maybeAcceptDB $ \ acceptDB -> runMaybeT $ do
|
||||
|
||||
-- Find the accepted activity in our DB
|
||||
accepteeDB <- MaybeT $ getActivity acceptee
|
||||
|
||||
tryFollow (personActor personRecip) accepteeDB acceptID
|
||||
tryFollow (personActor personRecip) accepteeDB acceptDB
|
||||
|
||||
case maybeAccept of
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just Nothing -> done "Not my Follow; Just inserted to my inbox"
|
||||
Just (Just ()) ->
|
||||
|
|
@ -241,7 +243,7 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
|
|||
|
||||
where
|
||||
|
||||
tryFollow actorID (Left (_, _, outboxItemID)) acceptID = do
|
||||
tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
|
||||
Entity key val <-
|
||||
MaybeT $ lift $
|
||||
getBy $ UniqueFollowRemoteRequestActivity outboxItemID
|
||||
|
|
@ -261,42 +263,55 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
|
|||
, followRemoteFollow = outboxItemID
|
||||
, followRemoteAccept = acceptID
|
||||
}
|
||||
tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, acceptID)) = do
|
||||
Entity key val <-
|
||||
MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
|
||||
guard $ followRequestActor val == actorID
|
||||
targetByKey <-
|
||||
lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
|
||||
unless (authorByKey == targetByKey) $
|
||||
lift $ throwE "You're Accepting a Follow I sent to someone else"
|
||||
lift $ lift $ delete key
|
||||
lift $ lift $ insert_ Follow
|
||||
{ followActor = actorID
|
||||
, followTarget = followRequestTarget val
|
||||
, followPublic = followRequestPublic val
|
||||
, followFollow = outboxItemID
|
||||
, followAccept = acceptID
|
||||
}
|
||||
tryFollow _ (Right _) _ = mzero
|
||||
|
||||
-- Meaning: A remote actor rejected something
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
-- * If it's a Follow I sent to them, remove record from my DB
|
||||
personReject
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personReject now recipPersonID author body _mfwd luReject reject = do
|
||||
personReject now recipPersonID (Verse authorIdMsig body) reject = do
|
||||
|
||||
-- Check input
|
||||
rejectee <- parseReject reject
|
||||
|
||||
maybeReject <- withDBExcept $ do
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luReject True
|
||||
for mractid $ \ rejectID -> runMaybeT $ do
|
||||
maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for maybeRejectDB $ \ _rejectDB -> runMaybeT $ do
|
||||
|
||||
-- Find the rejected activity in our DB
|
||||
rejecteeDB <- MaybeT $ getActivity rejectee
|
||||
|
||||
tryFollow rejecteeDB
|
||||
tryFollow (personActor personRecip) rejecteeDB authorIdMsig
|
||||
|
||||
case maybeReject of
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just Nothing -> done "Not my Follow; Just inserted to my inbox"
|
||||
Just (Just ()) ->
|
||||
|
|
@ -304,7 +319,7 @@ personReject now recipPersonID author body _mfwd luReject reject = do
|
|||
|
||||
where
|
||||
|
||||
tryFollow (Left (_, _, outboxItemID)) = do
|
||||
tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do
|
||||
Entity key val <-
|
||||
MaybeT $ lift $
|
||||
getBy $ UniqueFollowRemoteRequestActivity outboxItemID
|
||||
|
|
@ -316,7 +331,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
|
|||
unless (remoteAuthorURI author == uRecip) $
|
||||
lift $ throwE "You're Rejecting a Follow I sent to someone else"
|
||||
lift $ lift $ delete key
|
||||
tryFollow (Right _) = mzero
|
||||
tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, _)) = do
|
||||
Entity key val <-
|
||||
MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
|
||||
guard $ followRequestActor val == actorID
|
||||
targetByKey <-
|
||||
lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
|
||||
unless (authorByKey == targetByKey) $
|
||||
lift $ throwE "You're Rejecting a Follow I sent to someone else"
|
||||
lift $ lift $ delete key
|
||||
tryFollow _ (Right _) _ = mzero
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Commenting
|
||||
|
|
@ -327,18 +351,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
|
|||
personCreateNote
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Note URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personCreateNote now recipPersonID author body mfwd luCreate note = do
|
||||
personCreateNote now recipPersonID (Verse authorIdMsig body) note = do
|
||||
|
||||
-- Check input
|
||||
(luNote, published, Comment maybeParent topic source content) <- do
|
||||
(luId, luAuthor, published, comment) <- parseRemoteComment note
|
||||
unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
|
||||
uCreateAuthor <- lift $ getActorURI authorIdMsig
|
||||
unless (luAuthor == objUriLocal uCreateAuthor) $
|
||||
throwE "Create author != note author"
|
||||
return (luId, published, comment)
|
||||
|
||||
|
|
@ -352,7 +374,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
|
|||
|
||||
Right uContext -> do
|
||||
checkContextParent uContext maybeParent
|
||||
lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
|
||||
lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
|
||||
|
||||
Left (CommentTopicTicket deckID taskID) -> do
|
||||
(_, _, Entity _ ticket, _, _) <- do
|
||||
|
|
@ -360,7 +382,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
|
|||
fromMaybeE mticket "Context: No such deck-ticket"
|
||||
let did = ticketDiscuss ticket
|
||||
_ <- traverse (getMessageParent did) maybeParent
|
||||
lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
|
||||
lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
|
||||
|
||||
Left (CommentTopicCloth loomID clothID) -> do
|
||||
(_, _, Entity _ ticket, _, _, _) <- do
|
||||
|
|
@ -368,7 +390,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
|
|||
fromMaybeE mticket "Context: No such loom-cloth"
|
||||
let did = ticketDiscuss ticket
|
||||
_ <- traverse (getMessageParent did) maybeParent
|
||||
lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
|
||||
lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
|
||||
|
||||
done $
|
||||
case mractid of
|
||||
|
|
@ -409,56 +431,46 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
|
|||
personInvite
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personInvite now recipPersonID author body mfwd luInvite invite = do
|
||||
personInvite now recipPersonID (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check input
|
||||
recipient <- do
|
||||
(_resource, target) <-
|
||||
parseInvite (Right $ remoteAuthorURI author) invite
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(_resource, target) <- parseInvite author invite
|
||||
return target
|
||||
|
||||
maybeInvite <- withDBExcept $ do
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True
|
||||
for mractid $ \ inviteID ->
|
||||
return (personActor personRecip, inviteID)
|
||||
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for maybeInviteDB $ \ _inviteDB ->
|
||||
return $ personActor personRecip
|
||||
|
||||
case maybeInvite of
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, inviteID) -> do
|
||||
Just actorID -> do
|
||||
let targetIsRecip =
|
||||
case recipient of
|
||||
Left (GrantRecipPerson p) -> p == recipPersonID
|
||||
_ -> False
|
||||
if not targetIsRecip
|
||||
then done "I'm not the target; Inserted to inbox"
|
||||
else case mfwd of
|
||||
Nothing ->
|
||||
done
|
||||
"I'm the target; Inserted to inbox; \
|
||||
\Forwarding not approved"
|
||||
Just (localRecips, sig) -> do
|
||||
else do
|
||||
recipHash <- encodeKeyHashid recipPersonID
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStagePersonFollowers recipHash]
|
||||
lift $ forwardActivity
|
||||
(actbBL body) localRecips sig
|
||||
actorID
|
||||
(LocalActorPerson recipPersonID) sieve
|
||||
(EventRemoteInviteLocalRecipFwdToFollower inviteID)
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorPerson recipPersonID)
|
||||
actorID sieve
|
||||
done
|
||||
"I'm the target; Inserted to inbox; \
|
||||
\Forwarded to followers if addressed"
|
||||
|
|
@ -468,285 +480,116 @@ personInvite now recipPersonID author body mfwd luInvite invite = do
|
|||
personJoin
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personJoin now recipPersonID author body mfwd luJoin join = do
|
||||
personJoin now recipPersonID (Verse authorIdMsig body) join = do
|
||||
|
||||
-- Check input
|
||||
_resource <- parseJoin join
|
||||
|
||||
maybeJoinID <- lift $ withDB $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
insertToInbox now author body (actorInbox actorRecip) luJoin True
|
||||
insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
|
||||
case maybeJoinID of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just _joinID -> done "Inserted to my inbox"
|
||||
|
||||
-- Meaning: A remote actor published a Grant
|
||||
-- Meaning: An actor published a Grant
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
personGrant
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Grant URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personGrant now recipPersonID author body mfwd luGrant grant = do
|
||||
personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||
|
||||
-- Check input
|
||||
(_remoteResource, recipient) <- do
|
||||
let u@(ObjURI h _) = remoteAuthorURI author
|
||||
target <- do
|
||||
h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
|
||||
(resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant
|
||||
resourceURI <-
|
||||
case resource of
|
||||
Right r -> return (u, r)
|
||||
_ -> error "Remote Grant but parseGrant identified local resource"
|
||||
when (recip == Right u) $
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _))
|
||||
| p == p' ->
|
||||
throwE "Grant sender and target are the same local Person"
|
||||
(Right uRecip, Right (author, _, _))
|
||||
| uRecip == remoteAuthorURI author ->
|
||||
throwE "Grant sender and target are the same remote actor"
|
||||
return (resourceURI, recip)
|
||||
_ -> pure ()
|
||||
return recip
|
||||
|
||||
maybeGrant <- withDBExcept $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
|
||||
for mractid $ \ grantID ->
|
||||
return (personActor personRecip, grantID)
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for mractid $ \ _grantDB -> return $ personActor personRecip
|
||||
|
||||
case maybeGrant of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (_actorID, _grantID) -> do
|
||||
Just _actorID -> do
|
||||
let targetIsRecip =
|
||||
case recipient of
|
||||
case target of
|
||||
Left (GrantRecipPerson p) -> p == recipPersonID
|
||||
_ -> False
|
||||
if not targetIsRecip
|
||||
then done "I'm not the target; Inserted to inbox"
|
||||
else done "I'm the target; Inserted to inbox"
|
||||
|
||||
-- Meaning: A remote actor has revoked some previously published Grants
|
||||
-- Meaning: An actor has revoked some previously published Grants
|
||||
-- Behavior: Insert to my inbox
|
||||
personRevoke
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Verse
|
||||
-> AP.Revoke URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personRevoke now recipPersonID author body _mfwd luRevoke (AP.Revoke _lus) = do
|
||||
personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do
|
||||
|
||||
maybeRevoke <- lift $ withDB $ do
|
||||
|
||||
-- Grab recipient person from DB
|
||||
-- Grab me from DB
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
insertToInbox now author body (actorInbox actorRecip) luRevoke True
|
||||
insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
|
||||
case maybeRevoke of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just _revokeID -> done "Inserted to my inbox"
|
||||
Just _revokeDB -> done "Inserted to my inbox"
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Main behavior function
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
insertActivityToInbox
|
||||
:: MonadIO m
|
||||
=> UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
|
||||
insertActivityToInbox now recipActorID outboxItemID = do
|
||||
inboxID <- actorInbox <$> getJust recipActorID
|
||||
inboxItemID <- insert $ InboxItem True now
|
||||
maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
|
||||
case maybeItem of
|
||||
Nothing -> do
|
||||
delete inboxItemID
|
||||
return False
|
||||
Just _ -> return True
|
||||
|
||||
personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
|
||||
personBehavior now personID (Left event) =
|
||||
case event of
|
||||
-- Meaning: Someone X received an Invite and forwarded it to me because
|
||||
-- I'm a follower of X
|
||||
-- Behavior: Insert to my inbox
|
||||
EventRemoteInviteLocalRecipFwdToFollower inviteID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID inviteID itemID
|
||||
done "Inserted Invite to inbox"
|
||||
-- Meaning: A remote actor has forwarded to me a local activity
|
||||
-- Behavior: Insert it to my inbox
|
||||
EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do
|
||||
recipPerson <- lift $ getJust personID
|
||||
verifyLocalActivityExistsInDB authorByKey outboxItemID
|
||||
if LocalActorPerson personID == authorByKey
|
||||
then done "Received activity authored by self, ignoring"
|
||||
else do
|
||||
inserted <- lift $ insertActivityToInbox now (personActor recipPerson) outboxItemID
|
||||
done $
|
||||
if inserted
|
||||
then "Activity inserted to my inbox"
|
||||
else "Activity already exists in my inbox, ignoring"
|
||||
-- Meaning: A deck/loom received an Undo{Resolve} and forwarded it to
|
||||
-- me because I'm a follower of the deck/loom or the ticket
|
||||
-- Behavior: Insert to my inbox
|
||||
EventRemoteUnresolveLocalResourceFwdToFollower undoID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID undoID itemID
|
||||
done "Inserted Undo{Resolve} to inbox"
|
||||
-- Meaning: A remote actor accepted an Invite on a local resource, I'm
|
||||
-- being forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Accept to my inbox
|
||||
EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID acceptID itemID
|
||||
done "Inserted Accept{Invite} to inbox"
|
||||
-- Meaning: A remote actor approved a Join on a local resource, I'm
|
||||
-- being forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Accept to my inbox
|
||||
EventRemoteApproveJoinLocalResourceFwdToFollower acceptID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID acceptID itemID
|
||||
done "Inserted Accept{Join} to inbox"
|
||||
-- Meaning: Local resource sent a Grant, I'm the
|
||||
-- inviter/approver/target/follower
|
||||
--
|
||||
-- Behavior: Insert the Grant to my inbox
|
||||
EventGrantAfterRemoteAccept grantID -> do
|
||||
_ <- lift $ withDB $ do
|
||||
(personRecip, _actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
insertActivityToInbox now (personActor personRecip) grantID
|
||||
done "Inserted Grant to my inbox"
|
||||
-- Meaning: A remote actor rejected an Invite on a local resource, I'm
|
||||
-- being forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Accept to my inbox
|
||||
EventRemoteRejectInviteLocalResourceFwdToFollower rejectID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID rejectID itemID
|
||||
done "Inserted Reject{Invite} to inbox"
|
||||
-- Meaning: A remote actor disapproved a Join on a local resource, I'm
|
||||
-- being forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Reject to my inbox
|
||||
EventRemoteForbidJoinLocalResourceFwdToFollower rejectID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID rejectID itemID
|
||||
done "Inserted Reject{Join} to inbox"
|
||||
-- Meaning: Local resource sent a Reject on Invite/Join, I'm the
|
||||
-- inviter/disapprover/target/follower
|
||||
--
|
||||
-- Behavior: Insert the Reject to my inbox
|
||||
EventRejectAfterRemoteReject rejectID -> do
|
||||
_ <- lift $ withDB $ do
|
||||
(personRecip, _actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
insertActivityToInbox now (personActor personRecip) rejectID
|
||||
done "Inserted Reject to my inbox"
|
||||
-- Meaning: An authorized remote actor sent an Invite on a local
|
||||
-- resource, I'm being forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Invite to my inbox
|
||||
EventRemoteInviteLocalTopicFwdToFollower inviteID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID inviteID itemID
|
||||
done "Inserted Invite to inbox"
|
||||
-- Meaning: A remote actor sent a Join on a local resource, I'm being
|
||||
-- forwarded as a follower of the resource
|
||||
--
|
||||
-- Behavior: Insert the Join to my inbox
|
||||
EventRemoteJoinLocalTopicFwdToFollower joinID -> do
|
||||
lift $ withDB $ do
|
||||
(_personRecip, actorRecip) <- do
|
||||
p <- getJust personID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let inboxID = actorInbox actorRecip
|
||||
itemID <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemRemote inboxID joinID itemID
|
||||
done "Inserted Invite to inbox"
|
||||
_ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
|
||||
personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
|
||||
personBehavior now personID verse@(Verse _authorIdMsig body) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept ->
|
||||
personAccept now personID author body mfwd luActivity accept
|
||||
AP.AcceptActivity accept -> personAccept now personID verse accept
|
||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||
case obj of
|
||||
AP.CreateNote _ note ->
|
||||
personCreateNote now personID author body mfwd luActivity note
|
||||
personCreateNote now personID verse note
|
||||
_ -> throwE "Unsupported create object type for people"
|
||||
AP.FollowActivity follow ->
|
||||
personFollow now personID author body mfwd luActivity follow
|
||||
AP.GrantActivity grant ->
|
||||
personGrant now personID author body mfwd luActivity grant
|
||||
AP.InviteActivity invite ->
|
||||
personInvite now personID author body mfwd luActivity invite
|
||||
AP.JoinActivity join ->
|
||||
personJoin now personID author body mfwd luActivity join
|
||||
AP.RejectActivity reject ->
|
||||
personReject now personID author body mfwd luActivity reject
|
||||
AP.RevokeActivity revoke ->
|
||||
personRevoke now personID author body mfwd luActivity revoke
|
||||
AP.UndoActivity undo ->
|
||||
personUndo now personID author body mfwd luActivity undo
|
||||
AP.FollowActivity follow -> personFollow now personID verse follow
|
||||
AP.GrantActivity grant -> personGrant now personID verse grant
|
||||
AP.InviteActivity invite -> personInvite now personID verse invite
|
||||
AP.JoinActivity join -> personJoin now personID verse join
|
||||
AP.RejectActivity reject -> personReject now personID verse reject
|
||||
AP.RevokeActivity revoke -> personRevoke now personID verse revoke
|
||||
AP.UndoActivity undo -> personUndo now personID verse undo
|
||||
_ -> throwE "Unsupported activity type for Person"
|
||||
|
||||
instance VervisActor Person where
|
||||
|
|
|
|||
|
|
@ -52,14 +52,8 @@ import Vervis.Model
|
|||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
repoBehavior
|
||||
:: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next)
|
||||
repoBehavior now repoID (Left event) =
|
||||
case event of
|
||||
EventRemoteFwdLocalActivity _ _ ->
|
||||
throwE "Got a forwarded local activity, I don't need those"
|
||||
_ -> throwE $ "Unsupported event for Repo: " <> T.pack (show event)
|
||||
repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) =
|
||||
repoBehavior :: UTCTime -> RepoId -> Verse -> ActE (Text, Act (), Next)
|
||||
repoBehavior now repoID _verse@(Verse _authorIdMsig body) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
_ -> throwE "Unsupported activity type for Repo"
|
||||
|
||||
|
|
|
|||
|
|
@ -23,6 +23,11 @@ module Vervis.Actor2
|
|||
( -- * Sending messages to actors
|
||||
sendActivity
|
||||
, forwardActivity
|
||||
-- * Preparing a new activity
|
||||
, makeAudSenderOnly
|
||||
, makeAudSenderWithFollowers
|
||||
, getActivityURI
|
||||
, getActorURI
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -31,10 +36,13 @@ import Control.Monad.IO.Class
|
|||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
|
|
@ -58,23 +66,16 @@ import Web.Actor.Persist
|
|||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model hiding (Actor, Message)
|
||||
import Vervis.Recipient (renderLocalActor, localRecipSieve')
|
||||
import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience')
|
||||
import Vervis.Settings
|
||||
|
||||
instance StageWebRoute Env where
|
||||
type StageRoute Env = Route App
|
||||
askUrlRenderParams = do
|
||||
Env _ _ _ _ _ render _ _ <- askEnv
|
||||
case cast render of
|
||||
Nothing -> error "Env site isn't App"
|
||||
Just r -> pure r
|
||||
pageParamName _ = "page"
|
||||
|
||||
askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
|
||||
askLatestInstanceKey = do
|
||||
maybeTVar <- asksEnv envActorKeys
|
||||
|
|
@ -173,15 +174,28 @@ sendActivity
|
|||
-- ^ Instances for which the sender is approving to forward this activity
|
||||
-> OutboxItemId
|
||||
-- ^ DB ID of the item in the author's outbox
|
||||
-> Event
|
||||
-- ^ Event to send to local live actors
|
||||
-> AP.Action URIMode
|
||||
-- ^ Activity to send to remote actors
|
||||
-> Act ()
|
||||
sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do
|
||||
moreRemoteRecips <-
|
||||
sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID action = do
|
||||
moreRemoteRecips <- do
|
||||
let justSender = Just senderByKey
|
||||
in sendToLocalActors event True justSender justSender localRecips
|
||||
author = (senderByKey, senderActorID, itemID)
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
itemHash <- encodeKeyHashid itemID
|
||||
senderByHash <- hashLocalActor senderByKey
|
||||
hLocal <- asksEnv stageInstanceHost
|
||||
let act =
|
||||
let luId = encodeRouteLocal $ activityRoute senderByHash itemHash
|
||||
luActor = encodeRouteLocal $ renderLocalActor senderByHash
|
||||
in AP.makeActivity luId luActor action
|
||||
bodyBL = A.encode $ AP.Doc hLocal act
|
||||
bodyO <-
|
||||
case A.eitherDecode' bodyBL of
|
||||
Left s -> error $ "Parsing encoded activity failed: " ++ s
|
||||
Right o -> return o
|
||||
let body = ActivityBody bodyBL bodyO act
|
||||
sendToLocalActors (Left author) body True justSender justSender localRecips
|
||||
envelope <- do
|
||||
senderByHash <- hashLocalActor senderByKey
|
||||
prepareSendH senderActorID senderByHash itemID action
|
||||
|
|
@ -210,20 +224,20 @@ prepareForwardIK
|
|||
:: (Route App, ActorKey)
|
||||
-> LocalActorBy KeyHashid
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> Act (AP.Errand URIMode)
|
||||
prepareForwardIK (keyR, akey) fwderByHash body proof = do
|
||||
prepareForwardIK (keyR, akey) fwderByHash body mproof = do
|
||||
let sign = actorKeySign akey
|
||||
fwderR = renderLocalActor fwderByHash
|
||||
prepareToForward keyR sign True fwderR body proof
|
||||
prepareToForward keyR sign True fwderR body mproof
|
||||
|
||||
prepareForwardAK
|
||||
:: ActorId
|
||||
-> LocalActorBy KeyHashid
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> ActDB (AP.Errand URIMode)
|
||||
prepareForwardAK actorID fwderByHash body proof = do
|
||||
prepareForwardAK actorID fwderByHash body mproof = do
|
||||
Entity keyID key <- do
|
||||
mk <- getBy $ UniqueSigKey actorID
|
||||
case mk of
|
||||
|
|
@ -233,31 +247,31 @@ prepareForwardAK actorID fwderByHash body proof = do
|
|||
let keyR = stampRoute fwderByHash keyHash
|
||||
sign = actorKeySign $ sigKeyMaterial key
|
||||
fwderR = renderLocalActor fwderByHash
|
||||
prepareToForward keyR sign False fwderR body proof
|
||||
prepareToForward keyR sign False fwderR body mproof
|
||||
|
||||
prepareForwardP
|
||||
:: ActorId
|
||||
-> LocalActorBy KeyHashid
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> ActDB (AP.Errand URIMode)
|
||||
prepareForwardP actorID fwderByHash body proof = do
|
||||
prepareForwardP actorID fwderByHash body mproof = do
|
||||
maybeKey <- lift askLatestInstanceKey
|
||||
case maybeKey of
|
||||
Nothing -> prepareForwardAK actorID fwderByHash body proof
|
||||
Just key -> lift $ prepareForwardIK key fwderByHash body proof
|
||||
Nothing -> prepareForwardAK actorID fwderByHash body mproof
|
||||
Just key -> lift $ prepareForwardIK key fwderByHash body mproof
|
||||
|
||||
prepareForwardH
|
||||
:: ActorId
|
||||
-> LocalActorBy KeyHashid
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> Act (AP.Errand URIMode)
|
||||
prepareForwardH actorID fwderByHash body proof = do
|
||||
prepareForwardH actorID fwderByHash body mproof = do
|
||||
maybeKey <- askLatestInstanceKey
|
||||
case maybeKey of
|
||||
Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof
|
||||
Just key -> prepareForwardIK key fwderByHash body proof
|
||||
Nothing -> withDB $ prepareForwardAK actorID fwderByHash body mproof
|
||||
Just key -> prepareForwardIK key fwderByHash body mproof
|
||||
|
||||
-- | Given a list of local recipients, which may include actors and
|
||||
-- collections,
|
||||
|
|
@ -269,26 +283,92 @@ prepareForwardH actorID fwderByHash body proof = do
|
|||
--
|
||||
-- This function reads remote recipient data and the sender's signing key from
|
||||
-- the PostgreSQL database. Don't use it inside a database transaction.
|
||||
--
|
||||
-- For a remote author, no forwarding is done if a signature isn't provided.
|
||||
forwardActivity
|
||||
:: BL.ByteString
|
||||
-> RecipientRoutes
|
||||
-> ByteString
|
||||
-> ActorId
|
||||
:: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> ActivityBody
|
||||
-> LocalActorBy Key
|
||||
-> ActorId
|
||||
-> RecipientRoutes
|
||||
-> Event
|
||||
-> Act ()
|
||||
forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = do
|
||||
-> ActE ()
|
||||
forwardActivity sourceMaybeForward body fwderByKey fwderActorID sieve = do
|
||||
let maybeForward =
|
||||
case sourceMaybeForward of
|
||||
Left l -> Just $ Left l
|
||||
Right (author, luAct, msig) ->
|
||||
Right . (author,luAct,) <$> msig
|
||||
for_ maybeForward $ \ source -> do
|
||||
localRecips <- do
|
||||
mrecips <- parseAudience' $ AP.activityAudience $ actbActivity body
|
||||
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
|
||||
remoteRecips <-
|
||||
let localRecipsFinal = localRecipSieve' sieve False False localRecips
|
||||
justSender = Just fwderByKey
|
||||
in sendToLocalActors event False justSender justSender localRecipsFinal
|
||||
errand <- do
|
||||
authorAndId =
|
||||
second (\ (author, luAct, _sig) -> (author, luAct)) source
|
||||
in lift $ sendToLocalActors authorAndId body False justSender justSender localRecipsFinal
|
||||
errand <- lift $ do
|
||||
fwderByHash <- hashLocalActor fwderByKey
|
||||
prepareForwardH fwderActorID fwderByHash body sig
|
||||
let msig =
|
||||
case source of
|
||||
Left _ -> Nothing
|
||||
Right (_, _, b) -> Just b
|
||||
prepareForwardH fwderActorID fwderByHash (actbBL body) msig
|
||||
let remoteRecipsList =
|
||||
concatMap
|
||||
(\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
|
||||
remoteRecips
|
||||
dt <- asksEnv stageDeliveryTheater
|
||||
liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList
|
||||
dt <- lift $ asksEnv stageDeliveryTheater
|
||||
lift $ liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList
|
||||
|
||||
makeAudSenderOnly
|
||||
:: Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> Act (Aud URIMode)
|
||||
makeAudSenderOnly (Left (actorByKey, _, _)) = do
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
return $ AudLocal [actorByHash] []
|
||||
makeAudSenderOnly (Right (author, _, _)) = do
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
pure $ AudRemote hAuthor [luAuthor] []
|
||||
|
||||
makeAudSenderWithFollowers
|
||||
:: Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> ActDB (Aud URIMode)
|
||||
makeAudSenderWithFollowers (Left (actorByKey, _, _)) = do
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
return $ AudLocal [actorByHash] [localActorFollowers actorByHash]
|
||||
makeAudSenderWithFollowers (Right (author, _, _)) = do
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
return $
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
|
||||
getActivityURI
|
||||
:: Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> Act FedURI
|
||||
getActivityURI (Left (actorByKey, _, outboxItemID)) = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
outboxItemHash <- encodeKeyHashid outboxItemID
|
||||
return $ encodeRouteHome $ activityRoute actorByHash outboxItemHash
|
||||
getActivityURI (Right (author, luAct, _)) = do
|
||||
let ObjURI hAuthor _ = remoteAuthorURI author
|
||||
pure $ ObjURI hAuthor luAct
|
||||
|
||||
getActorURI
|
||||
:: Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> Act FedURI
|
||||
getActorURI (Left (actorByKey, _, _)) = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
return $ encodeRouteHome $ renderLocalActor actorByHash
|
||||
getActorURI (Right (author, _, _)) = pure $ remoteAuthorURI author
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ parseTopic u = do
|
|||
|
||||
parseInvite
|
||||
:: StageRoute Env ~ Route App
|
||||
=> Either PersonId FedURI
|
||||
=> Either (LocalActorBy Key) FedURI
|
||||
-> AP.Invite URIMode
|
||||
-> ActE
|
||||
( Either (GrantResourceBy Key) FedURI
|
||||
|
|
@ -144,7 +144,7 @@ parseInvite sender (AP.Invite instrument object target) = do
|
|||
recipHash
|
||||
"Contains invalid hashid"
|
||||
case recipKey of
|
||||
GrantRecipPerson p | Left p == sender ->
|
||||
GrantRecipPerson p | Left (LocalActorPerson p) == sender ->
|
||||
throwE "Invite local sender and recipient are the same Person"
|
||||
_ -> return recipKey
|
||||
)
|
||||
|
|
|
|||
|
|
@ -404,12 +404,12 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
|
|||
else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
|
||||
-> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
|
||||
:: UTCTime -> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
|
||||
authenticateActivity now = do
|
||||
(ra, wv, body) <- do
|
||||
verifyContentTypeAP_E
|
||||
|
||||
-- Compute input for HTTP Signature verification
|
||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
|
||||
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
|
||||
let requires = [hRequestTarget, hHost, hDigest]
|
||||
|
|
@ -419,6 +419,7 @@ authenticateActivity now = do
|
|||
toSeconds = toTimeUnit
|
||||
in fromIntegral $ toSeconds timeLimit
|
||||
prepareToVerifyHttpSig requires wants seconds now
|
||||
|
||||
(remoteAuthor, body) <-
|
||||
withExceptT T.pack $
|
||||
(,) <$> verifyActorSig proof
|
||||
|
|
@ -429,21 +430,13 @@ authenticateActivity now = do
|
|||
Right wv -> return wv
|
||||
return (remoteAuthor, wvdoc, body)
|
||||
let WithValue raw (Doc hActivity activity) = wv
|
||||
uSender = remoteAuthorURI ra
|
||||
ObjURI hSender luSender = uSender
|
||||
uSender@(ObjURI hSender luSender) = remoteAuthorURI ra
|
||||
luAuthor = activityActor activity
|
||||
auth <-
|
||||
if hSender == hActivity
|
||||
then do
|
||||
unless (activityActor activity == luSender) $
|
||||
throwE $ T.concat
|
||||
[ "Activity's actor <"
|
||||
, renderObjURI $
|
||||
ObjURI hActivity $ activityActor activity
|
||||
, "> != Signature key's actor <", renderObjURI uSender
|
||||
, ">"
|
||||
]
|
||||
return $ ActivityAuthRemote ra
|
||||
else do
|
||||
case (hSender == hActivity, luSender == luAuthor) of
|
||||
(False, _) -> do
|
||||
-- Sender and author are on different hosts, therefore require
|
||||
-- a valid forwarded signature that approves the forwarding
|
||||
ma <- checkForward uSender hActivity (activityActor activity)
|
||||
case ma of
|
||||
Nothing -> throwE $ T.concat
|
||||
|
|
@ -452,6 +445,28 @@ authenticateActivity now = do
|
|||
, renderAuthority hSender, ">"
|
||||
]
|
||||
Just a -> return a
|
||||
(True, False) -> do
|
||||
-- Sender and author are different actors on the same host,
|
||||
-- therefore we approve the forwarding without a signature
|
||||
hl <- hostIsLocalOld hActivity
|
||||
if hl
|
||||
then ActivityAuthLocal <$> do
|
||||
route <- parseLocalURI luAuthor
|
||||
parseLocalActorE route
|
||||
else ActivityAuthRemote <$> do
|
||||
let uAuthor = ObjURI hActivity luAuthor
|
||||
instanceID = remoteAuthorInstance ra
|
||||
remoteActorID <- do
|
||||
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hActivity luAuthor
|
||||
case result of
|
||||
Left Nothing -> throwE "Author @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Author isn't an actor"
|
||||
Right (Just actor) -> return $ entityKey actor
|
||||
return $ RemoteAuthor uAuthor instanceID remoteActorID
|
||||
(True, True) ->
|
||||
-- Sender and author are the same actor
|
||||
pure $ ActivityAuthRemote ra
|
||||
|
||||
-- Verify FEP-8b32 jcs-eddsa-2022 VC data integrity proof
|
||||
for_ (AP.activityProof activity) $ \ proof -> do
|
||||
|
|
|
|||
|
|
@ -176,7 +176,8 @@ personCreateNoteF
|
|||
-> AP.Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
|
||||
|
||||
error "personCreateNoteF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipPersonID <- decodeKeyHashid404 recipPersonHash
|
||||
(luNote, published, Comment maybeParent topic source content) <- do
|
||||
|
|
@ -240,6 +241,7 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
|
|||
did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
|
||||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
-}
|
||||
|
||||
deckCreateNoteF
|
||||
:: UTCTime
|
||||
|
|
@ -251,7 +253,8 @@ deckCreateNoteF
|
|||
-> AP.Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
|
||||
|
||||
error "deckCreateNoteF disabled for refactoring"
|
||||
{-
|
||||
recipDeckID <- decodeKeyHashid404 recipDeckHash
|
||||
(luNote, published, Comment maybeParent topic source content) <- do
|
||||
(luId, luAuthor, published, comment) <- parseRemoteCommentOld note
|
||||
|
|
@ -309,6 +312,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
|
|||
Right forwardHttp -> do
|
||||
forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
|
||||
return "Stored to inbox, cached comment, and did inbox forwarding"
|
||||
-}
|
||||
|
||||
loomCreateNoteF
|
||||
:: UTCTime
|
||||
|
|
@ -320,7 +324,8 @@ loomCreateNoteF
|
|||
-> AP.Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
|
||||
|
||||
error "loomCreateNoteF disabled for refactoring"
|
||||
{-
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(luNote, published, Comment maybeParent topic source content) <- do
|
||||
(luId, luAuthor, published, comment) <- parseRemoteCommentOld note
|
||||
|
|
@ -378,3 +383,4 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
|
|||
Right forwardHttp -> do
|
||||
forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
|
||||
return "Stored to inbox, cached comment, and did inbox forwarding"
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -500,7 +500,8 @@ loomUndoF
|
|||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
error "loomUndoF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
undone <-
|
||||
|
|
@ -700,6 +701,7 @@ loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
repoUndoF
|
||||
:: UTCTime
|
||||
|
|
@ -711,7 +713,8 @@ repoUndoF
|
|||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
error "repoUndoF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipRepoID <- decodeKeyHashid404 recipRepoHash
|
||||
undone <-
|
||||
|
|
@ -839,3 +842,4 @@ repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -335,7 +335,8 @@ deckOfferTicketF
|
|||
-> FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
||||
|
||||
error "deckOfferTicketF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipDeckID <- decodeKeyHashid404 recipDeckHash
|
||||
(title, desc, source) <- do
|
||||
|
|
@ -474,6 +475,7 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
||||
|
|
@ -492,7 +494,8 @@ loomOfferTicketF
|
|||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||
|
||||
error "loomOfferTicketF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
|
||||
|
|
@ -808,6 +811,7 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
repoOfferTicketF
|
||||
:: UTCTime
|
||||
|
|
@ -1130,7 +1134,8 @@ loomApplyF
|
|||
-> AP.Apply URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||
|
||||
error "loomApplyF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(repoID, maybeBranch, clothID, bundleID) <- do
|
||||
|
|
@ -1295,6 +1300,7 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
personOfferDepF
|
||||
:: UTCTime
|
||||
|
|
@ -1899,7 +1905,8 @@ trackerResolveF
|
|||
-> AP.Resolve URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
|
||||
|
||||
error "trackerResolveF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipID <- decodeKeyHashid404 recipHash
|
||||
wiID <- nameExceptT "Resolve object" $ do
|
||||
|
|
@ -2053,6 +2060,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
deckResolveF
|
||||
:: UTCTime
|
||||
|
|
|
|||
|
|
@ -15,12 +15,12 @@
|
|||
|
||||
module Vervis.Federation.Util
|
||||
( insertToInbox
|
||||
, insertToInbox'
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Time.Clock
|
||||
import Database.Persist
|
||||
|
|
@ -36,30 +36,32 @@ import Vervis.Federation.Auth
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
||||
-- | Insert a remote activity delivered to us into our inbox. Return its
|
||||
-- | Insert an activity delivered to us into our inbox. Return its
|
||||
-- database ID if the activity wasn't already in our inbox.
|
||||
insertToInbox
|
||||
:: MonadIO m
|
||||
=> UTCTime
|
||||
-> RemoteAuthor
|
||||
:: UTCTime
|
||||
-> Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> ActivityBody
|
||||
-> InboxId
|
||||
-> LocalURI
|
||||
-> Bool
|
||||
-> ReaderT SqlBackend m (Maybe RemoteActivityId)
|
||||
insertToInbox now author body ibid luAct unread =
|
||||
fmap fst <$> insertToInbox' now author body ibid luAct unread
|
||||
|
||||
insertToInbox'
|
||||
:: MonadIO m
|
||||
=> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> InboxId
|
||||
-> LocalURI
|
||||
-> Bool
|
||||
-> ReaderT SqlBackend m (Maybe (RemoteActivityId, InboxItemId))
|
||||
insertToInbox' now author body ibid luAct unread = do
|
||||
-> ActDB
|
||||
(Maybe
|
||||
(Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, RemoteActivityId)
|
||||
)
|
||||
)
|
||||
insertToInbox now (Left a@(_, _, outboxItemID)) body inboxID unread = do
|
||||
inboxItemID <- insert $ InboxItem unread now
|
||||
maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
|
||||
case maybeItem of
|
||||
Nothing -> do
|
||||
delete inboxItemID
|
||||
return Nothing
|
||||
Just _ -> return $ Just $ Left a
|
||||
insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
roid <-
|
||||
either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
|
||||
|
|
@ -69,9 +71,9 @@ insertToInbox' now author body ibid luAct unread = do
|
|||
, remoteActivityReceived = now
|
||||
}
|
||||
ibiid <- insert $ InboxItem unread now
|
||||
mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
|
||||
mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
|
||||
case mibrid of
|
||||
Nothing -> do
|
||||
delete ibiid
|
||||
return Nothing
|
||||
Just _ -> return $ Just (ractid, ibiid)
|
||||
Just _ -> return $ Just $ Right (author, luAct, ractid)
|
||||
|
|
|
|||
|
|
@ -2936,6 +2936,8 @@ changes hLocal ctx =
|
|||
, removeField "Ticket" "status"
|
||||
-- 530
|
||||
, addEntities model_530_join
|
||||
-- 531
|
||||
, addEntities model_531_follow_request
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2018, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2018, 2019, 2020, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -60,6 +61,7 @@ module Vervis.Migration.Entities
|
|||
, model_497_sigkey
|
||||
, model_508_invite
|
||||
, model_530_join
|
||||
, model_531_follow_request
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -235,3 +237,6 @@ model_508_invite = $(schema "508_2022-10-19_invite")
|
|||
|
||||
model_530_join :: [Entity SqlBackend]
|
||||
model_530_join = $(schema "530_2022-11-01_join")
|
||||
|
||||
model_531_follow_request :: [Entity SqlBackend]
|
||||
model_531_follow_request = $(schema "531_2023-06-15_follow_request")
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@ module Vervis.Recipient
|
|||
, ParsedAudience (..)
|
||||
, concatRecipients
|
||||
, parseAudience
|
||||
, parseAudience'
|
||||
|
||||
-- * Creating a recipient set, supporting both local and remote recips
|
||||
, Aud (..)
|
||||
|
|
@ -93,6 +94,7 @@ module Vervis.Recipient
|
|||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.Actor
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
|
@ -108,6 +110,7 @@ import Data.Semigroup
|
|||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Traversable
|
||||
import Data.Typeable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import GHC.Generics
|
||||
|
|
@ -127,6 +130,7 @@ import Yesod.Hashids
|
|||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
import qualified Web.Actor as WA
|
||||
|
||||
import Data.List.Local
|
||||
import Data.List.NonEmpty.Local
|
||||
|
|
@ -143,6 +147,15 @@ import Vervis.FedURI
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
||||
instance WA.StageWebRoute Env where
|
||||
type StageRoute Env = Route App
|
||||
askUrlRenderParams = do
|
||||
Env _ _ _ _ _ render _ _ <- askEnv
|
||||
case cast render of
|
||||
Nothing -> error "Env site isn't App"
|
||||
Just r -> pure r
|
||||
pageParamName _ = "page"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Actor and collection-of-actors types
|
||||
--
|
||||
|
|
@ -785,6 +798,48 @@ parseRecipients recips = do
|
|||
Nothing -> Left route
|
||||
Just recip -> Right recip
|
||||
|
||||
parseRecipients'
|
||||
:: WA.StageRoute Env ~ Route App
|
||||
=> NonEmpty FedURI -> ActE (RecipientRoutes, [FedURI])
|
||||
parseRecipients' recips = do
|
||||
hLocal <- asksEnv WA.stageInstanceHost
|
||||
let (locals, remotes) = splitRecipients hLocal recips
|
||||
(lusInvalid, routesInvalid, localsSet) = parseLocalRecipients locals
|
||||
unless (null lusInvalid) $
|
||||
throwE $
|
||||
"Local recipients are invalid routes: " <>
|
||||
T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid)
|
||||
unless (null routesInvalid) $ do
|
||||
renderUrl <- WA.askUrlRender
|
||||
throwE $
|
||||
"Local recipients are non-recipient routes: " <>
|
||||
T.pack (show $ map renderUrl routesInvalid)
|
||||
return (localsSet, remotes)
|
||||
where
|
||||
splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI])
|
||||
splitRecipients home recips =
|
||||
let (local, remote) = NE.partition ((== home) . objUriAuthority) recips
|
||||
in (map objUriLocal local, remote)
|
||||
|
||||
parseLocalRecipients
|
||||
:: [LocalURI] -> ([LocalURI], [Route App], RecipientRoutes)
|
||||
parseLocalRecipients lus =
|
||||
let (lusInvalid, routes) = partitionEithers $ map parseRoute lus
|
||||
(routesInvalid, recips) = partitionEithers $ map parseRecip routes
|
||||
(actors, stages) = partitionEithers recips
|
||||
grouped =
|
||||
map recipientFromActor actors ++ map recipientFromStage stages
|
||||
in (lusInvalid, routesInvalid, groupLocalRecipients grouped)
|
||||
where
|
||||
parseRoute lu =
|
||||
case decodeRouteLocal lu of
|
||||
Nothing -> Left lu
|
||||
Just route -> Right route
|
||||
parseRecip route =
|
||||
case parseLocalRecipient route of
|
||||
Nothing -> Left route
|
||||
Just recip -> Right recip
|
||||
|
||||
parseAudience
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> AP.Audience URIMode
|
||||
|
|
@ -811,6 +866,31 @@ parseAudience audience = do
|
|||
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
|
||||
groupByHost = groupAllExtract objUriAuthority objUriLocal
|
||||
|
||||
parseAudience'
|
||||
:: WA.StageRoute Env ~ Route App
|
||||
=> AP.Audience URIMode -> ActE (Maybe (ParsedAudience URIMode))
|
||||
parseAudience' audience = do
|
||||
let recips = concatRecipients audience
|
||||
for (nonEmpty recips) $ \ recipsNE -> do
|
||||
(localsSet, remotes) <- parseRecipients' recipsNE
|
||||
let remotesGrouped =
|
||||
groupByHost $ remotes \\ AP.audienceNonActors audience
|
||||
hosts = map fst remotesGrouped
|
||||
return ParsedAudience
|
||||
{ paudLocalRecips = localsSet
|
||||
, paudRemoteActors = remotesGrouped
|
||||
, paudBlinded =
|
||||
audience { AP.audienceBto = [], AP.audienceBcc = [] }
|
||||
, paudFwdHosts =
|
||||
let nonActorHosts =
|
||||
LO.nubSort $
|
||||
map objUriAuthority $ AP.audienceNonActors audience
|
||||
in LO.isect hosts nonActorHosts
|
||||
}
|
||||
where
|
||||
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
|
||||
groupByHost = groupAllExtract objUriAuthority objUriLocal
|
||||
|
||||
data Aud u
|
||||
= AudLocal [LocalActor] [LocalStage]
|
||||
| AudRemote (Authority u) [LocalURI] [LocalURI]
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ import Yesod.Persist.Local
|
|||
import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..))
|
||||
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -106,6 +106,7 @@ import Vervis.Foundation
|
|||
import Vervis.Model hiding (Ticket)
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Paginate
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
|
@ -236,26 +237,27 @@ postInbox recipByKey = do
|
|||
now <- liftIO getCurrentTime
|
||||
result <- runExceptT $ do
|
||||
(auth, body) <- authenticateActivity now
|
||||
verse <-
|
||||
authorIdMsig <-
|
||||
case auth of
|
||||
ActivityAuthLocal authorByKey -> Left <$> do
|
||||
outboxItemID <-
|
||||
parseAuthenticatedLocalActivityURI
|
||||
authorByKey
|
||||
(AP.activityId $ actbActivity body)
|
||||
return $ EventRemoteFwdLocalActivity authorByKey outboxItemID
|
||||
actorID <- do
|
||||
ment <- lift $ runDB $ getLocalActorEntity authorByKey
|
||||
case ment of
|
||||
Nothing -> throwE "Author not found in DB"
|
||||
Just ent -> return $ localActorID ent
|
||||
return (authorByKey, actorID, outboxItemID)
|
||||
ActivityAuthRemote author -> Right <$> do
|
||||
luActivity <-
|
||||
fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
|
||||
localRecips <- do
|
||||
mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
|
||||
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
|
||||
recipByHash <- hashLocalActor recipByKey
|
||||
msig <- checkForwarding recipByHash
|
||||
let mfwd = (localRecips,) <$> msig
|
||||
return $ VerseRemote author body mfwd luActivity
|
||||
return (author, luActivity, msig)
|
||||
theater <- getsYesod appTheater
|
||||
r <- liftIO $ callIO theater recipByKey verse
|
||||
r <- liftIO $ callIO theater recipByKey $ Verse authorIdMsig body
|
||||
case r of
|
||||
Nothing -> notFound
|
||||
Just (Left e) -> throwE e
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ import Data.Maybe.Local
|
|||
import Data.Tuple.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Actor (Event)
|
||||
--import Vervis.Actor
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
|
|
|
|||
|
|
@ -106,6 +106,7 @@ module Web.ActivityPub
|
|||
, hForwardedSignature
|
||||
, Envelope ()
|
||||
, Errand ()
|
||||
, encodeForwardingSigHeader
|
||||
, sending
|
||||
, retrying
|
||||
, deliver
|
||||
|
|
@ -2223,7 +2224,7 @@ httpPostAP manager headers keyid sign uSender value =
|
|||
data ForwardMode u
|
||||
= SendNoForward
|
||||
| SendAllowForward LocalURI
|
||||
| ForwardBy (ObjURI u) ByteString
|
||||
| ForwardBy (ObjURI u) (Maybe ByteString)
|
||||
|
||||
data Envelope u = Envelope
|
||||
{ envelopeKey :: RefURI u
|
||||
|
|
@ -2238,9 +2239,30 @@ data Errand u = Errand
|
|||
, errandHolder :: Bool
|
||||
, errandFwder :: LocalURI
|
||||
, errandBody :: BL.ByteString
|
||||
, errandProof :: ByteString
|
||||
, errandProof :: Maybe ByteString
|
||||
}
|
||||
|
||||
-- | Produce a 'hForwardingSignature' header value for use when forwarding a
|
||||
-- local activity, i.e. an activity of another local actor.
|
||||
encodeForwardingSigHeader
|
||||
:: UriMode u
|
||||
=> UTCTime
|
||||
-> RefURI u
|
||||
-> (ByteString -> S.Signature)
|
||||
-> BL.ByteString
|
||||
-> ObjURI u
|
||||
-> Either S.HttpSigGenError ByteString
|
||||
encodeForwardingSigHeader now ruKey sign body uRecipActor =
|
||||
let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
||||
fwder = encodeUtf8 $ renderObjURI uRecipActor
|
||||
req =
|
||||
consHeader hActivityPubForwarder fwder $
|
||||
consHeader hDigest digest defaultRequest
|
||||
keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey
|
||||
in signRequestBytes (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now req
|
||||
where
|
||||
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
||||
|
||||
-- | Like 'httpPostAP', except it takes the object as a raw lazy
|
||||
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
|
||||
httpPostAPBytes
|
||||
|
|
@ -2276,9 +2298,9 @@ httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uI
|
|||
except $ first APPostErrorSig $
|
||||
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
|
||||
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
|
||||
ForwardBy uSender sig ->
|
||||
ForwardBy uSender msig ->
|
||||
return $
|
||||
consHeader hForwardedSignature sig $
|
||||
maybe id (consHeader hForwardedSignature) msig $
|
||||
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
|
||||
req''
|
||||
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
|
||||
|
|
@ -2331,16 +2353,16 @@ forwarding
|
|||
-> Bool
|
||||
-> ObjURI u
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> Errand u
|
||||
forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig =
|
||||
forwarding lruKey sign holder (ObjURI hFwder luFwder) body msig =
|
||||
Errand
|
||||
{ errandKey = RefURI hFwder lruKey
|
||||
, errandSign = sign
|
||||
, errandHolder = holder
|
||||
, errandFwder = luFwder
|
||||
, errandBody = body
|
||||
, errandProof = sig
|
||||
, errandProof = msig
|
||||
}
|
||||
|
||||
deliver
|
||||
|
|
@ -2369,7 +2391,7 @@ forward
|
|||
-> Errand u
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox =
|
||||
forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body msig) uInbox =
|
||||
httpPostAPBytes
|
||||
manager
|
||||
headers
|
||||
|
|
@ -2377,7 +2399,7 @@ forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body s
|
|||
sign
|
||||
(guard holder >> Just luFwder)
|
||||
body
|
||||
(ForwardBy (ObjURI hKey luFwder) sig)
|
||||
(ForwardBy (ObjURI hKey luFwder) msig)
|
||||
uInbox
|
||||
|
||||
-- | Result of GETing the keyId URI and processing the JSON document.
|
||||
|
|
|
|||
|
|
@ -193,11 +193,11 @@ prepareToForward
|
|||
-> Bool
|
||||
-> StageRoute s
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Maybe ByteString
|
||||
-> m (AP.Errand u)
|
||||
prepareToForward keyR sign holder fwderR body sig = do
|
||||
prepareToForward keyR sign holder fwderR body msig = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uFwder = encodeRouteHome fwderR
|
||||
return $ AP.forwarding lruKey sign holder uFwder body sig
|
||||
return $ AP.forwarding lruKey sign holder uFwder body msig
|
||||
|
|
|
|||
|
|
@ -163,6 +163,7 @@ deliverActivityThrow envelope mluFwd uInbox = do
|
|||
Left e -> liftIO $ throwIO e
|
||||
Right response -> return response
|
||||
|
||||
{-
|
||||
prepareToForward
|
||||
:: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
|
||||
=> Route site
|
||||
|
|
@ -178,6 +179,7 @@ prepareToForward keyR sign holder fwderR body sig = do
|
|||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uFwder = encodeRouteHome fwderR
|
||||
return $ AP.forwarding lruKey sign holder uFwder body sig
|
||||
-}
|
||||
|
||||
forwardActivity
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
|
|
|
|||
13
th/models
13
th/models
|
|
@ -228,11 +228,14 @@ FollowRemote
|
|||
UniqueFollowRemoteFollow follow
|
||||
UniqueFollowRemoteAccept accept
|
||||
|
||||
--FollowRequest
|
||||
-- person PersonId
|
||||
-- target FollowerSetId
|
||||
--
|
||||
-- UniqueFollowRequest person target
|
||||
FollowRequest
|
||||
actor ActorId
|
||||
target FollowerSetId
|
||||
public Bool
|
||||
follow OutboxItemId
|
||||
|
||||
UniqueFollowRequest actor target
|
||||
UniqueFollowRequestFollow follow
|
||||
|
||||
Follow
|
||||
actor ActorId
|
||||
|
|
|
|||
Loading…
Reference in a new issue