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 inviteC
:: Entity Person :: Entity Person
-> Actor -> Actor
@ -1853,11 +1866,11 @@ inviteC
-> AP.Invite URIMode -> AP.Invite URIMode
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do 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 -- Check input
(resource, recipient) <- parseInvite (Left senderPersonID) invite (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 -- 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. -- 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") (runDBExcept . flip getGrantResource "Grant context not found in DB")
(\ u@(ObjURI h lu) -> do (\ u@(ObjURI h lu) -> do
instanceID <- instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h) lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <- result <-
ExceptT $ first (T.pack . show) <$> ExceptT $ first (T.pack . show) <$>
fetchRemoteResource instanceID h lu fetchRemoteResource instanceID h lu
@ -1888,7 +1901,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
lift $ runDB $ either entityKey id <$> insertBy' (Instance h) lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
result <- result <-
ExceptT $ first (T.pack . displayException) <$> ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor instanceID h lu fetchRemoteActor' instanceID h lu
case result of case result of
Left Nothing -> throwE "Recipient @id mismatch" Left Nothing -> throwE "Recipient @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err Left (Just err) -> throwE $ T.pack $ displayException err
@ -1910,27 +1923,25 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
senderHash <- encodeKeyHashid senderPersonID senderHash <- encodeKeyHashid senderPersonID
? <- withDBExcept $ do
(obiidInvite, deliverHttpInvite) <- runDBExcept $ do (obiidInvite, deliverHttpInvite) <- runDBExcept $ do
-- If resource is local, verify the specified capability gives relevant -- Insert the Invite activity to author's outbox
-- 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
inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now 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 _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action
-- Deliver the Invite activity to local recipients, and schedule -- 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 instructions for HTTP delivery to remote recipients
return (inviteID, deliverHttpInvite) return (inviteID, deliverHttpInvite)
-- Notify the resource
-- Launch asynchronous HTTP delivery of the Grant activity -- Launch asynchronous HTTP delivery of the Grant activity
lift $ do lift $ do
forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
@ -1995,20 +2022,20 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
where where
fetchRemoteResource instanceID host localURI = do fetchRemoteResource instanceID host localURI = do
maybeActor <- runSiteDB $ runMaybeT $ do maybeActor <- withDB $ runMaybeT $ do
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
MaybeT $ getBy $ UniqueRemoteActor roid MaybeT $ getBy $ UniqueRemoteActor roid
case maybeActor of case maybeActor of
Just actor -> return $ Right $ Left actor Just actor -> return $ Right $ Left actor
Nothing -> do Nothing -> do
manager <- asksSite getHttpManager manager <- asksEnv getHttpManager
errorOrResource <- fetchResource manager host localURI errorOrResource <- fetchResource manager host localURI
case errorOrResource of case errorOrResource of
Left maybeError -> Left maybeError ->
return $ Left $ maybe ResultIdMismatch ResultGetError maybeError return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
Right resource -> do Right resource -> do
case resource of 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) roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
let ra = RemoteActor let ra = RemoteActor
{ remoteActorIdent = roid { remoteActorIdent = roid
@ -2020,8 +2047,8 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
} }
Right . Left . either id id <$> insertByEntity' ra Right . Left . either id id <$> insertByEntity' ra
ResourceChild luId luManager -> do ResourceChild luId luManager -> do
roid <- runSiteDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI) roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
result <- fetchRemoteActor instanceID host luManager result <- fetchRemoteActor' instanceID host luManager
return $ return $
case result of case result of
Left e -> Left $ ResultSomeException e Left e -> Left $ ResultSomeException e
@ -2038,23 +2065,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
routes <- lookup p $ recipPeople localRecips routes <- lookup p $ recipPeople localRecips
guard $ routePerson routes 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) = hashGrantRecip (GrantRecipPerson k) =
GrantRecipPerson <$> encodeKeyHashid k GrantRecipPerson <$> encodeKeyHashid k
-} -}

25
src/Vervis/Access.hs
View file

@ -77,6 +77,7 @@ module Vervis.Access
, grantResourceLocalActor , grantResourceLocalActor
, verifyCapability , verifyCapability
, verifyCapability'
) )
where where
@ -89,6 +90,8 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie import Data.Barbie
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Database.Persist import Database.Persist
@ -99,6 +102,7 @@ import Yesod.Core.Handler
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Control.Concurrent.Actor import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor.Persist (stageHashidsContext) import Web.Actor.Persist (stageHashidsContext)
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
@ -107,6 +111,7 @@ import Control.Monad.Trans.Except.Local
import Data.Either.Local import Data.Either.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.Actor
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Role 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" -- 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 -- role that supports every operation, we don't need to check role access
return () 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 -- * AP system base types
, RemoteAuthor (..) , RemoteAuthor (..)
, ActivityBody (..) , ActivityBody (..)
, VerseRemote (..) --, VerseRemote (..)
, Verse (..)
-- * Behavior utility types -- * Behavior utility types
, Verse --, Verse
, Event (..) --, Event (..)
, Env (..) , Env (..)
, Act , Act
, ActE , ActE
@ -87,6 +88,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie import Data.Barbie
import Data.Bifunctor
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
@ -290,6 +292,27 @@ data ActivityBody = ActivityBody
, actbActivity :: AP.Activity URIMode , 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 data VerseRemote = VerseRemote
{ verseAuthor :: RemoteAuthor { verseAuthor :: RemoteAuthor
, verseBody :: ActivityBody , verseBody :: ActivityBody
@ -341,6 +364,14 @@ data Event
| EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId | EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId
-- ^ A remote actor asked to Join a local topic, and the local topic is -- ^ 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 -- 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 | EventUnknown
deriving Show deriving Show
@ -356,6 +387,7 @@ instance Message Verse where
refer (Right (VerseRemote author _body _fwd uri)) = refer (Right (VerseRemote author _body _fwd uri)) =
let ObjURI h _ = remoteAuthorURI author let ObjURI h _ = remoteAuthorURI author
in renderObjURI $ ObjURI h uri in renderObjURI $ ObjURI h uri
-}
type YesodRender y = Route y -> [(Text, Text)] -> Text 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 -- This function reads the follower sets and remote recipient data from the
-- PostgreSQL database. Don't use it inside a database transaction. -- PostgreSQL database. Don't use it inside a database transaction.
sendToLocalActors sendToLocalActors
:: Event :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)
-- ^ Event to send to local live actors -- ^ Author of the activity being sent
-> ActivityBody
-- ^ Activity to send
-> Bool -> Bool
-- ^ Whether to deliver to collection only if owner actor is addressed -- ^ Whether to deliver to collection only if owner actor is addressed
-> Maybe (LocalActorBy Key) -> Maybe (LocalActorBy Key)
-- ^ An actor whose collections are excluded from requiring an owner, i.e. -- ^ An actor whose collections are excluded from requiring an owner, i.e.
-- even if owner is required, this actor's collections will be delivered -- 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 -- to, even if this actor isn't addressed. This is meant to be the
-- activity's author. -- activity's sender.
-> Maybe (LocalActorBy Key) -> Maybe (LocalActorBy Key)
-- ^ An actor whose inbox to exclude from delivery, even if this actor is -- ^ 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 -- listed in the recipient set. This is meant to be the activity's
-- author. -- sender.
-> RecipientRoutes -> RecipientRoutes
-> Act [((InstanceId, Host), NonEmpty RemoteRecipient)] -> 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 -- Unhash actor and work item hashids
people <- unhashKeys $ recipPeople recips people <- unhashKeys $ recipPeople recips
@ -608,7 +642,9 @@ sendToLocalActors event requireOwner mauthor maidAuthor recips = do
in case maidAuthor of in case maidAuthor of
Nothing -> s Nothing -> s
Just a -> HS.delete a 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 remote followers, to whom we need to deliver via HTTP
return remoteFollowers return remoteFollowers

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

