forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Switch to converged handlers than handle both local and remote activities

Browse source 
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 2023-06-15 15:44:43 +03:00
parent d5d6b0af61
commit d33f272ede
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
26 changed files with 871 additions and 760 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
migrations/531_2023-06-15_follow_request.model Normal file
View file

@ -0,0 +1,8 @@
FollowRequest
actor ActorId
target FollowerSetId
public Bool
follow OutboxItemId
UniqueFollowRequest actor target
UniqueFollowRequestFollow follow

98
src/Vervis/API.hs
View file

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

25
src/Vervis/Access.hs
View file

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

54
src/Vervis/Actor.hs
View file

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

337
src/Vervis/Actor/Common.hs
View file

@ -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
let followerID = remoteAuthorId author
maybeFollow <-
lift $ getBy $ UniqueRemoteFollow followerID followerSetID
verifyNothingE maybeFollow "You're already following this object"
-- 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
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,26 +779,27 @@ 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
let authorID = remoteAuthorId author
insert_ $ CollabInviterRemote fulfillsID authorID inviteID
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
Left (GrantRecipPerson (Entity personID _)) ->
insert_ $ CollabRecipLocal collabID personID
@ -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,58 +829,81 @@ 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
let targetID = remoteAuthorId author
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
E.on $
topic E.^. topicCollabField E.==.
recipr E.^. CollabRecipRemoteCollab
E.where_ $
topic E.^. topicField E.==. E.val topicKey E.&&.
recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
return $ recipr E.^. CollabRecipRemoteCollab
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 $
topic E.^. topicCollabField E.==.
recipr E.^. CollabRecipRemoteCollab
E.where_ $
topic E.^. topicField E.==. E.val topicKey E.&&.
recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
return $ recipr E.^. CollabRecipRemoteCollab
case existingCollabIDs of
[] -> pure ()
[_] -> 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
let authorID = remoteAuthorId author
recipID <- insert $ CollabRecipRemote collabID authorID
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
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

149
src/Vervis/Actor/Deck.hs
View file

@ -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
forwardActivity
(actbBL body) localRecips sig actorID
(LocalActorDeck recipDeckID) sieve
(EventRemoteUnresolveLocalResourceFwdToFollower undoID)
Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
forwardActivity
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

10
src/Vervis/Actor/Group.hs
View file

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

10
src/Vervis/Actor/Loom.hs
View file

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

445
src/Vervis/Actor/Person.hs
View file

@ -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,344 +431,165 @@ 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
recipHash <- encodeKeyHashid recipPersonID
let sieve =
makeRecipientSet
[]
[LocalStagePersonFollowers recipHash]
lift $ forwardActivity
(actbBL body) localRecips sig
actorID
(LocalActorPerson recipPersonID) sieve
(EventRemoteInviteLocalRecipFwdToFollower inviteID)
done
"I'm the target; Inserted to inbox; \
\Forwarded to followers if addressed"
else do
recipHash <- encodeKeyHashid recipPersonID
let sieve =
makeRecipientSet
[]
[LocalStagePersonFollowers recipHash]
forwardActivity
authorIdMsig body (LocalActorPerson recipPersonID)
actorID sieve
done
"I'm the target; Inserted to inbox; \
\Forwarded to followers if addressed"
-- Meaning: Someone asked to join a resource
-- Behavior: Insert to my inbox
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) $
throwE "Grant sender and target are the same remote actor"
return (resourceURI, recip)
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"
_ -> 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

10
src/Vervis/Actor/Repo.hs
View file

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

178
src/Vervis/Actor2.hs
View file

@ -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
remoteRecips <-
let localRecipsFinal = localRecipSieve' sieve False False localRecips
justSender = Just fwderByKey
in sendToLocalActors event False justSender justSender localRecipsFinal
errand <- do
fwderByHash <- hashLocalActor fwderByKey
prepareForwardH fwderActorID fwderByHash body sig
let remoteRecipsList =
concatMap
(\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
remoteRecips
dt <- asksEnv stageDeliveryTheater
liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList
-> 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
authorAndId =
second (\ (author, luAct, _sig) -> (author, luAct)) source
in lift $ sendToLocalActors authorAndId body False justSender justSender localRecipsFinal
errand <- lift $ do
fwderByHash <- hashLocalActor fwderByKey
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 <- 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

4
src/Vervis/Data/Collab.hs
View file

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

49
src/Vervis/Federation/Auth.hs
View file

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

12
src/Vervis/Federation/Discussion.hs
View file

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

8
src/Vervis/Federation/Offer.hs
View file

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

16
src/Vervis/Federation/Ticket.hs
View file

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

46
src/Vervis/Federation/Util.hs
View file

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

2
src/Vervis/Migration.hs
View file

@ -2936,6 +2936,8 @@ changes hLocal ctx =
, removeField "Ticket" "status"
-- 530
, addEntities model_530_join
-- 531
, addEntities model_531_follow_request
]
migrateDB

7
src/Vervis/Migration/Entities.hs
View file

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

80
src/Vervis/Recipient.hs
View file

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

20
src/Vervis/Web/Actor.hs
View file

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

2
src/Vervis/Web/Delivery.hs
View file

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

40
src/Web/ActivityPub.hs
View file

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

6
src/Web/Actor.hs
View file

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

2
src/Yesod/ActivityPub.hs
View file

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

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