@ -20,6 +20,7 @@ module Vervis.Actor.Common
, topicAccept , topicAccept
, topicReject , topicReject
, topicInvite , topicInvite
--, topicHandleLocalInvite
, topicJoin , topicJoin
) )
where where
@ -33,6 +34,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifoldable
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -92,13 +94,10 @@ actorFollow
-> (a -> Act [Aud URIMode]) -> (a -> Act [Aud URIMode])
-> UTCTime -> UTCTime
-> Key r -> Key r
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
followee <- nameExceptT "Follow object" $ do followee <- nameExceptT "Follow object" $ do
@ -107,6 +106,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
case routeOrRemote of case routeOrRemote of
Left route -> pure route Left route -> pure route
Right _ -> throwE "Remote, so definitely not me/mine" Right _ -> throwE "Remote, so definitely not me/mine"
-- Verify the followee is me or a subobject of mine
parseFollowee route parseFollowee route
verifyNothingE verifyNothingE
(AP.activityCapability $ actbActivity body) (AP.activityCapability $ actbActivity body)
@ -114,28 +114,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
maybeFollow <- withDBExcept $ do maybeFollow <- withDBExcept $ do
-- Find recipient actor in DB -- Find me in DB
recip <- lift $ getJust recipID recip <- lift $ getJust recipID
let recipActorID = grabActor recip let recipActorID = grabActor recip
recipActor <- lift $ getJust recipActorID recipActor <- lift $ getJust recipActorID
-- Insert the Follow to actor's inbox -- Insert the Follow to my inbox
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread maybeFollowDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) unread
for mractid $ \ followID -> do for maybeFollowDB $ \ followDB -> do
-- Find followee in DB -- Find followee in DB
followerSetID <- getFollowee recipActor followee followerSetID <- getFollowee recipActor followee
-- Verify not already following us -- Verify not already following me
case followDB of
Left (_, followerID, followID) -> do
maybeFollow <- lift $ getBy $ UniqueFollow followerID followerSetID
verifyNothingE maybeFollow "You're already following this object"
Right (author, _, followID) -> do
let followerID = remoteAuthorId author let followerID = remoteAuthorId author
maybeFollow <- maybeFollow <- lift $ getBy $ UniqueRemoteFollow followerID followerSetID
lift $ getBy $ UniqueRemoteFollow followerID followerSetID
verifyNothingE maybeFollow "You're already following this object" verifyNothingE maybeFollow "You're already following this object"
-- Record the new follow in DB -- Record the new follow in DB
acceptID <- acceptID <-
lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now 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 -- Prepare an Accept activity and insert to actor's outbox
accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
@ -143,20 +152,15 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
_luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept
sieve <- lift $ getSieve followee sieve <- lift $ getSieve followee
return (recipActorID, followID, acceptID, sieve, accept) return (recipActorID, acceptID, sieve, accept)
case maybeFollow of case maybeFollow of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do Just (actorID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
lift $ for_ mfwd $ \ (localRecips, sig) -> forwardActivity authorIdMsig body (makeLocalActor recipID) actorID sieve
forwardActivity
(actbBL body) localRecips sig actorID
(makeLocalActor recipID) sieve
(EventRemoteFollowLocalRecipFwdToFollower followID)
lift $ sendActivity lift $ sendActivity
(makeLocalActor recipID) actorID localRecipsAccept (makeLocalActor recipID) actorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID remoteRecipsAccept fwdHostsAccept acceptID actionAccept
EventAcceptRemoteFollow actionAccept
done "Recorded Follow and published Accept" done "Recorded Follow and published Accept"
where where
@ -164,14 +168,8 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
prepareAccept followee = do prepareAccept followee = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
ra <- getJust $ remoteAuthorId author audSender <- makeAudSenderWithFollowers authorIdMsig
uFollow <- lift $ getActivityURI authorIdMsig
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audSender =
AudRemote hAuthor
[luAuthor]
(maybeToList $ remoteActorFollowers ra)
audsRecip <- lift $ makeAudience followee audsRecip <- lift $ makeAudience followee
@ -185,7 +183,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
, AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [] , AP.actionFulfills = []
, AP.actionSpecific = AP.AcceptActivity AP.Accept , AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = ObjURI hAuthor luFollow { AP.acceptObject = uFollow
, AP.acceptResult = Nothing , AP.acceptResult = Nothing
} }
} }
@ -198,13 +196,10 @@ topicAccept
-> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> GrantResourceBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Accept URIMode -> AP.Accept URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
acceptee <- parseAccept accept acceptee <- parseAccept accept
@ -219,7 +214,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient deck from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do (recipActorID, recipActor) <- lift $ do
recip <- getJust recipKey recip <- getJust recipKey
let actorID = topicActor recip let actorID = topicActor recip
@ -263,9 +258,13 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
(getBy $ UniqueCollabRecipRemote collabID) (getBy $ UniqueCollabRecipRemote collabID)
"Found Collab with no recip" "Found Collab with no recip"
"Found Collab with multiple recips" "Found Collab with multiple recips"
case recip of case (recip, authorIdMsig) of
Right (Entity crrid crr) (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
| collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid) | 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" _ -> throwE "Accepting an Invite whose recipient is someone else"
-- If accepting a Join, verify accepter has permission -- 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 case capID of
Left (capActor, _, capItem) -> return (capActor, capItem) Left (capActor, _, capItem) -> return (capActor, capItem)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
verifyCapability verifyCapability'
capability capability
(Right $ remoteAuthorId author) authorIdMsig
(topicResource recipKey) (topicResource recipKey)
return fulfillsID return fulfillsID
@ -285,27 +284,33 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
for mractid $ \ acceptID -> do for maybeAcceptDB $ \ acceptDB -> do
-- Record the Accept on the Collab -- Record the Accept on the Collab
case idsForAccept of case (idsForAccept, acceptDB) of
Left (fulfillsID, recipID) -> do (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
unless (isNothing maybeAccept) $ do unless (isNothing maybeAccept) $
lift $ delete acceptID
throwE "This Invite already has an Accept by recip" throwE "This Invite already has an Accept by recip"
Right fulfillsID -> do (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
unless (isNothing maybeAccept) $ do unless (isJust maybeAccept) $
lift $ delete acceptID 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" 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 -- Prepare forwarding of Accept to my followers
let recipByID = grantResourceLocalActor $ topicResource recipKey let recipByID = grantResourceLocalActor $ topicResource recipKey
recipByHash <- hashLocalActor recipByID recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash] let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
isInvite = isLeft collab
grantInfo <- do 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 -- Prepare a Grant activity and insert to my outbox
let inviterOrJoiner = either snd snd collab let inviterOrJoiner = either snd snd collab
isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- grant@(actionGrant, _, _, _) <-
lift $ prepareGrant isInvite inviterOrJoiner lift $ prepareGrant isInvite inviterOrJoiner
let recipByKey = grantResourceLocalActor $ topicResource recipKey let recipByKey = grantResourceLocalActor $ topicResource recipKey
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
return (grantID, grant) return (grantID, grant)
return (recipActorID, isInvite, acceptID, sieve, grantInfo) return (recipActorID, sieve, grantInfo)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" 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 let recipByID = grantResourceLocalActor $ topicResource recipKey
lift $ for_ mfwd $ \ (localRecips, sig) -> do forwardActivity authorIdMsig body recipByID recipActorID sieve
forwardActivity
(actbBL body) localRecips sig recipActorID recipByID sieve
(if isInvite
then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID
else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID
)
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecipsGrant recipByID recipActorID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID remoteRecipsGrant fwdHostsGrant grantID actionGrant
(EventGrantAfterRemoteAccept grantID) actionGrant
done "Forwarded the Accept and published a Grant" done "Forwarded the Accept and published a Grant"
where where
@ -371,12 +370,15 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
accepter <- getJust $ remoteAuthorId author audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash let topicByHash = grantResourceLocalActor $ topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender senderHash <- bitraverse hashLocalActor pure sender
uAccepter <- lift $ getActorURI authorIdMsig
let audience = let audience =
if isInvite if isInvite
then then
@ -385,9 +387,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
Left actor -> AudLocal [actor] [] Left actor -> AudLocal [actor] []
Right (ObjURI h lu, _followers) -> Right (ObjURI h lu, _followers) ->
AudRemote h [lu] [] AudRemote h [lu] []
audAccepter =
let ObjURI h lu = remoteAuthorURI author
in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
audTopic = AudLocal [] [localActorFollowers topicByHash] audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audInviter, audAccepter, audTopic] in [audInviter, audAccepter, audTopic]
else else
@ -396,9 +395,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
Left actor -> AudLocal [actor] [localActorFollowers actor] Left actor -> AudLocal [actor] [localActorFollowers actor]
Right (ObjURI h lu, followers) -> Right (ObjURI h lu, followers) ->
AudRemote h [lu] (maybeToList followers) AudRemote h [lu] (maybeToList followers)
audApprover =
let ObjURI h lu = remoteAuthorURI author
in AudRemote h [lu] []
audTopic = AudLocal [] [localActorFollowers topicByHash] audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audJoiner, audApprover, audTopic] in [audJoiner, audApprover, audTopic]
@ -417,7 +413,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
encodeRouteLocal $ renderLocalActor topicByHash encodeRouteLocal $ renderLocalActor topicByHash
, AP.grantTarget = , AP.grantTarget =
if isInvite if isInvite
then remoteAuthorURI author then uAccepter
else case senderHash of else case senderHash of
Left actor -> Left actor ->
encodeRouteHome $ renderLocalActor actor encodeRouteHome $ renderLocalActor actor
@ -438,13 +434,10 @@ topicReject
-> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> GrantResourceBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
rejectee <- parseReject reject rejectee <- parseReject reject
@ -459,7 +452,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient deck from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do (recipActorID, recipActor) <- lift $ do
recip <- getJust recipKey recip <- getJust recipKey
let actorID = topicActor recip let actorID = topicActor recip
@ -503,9 +496,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
(getBy $ UniqueCollabRecipRemote collabID) (getBy $ UniqueCollabRecipRemote collabID)
"Found Collab with no recip" "Found Collab with no recip"
"Found Collab with multiple recips" "Found Collab with multiple recips"
case recip of case (recip, authorIdMsig) of
Right (Entity crrid crr) (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
| collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid, deleteInviter) | 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" _ -> throwE "Rejecting an Invite whose recipient is someone else"
-- If rejecting a Join, verify accepter has permission -- 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 case capID of
Left (capActor, _, capItem) -> return (capActor, capItem) Left (capActor, _, capItem) -> return (capActor, capItem)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
verifyCapability verifyCapability'
capability capability
(Right $ remoteAuthorId author) authorIdMsig
(topicResource recipKey) (topicResource recipKey)
return (fulfillsID, deleteRecipJoin, deleteRecip) 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 -- Verify the Collab isn't already accepted/approved
case idsForReject of 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 <- mval <-
lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID
verifyNothingE mval "Invite is already accepted" 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) $ unless (isNothing mval1 && isNothing mval2) $
throwE "Join is already approved" throwE "Join is already approved"
mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
for mractid $ \ rejectID -> do for maybeRejectDB $ \ rejectDB -> do
-- Delete the whole Collab record -- Delete the whole Collab record
case idsForReject of case idsForReject of
Left (fulfillsID, recipID, deleteInviter) -> lift $ do Left (fulfillsID, recipID, deleteInviter) -> lift $ do
delete recipID bitraverse_ delete delete recipID
deleteTopic deleteTopic
deleteInviter deleteInviter
delete fulfillsID delete fulfillsID
@ -558,36 +559,29 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
let recipByID = grantResourceLocalActor $ topicResource recipKey let recipByID = grantResourceLocalActor $ topicResource recipKey
recipByHash <- hashLocalActor recipByID recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash] let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
isInvite = isLeft collab
newRejectInfo <- do newRejectInfo <- do
-- Prepare a Reject activity and insert to my outbox -- Prepare a Reject activity and insert to my outbox
newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
let inviterOrJoiner = either (view _2) (view _2) collab let inviterOrJoiner = either (view _2) (view _2) collab
isInvite = isLeft collab
newReject@(actionReject, _, _, _) <- newReject@(actionReject, _, _, _) <-
lift $ prepareReject isInvite inviterOrJoiner lift $ prepareReject isInvite inviterOrJoiner
let recipByKey = grantResourceLocalActor $ topicResource recipKey let recipByKey = grantResourceLocalActor $ topicResource recipKey
_luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
return (newRejectID, newReject) return (newRejectID, newReject)
return (recipActorID, isInvite, rejectID, sieve, newRejectInfo) return (recipActorID, sieve, newRejectInfo)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" 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 let recipByID = grantResourceLocalActor $ topicResource recipKey
lift $ for_ mfwd $ \ (localRecips, sig) -> do forwardActivity authorIdMsig body recipByID recipActorID sieve
forwardActivity
(actbBL body) localRecips sig recipActorID recipByID sieve
(if isInvite
then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID
else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID
)
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecips recipByID recipActorID localRecips
remoteRecips fwdHosts newRejectID remoteRecips fwdHosts newRejectID action
(EventRejectAfterRemoteReject newRejectID) action
done "Forwarded the Reject and published my own Reject" done "Forwarded the Reject and published my own Reject"
where where
@ -623,12 +617,15 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
rejecter <- getJust $ remoteAuthorId author audRejecter <- makeAudSenderWithFollowers authorIdMsig
audForbidder <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash let topicByHash = grantResourceLocalActor $ topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender senderHash <- bitraverse hashLocalActor pure sender
uReject <- lift $ getActivityURI authorIdMsig
let audience = let audience =
if isInvite if isInvite
then then
@ -637,9 +634,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
Left actor -> AudLocal [actor] [] Left actor -> AudLocal [actor] []
Right (ObjURI h lu, _followers) -> Right (ObjURI h lu, _followers) ->
AudRemote h [lu] [] AudRemote h [lu] []
audRejecter =
let ObjURI h lu = remoteAuthorURI author
in AudRemote h [lu] (maybeToList $ remoteActorFollowers rejecter)
audTopic = AudLocal [] [localActorFollowers topicByHash] audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audInviter, audRejecter, audTopic] in [audInviter, audRejecter, audTopic]
else else
@ -648,9 +642,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
Left actor -> AudLocal [actor] [localActorFollowers actor] Left actor -> AudLocal [actor] [localActorFollowers actor]
Right (ObjURI h lu, followers) -> Right (ObjURI h lu, followers) ->
AudRemote h [lu] (maybeToList followers) AudRemote h [lu] (maybeToList followers)
audForbidder =
let ObjURI h lu = remoteAuthorURI author
in AudRemote h [lu] []
audTopic = AudLocal [] [localActorFollowers topicByHash] audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audJoiner, audForbidder, audTopic] in [audJoiner, audForbidder, audTopic]
@ -662,10 +653,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
{ AP.actionCapability = Nothing { AP.actionCapability = Nothing
, AP.actionSummary = Nothing , AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = , AP.actionFulfills = [uReject]
[ let ObjURI h _ = remoteAuthorURI author
in ObjURI h luReject
]
, AP.actionSpecific = AP.RejectActivity AP.Reject , AP.actionSpecific = AP.RejectActivity AP.Reject
{ AP.rejectObject = AP.rejectObject reject { AP.rejectObject = AP.rejectObject reject
} }
@ -684,13 +672,10 @@ topicInvite
-> (CollabId -> Key topic -> ct) -> (CollabId -> Key topic -> ct)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check capability
capability <- do capability <- do
@ -713,8 +698,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
-- Check invite -- Check invite
targetByKey <- do targetByKey <- do
(resource, recipient) <- let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
parseInvite (Right $ remoteAuthorURI author) invite (resource, recipient) <- parseInvite author invite
unless (Left (topicResource topicKey) == resource) $ unless (Left (topicResource topicKey) == resource) $
throwE "Invite topic isn't me" throwE "Invite topic isn't me"
return recipient return recipient
@ -747,17 +732,14 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab topic from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do (topicActorID, topicActor) <- lift $ do
recip <- getJust topicKey recip <- getJust topicKey
let actorID = grabActor recip let actorID = grabActor recip
(actorID,) <$> getJust actorID (actorID,) <$> getJust actorID
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability verifyCapability' capability authorIdMsig (topicResource topicKey)
capability
(Right $ remoteAuthorId author)
(topicResource topicKey)
-- Verify that target doesn't already have a Collab for me -- Verify that target doesn't already have a Collab for me
existingCollabIDs <- existingCollabIDs <-
@ -785,11 +767,11 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
[_] -> throwE "I already have a Collab for the target" [_] -> throwE "I already have a Collab for the target"
_ -> error "Multiple collabs found for target" _ -> error "Multiple collabs found for target"
mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luInvite False maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for mractid $ \ inviteID -> do lift $ for maybeInviteDB $ \ inviteDB -> do
-- Insert Collab record to DB -- Insert Collab record to DB
insertCollab targetDB inviteID insertCollab targetDB inviteDB
-- Prepare forwarding Invite to my followers -- Prepare forwarding Invite to my followers
sieve <- do sieve <- do
@ -797,24 +779,25 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
let topicByHash = let topicByHash =
grantResourceLocalActor $ topicResource topicHash grantResourceLocalActor $ topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
return (topicActorID, inviteID, sieve) return (topicActorID, sieve)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, inviteID, sieve) -> do Just (topicActorID, sieve) -> do
let topicByID = grantResourceLocalActor $ topicResource topicKey let topicByID = grantResourceLocalActor $ topicResource topicKey
lift $ for_ mfwd $ \ (localRecips, sig) -> do forwardActivity authorIdMsig body topicByID topicActorID sieve
forwardActivity
(actbBL body) localRecips sig topicActorID topicByID sieve
(EventRemoteInviteLocalTopicFwdToFollower inviteID)
done "Recorded and forwarded the Invite" done "Recorded and forwarded the Invite"
where where
insertCollab recipient inviteID = do insertCollab recipient inviteDB = do
collabID <- insert Collab collabID <- insert Collab
fulfillsID <- insert $ CollabFulfillsInvite collabID fulfillsID <- insert $ CollabFulfillsInvite collabID
insert_ $ collabTopicCtor collabID topicKey insert_ $ collabTopicCtor collabID topicKey
case inviteDB of
Left (_, _, inviteID) ->
insert_ $ CollabInviterLocal fulfillsID inviteID
Right (author, _, inviteID) -> do
let authorID = remoteAuthorId author let authorID = remoteAuthorId author
insert_ $ CollabInviterRemote fulfillsID authorID inviteID insert_ $ CollabInviterRemote fulfillsID authorID inviteID
case recipient of case recipient of
@ -834,13 +817,10 @@ topicJoin
-> (CollabId -> Key topic -> ct) -> (CollabId -> Key topic -> ct)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
resource <- parseJoin join resource <- parseJoin join
@ -849,14 +829,26 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab topic from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do (topicActorID, topicActor) <- lift $ do
recip <- getJust topicKey recip <- getJust topicKey
let actorID = grabActor recip let actorID = grabActor recip
(actorID,) <$> getJust actorID (actorID,) <$> getJust actorID
-- Verify that target doesn't already have a Collab for me -- Verify that target doesn't already have a Collab for me
existingCollabIDs <- lift $ do existingCollabIDs <- lift $
case authorIdMsig of
Left (LocalActorPerson personID, _, _) ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
E.on $
topic E.^. topicCollabField E.==.
recipl E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. topicField E.==. E.val topicKey E.&&.
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab
Left (_, _, _) -> pure []
Right (author, _, _) -> do
let targetID = remoteAuthorId author let targetID = remoteAuthorId author
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
E.on $ E.on $
@ -871,36 +863,47 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
[_] -> throwE "I already have a Collab for the target" [_] -> throwE "I already have a Collab for the target"
_ -> error "Multiple collabs found for target" _ -> error "Multiple collabs found for target"
mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luJoin False maybeJoinDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for mractid $ \ joinID -> do for maybeJoinDB $ \ joinDB -> do
-- Insert Collab record to DB -- 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 -- Prepare forwarding Join to my followers
sieve <- do sieve <- lift $ do
topicHash <- encodeKeyHashid topicKey topicHash <- encodeKeyHashid topicKey
let topicByHash = let topicByHash =
grantResourceLocalActor $ topicResource topicHash grantResourceLocalActor $ topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
return (topicActorID, joinID, sieve) return (topicActorID, sieve)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, joinID, sieve) -> do Just (topicActorID, sieve) -> do
let topicByID = grantResourceLocalActor $ topicResource topicKey let topicByID = grantResourceLocalActor $ topicResource topicKey
lift $ for_ mfwd $ \ (localRecips, sig) -> do forwardActivity authorIdMsig body topicByID topicActorID sieve
forwardActivity
(actbBL body) localRecips sig topicActorID topicByID sieve
(EventRemoteJoinLocalTopicFwdToFollower joinID)
done "Recorded and forwarded the Join" done "Recorded and forwarded the Join"
where where
insertCollab joinID = do insertCollab joinDB = do
collabID <- insert Collab collabID <- insert Collab
fulfillsID <- insert $ CollabFulfillsJoin collabID fulfillsID <- insert $ CollabFulfillsJoin collabID
insert_ $ collabTopicCtor collabID topicKey insert_ $ collabTopicCtor collabID topicKey
case joinDB of
Left (personID, joinID) -> do
recipID <- insert $ CollabRecipLocal collabID personID
insert_ $ CollabRecipLocalJoin recipID fulfillsID joinID
Right (author, _, joinID) -> do
let authorID = remoteAuthorId author let authorID = remoteAuthorId author
recipID <- insert $ CollabRecipRemote collabID authorID recipID <- insert $ CollabRecipRemote collabID authorID
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID

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

@ -82,13 +82,10 @@ import Vervis.Ticket
deckFollow deckFollow
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckFollow now recipDeckID author body mfwd luFollow follow = do deckFollow now recipDeckID verse follow = do
recipDeckHash <- encodeKeyHashid recipDeckID recipDeckHash <- encodeKeyHashid recipDeckID
actorFollow actorFollow
(\case (\case
@ -111,13 +108,13 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
(\ _ -> pure $ makeRecipientSet [] []) (\ _ -> pure $ makeRecipientSet [] [])
LocalActorDeck LocalActorDeck
(\ _ -> pure []) (\ _ -> pure [])
now recipDeckID author body mfwd luFollow follow now recipDeckID verse follow
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Access -- Access
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Meaning: A remote actor accepted something -- Meaning: An actor accepted something
-- Behavior: -- Behavior:
-- * If it's on an Invite where I'm the resource: -- * If it's on an Invite where I'm the resource:
-- * Verify the Accept is by the Invite target -- * Verify the Accept is by the Invite target
@ -135,15 +132,12 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
deckAccept deckAccept
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Accept URIMode -> AP.Accept URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckAccept = topicAccept deckActor GrantResourceDeck deckAccept = topicAccept deckActor GrantResourceDeck
-- Meaning: A remote actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
-- * If it's on an Invite where I'm the resource: -- * If it's on an Invite where I'm the resource:
-- * Verify the Reject is by the Invite target -- * Verify the Reject is by the Invite target
@ -163,15 +157,12 @@ deckAccept = topicAccept deckActor GrantResourceDeck
deckReject deckReject
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckReject = topicReject deckActor GrantResourceDeck 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: -- Behavior:
-- * Verify the resource is me -- * Verify the resource is me
-- * Verify A isn't inviting themselves -- * Verify A isn't inviting themselves
@ -182,10 +173,7 @@ deckReject = topicReject deckActor GrantResourceDeck
deckInvite deckInvite
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckInvite = deckInvite =
@ -193,7 +181,7 @@ deckInvite =
deckActor GrantResourceDeck deckActor GrantResourceDeck
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
-- Meaning: A remote actor A asked to join a resource -- Meaning: An actor A asked to join a resource
-- Behavior: -- Behavior:
-- * Verify the resource is me -- * Verify the resource is me
-- * Verify A doesn't already have an invite/join/grant for me -- * Verify A doesn't already have an invite/join/grant for me
@ -202,10 +190,7 @@ deckInvite =
deckJoin deckJoin
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckJoin = deckJoin =
@ -217,7 +202,7 @@ deckJoin =
-- Ambiguous: Following/Resolving -- Ambiguous: Following/Resolving
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Meaning: A remote actor is undoing some previous action -- Meaning: An actor is undoing some previous action
-- Behavior: -- Behavior:
-- * If they're undoing their Following of me, or a ticket of mine: -- * If they're undoing their Following of me, or a ticket of mine:
-- * Record it in my DB -- * Record it in my DB
@ -231,13 +216,10 @@ deckJoin =
deckUndo deckUndo
:: UTCTime :: UTCTime
-> DeckId -> DeckId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Undo URIMode -> AP.Undo URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
undone <- undone <-
@ -255,14 +237,14 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient deck from DB -- Grab me from DB
(deckRecip, actorRecip) <- lift $ do (deckRecip, actorRecip) <- lift $ do
p <- getJust recipDeckID p <- getJust recipDeckID
(p,) <$> getJust (deckActor p) (p,) <$> getJust (deckActor p)
-- Insert the Undo to deck's inbox -- Insert the Undo to my inbox
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
for mractid $ \ undoID -> do for mractid $ \ _undoDB -> do
maybeUndo <- runMaybeT $ do maybeUndo <- runMaybeT $ do
@ -271,7 +253,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
let followers = actorFollowers actorRecip let followers = actorFollowers actorRecip
asum asum
[ tryUnfollow followers undoneDB [ tryUnfollow followers undoneDB authorIdMsig
, tryUnresolve maybeCapability undoneDB , tryUnresolve maybeCapability undoneDB
] ]
@ -285,28 +267,43 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
_luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept _luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept
return (deckActor deckRecip, undoID, sieve, acceptID, accept) return (deckActor deckRecip, sieve, acceptID, accept)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (actorID, undoID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
lift $ for_ mfwd $ \ (localRecips, sig) -> do
forwardActivity forwardActivity
(actbBL body) localRecips sig actorID authorIdMsig body (LocalActorDeck recipDeckID) actorID sieve
(LocalActorDeck recipDeckID) sieve
(EventRemoteUnresolveLocalResourceFwdToFollower undoID)
lift $ sendActivity lift $ sendActivity
(LocalActorDeck recipDeckID) actorID localRecipsAccept (LocalActorDeck recipDeckID) actorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID remoteRecipsAccept fwdHostsAccept acceptID actionAccept
EventAcceptRemoteFollow actionAccept
done done
"Undid the Follow/Resolve, forwarded the Undo and published \ "Undid the Follow/Resolve, forwarded the Undo and published \
\Accept" \Accept"
where where
tryUnfollow _ (Left _) = mzero verifyTargetTicket followerSetID = do
tryUnfollow deckFollowersID (Right remoteActivityID) = 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 <- Entity remoteFollowID remoteFollow <-
MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
let followerID = remoteFollowActor remoteFollow let followerID = remoteFollowActor remoteFollow
@ -315,17 +312,11 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
unless (followerID == remoteAuthorId author) $ unless (followerID == remoteAuthorId author) $
lift $ throwE "You're trying to Undo someone else's Follow" lift $ throwE "You're trying to Undo someone else's Follow"
lift $ lift $ delete remoteFollowID lift $ lift $ delete remoteFollowID
let ObjURI hAuthor luAuthor = remoteAuthorURI author audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
audSenderOnly = AudRemote hAuthor [luAuthor] []
return (makeRecipientSet [] [], [audSenderOnly]) return (makeRecipientSet [] [], [audSenderOnly])
where where
verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID
verifyTargetTicket followerSetID = do tryUnfollow _ _ _ = mzero
ticketID <-
MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
TicketDeck _ d <-
MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
guard $ d == recipDeckID
tryUnresolve maybeCapability undone = do tryUnresolve maybeCapability undone = do
(deleteFromDB, ticketID) <- findTicket undone (deleteFromDB, ticketID) <- findTicket undone
@ -343,22 +334,16 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
Left c -> pure c Left c -> pure c
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
lift $ lift $
verifyCapability verifyCapability'
capability capability
(Right $ remoteAuthorId author) authorIdMsig
(GrantResourceDeck recipDeckID) (GrantResourceDeck recipDeckID)
lift $ lift deleteFromDB lift $ lift deleteFromDB
recipDeckHash <- encodeKeyHashid recipDeckID recipDeckHash <- encodeKeyHashid recipDeckID
taskHash <- encodeKeyHashid taskID taskHash <- encodeKeyHashid taskID
audSender <- lift $ do audSender <- lift $ lift $ makeAudSenderWithFollowers authorIdMsig
ra <- lift $ getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
return $
AudRemote hAuthor
[luAuthor]
(maybeToList $ remoteActorFollowers ra)
return return
( makeRecipientSet ( makeRecipientSet
[] []
@ -399,8 +384,8 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
prepareAccept audience = do prepareAccept audience = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let ObjURI hAuthor _ = remoteAuthorURI author uUndo <- getActivityURI authorIdMsig
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote 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.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [] , AP.actionFulfills = []
, AP.actionSpecific = AP.AcceptActivity AP.Accept , AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = ObjURI hAuthor luUndo { AP.acceptObject = uUndo
, AP.acceptResult = Nothing , AP.acceptResult = Nothing
} }
} }
@ -421,27 +406,15 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
-- Main behavior function -- Main behavior function
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
deckBehavior deckBehavior :: UTCTime -> DeckId -> Verse -> ActE (Text, Act (), Next)
:: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next) deckBehavior now deckID verse@(Verse _authorIdMsig body) =
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)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> AP.AcceptActivity accept -> deckAccept now deckID verse accept
deckAccept now deckID author body mfwd luActivity accept AP.FollowActivity follow -> deckFollow now deckID verse follow
AP.FollowActivity follow -> AP.InviteActivity invite -> deckInvite now deckID verse invite
deckFollow now deckID author body mfwd luActivity follow AP.JoinActivity join -> deckJoin now deckID verse join
AP.InviteActivity invite -> AP.RejectActivity reject -> deckReject now deckID verse reject
deckInvite now deckID author body mfwd luActivity invite AP.UndoActivity undo -> deckUndo now deckID verse undo
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
_ -> throwE "Unsupported activity type for Deck" _ -> throwE "Unsupported activity type for Deck"
instance VervisActor Deck where 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.Persist.Discussion
import Vervis.Ticket import Vervis.Ticket
groupBehavior groupBehavior :: UTCTime -> GroupId -> Verse -> ActE (Text, Act (), Next)
:: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next) groupBehavior now groupID _verse@(Verse _authorIdMsig body) =
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)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
_ -> throwE "Unsupported activity type for Group" _ -> 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.Persist.Discussion
import Vervis.Ticket import Vervis.Ticket
loomBehavior loomBehavior :: UTCTime -> LoomId -> Verse -> ActE (Text, Act (), Next)
:: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next) loomBehavior now loomID _verse@(Verse _authorIdMsig body) =
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)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
_ -> throwE "Unsupported activity type for Loom" _ -> throwE "Unsupported activity type for Loom"

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

@ -36,6 +36,7 @@ import Data.Time.Clock
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
import Optics.Core
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Data.Text as T import qualified Data.Text as T
@ -60,6 +61,7 @@ import Vervis.Cloth
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Data.Discussion import Vervis.Data.Discussion
import Vervis.Data.Follow
import Vervis.FedURI import Vervis.FedURI
import Vervis.Federation.Util import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
@ -68,6 +70,7 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Persist.Follow
import Vervis.Ticket import Vervis.Ticket
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -82,13 +85,10 @@ import Vervis.Ticket
personFollow personFollow
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personFollow now recipPersonID author body mfwd luFollow follow = do personFollow now recipPersonID verse follow = do
recipPersonHash <- encodeKeyHashid recipPersonID recipPersonHash <- encodeKeyHashid recipPersonID
actorFollow actorFollow
(\case (\case
@ -103,9 +103,9 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
(\ () -> pure $ makeRecipientSet [] []) (\ () -> pure $ makeRecipientSet [] [])
LocalActorPerson LocalActorPerson
(\ () -> pure []) (\ () -> 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: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
-- * If they're undoing their Following of me: -- * If they're undoing their Following of me:
@ -114,13 +114,10 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
personUndo personUndo
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Undo URIMode -> AP.Undo URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
undone <- undone <-
@ -129,14 +126,14 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
maybeUndo <- withDBExcept $ do maybeUndo <- withDBExcept $ do
-- Grab recipient person from DB -- Grab me from DB
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
-- Insert the Undo to person's inbox -- Insert the Undo to person's inbox
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
for mractid $ \ undoID -> do for maybeUndoDB $ \ undoDB -> do
maybeUndo <- runMaybeT $ do maybeUndo <- runMaybeT $ do
@ -144,7 +141,7 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
undoneDB <- MaybeT $ getActivity undone undoneDB <- MaybeT $ getActivity undone
let followers = actorFollowers actorRecip let followers = actorFollowers actorRecip
tryUnfollow followers undoneDB tryUnfollow followers undoneDB undoDB
for maybeUndo $ \ () -> do 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 Just (Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept))) -> do
lift $ sendActivity lift $ sendActivity
(LocalActorPerson recipPersonID) actorID localRecipsAccept (LocalActorPerson recipPersonID) actorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID remoteRecipsAccept fwdHostsAccept acceptID actionAccept
EventAcceptRemoteFollow actionAccept
done "Undid the Follow and published Accept" done "Undid the Follow and published Accept"
where where
tryUnfollow _ (Left _) = mzero tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
tryUnfollow personFollowersID (Right remoteActivityID) = do
Entity remoteFollowID remoteFollow <- Entity remoteFollowID remoteFollow <-
MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
let followerID = remoteFollowActor remoteFollow let followerID = remoteFollowActor remoteFollow
@ -177,13 +172,23 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
unless (followerID == remoteAuthorId author) $ unless (followerID == remoteAuthorId author) $
lift $ throwE "You're trying to Undo someone else's Follow" lift $ throwE "You're trying to Undo someone else's Follow"
lift $ lift $ delete remoteFollowID 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 prepareAccept = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let ObjURI hAuthor luAuthor = remoteAuthorURI author audSender <- makeAudSenderOnly authorIdMsig
audSender = AudRemote hAuthor [luAuthor] [] uUndo <- getActivityURI authorIdMsig
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audSender] collectAudience [audSender]
recips = map encodeRouteHome audLocal ++ audRemote 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.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [] , AP.actionFulfills = []
, AP.actionSpecific = AP.AcceptActivity AP.Accept , AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = ObjURI hAuthor luUndo { AP.acceptObject = uUndo
, AP.acceptResult = Nothing , AP.acceptResult = Nothing
} }
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: A remote actor accepted something -- Meaning: An actor accepted something
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
-- * If it's a Follow I sent to them, add to my following list in DB -- * If it's a Follow I sent to them, add to my following list in DB
personAccept personAccept
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Accept URIMode -> AP.Accept URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personAccept now recipPersonID author body _mfwd luAccept accept = do personAccept now recipPersonID (Verse authorIdMsig body) accept = do
-- Check input -- Check input
acceptee <- parseAccept accept acceptee <- parseAccept accept
maybeAccept <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient person from DB -- Grab me from DB
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luAccept True maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
for mractid $ \ acceptID -> runMaybeT $ do for maybeAcceptDB $ \ acceptDB -> runMaybeT $ do
-- Find the accepted activity in our DB -- Find the accepted activity in our DB
accepteeDB <- MaybeT $ getActivity acceptee 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" Nothing -> done "I already have this activity in my inbox"
Just Nothing -> done "Not my Follow; Just inserted to my inbox" Just Nothing -> done "Not my Follow; Just inserted to my inbox"
Just (Just ()) -> Just (Just ()) ->
@ -241,7 +243,7 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
where where
tryFollow actorID (Left (_, _, outboxItemID)) acceptID = do tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
Entity key val <- Entity key val <-
MaybeT $ lift $ MaybeT $ lift $
getBy $ UniqueFollowRemoteRequestActivity outboxItemID getBy $ UniqueFollowRemoteRequestActivity outboxItemID
@ -261,42 +263,55 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
, followRemoteFollow = outboxItemID , followRemoteFollow = outboxItemID
, followRemoteAccept = acceptID , 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 tryFollow _ (Right _) _ = mzero
-- Meaning: A remote actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
-- * If it's a Follow I sent to them, remove record from my DB -- * If it's a Follow I sent to them, remove record from my DB
personReject personReject
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personReject now recipPersonID author body _mfwd luReject reject = do personReject now recipPersonID (Verse authorIdMsig body) reject = do
-- Check input -- Check input
rejectee <- parseReject reject rejectee <- parseReject reject
maybeReject <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient person from DB -- Grab me from DB
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luReject True maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
for mractid $ \ rejectID -> runMaybeT $ do for maybeRejectDB $ \ _rejectDB -> runMaybeT $ do
-- Find the rejected activity in our DB -- Find the rejected activity in our DB
rejecteeDB <- MaybeT $ getActivity rejectee 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" Nothing -> done "I already have this activity in my inbox"
Just Nothing -> done "Not my Follow; Just inserted to my inbox" Just Nothing -> done "Not my Follow; Just inserted to my inbox"
Just (Just ()) -> Just (Just ()) ->
@ -304,7 +319,7 @@ personReject now recipPersonID author body _mfwd luReject reject = do
where where
tryFollow (Left (_, _, outboxItemID)) = do tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do
Entity key val <- Entity key val <-
MaybeT $ lift $ MaybeT $ lift $
getBy $ UniqueFollowRemoteRequestActivity outboxItemID getBy $ UniqueFollowRemoteRequestActivity outboxItemID
@ -316,7 +331,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
unless (remoteAuthorURI author == uRecip) $ unless (remoteAuthorURI author == uRecip) $
lift $ throwE "You're Rejecting a Follow I sent to someone else" lift $ throwE "You're Rejecting a Follow I sent to someone else"
lift $ lift $ delete key 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 -- Commenting
@ -327,18 +351,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
personCreateNote personCreateNote
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Note URIMode -> AP.Note URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personCreateNote now recipPersonID author body mfwd luCreate note = do personCreateNote now recipPersonID (Verse authorIdMsig body) note = do
-- Check input -- Check input
(luNote, published, Comment maybeParent topic source content) <- do (luNote, published, Comment maybeParent topic source content) <- do
(luId, luAuthor, published, comment) <- parseRemoteComment note (luId, luAuthor, published, comment) <- parseRemoteComment note
unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ uCreateAuthor <- lift $ getActorURI authorIdMsig
unless (luAuthor == objUriLocal uCreateAuthor) $
throwE "Create author != note author" throwE "Create author != note author"
return (luId, published, comment) return (luId, published, comment)
@ -352,7 +374,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
Right uContext -> do Right uContext -> do
checkContextParent uContext maybeParent 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 Left (CommentTopicTicket deckID taskID) -> do
(_, _, Entity _ ticket, _, _) <- do (_, _, Entity _ ticket, _, _) <- do
@ -360,7 +382,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
fromMaybeE mticket "Context: No such deck-ticket" fromMaybeE mticket "Context: No such deck-ticket"
let did = ticketDiscuss ticket let did = ticketDiscuss ticket
_ <- traverse (getMessageParent did) maybeParent _ <- 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 Left (CommentTopicCloth loomID clothID) -> do
(_, _, Entity _ ticket, _, _, _) <- do (_, _, Entity _ ticket, _, _, _) <- do
@ -368,7 +390,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
fromMaybeE mticket "Context: No such loom-cloth" fromMaybeE mticket "Context: No such loom-cloth"
let did = ticketDiscuss ticket let did = ticketDiscuss ticket
_ <- traverse (getMessageParent did) maybeParent _ <- traverse (getMessageParent did) maybeParent
lift $ insertToInbox now author body (actorInbox recipActor) luCreate True lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
done $ done $
case mractid of case mractid of
@ -409,56 +431,46 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
personInvite personInvite
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personInvite now recipPersonID author body mfwd luInvite invite = do personInvite now recipPersonID (Verse authorIdMsig body) invite = do
-- Check input -- Check input
recipient <- do recipient <- do
(_resource, target) <- let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
parseInvite (Right $ remoteAuthorURI author) invite (_resource, target) <- parseInvite author invite
return target return target
maybeInvite <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab recipient person from DB -- Grab me from DB
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
for mractid $ \ inviteID -> for maybeInviteDB $ \ _inviteDB ->
return (personActor personRecip, inviteID) return $ personActor personRecip
case maybeInvite of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (actorID, inviteID) -> do Just actorID -> do
let targetIsRecip = let targetIsRecip =
case recipient of case recipient of
Left (GrantRecipPerson p) -> p == recipPersonID Left (GrantRecipPerson p) -> p == recipPersonID
_ -> False _ -> False
if not targetIsRecip if not targetIsRecip
then done "I'm not the target; Inserted to inbox" then done "I'm not the target; Inserted to inbox"
else case mfwd of else do
Nothing ->
done
"I'm the target; Inserted to inbox; \
\Forwarding not approved"
Just (localRecips, sig) -> do
recipHash <- encodeKeyHashid recipPersonID recipHash <- encodeKeyHashid recipPersonID
let sieve = let sieve =
makeRecipientSet makeRecipientSet
[] []
[LocalStagePersonFollowers recipHash] [LocalStagePersonFollowers recipHash]
lift $ forwardActivity forwardActivity
(actbBL body) localRecips sig authorIdMsig body (LocalActorPerson recipPersonID)
actorID actorID sieve
(LocalActorPerson recipPersonID) sieve
(EventRemoteInviteLocalRecipFwdToFollower inviteID)
done done
"I'm the target; Inserted to inbox; \ "I'm the target; Inserted to inbox; \
\Forwarded to followers if addressed" \Forwarded to followers if addressed"
@ -468,285 +480,116 @@ personInvite now recipPersonID author body mfwd luInvite invite = do
personJoin personJoin
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personJoin now recipPersonID author body mfwd luJoin join = do personJoin now recipPersonID (Verse authorIdMsig body) join = do
-- Check input -- Check input
_resource <- parseJoin join _resource <- parseJoin join
maybeJoinID <- lift $ withDB $ do maybeJoinID <- lift $ withDB $ do
-- Grab recipient person from DB -- Grab me from DB
(_personRecip, actorRecip) <- do (_personRecip, actorRecip) <- do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
insertToInbox now author body (actorInbox actorRecip) luJoin True insertToInbox now authorIdMsig body (actorInbox actorRecip) True
case maybeJoinID of case maybeJoinID of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just _joinID -> done "Inserted to my inbox" Just _joinID -> done "Inserted to my inbox"
-- Meaning: A remote actor published a Grant -- Meaning: An actor published a Grant
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
personGrant personGrant
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Grant URIMode -> AP.Grant URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
personGrant now recipPersonID author body mfwd luGrant grant = do personGrant now recipPersonID (Verse authorIdMsig body) grant = do
-- Check input -- Check input
(_remoteResource, recipient) <- do target <- do
let u@(ObjURI h _) = remoteAuthorURI author h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
(resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant (resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant
resourceURI <- case (recip, authorIdMsig) of
case resource of (Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _))
Right r -> return (u, r) | p == p' ->
_ -> error "Remote Grant but parseGrant identified local resource" throwE "Grant sender and target are the same local Person"
when (recip == Right u) $ (Right uRecip, Right (author, _, _))
| uRecip == remoteAuthorURI author ->
throwE "Grant sender and target are the same remote actor" throwE "Grant sender and target are the same remote actor"
return (resourceURI, recip) _ -> pure ()
return recip
maybeGrant <- withDBExcept $ do maybeGrant <- withDBExcept $ do
-- Grab recipient person from DB -- Grab me from DB
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
for mractid $ \ grantID -> for mractid $ \ _grantDB -> return $ personActor personRecip
return (personActor personRecip, grantID)
case maybeGrant of case maybeGrant of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (_actorID, _grantID) -> do Just _actorID -> do
let targetIsRecip = let targetIsRecip =
case recipient of case target of
Left (GrantRecipPerson p) -> p == recipPersonID Left (GrantRecipPerson p) -> p == recipPersonID
_ -> False _ -> False
if not targetIsRecip if not targetIsRecip
then done "I'm not the target; Inserted to inbox" then done "I'm not the target; Inserted to inbox"
else done "I'm 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 -- Behavior: Insert to my inbox
personRevoke personRevoke
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> RemoteAuthor -> Verse
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Revoke URIMode -> AP.Revoke URIMode
-> ActE (Text, Act (), Next) -> 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 maybeRevoke <- lift $ withDB $ do
-- Grab recipient person from DB -- Grab me from DB
(_personRecip, actorRecip) <- do (_personRecip, actorRecip) <- do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
insertToInbox now author body (actorInbox actorRecip) luRevoke True insertToInbox now authorIdMsig body (actorInbox actorRecip) True
case maybeRevoke of case maybeRevoke of
Nothing -> done "I already have this activity in my inbox" 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 -- 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 :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
personBehavior now personID (Left event) = personBehavior now personID verse@(Verse _authorIdMsig body) =
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)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> AP.AcceptActivity accept -> personAccept now personID verse accept
personAccept now personID author body mfwd luActivity accept
AP.CreateActivity (AP.Create obj mtarget) -> AP.CreateActivity (AP.Create obj mtarget) ->
case obj of case obj of
AP.CreateNote _ note -> AP.CreateNote _ note ->
personCreateNote now personID author body mfwd luActivity note personCreateNote now personID verse note
_ -> throwE "Unsupported create object type for people" _ -> throwE "Unsupported create object type for people"
AP.FollowActivity follow -> AP.FollowActivity follow -> personFollow now personID verse follow
personFollow now personID author body mfwd luActivity follow AP.GrantActivity grant -> personGrant now personID verse grant
AP.GrantActivity grant -> AP.InviteActivity invite -> personInvite now personID verse invite
personGrant now personID author body mfwd luActivity grant AP.JoinActivity join -> personJoin now personID verse join
AP.InviteActivity invite -> AP.RejectActivity reject -> personReject now personID verse reject
personInvite now personID author body mfwd luActivity invite AP.RevokeActivity revoke -> personRevoke now personID verse revoke
AP.JoinActivity join -> AP.UndoActivity undo -> personUndo now personID verse undo
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
_ -> throwE "Unsupported activity type for Person" _ -> throwE "Unsupported activity type for Person"
instance VervisActor Person where 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.Persist.Discussion
import Vervis.Ticket import Vervis.Ticket
repoBehavior repoBehavior :: UTCTime -> RepoId -> Verse -> ActE (Text, Act (), Next)
:: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next) repoBehavior now repoID _verse@(Verse _authorIdMsig body) =
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)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
_ -> throwE "Unsupported activity type for Repo" _ -> throwE "Unsupported activity type for Repo"

162
src/Vervis/Actor2.hs
View file

@ -23,6 +23,11 @@ module Vervis.Actor2
( -- * Sending messages to actors ( -- * Sending messages to actors
sendActivity sendActivity
, forwardActivity , forwardActivity
-- * Preparing a new activity
, makeAudSenderOnly
, makeAudSenderWithFollowers
, getActivityURI
, getActorURI
) )
where where
@ -31,10 +36,13 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Barbie import Data.Barbie
import Data.Bifunctor
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Either import Data.Either
import Data.Foldable
import Data.Hashable import Data.Hashable
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock import Data.Time.Clock
import Data.Traversable import Data.Traversable
@ -58,23 +66,16 @@ import Web.Actor.Persist
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Vervis.Actor import Vervis.Actor
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model hiding (Actor, Message) import Vervis.Model hiding (Actor, Message)
import Vervis.Recipient (renderLocalActor, localRecipSieve') import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience')
import Vervis.Settings 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 :: Act (Maybe (Route App, ActorKey))
askLatestInstanceKey = do askLatestInstanceKey = do
maybeTVar <- asksEnv envActorKeys maybeTVar <- asksEnv envActorKeys
@ -173,15 +174,28 @@ sendActivity
-- ^ Instances for which the sender is approving to forward this activity -- ^ Instances for which the sender is approving to forward this activity
-> OutboxItemId -> OutboxItemId
-- ^ DB ID of the item in the author's outbox -- ^ DB ID of the item in the author's outbox
-> Event
-- ^ Event to send to local live actors
-> AP.Action URIMode -> AP.Action URIMode
-- ^ Activity to send to remote actors -- ^ Activity to send to remote actors
-> Act () -> Act ()
sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID action = do
moreRemoteRecips <- moreRemoteRecips <- do
let justSender = Just senderByKey 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 envelope <- do
senderByHash <- hashLocalActor senderByKey senderByHash <- hashLocalActor senderByKey
prepareSendH senderActorID senderByHash itemID action prepareSendH senderActorID senderByHash itemID action
@ -210,20 +224,20 @@ prepareForwardIK
:: (Route App, ActorKey) :: (Route App, ActorKey)
-> LocalActorBy KeyHashid -> LocalActorBy KeyHashid
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> Act (AP.Errand URIMode) -> Act (AP.Errand URIMode)
prepareForwardIK (keyR, akey) fwderByHash body proof = do prepareForwardIK (keyR, akey) fwderByHash body mproof = do
let sign = actorKeySign akey let sign = actorKeySign akey
fwderR = renderLocalActor fwderByHash fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign True fwderR body proof prepareToForward keyR sign True fwderR body mproof
prepareForwardAK prepareForwardAK
:: ActorId :: ActorId
-> LocalActorBy KeyHashid -> LocalActorBy KeyHashid
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> ActDB (AP.Errand URIMode) -> ActDB (AP.Errand URIMode)
prepareForwardAK actorID fwderByHash body proof = do prepareForwardAK actorID fwderByHash body mproof = do
Entity keyID key <- do Entity keyID key <- do
mk <- getBy $ UniqueSigKey actorID mk <- getBy $ UniqueSigKey actorID
case mk of case mk of
@ -233,31 +247,31 @@ prepareForwardAK actorID fwderByHash body proof = do
let keyR = stampRoute fwderByHash keyHash let keyR = stampRoute fwderByHash keyHash
sign = actorKeySign $ sigKeyMaterial key sign = actorKeySign $ sigKeyMaterial key
fwderR = renderLocalActor fwderByHash fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign False fwderR body proof prepareToForward keyR sign False fwderR body mproof
prepareForwardP prepareForwardP
:: ActorId :: ActorId
-> LocalActorBy KeyHashid -> LocalActorBy KeyHashid
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> ActDB (AP.Errand URIMode) -> ActDB (AP.Errand URIMode)
prepareForwardP actorID fwderByHash body proof = do prepareForwardP actorID fwderByHash body mproof = do
maybeKey <- lift askLatestInstanceKey maybeKey <- lift askLatestInstanceKey
case maybeKey of case maybeKey of
Nothing -> prepareForwardAK actorID fwderByHash body proof Nothing -> prepareForwardAK actorID fwderByHash body mproof
Just key -> lift $ prepareForwardIK key fwderByHash body proof Just key -> lift $ prepareForwardIK key fwderByHash body mproof
prepareForwardH prepareForwardH
:: ActorId :: ActorId
-> LocalActorBy KeyHashid -> LocalActorBy KeyHashid
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> Act (AP.Errand URIMode) -> Act (AP.Errand URIMode)
prepareForwardH actorID fwderByHash body proof = do prepareForwardH actorID fwderByHash body mproof = do
maybeKey <- askLatestInstanceKey maybeKey <- askLatestInstanceKey
case maybeKey of case maybeKey of
Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof Nothing -> withDB $ prepareForwardAK actorID fwderByHash body mproof
Just key -> prepareForwardIK key fwderByHash body proof Just key -> prepareForwardIK key fwderByHash body mproof
-- | Given a list of local recipients, which may include actors and -- | Given a list of local recipients, which may include actors and
-- collections, -- collections,
@ -269,26 +283,92 @@ prepareForwardH actorID fwderByHash body proof = do
-- --
-- This function reads remote recipient data and the sender's signing key from -- This function reads remote recipient data and the sender's signing key from
-- the PostgreSQL database. Don't use it inside a database transaction. -- 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 forwardActivity
:: BL.ByteString :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString)
-> RecipientRoutes -> ActivityBody
-> ByteString
-> ActorId
-> LocalActorBy Key -> LocalActorBy Key
-> ActorId
-> RecipientRoutes -> RecipientRoutes
-> Event -> ActE ()
-> Act () forwardActivity sourceMaybeForward body fwderByKey fwderActorID sieve = do
forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = 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 <- remoteRecips <-
let localRecipsFinal = localRecipSieve' sieve False False localRecips let localRecipsFinal = localRecipSieve' sieve False False localRecips
justSender = Just fwderByKey justSender = Just fwderByKey
in sendToLocalActors event False justSender justSender localRecipsFinal authorAndId =
errand <- do second (\ (author, luAct, _sig) -> (author, luAct)) source
in lift $ sendToLocalActors authorAndId body False justSender justSender localRecipsFinal
errand <- lift $ do
fwderByHash <- hashLocalActor fwderByKey fwderByHash <- hashLocalActor fwderByKey
prepareForwardH fwderActorID fwderByHash body sig let msig =
case source of
Left _ -> Nothing
Right (_, _, b) -> Just b
prepareForwardH fwderActorID fwderByHash (actbBL body) msig
let remoteRecipsList = let remoteRecipsList =
concatMap concatMap
(\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs) (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
remoteRecips remoteRecips
dt <- asksEnv stageDeliveryTheater dt <- lift $ asksEnv stageDeliveryTheater
liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList 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 parseInvite
:: StageRoute Env ~ Route App :: StageRoute Env ~ Route App
=> Either PersonId FedURI => Either (LocalActorBy Key) FedURI
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE -> ActE
( Either (GrantResourceBy Key) FedURI ( Either (GrantResourceBy Key) FedURI
@ -144,7 +144,7 @@ parseInvite sender (AP.Invite instrument object target) = do
recipHash recipHash
"Contains invalid hashid" "Contains invalid hashid"
case recipKey of case recipKey of
GrantRecipPerson p | Left p == sender -> GrantRecipPerson p | Left (LocalActorPerson p) == sender ->
throwE "Invite local sender and recipient are the same Person" throwE "Invite local sender and recipient are the same Person"
_ -> return recipKey _ -> return recipKey
) )

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) else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
authenticateActivity authenticateActivity
:: UTCTime :: UTCTime -> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
-- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
-> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
authenticateActivity now = do authenticateActivity now = do
(ra, wv, body) <- do (ra, wv, body) <- do
verifyContentTypeAP_E verifyContentTypeAP_E
-- Compute input for HTTP Signature verification
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
let requires = [hRequestTarget, hHost, hDigest] let requires = [hRequestTarget, hHost, hDigest]
@ -419,6 +419,7 @@ authenticateActivity now = do
toSeconds = toTimeUnit toSeconds = toTimeUnit
in fromIntegral $ toSeconds timeLimit in fromIntegral $ toSeconds timeLimit
prepareToVerifyHttpSig requires wants seconds now prepareToVerifyHttpSig requires wants seconds now
(remoteAuthor, body) <- (remoteAuthor, body) <-
withExceptT T.pack $ withExceptT T.pack $
(,) <$> verifyActorSig proof (,) <$> verifyActorSig proof
@ -429,21 +430,13 @@ authenticateActivity now = do
Right wv -> return wv Right wv -> return wv
return (remoteAuthor, wvdoc, body) return (remoteAuthor, wvdoc, body)
let WithValue raw (Doc hActivity activity) = wv let WithValue raw (Doc hActivity activity) = wv
uSender = remoteAuthorURI ra uSender@(ObjURI hSender luSender) = remoteAuthorURI ra
ObjURI hSender luSender = uSender luAuthor = activityActor activity
auth <- auth <-
if hSender == hActivity case (hSender == hActivity, luSender == luAuthor) of
then do (False, _) -> do
unless (activityActor activity == luSender) $ -- Sender and author are on different hosts, therefore require
throwE $ T.concat -- a valid forwarded signature that approves the forwarding
[ "Activity's actor <"
, renderObjURI $
ObjURI hActivity $ activityActor activity
, "> != Signature key's actor <", renderObjURI uSender
, ">"
]
return $ ActivityAuthRemote ra
else do
ma <- checkForward uSender hActivity (activityActor activity) ma <- checkForward uSender hActivity (activityActor activity)
case ma of case ma of
Nothing -> throwE $ T.concat Nothing -> throwE $ T.concat
@ -452,6 +445,28 @@ authenticateActivity now = do
, renderAuthority hSender, ">" , renderAuthority hSender, ">"
] ]
Just a -> return a 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 -- Verify FEP-8b32 jcs-eddsa-2022 VC data integrity proof
for_ (AP.activityProof activity) $ \ proof -> do for_ (AP.activityProof activity) $ \ proof -> do

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

@ -176,7 +176,8 @@ personCreateNoteF
-> AP.Note URIMode -> AP.Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
personCreateNoteF now recipPersonHash author body mfwd luCreate note = do personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
error "personCreateNoteF disabled for refactoring"
{-
-- Check input -- Check input
recipPersonID <- decodeKeyHashid404 recipPersonHash recipPersonID <- decodeKeyHashid404 recipPersonHash
(luNote, published, Comment maybeParent topic source content) <- do (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" did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
unless (messageRoot m == did) $ unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
-}
deckCreateNoteF deckCreateNoteF
:: UTCTime :: UTCTime
@ -251,7 +253,8 @@ deckCreateNoteF
-> AP.Note URIMode -> AP.Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
error "deckCreateNoteF disabled for refactoring"
{-
recipDeckID <- decodeKeyHashid404 recipDeckHash recipDeckID <- decodeKeyHashid404 recipDeckHash
(luNote, published, Comment maybeParent topic source content) <- do (luNote, published, Comment maybeParent topic source content) <- do
(luId, luAuthor, published, comment) <- parseRemoteCommentOld note (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
@ -309,6 +312,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
Right forwardHttp -> do Right forwardHttp -> do
forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
return "Stored to inbox, cached comment, and did inbox forwarding" return "Stored to inbox, cached comment, and did inbox forwarding"
-}
loomCreateNoteF loomCreateNoteF
:: UTCTime :: UTCTime
@ -320,7 +324,8 @@ loomCreateNoteF
-> AP.Note URIMode -> AP.Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
error "loomCreateNoteF disabled for refactoring"
{-
recipLoomID <- decodeKeyHashid404 recipLoomHash recipLoomID <- decodeKeyHashid404 recipLoomHash
(luNote, published, Comment maybeParent topic source content) <- do (luNote, published, Comment maybeParent topic source content) <- do
(luId, luAuthor, published, comment) <- parseRemoteCommentOld note (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
@ -378,3 +383,4 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
Right forwardHttp -> do Right forwardHttp -> do
forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
return "Stored to inbox, cached comment, and did inbox forwarding" 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 -> AP.Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
error "loomUndoF disabled for refactoring"
{-
-- Check input -- Check input
recipLoomID <- decodeKeyHashid404 recipLoomHash recipLoomID <- decodeKeyHashid404 recipLoomHash
undone <- undone <-
@ -700,6 +701,7 @@ loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-}
repoUndoF repoUndoF
:: UTCTime :: UTCTime
@ -711,7 +713,8 @@ repoUndoF
-> AP.Undo URIMode -> AP.Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
error "repoUndoF disabled for refactoring"
{-
-- Check input -- Check input
recipRepoID <- decodeKeyHashid404 recipRepoHash recipRepoID <- decodeKeyHashid404 recipRepoHash
undone <- undone <-
@ -839,3 +842,4 @@ repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-}

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

@ -335,7 +335,8 @@ deckOfferTicketF
-> FedURI -> FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
error "deckOfferTicketF disabled for refactoring"
{-
-- Check input -- Check input
recipDeckID <- decodeKeyHashid404 recipDeckHash recipDeckID <- decodeKeyHashid404 recipDeckHash
(title, desc, source) <- do (title, desc, source) <- do
@ -474,6 +475,7 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-}
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
@ -492,7 +494,8 @@ loomOfferTicketF
-> FedURI -> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
error "loomOfferTicketF disabled for refactoring"
{-
-- Check input -- Check input
recipLoomID <- decodeKeyHashid404 recipLoomHash recipLoomID <- decodeKeyHashid404 recipLoomHash
(title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do (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) return (action, recipientSet, remoteActors, fwdHosts)
-}
repoOfferTicketF repoOfferTicketF
:: UTCTime :: UTCTime
@ -1130,7 +1134,8 @@ loomApplyF
-> AP.Apply URIMode -> AP.Apply URIMode
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
error "loomApplyF disabled for refactoring"
{-
-- Check input -- Check input
recipLoomID <- decodeKeyHashid404 recipLoomHash recipLoomID <- decodeKeyHashid404 recipLoomHash
(repoID, maybeBranch, clothID, bundleID) <- do (repoID, maybeBranch, clothID, bundleID) <- do
@ -1295,6 +1300,7 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-}
personOfferDepF personOfferDepF
:: UTCTime :: UTCTime
@ -1899,7 +1905,8 @@ trackerResolveF
-> AP.Resolve URIMode -> AP.Resolve URIMode
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> 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 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 -- Check input
recipID <- decodeKeyHashid404 recipHash recipID <- decodeKeyHashid404 recipHash
wiID <- nameExceptT "Resolve object" $ do wiID <- nameExceptT "Resolve object" $ do
@ -2053,6 +2060,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower
} }
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-}
deckResolveF deckResolveF
:: UTCTime :: UTCTime

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

@ -15,12 +15,12 @@
module Vervis.Federation.Util module Vervis.Federation.Util
( insertToInbox ( insertToInbox
, insertToInbox'
) )
where where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.ByteString (ByteString)
import Data.Either import Data.Either
import Data.Time.Clock import Data.Time.Clock
import Database.Persist import Database.Persist
@ -36,30 +36,32 @@ import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model 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. -- database ID if the activity wasn't already in our inbox.
insertToInbox insertToInbox
:: MonadIO m :: UTCTime
=> UTCTime -> Either
-> RemoteAuthor (LocalActorBy Key, ActorId, OutboxItemId)
(RemoteAuthor, LocalURI, Maybe ByteString)
-> ActivityBody -> ActivityBody
-> InboxId -> InboxId
-> LocalURI
-> Bool -> Bool
-> ReaderT SqlBackend m (Maybe RemoteActivityId) -> ActDB
insertToInbox now author body ibid luAct unread = (Maybe
fmap fst <$> insertToInbox' now author body ibid luAct unread (Either
(LocalActorBy Key, ActorId, OutboxItemId)
insertToInbox' (RemoteAuthor, LocalURI, RemoteActivityId)
:: MonadIO m )
=> UTCTime )
-> RemoteAuthor insertToInbox now (Left a@(_, _, outboxItemID)) body inboxID unread = do
-> ActivityBody inboxItemID <- insert $ InboxItem unread now
-> InboxId maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-> LocalURI case maybeItem of
-> Bool Nothing -> do
-> ReaderT SqlBackend m (Maybe (RemoteActivityId, InboxItemId)) delete inboxItemID
insertToInbox' now author body ibid luAct unread = do return Nothing
Just _ -> return $ Just $ Left a
insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
roid <- roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct) either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
@ -69,9 +71,9 @@ insertToInbox' now author body ibid luAct unread = do
, remoteActivityReceived = now , remoteActivityReceived = now
} }
ibiid <- insert $ InboxItem unread now ibiid <- insert $ InboxItem unread now
mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
case mibrid of case mibrid of
Nothing -> do Nothing -> do
delete ibiid delete ibiid
return Nothing 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" , removeField "Ticket" "status"
-- 530 -- 530
, addEntities model_530_join , addEntities model_530_join
-- 531
, addEntities model_531_follow_request
] ]
migrateDB migrateDB

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

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- 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. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -60,6 +61,7 @@ module Vervis.Migration.Entities
, model_497_sigkey , model_497_sigkey
, model_508_invite , model_508_invite
, model_530_join , model_530_join
, model_531_follow_request
) )
where where
@ -235,3 +237,6 @@ model_508_invite = $(schema "508_2022-10-19_invite")
model_530_join :: [Entity SqlBackend] model_530_join :: [Entity SqlBackend]
model_530_join = $(schema "530_2022-11-01_join") 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 (..) , ParsedAudience (..)
, concatRecipients , concatRecipients
, parseAudience , parseAudience
, parseAudience'
-- * Creating a recipient set, supporting both local and remote recips -- * Creating a recipient set, supporting both local and remote recips
, Aud (..) , Aud (..)
@ -93,6 +94,7 @@ module Vervis.Recipient
where where
import Control.Applicative import Control.Applicative
import Control.Concurrent.Actor
import Control.Monad import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
@ -108,6 +110,7 @@ import Data.Semigroup
import Data.Text (Text) import Data.Text (Text)
import Data.These import Data.These
import Data.Traversable import Data.Traversable
import Data.Typeable
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
import GHC.Generics import GHC.Generics
@ -127,6 +130,7 @@ import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import qualified Web.Actor as WA
import Data.List.Local import Data.List.Local
import Data.List.NonEmpty.Local import Data.List.NonEmpty.Local
@ -143,6 +147,15 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model 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 -- Actor and collection-of-actors types
-- --
@ -785,6 +798,48 @@ parseRecipients recips = do
Nothing -> Left route Nothing -> Left route
Just recip -> Right recip 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 parseAudience
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> AP.Audience URIMode => AP.Audience URIMode
@ -811,6 +866,31 @@ parseAudience audience = do
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
groupByHost = groupAllExtract objUriAuthority objUriLocal 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 data Aud u
= AudLocal [LocalActor] [LocalStage] = AudLocal [LocalActor] [LocalStage]
| AudRemote (Authority u) [LocalURI] [LocalURI] | 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 Data.Aeson.Encode.Pretty.ToEncoding as P
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..)) import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.API import Vervis.API
import Vervis.Data.Actor import Vervis.Data.Actor
@ -106,6 +106,7 @@ import Vervis.Foundation
import Vervis.Model hiding (Ticket) import Vervis.Model hiding (Ticket)
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Paginate import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Recipient import Vervis.Recipient
import Vervis.Settings import Vervis.Settings
import Vervis.Ticket import Vervis.Ticket
@ -236,26 +237,27 @@ postInbox recipByKey = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
result <- runExceptT $ do result <- runExceptT $ do
(auth, body) <- authenticateActivity now (auth, body) <- authenticateActivity now
verse <- authorIdMsig <-
case auth of case auth of
ActivityAuthLocal authorByKey -> Left <$> do ActivityAuthLocal authorByKey -> Left <$> do
outboxItemID <- outboxItemID <-
parseAuthenticatedLocalActivityURI parseAuthenticatedLocalActivityURI
authorByKey authorByKey
(AP.activityId $ actbActivity body) (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 ActivityAuthRemote author -> Right <$> do
luActivity <- luActivity <-
fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" 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 recipByHash <- hashLocalActor recipByKey
msig <- checkForwarding recipByHash msig <- checkForwarding recipByHash
let mfwd = (localRecips,) <$> msig return (author, luActivity, msig)
return $ VerseRemote author body mfwd luActivity
theater <- getsYesod appTheater theater <- getsYesod appTheater
r <- liftIO $ callIO theater recipByKey verse r <- liftIO $ callIO theater recipByKey $ Verse authorIdMsig body
case r of case r of
Nothing -> notFound Nothing -> notFound
Just (Left e) -> throwE e 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 Data.Tuple.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.Actor (Event) --import Vervis.Actor
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.FedURI import Vervis.FedURI

40
src/Web/ActivityPub.hs
View file

@ -106,6 +106,7 @@ module Web.ActivityPub
, hForwardedSignature , hForwardedSignature
, Envelope () , Envelope ()
, Errand () , Errand ()
, encodeForwardingSigHeader
, sending , sending
, retrying , retrying
, deliver , deliver
@ -2223,7 +2224,7 @@ httpPostAP manager headers keyid sign uSender value =
data ForwardMode u data ForwardMode u
= SendNoForward = SendNoForward
| SendAllowForward LocalURI | SendAllowForward LocalURI
| ForwardBy (ObjURI u) ByteString | ForwardBy (ObjURI u) (Maybe ByteString)
data Envelope u = Envelope data Envelope u = Envelope
{ envelopeKey :: RefURI u { envelopeKey :: RefURI u
@ -2238,9 +2239,30 @@ data Errand u = Errand
, errandHolder :: Bool , errandHolder :: Bool
, errandFwder :: LocalURI , errandFwder :: LocalURI
, errandBody :: BL.ByteString , 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 -- | Like 'httpPostAP', except it takes the object as a raw lazy
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON. -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
httpPostAPBytes httpPostAPBytes
@ -2276,9 +2298,9 @@ httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uI
except $ first APPostErrorSig $ except $ first APPostErrorSig $
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $ signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req'' consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
ForwardBy uSender sig -> ForwardBy uSender msig ->
return $ return $
consHeader hForwardedSignature sig $ maybe id (consHeader hForwardedSignature) msig $
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender) consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
req'' req''
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
@ -2331,16 +2353,16 @@ forwarding
-> Bool -> Bool
-> ObjURI u -> ObjURI u
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> Errand u -> Errand u
forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig = forwarding lruKey sign holder (ObjURI hFwder luFwder) body msig =
Errand Errand
{ errandKey = RefURI hFwder lruKey { errandKey = RefURI hFwder lruKey
, errandSign = sign , errandSign = sign
, errandHolder = holder , errandHolder = holder
, errandFwder = luFwder , errandFwder = luFwder
, errandBody = body , errandBody = body
, errandProof = sig , errandProof = msig
} }
deliver deliver
@ -2369,7 +2391,7 @@ forward
-> Errand u -> Errand u
-> ObjURI u -> ObjURI u
-> m (Either APPostError (Response ())) -> 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 httpPostAPBytes
manager manager
headers headers
@ -2377,7 +2399,7 @@ forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body s
sign sign
(guard holder >> Just luFwder) (guard holder >> Just luFwder)
body body
(ForwardBy (ObjURI hKey luFwder) sig) (ForwardBy (ObjURI hKey luFwder) msig)
uInbox uInbox
-- | Result of GETing the keyId URI and processing the JSON document. -- | Result of GETing the keyId URI and processing the JSON document.

6
src/Web/Actor.hs
View file

@ -193,11 +193,11 @@ prepareToForward
-> Bool -> Bool
-> StageRoute s -> StageRoute s
-> BL.ByteString -> BL.ByteString
-> ByteString -> Maybe ByteString
-> m (AP.Errand u) -> m (AP.Errand u)
prepareToForward keyR sign holder fwderR body sig = do prepareToForward keyR sign holder fwderR body msig = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
uFwder = encodeRouteHome fwderR 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 Left e -> liftIO $ throwIO e
Right response -> return response Right response -> return response
{-
prepareToForward prepareToForward
:: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u) :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
=> Route site => Route site
@ -178,6 +179,7 @@ prepareToForward keyR sign holder fwderR body sig = do
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
uFwder = encodeRouteHome fwderR uFwder = encodeRouteHome fwderR
return $ AP.forwarding lruKey sign holder uFwder body sig return $ AP.forwarding lruKey sign holder uFwder body sig
-}
forwardActivity forwardActivity
:: ( MonadSite m, SiteEnv m ~ site :: ( MonadSite m, SiteEnv m ~ site

13
th/models
View file

@ -228,11 +228,14 @@ FollowRemote
UniqueFollowRemoteFollow follow UniqueFollowRemoteFollow follow
UniqueFollowRemoteAccept accept UniqueFollowRemoteAccept accept
--FollowRequest FollowRequest
-- person PersonId actor ActorId
-- target FollowerSetId target FollowerSetId
-- public Bool
-- UniqueFollowRequest person target follow OutboxItemId
UniqueFollowRequest actor target
UniqueFollowRequestFollow follow
Follow Follow
actor ActorId actor ActorId