From 9955a3c0ad7f459b1579e1a2fe61c6cb663a9a7c Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 7 Jun 2023 10:15:30 +0300 Subject: [PATCH] Deck: Port/write Accept, Reject, Follow, Undo --- src/Vervis/Actor.hs | 23 ++ src/Vervis/Actor/Common.hs | 669 ++++++++++++++++++++++++++++++++ src/Vervis/Actor/Deck.hs | 339 +++++++++++++++- src/Vervis/Actor/Person.hs | 205 +++++----- src/Vervis/Federation/Collab.hs | 240 +----------- src/Vervis/Federation/Offer.hs | 275 +------------ src/Vervis/Persist/Collab.hs | 20 +- stack.yaml | 3 + vervis.cabal | 2 + 9 files changed, 1148 insertions(+), 628 deletions(-) create mode 100644 src/Vervis/Actor/Common.hs diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index edc69da..0867141 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -306,6 +306,29 @@ data Event | EventAcceptRemoteFollow -- ^ A local actor (that I'm following) has accepted a Follow from some -- remote actor + | EventRemoteUnresolveLocalResourceFwdToFollower RemoteActivityId + -- ^ A remote authorized actor unresolved a local ticket, and the local + -- deck/loom is forwarding to me because I'm following the deck/loom + -- and/or the specific ticket + | EventRemoteAcceptInviteLocalResourceFwdToFollower RemoteActivityId + -- ^ A remote actor accepted an Invite, and the local resource is + -- forwarding the Accept to me because I'm following the resource + | EventRemoteApproveJoinLocalResourceFwdToFollower RemoteActivityId + -- ^ An authorized remote actor approved a Join, and the local resource is + -- forwarding the Accept to me because I'm following the resource + | EventGrantAfterRemoteAccept OutboxItemId + -- ^ A local resource published a Grant, I'm receiving it because I'm + -- following the resource/target, or I'm the inviter/approver/target + | EventRemoteRejectInviteLocalResourceFwdToFollower RemoteActivityId + -- ^ A remote actor rejected an Invite, and the local resource is + -- forwarding the Reject to me because I'm following the resource + | EventRemoteForbidJoinLocalResourceFwdToFollower RemoteActivityId + -- ^ An authorized remote actor rejected a Join, and the local resource is + -- forwarding the Reject to me because I'm following the resource + | EventRejectAfterRemoteReject OutboxItemId + -- ^ A local resource published a Reject on an Invite/Join, I'm receiving + -- it because I'm following the resource/target, or I'm the + -- inviter/rejecter/target | EventUnknown deriving Show diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs new file mode 100644 index 0000000..eb8477e --- /dev/null +++ b/src/Vervis/Actor/Common.hs @@ -0,0 +1,669 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +{-# LANGUAGE RankNTypes #-} + +module Vervis.Actor.Common + ( actorFollow + , topicAccept + , topicReject + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger.CallStack +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Either +import Data.Foldable +import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Database.Persist.Sql +import Optics.Core +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Web.Actor +import Web.Actor.Persist +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Database.Persist.Local + +import Vervis.Access +import Vervis.ActivityPub +import Vervis.Actor +import Vervis.Actor2 +import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) +import Vervis.Persist.Actor +import Vervis.Persist.Collab +import Vervis.Persist.Discussion +import Vervis.Ticket + +actorFollow + :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) + => (Route App -> ActE a) + -> (r -> ActorId) + -> Bool + -> (Actor -> a -> ActDBE FollowerSetId) + -> (a -> ActDB RecipientRoutes) + -> (forall f. f r -> LocalActorBy f) + -> (a -> Act [Aud URIMode]) + -> UTCTime + -> Key r + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Follow URIMode + -> ActE (Text, Act (), Next) +actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do + + -- Check input + followee <- nameExceptT "Follow object" $ do + route <- do + routeOrRemote <- parseFedURI uObject + case routeOrRemote of + Left route -> pure route + Right _ -> throwE "Remote, so definitely not me/mine" + parseFollowee route + verifyNothingE + (AP.activityCapability $ actbActivity body) + "Capability not needed" + + maybeFollow <- withDBExcept $ do + + -- Find recipient actor in DB + recip <- lift $ getJust recipID + let recipActorID = grabActor recip + recipActor <- lift $ getJust recipActorID + + -- Insert the Follow to actor's inbox + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread + for mractid $ \ followID -> do + + -- Find followee in DB + followerSetID <- getFollowee recipActor followee + + -- Verify not already following us + let followerID = remoteAuthorId author + maybeFollow <- + lift $ getBy $ UniqueRemoteFollow followerID followerSetID + verifyNothingE maybeFollow "You're already following this object" + + -- Record the new follow in DB + acceptID <- + lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID + + -- Prepare an Accept activity and insert to actor's outbox + accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ prepareAccept followee + _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept + + sieve <- lift $ getSieve followee + return (recipActorID, followID, acceptID, sieve, accept) + + case maybeFollow of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + lift $ for_ mfwd $ \ (localRecips, sig) -> + forwardActivity + (actbBL body) localRecips sig actorID + (makeLocalActor recipID) sieve + (EventRemoteFollowLocalRecipFwdToFollower followID) + lift $ sendActivity + (makeLocalActor recipID) actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID + EventAcceptRemoteFollow actionAccept + done "Recorded Follow and published Accept" + + where + + prepareAccept followee = do + encodeRouteHome <- getEncodeRouteHome + + ra <- getJust $ remoteAuthorId author + + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audSender = + AudRemote hAuthor + [luAuthor] + (maybeToList $ remoteActorFollowers ra) + + audsRecip <- lift $ makeAudience followee + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ audSender : audsRecip + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hAuthor luFollow + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +topicAccept + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> ActorId) + -> (forall f. f topic -> GrantResourceBy f) + -> UTCTime + -> Key topic + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ActE (Text, Act (), Next) +topicAccept topicActor topicResource now recipKey author body mfwd luAccept accept = do + + -- Check input + acceptee <- parseAccept accept + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCap <- + traverse + (nameExceptT "Accept capability" . parseActivityURI') + (AP.activityCapability $ actbActivity body) + + maybeNew <- withDBExcept $ do + + -- Grab recipient deck from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust recipKey + let actorID = topicActor recip + (actorID,) <$> getJust actorID + + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + + -- See if the accepted activity is an Invite or Join to a local + -- resource, grabbing the Collab record from our DB + collab <- do + maybeCollab <- + lift $ runMaybeT $ + Left <$> tryInvite accepteeDB <|> + Right <$> tryJoin accepteeDB + fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of" + + -- Find the local resource and verify it's me + collabID <- + lift $ case collab of + Left (fulfillsID, _) -> + collabFulfillsInviteCollab <$> getJust fulfillsID + Right (fulfillsID, _) -> + collabFulfillsJoinCollab <$> getJust fulfillsID + topic <- lift $ getCollabTopic collabID + unless (topicResource recipKey == topic) $ + throwE "Accept object is an Invite/Join for some other resource" + + idsForAccept <- + case collab of + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + Left (fulfillsID, _) -> Left <$> do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case recip of + Right (Entity crrid crr) + | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid) + _ -> throwE "Accepting an Invite whose recipient is someone else" + + -- If accepting a Join, verify accepter has permission + Right (fulfillsID, _) -> Right <$> do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability + capability + (Right $ remoteAuthorId author) + (topicResource recipKey) + return fulfillsID + + -- Verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False + for mractid $ \ acceptID -> do + + -- Record the Accept on the Collab + case idsForAccept of + Left (fulfillsID, recipID) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Invite already has an Accept by recip" + Right fulfillsID -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Join already has an Accept" + + -- Prepare forwarding of Accept to my followers + let recipByID = grantResourceLocalActor $ topicResource recipKey + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + isInvite = isLeft collab + + grantInfo <- do + + -- Enable the Collab in our DB + grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ CollabEnable collabID grantID + + -- Prepare a Grant activity and insert to my outbox + let inviterOrJoiner = either snd snd collab + grant@(actionGrant, _, _, _) <- + lift $ prepareGrant isInvite inviterOrJoiner + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + return (recipActorID, isInvite, acceptID, sieve, grantInfo) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, isInvite, acceptID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do + let recipByID = grantResourceLocalActor $ topicResource recipKey + lift $ for_ mfwd $ \ (localRecips, sig) -> do + forwardActivity + (actbBL body) localRecips sig recipActorID recipByID sieve + (if isInvite + then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID + else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID + ) + lift $ sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID + (EventGrantAfterRemoteAccept grantID) actionGrant + done "Forwarded the Accept and published a Grant" + + where + + tryInvite (Left (actorByKey, _actorEntity, itemID)) = + (,Left actorByKey) . collabInviterLocalCollab <$> + MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) + tryInvite (Right remoteActivityID) = do + CollabInviterRemote collab actorID _ <- + MaybeT $ getValBy $ + UniqueCollabInviterRemoteInvite remoteActivityID + actor <- lift $ getJust actorID + sender <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collab, Right sender) + + tryJoin (Left (actorByKey, _actorEntity, itemID)) = + (,Left actorByKey) . collabRecipLocalJoinFulfills <$> + MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) + tryJoin (Right remoteActivityID) = do + CollabRecipRemoteJoin recipID fulfillsID _ <- + MaybeT $ getValBy $ + UniqueCollabRecipRemoteJoinJoin remoteActivityID + remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID + actor <- lift $ getJust remoteActorID + joiner <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (fulfillsID, Right joiner) + + prepareGrant isInvite sender = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + accepter <- getJust $ remoteAuthorId author + recipHash <- encodeKeyHashid recipKey + let topicByHash = grantResourceLocalActor $ topicResource recipHash + + senderHash <- bitraverse hashLocalActor pure sender + + let audience = + if isInvite + then + let audInviter = + case senderHash of + Left actor -> AudLocal [actor] [] + Right (ObjURI h lu, _followers) -> + AudRemote h [lu] [] + audAccepter = + let ObjURI h lu = remoteAuthorURI author + in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audInviter, audAccepter, audTopic] + else + let audJoiner = + case senderHash of + Left actor -> AudLocal [actor] [localActorFollowers actor] + Right (ObjURI h lu, followers) -> + AudRemote h [lu] (maybeToList followers) + audApprover = + let ObjURI h lu = remoteAuthorURI author + in AudRemote h [lu] [] + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audJoiner, audApprover, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [AP.acceptObject accept] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = Left AP.RoleAdmin + , AP.grantContext = + encodeRouteLocal $ renderLocalActor topicByHash + , AP.grantTarget = + if isInvite + then remoteAuthorURI author + else case senderHash of + Left actor -> + encodeRouteHome $ renderLocalActor actor + Right (ObjURI h lu, _) -> ObjURI h lu + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +topicReject + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> ActorId) + -> (forall f. f topic -> GrantResourceBy f) + -> UTCTime + -> Key topic + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Reject URIMode + -> ActE (Text, Act (), Next) +topicReject topicActor topicResource now recipKey author body mfwd luReject reject = do + + -- Check input + rejectee <- parseReject reject + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCap <- + traverse + (nameExceptT "Accept capability" . parseActivityURI') + (AP.activityCapability $ actbActivity body) + + maybeNew <- withDBExcept $ do + + -- Grab recipient deck from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust recipKey + let actorID = topicActor recip + (actorID,) <$> getJust actorID + + -- Find the rejected activity in our DB + rejecteeDB <- do + a <- getActivity rejectee + fromMaybeE a "Can't find rejectee in DB" + + -- See if the rejected activity is an Invite or Join to a local + -- resource, grabbing the Collab record from our DB + collab <- do + maybeCollab <- + lift $ runMaybeT $ + Left <$> tryInvite rejecteeDB <|> + Right <$> tryJoin rejecteeDB + fromMaybeE maybeCollab "Rejected activity isn't an Invite or Join I'm aware of" + + -- Find the local resource and verify it's me + collabID <- + lift $ case collab of + Left (fulfillsID, _, _) -> + collabFulfillsInviteCollab <$> getJust fulfillsID + Right (fulfillsID, _, _, _) -> + collabFulfillsJoinCollab <$> getJust fulfillsID + (deleteTopic, topic) <- lift $ getCollabTopic' collabID + unless (topicResource recipKey == topic) $ + throwE "Accept object is an Invite/Join for some other resource" + + idsForReject <- + case collab of + + -- If rejecting an Invite, find the Collab recipient and verify + -- it's the sender of the Reject + Left (fulfillsID, _, deleteInviter) -> Left <$> do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case recip of + Right (Entity crrid crr) + | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid, deleteInviter) + _ -> throwE "Rejecting an Invite whose recipient is someone else" + + -- If rejecting a Join, verify accepter has permission + Right (fulfillsID, _, deleteRecipJoin, deleteRecip) -> Right <$> do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability + capability + (Right $ remoteAuthorId author) + (topicResource recipKey) + return (fulfillsID, deleteRecipJoin, deleteRecip) + + -- Verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + + -- Verify the Collab isn't already accepted/approved + case idsForReject of + Left (_fulfillsID, recipID, _) -> do + mval <- + lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID + verifyNothingE mval "Invite is already accepted" + Right (fulfillsID, _, _) -> do + mval1 <- lift $ getBy $ UniqueCollabApproverLocal fulfillsID + mval2 <- lift $ getBy $ UniqueCollabApproverRemote fulfillsID + unless (isNothing mval1 && isNothing mval2) $ + throwE "Join is already approved" + + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False + for mractid $ \ rejectID -> do + + -- Delete the whole Collab record + case idsForReject of + Left (fulfillsID, recipID, deleteInviter) -> lift $ do + delete recipID + deleteTopic + deleteInviter + delete fulfillsID + Right (fulfillsID, deleteRecipJoin, deleteRecip) -> lift $ do + deleteRecipJoin + deleteRecip + deleteTopic + delete fulfillsID + lift $ delete collabID + + -- Prepare forwarding of Reject to my followers + let recipByID = grantResourceLocalActor $ topicResource recipKey + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + isInvite = isLeft collab + + newRejectInfo <- do + + -- Prepare a Reject activity and insert to my outbox + newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + let inviterOrJoiner = either (view _2) (view _2) collab + newReject@(actionReject, _, _, _) <- + lift $ prepareReject isInvite inviterOrJoiner + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject + return (newRejectID, newReject) + + return (recipActorID, isInvite, rejectID, sieve, newRejectInfo) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, isInvite, rejectID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do + let recipByID = grantResourceLocalActor $ topicResource recipKey + lift $ for_ mfwd $ \ (localRecips, sig) -> do + forwardActivity + (actbBL body) localRecips sig recipActorID recipByID sieve + (if isInvite + then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID + else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID + ) + lift $ sendActivity + recipByID recipActorID localRecips + remoteRecips fwdHosts newRejectID + (EventRejectAfterRemoteReject newRejectID) action + done "Forwarded the Reject and published my own Reject" + + where + + tryInvite (Left (actorByKey, _actorEntity, itemID)) = do + Entity k (CollabInviterLocal f _) <- + MaybeT $ getBy $ UniqueCollabInviterLocalInvite itemID + return (f, Left actorByKey, delete k) + tryInvite (Right remoteActivityID) = do + Entity k (CollabInviterRemote collab actorID _) <- + MaybeT $ getBy $ + UniqueCollabInviterRemoteInvite remoteActivityID + actor <- lift $ getJust actorID + sender <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collab, Right sender, delete k) + + tryJoin (Left (actorByKey, _actorEntity, itemID)) = do + Entity k (CollabRecipLocalJoin recipID fulfillsID _) <- + MaybeT $ getBy $ UniqueCollabRecipLocalJoinJoin itemID + return (fulfillsID, Left actorByKey, delete k, delete recipID) + tryJoin (Right remoteActivityID) = do + Entity k (CollabRecipRemoteJoin recipID fulfillsID _) <- + MaybeT $ getBy $ + UniqueCollabRecipRemoteJoinJoin remoteActivityID + remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID + actor <- lift $ getJust remoteActorID + joiner <- + lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (fulfillsID, Right joiner, delete k, delete recipID) + + prepareReject isInvite sender = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + rejecter <- getJust $ remoteAuthorId author + recipHash <- encodeKeyHashid recipKey + let topicByHash = grantResourceLocalActor $ topicResource recipHash + + senderHash <- bitraverse hashLocalActor pure sender + + let audience = + if isInvite + then + let audInviter = + case senderHash of + Left actor -> AudLocal [actor] [] + Right (ObjURI h lu, _followers) -> + AudRemote h [lu] [] + audRejecter = + let ObjURI h lu = remoteAuthorURI author + in AudRemote h [lu] (maybeToList $ remoteActorFollowers rejecter) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audInviter, audRejecter, audTopic] + else + let audJoiner = + case senderHash of + Left actor -> AudLocal [actor] [localActorFollowers actor] + Right (ObjURI h lu, followers) -> + AudRemote h [lu] (maybeToList followers) + audForbidder = + let ObjURI h lu = remoteAuthorURI author + in AudRemote h [lu] [] + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audJoiner, audForbidder, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = + [ let ObjURI h _ = remoteAuthorURI author + in ObjURI h luReject + ] + , AP.actionSpecific = AP.RejectActivity AP.Reject + { AP.rejectObject = AP.rejectObject reject + } + } + + return (action, recipientSet, remoteActors, fwdHosts) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index e57f473..9b187a4 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -18,23 +18,32 @@ module Vervis.Actor.Deck ) where +import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Bifunctor +import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.Maybe import Data.Text (Text) import Data.Time.Clock +import Data.Traversable import Database.Persist +import Database.Persist.Sql import Yesod.Persist.Core import qualified Data.Text as T import Control.Concurrent.Actor import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Yesod.MonadSite import qualified Web.ActivityPub as AP @@ -42,23 +51,349 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Database.Persist.Local +import Vervis.Access +import Vervis.ActivityPub import Vervis.Actor +import Vervis.Actor.Common +import Vervis.Actor2 import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +------------------------------------------------------------------------------ +-- Following +------------------------------------------------------------------------------ + +-- Meaning: A remote actor is following someone/something +-- Behavior: +-- * Verify the target is me or a ticket of mine +-- * Record the follow in DB +-- * Publish and send an Accept to the sender and its followers +deckFollow + :: UTCTime + -> DeckId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Follow URIMode + -> ActE (Text, Act (), Next) +deckFollow now recipDeckID author body mfwd luFollow follow = do + recipDeckHash <- encodeKeyHashid recipDeckID + actorFollow + (\case + DeckR d | d == recipDeckHash -> pure Nothing + TicketR d t | d == recipDeckHash -> + Just <$> decodeKeyHashidE t "Invalid task keyhashid" + _ -> throwE "Asking to follow someone else" + ) + deckActor + False + (\ recipDeckActor maybeTaskID -> + case maybeTaskID of + Nothing -> pure $ actorFollowers recipDeckActor + Just taskID -> do + maybeTicket <- lift $ getTicket recipDeckID taskID + (_deck, _task, Entity _ ticket, _author, _resolve) <- + fromMaybeE maybeTicket "I don't have this ticket in DB" + return $ ticketFollowers ticket + ) + (\ _ -> pure $ makeRecipientSet [] []) + LocalActorDeck + (\ _ -> pure []) + now recipDeckID author body mfwd luFollow follow + +------------------------------------------------------------------------------ +-- Access +------------------------------------------------------------------------------ + +-- Meaning: A remote actor accepted something +-- Behavior: +-- * If it's on an Invite where I'm the resource: +-- * Verify the Accept is by the Invite target +-- * Forward the Accept to my followers +-- * Send a Grant: +-- * To: Accepter (i.e. Invite target) +-- * CC: Invite sender, Accepter's followers, my followers +-- * If it's on a Join where I'm the resource: +-- * Verify the Accept is authorized +-- * Forward the Accept to my followers +-- * Send a Grant: +-- * To: Join sender +-- * CC: Accept sender, Join sender's followers, my followers +-- * Otherwise respond with error +deckAccept + :: UTCTime + -> DeckId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ActE (Text, Act (), Next) +deckAccept = topicAccept deckActor GrantResourceDeck + +-- Meaning: A remote actor rejected something +-- Behavior: +-- * If it's on an Invite where I'm the resource: +-- * Verify the Reject is by the Invite target +-- * Remove the relevant Collab record from DB +-- * Forward the Reject to my followers +-- * Send a Reject on the Invite: +-- * To: Rejecter (i.e. Invite target) +-- * CC: Invite sender, Rejecter's followers, my followers +-- * If it's on a Join where I'm the resource: +-- * Verify the Reject is authorized +-- * Remove the relevant Collab record from DB +-- * Forward the Reject to my followers +-- * Send a Reject: +-- * To: Join sender +-- * CC: Reject sender, Join sender's followers, my followers +-- * Otherwise respond with error +deckReject + :: UTCTime + -> DeckId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Reject URIMode + -> ActE (Text, Act (), Next) +deckReject = topicReject deckActor GrantResourceDeck + +------------------------------------------------------------------------------ +-- Ambiguous: Following/Resolving +------------------------------------------------------------------------------ + +-- Meaning: A remote actor is undoing some previous action +-- Behavior: +-- * If they're undoing their Following of me, or a ticket of mine: +-- * Record it in my DB +-- * Publish and send an Accept only to the sender +-- * If they're unresolving a resolved ticket of mine: +-- * Verify they're authorized via a Grant +-- * Record it in my DB +-- * Forward the Undo to my+ticket followers +-- * Send an Accept to sender+followers and to my+ticket followers +-- * Otherwise respond with an error +deckUndo + :: UTCTime + -> DeckId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Undo URIMode + -> ActE (Text, Act (), Next) +deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do + + -- Check input + undone <- + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uObject + + -- Verify the capability URI, if provided, is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCapability <- + for (AP.activityCapability $ actbActivity body) $ \ uCap -> + nameExceptT "Undo capability" $ + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uCap + + maybeNew <- withDBExcept $ do + + -- Grab recipient deck from DB + (deckRecip, actorRecip) <- lift $ do + p <- getJust recipDeckID + (p,) <$> getJust (deckActor p) + + -- Insert the Undo to deck's inbox + mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False + for mractid $ \ undoID -> do + + maybeUndo <- runMaybeT $ do + + -- Find the undone activity in our DB + undoneDB <- MaybeT $ getActivity undone + + let followers = actorFollowers actorRecip + asum + [ tryUnfollow followers undoneDB + , tryUnresolve maybeCapability undoneDB + ] + + (sieve, audience) <- + fromMaybeE + maybeUndo + "Undone activity isn't a Follow or Resolve related to me" + + -- Prepare an Accept activity and insert to deck's outbox + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now + accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience + _luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept + + return (deckActor deckRecip, undoID, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, undoID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + lift $ for_ mfwd $ \ (localRecips, sig) -> do + forwardActivity + (actbBL body) localRecips sig actorID + (LocalActorDeck recipDeckID) sieve + (EventRemoteUnresolveLocalResourceFwdToFollower undoID) + lift $ sendActivity + (LocalActorDeck recipDeckID) actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID + EventAcceptRemoteFollow actionAccept + done + "Undid the Follow/Resolve, forwarded the Undo and published \ + \Accept" + + where + + tryUnfollow _ (Left _) = mzero + tryUnfollow deckFollowersID (Right remoteActivityID) = do + Entity remoteFollowID remoteFollow <- + MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID + let followerID = remoteFollowActor remoteFollow + followerSetID = remoteFollowTarget remoteFollow + verifyTargetMe followerSetID <|> verifyTargetTicket followerSetID + unless (followerID == remoteAuthorId author) $ + lift $ throwE "You're trying to Undo someone else's Follow" + lift $ lift $ delete remoteFollowID + let ObjURI hAuthor luAuthor = remoteAuthorURI author + audSenderOnly = AudRemote hAuthor [luAuthor] [] + return (makeRecipientSet [] [], [audSenderOnly]) + where + verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID + verifyTargetTicket followerSetID = do + ticketID <- + MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID + TicketDeck _ d <- + MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID + guard $ d == recipDeckID + + tryUnresolve maybeCapability undone = do + (deleteFromDB, ticketID) <- findTicket undone + Entity taskID (TicketDeck _ d) <- + MaybeT $ lift $ getBy $ UniqueTicketDeck ticketID + guard $ d == recipDeckID + + -- Verify the sender is authorized by the deck to unresolve a ticket + capability <- lift $ do + cap <- + fromMaybeE + maybeCapability + "Asking to unresolve ticket but no capability provided" + case cap of + Left c -> pure c + Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" + lift $ + verifyCapability + capability + (Right $ remoteAuthorId author) + (GrantResourceDeck recipDeckID) + + lift $ lift deleteFromDB + + recipDeckHash <- encodeKeyHashid recipDeckID + taskHash <- encodeKeyHashid taskID + audSender <- lift $ do + ra <- lift $ getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + return $ + AudRemote hAuthor + [luAuthor] + (maybeToList $ remoteActorFollowers ra) + return + ( makeRecipientSet + [] + [ LocalStageDeckFollowers recipDeckHash + , LocalStageTicketFollowers recipDeckHash taskHash + ] + , [ AudLocal + [] + [ LocalStageDeckFollowers recipDeckHash + , LocalStageTicketFollowers recipDeckHash taskHash + ] + , audSender + ] + ) + where + findTicket (Left (_actorByKey, _actorEntity, itemID)) = do + Entity resolveLocalID resolveLocal <- + MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity itemID + let resolveID = ticketResolveLocalTicket resolveLocal + resolve <- lift $ lift $ getJust resolveID + let ticketID = ticketResolveTicket resolve + return + ( delete resolveLocalID >> delete resolveID + , ticketID + ) + findTicket (Right remoteActivityID) = do + Entity resolveRemoteID resolveRemote <- + MaybeT $ lift $ getBy $ + UniqueTicketResolveRemoteActivity remoteActivityID + let resolveID = ticketResolveRemoteTicket resolveRemote + resolve <- lift $ lift $ getJust resolveID + let ticketID = ticketResolveTicket resolve + return + ( delete resolveRemoteID >> delete resolveID + , ticketID + ) + + prepareAccept audience = do + encodeRouteHome <- getEncodeRouteHome + + let ObjURI hAuthor _ = remoteAuthorURI author + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hAuthor luUndo + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +------------------------------------------------------------------------------ +-- Main behavior function +------------------------------------------------------------------------------ + deckBehavior :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next) -deckBehavior now deckID (Left event) = +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 + AP.AcceptActivity accept -> + deckAccept now deckID author body mfwd luActivity accept + AP.FollowActivity follow -> + deckFollow now deckID author body mfwd luActivity follow + 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" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 84e3ddd..b1b3d8b 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -14,9 +14,6 @@ - . -} --- for actorFollow -{-# LANGUAGE RankNTypes #-} - module Vervis.Actor.Person ( personBehavior ) @@ -57,6 +54,7 @@ import Database.Persist.Local import Vervis.Access import Vervis.ActivityPub import Vervis.Actor +import Vervis.Actor.Common import Vervis.Actor2 import Vervis.Cloth import Vervis.Data.Actor @@ -76,117 +74,6 @@ import Vervis.Ticket -- Following ------------------------------------------------------------------------------ -actorFollow - :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) - => (Route App -> ActE a) - -> (r -> ActorId) - -> Bool - -> (Key r -> Actor -> a -> ActDBE FollowerSetId) - -> (a -> ActDB RecipientRoutes) - -> (forall f. f r -> LocalActorBy f) - -> (a -> Act [Aud URIMode]) - -> UTCTime - -> Key r - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Follow URIMode - -> ActE (Text, Act (), Next) -actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do - - -- Check input - followee <- nameExceptT "Follow object" $ do - route <- do - routeOrRemote <- parseFedURI uObject - case routeOrRemote of - Left route -> pure route - Right _ -> throwE "Remote, so definitely not me/mine" - parseFollowee route - verifyNothingE - (AP.activityCapability $ actbActivity body) - "Capability not needed" - - maybeFollow <- withDBExcept $ do - - -- Find recipient actor in DB - recip <- lift $ getJust recipID - let recipActorID = grabActor recip - recipActor <- lift $ getJust recipActorID - - -- Insert the Follow to actor's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread - for mractid $ \ followID -> do - - -- Find followee in DB - followerSetID <- getFollowee recipID recipActor followee - - -- Verify not already following us - let followerID = remoteAuthorId author - maybeFollow <- - lift $ getBy $ UniqueRemoteFollow followerID followerSetID - verifyNothingE maybeFollow "You're already following this object" - - -- Record the new follow in DB - acceptID <- - lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID - - -- Prepare an Accept activity and insert to actor's outbox - accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ prepareAccept followee - _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept - - sieve <- lift $ getSieve followee - return (recipActorID, followID, acceptID, sieve, accept) - - case maybeFollow of - Nothing -> done "I already have this activity in my inbox" - Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do - lift $ for_ mfwd $ \ (localRecips, sig) -> - forwardActivity - (actbBL body) localRecips sig actorID - (makeLocalActor recipID) sieve - (EventRemoteFollowLocalRecipFwdToFollower followID) - lift $ sendActivity - (makeLocalActor recipID) actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID - EventAcceptRemoteFollow actionAccept - done "Recorded Follow and published Accept" - - where - - prepareAccept followee = do - encodeRouteHome <- getEncodeRouteHome - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audSender = - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) - - audsRecip <- lift $ makeAudience followee - - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience $ audSender : audsRecip - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luFollow - , AP.acceptResult = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - -- Meaning: Someone is following someone -- Behavior: -- * Verify I'm the target @@ -210,7 +97,7 @@ personFollow now recipPersonID author body mfwd luFollow follow = do ) personActor True - (\ _recipPersonID recipPersonActor () -> + (\ recipPersonActor () -> pure $ actorFollowers recipPersonActor ) (\ () -> pure $ makeRecipientSet [] []) @@ -711,7 +598,7 @@ personBehavior now personID (Left event) = itemID <- insert $ InboxItem True now insert_ $ InboxItemRemote inboxID inviteID itemID done "Inserted Invite to inbox" - -- Meaning: A remote actor has forwarded to me a remote activity + -- 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 @@ -724,6 +611,92 @@ personBehavior now personID (Left event) = 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" _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event) personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = case AP.activitySpecific $ actbActivity body of diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index 70c9f9f..b54d460 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -23,9 +23,9 @@ module Vervis.Federation.Collab , deckJoinF , loomJoinF - , repoAcceptF - , deckAcceptF - , loomAcceptF + --, repoAcceptF + --, deckAcceptF + --, loomAcceptF --, personGrantF ) @@ -344,229 +344,7 @@ loomJoinF -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) loomJoinF = topicJoinF loomActor GrantResourceLoom -topicAcceptF - :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) - => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) - -> UTCTime - -> KeyHashid topic - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Accept URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do - error "topicAcceptF temporarily disabled due to actor refactoring" {- - -- Check input - acceptee <- parseAccept accept - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - maybeCap <- - traverse - (nameExceptT "Accept capability" . parseActivityURI) - (AP.activityCapability $ actbActivity body) - - -- Find recipient topic in DB, returning 404 if doesn't exist because - -- we're in the topic's inbox post handler - recipKey <- decodeKeyHashid404 recipHash - mhttp <- runDBExcept $ do - (recipActorID, recipActor) <- lift $ do - recip <- get404 recipKey - let actorID = topicActor recip - (actorID,) <$> getJust actorID - - -- Find the accepted activity in our DB - accepteeDB <- do - a <- getActivity acceptee - fromMaybeE a "Can't find acceptee in DB" - - -- See if the accepted activity is an Invite or Join to a local - -- resource, grabbing the Collab record from our DB - collab <- do - maybeCollab <- - lift $ runMaybeT $ - Left <$> tryInvite accepteeDB <|> - Right <$> tryJoin accepteeDB - fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of" - - -- Find the local resource and verify it's me - collabID <- - lift $ case collab of - Left (fulfillsID, _) -> - collabFulfillsInviteCollab <$> getJust fulfillsID - Right (fulfillsID, _) -> - collabFulfillsJoinCollab <$> getJust fulfillsID - topic <- lift $ getCollabTopic collabID - unless (topicResource recipKey == topic) $ - throwE "Accept object is an Invite for some other resource" - - idsForAccept <- - case collab of - - -- If accepting an Invite, find the Collab recipient and verify - -- it's the sender of the Accept - Left (fulfillsID, _) -> Left <$> do - recip <- - lift $ - requireEitherAlt - (getBy $ UniqueCollabRecipLocal collabID) - (getBy $ UniqueCollabRecipRemote collabID) - "Found Collab with no recip" - "Found Collab with multiple recips" - case recip of - Right (Entity crrid crr) - | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid) - _ -> throwE "Accepting an Invite whose recipient is someone else" - - -- If accepting a Join, verify accepter has permission - Right (fulfillsID, _) -> Right <$> do - capID <- fromMaybeE maybeCap "No capability provided" - capability <- - case capID of - Left (capActor, _, capItem) -> return (capActor, capItem) - Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" - verifyCapability - capability - (Right $ remoteAuthorId author) - (topicResource recipKey) - return fulfillsID - - -- Verify the Collab isn't already validated - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" - - -- Record the Accept on the Collab - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False - for mractid $ \ acceptID -> do - - case idsForAccept of - Left (fulfillsID, recipID) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID - throwE "This Invite already has an Accept by recip" - Right fulfillsID -> do - maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID - throwE "This Join already has an Accept" - - -- Forward the Accept activity to relevant local stages, and - -- schedule delivery for unavailable remote members of them - let recipByHash = grantResourceLocalActor $ topicResource recipHash - maybeHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do - let sieve = - makeRecipientSet [] [localActorFollowers recipByHash] - forwardActivityDB - (actbBL body) localRecips sig recipActorID recipByHash - sieve acceptID - - deliverHttpGrant <- do - - -- Enable the Collab in our DB - grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now - lift $ insert_ $ CollabEnable collabID grantID - - -- Prepare a Grant activity and insert to topic's outbox - let inviterOrJoiner = either snd snd collab - (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- - lift $ prepareGrant inviterOrJoiner - let recipByKey = grantResourceLocalActor $ topicResource recipKey - _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant - - -- Deliver the Grant to local recipients, and schedule delivery - -- for unavailable remote recipients - deliverActivityDB - recipByHash recipActorID localRecipsGrant remoteRecipsGrant - fwdHostsGrant grantID actionGrant - - return (maybeHttpFwdAccept, deliverHttpGrant) - - -- Launch asynchronous HTTP forwarding of the Accept activity - case mhttp of - Nothing -> return "I already have this activity in my inbox, doing nothing" - Just (mhttpFwd, deliverHttpGrant) -> do - forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant - case mhttpFwd of - Nothing -> return "Sent a Grant, no inbox-forwarding to do" - Just forwardHttpAccept -> do - forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept - return "Sent a Grant and ran inbox-forwarding of the Accept" - - where - - tryInvite (Left (actorByKey, _actorEntity, itemID)) = - (,Left actorByKey) . collabInviterLocalCollab <$> - MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) - tryInvite (Right remoteActivityID) = do - CollabInviterRemote collab actorID _ <- - MaybeT $ getValBy $ - UniqueCollabInviterRemoteInvite remoteActivityID - actor <- lift $ getJust actorID - sender <- - lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor - return (collab, Right sender) - - tryJoin (Left (actorByKey, _actorEntity, itemID)) = - (,Left actorByKey) . collabRecipLocalJoinFulfills <$> - MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) - tryJoin (Right remoteActivityID) = do - CollabRecipRemoteJoin recipID fulfillsID _ <- - MaybeT $ getValBy $ - UniqueCollabRecipRemoteJoinJoin remoteActivityID - remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID - actor <- lift $ getJust remoteActorID - joiner <- - lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor - return (fulfillsID, Right joiner) - - prepareGrant sender = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - - accepter <- getJust $ remoteAuthorId author - let topicByHash = grantResourceLocalActor $ topicResource recipHash - - senderHash <- bitraverse hashLocalActor pure sender - - let audSender = - case senderHash of - Left actor -> AudLocal [actor] [localActorFollowers actor] - Right (ObjURI h lu, followers) -> - AudRemote h [lu] (maybeToList followers) - audRecip = - let ObjURI h lu = remoteAuthorURI author - in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter) - audTopic = AudLocal [] [localActorFollowers topicByHash] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audSender, audRecip, audTopic] - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [AP.acceptObject accept] - , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = Left AP.RoleAdmin - , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash - , AP.grantTarget = remoteAuthorURI author - , AP.grantResult = Nothing - , AP.grantStart = Nothing - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Invoke - , AP.grantDelegates = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) --} - repoAcceptF :: UTCTime -> KeyHashid Repo @@ -578,17 +356,6 @@ repoAcceptF -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) repoAcceptF = topicAcceptF repoActor GrantResourceRepo -deckAcceptF - :: UTCTime - -> KeyHashid Deck - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Accept URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckAcceptF = topicAcceptF deckActor GrantResourceDeck - loomAcceptF :: UTCTime -> KeyHashid Loom @@ -599,3 +366,4 @@ loomAcceptF -> AP.Accept URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) loomAcceptF = topicAcceptF loomActor GrantResourceLoom +-} diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 6c23e41..db07f51 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -26,8 +26,8 @@ module Vervis.Federation.Offer --, repoFollowF --personUndoF - deckUndoF - , loomUndoF + --deckUndoF + loomUndoF , repoUndoF ) where @@ -429,66 +429,6 @@ followF -} {- -personFollowF - :: UTCTime - -> KeyHashid Person - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Follow URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -personFollowF now recipPersonHash = - followF - (\case - PersonR p | p == recipPersonHash -> pure () - _ -> throwE "Asking to follow someone else" - ) - personActor - True - (\ _recipPersonID recipPersonActor () -> - pure $ actorFollowers recipPersonActor - ) - (\ () -> pure $ makeRecipientSet [] []) - LocalActorPerson - (\ () -> pure []) - now - recipPersonHash - -deckFollowF - :: UTCTime - -> KeyHashid Deck - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Follow URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckFollowF now recipDeckHash = - followF - (\case - DeckR d | d == recipDeckHash -> pure Nothing - TicketR d t | d == recipDeckHash -> - Just <$> decodeKeyHashidE t "Invalid task keyhashid" - _ -> throwE "Asking to follow someone else" - ) - deckActor - False - (\ recipDeckID recipDeckActor maybeTaskID -> - case maybeTaskID of - Nothing -> pure $ actorFollowers recipDeckActor - Just taskID -> do - maybeTicket <- lift $ getTicket recipDeckID taskID - (_deck, _task, Entity _ ticket, _author, _resolve) <- - fromMaybeE maybeTicket "I don't have this ticket in DB" - return $ ticketFollowers ticket - ) - (\ _ -> pure $ makeRecipientSet [] []) - LocalActorDeck - (\ _ -> pure []) - now - recipDeckHash - loomFollowF :: UTCTime -> KeyHashid Loom @@ -550,217 +490,6 @@ repoFollowF now recipRepoHash = recipRepoHash -} -deckUndoF - :: UTCTime - -> KeyHashid Deck - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Undo URIMode - -> ExceptT Text Handler Text -deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do - - -- Check input - recipDeckID <- decodeKeyHashid404 recipDeckHash - undone <- - first (\ (actor, _, item) -> (actor, item)) <$> - parseActivityURI uObject - - -- Verify the capability URI, if provided, is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - maybeCapability <- - for (AP.activityCapability $ actbActivity body) $ \ uCap -> - nameExceptT "Undo capability" $ - first (\ (actor, _, item) -> (actor, item)) <$> - parseActivityURI uCap - - maybeHttp <- runDBExcept $ do - - -- Find recipient deck in DB, returning 404 if doesn't exist because we're - -- in the deck's inbox post handler - (recipDeckActorID, recipDeckActor) <- lift $ do - deck <- get404 recipDeckID - let actorID = deckActor deck - (actorID,) <$> getJust actorID - - -- Insert the Undo to deck's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luUndo False - for mractid $ \ undoID -> do - - -- Find the undone activity in our DB - undoneDB <- do - a <- getActivity undone - fromMaybeE a "Can't find undone in DB" - - (sieve, acceptAudience) <- do - maybeUndo <- do - let followers = actorFollowers recipDeckActor - lift $ runMaybeT $ - Left <$> tryUnfollow recipDeckID followers undoneDB <|> - Right <$> tryUnresolve recipDeckID undoneDB - undo <- fromMaybeE maybeUndo "Undone activity isn't a Follow or Resolve related to me" - (audSenderOnly, audSenderAndFollowers) <- do - ra <- lift $ getJust $ remoteAuthorId author - let ObjURI hAuthor luAuthor = remoteAuthorURI author - return - ( AudRemote hAuthor [luAuthor] [] - , AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) - ) - case undo of - Left (remoteFollowID, followerID) -> do - unless (followerID == remoteAuthorId author) $ - throwE "Trying to undo someone else's Follow" - lift $ delete remoteFollowID - return - ( makeRecipientSet [] [] - , [audSenderOnly] - ) - Right (deleteFromDB, taskID) -> do - - -- Verify the sender is authorized by the deck to unresolve a ticket - capability <- do - cap <- - fromMaybeE - maybeCapability - "Asking to unresolve ticket but no capability provided" - case cap of - Left c -> pure c - Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" - verifyCapability - capability - (Right $ remoteAuthorId author) - (GrantResourceDeck recipDeckID) - - lift deleteFromDB - - taskHash <- encodeKeyHashid taskID - return - ( makeRecipientSet - [LocalActorDeck recipDeckHash] - [ LocalStageDeckFollowers recipDeckHash - , LocalStageTicketFollowers recipDeckHash taskHash - ] - , [ AudLocal - [] - [ LocalStageDeckFollowers recipDeckHash - , LocalStageTicketFollowers recipDeckHash taskHash - ] - , audSenderAndFollowers - ] - ) - - -- Forward the Undo activity to relevant local stages, and - -- schedule delivery for unavailable remote members of them - maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) -> - forwardActivityDB - (actbBL body) localRecips sig recipDeckActorID - (LocalActorDeck recipDeckHash) sieve undoID - - - -- Prepare an Accept activity and insert to deck's outbox - acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now - (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift . lift $ prepareAccept acceptAudience - _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept - - -- Deliver the Accept to local recipients, and schedule delivery - -- for unavailable remote recipients - deliverHttpAccept <- - deliverActivityDB - (LocalActorDeck recipDeckHash) recipDeckActorID - localRecipsAccept remoteRecipsAccept fwdHostsAccept - acceptID actionAccept - - -- Return instructions for HTTP inbox-forwarding of the Undo - -- activity, and for HTTP delivery of the Accept activity to - -- remote recipients - return (maybeHttpFwdUndo, deliverHttpAccept) - - -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP - -- delivery of the Accept activity - case maybeHttp of - Nothing -> return "I already have this activity in my inbox, doing nothing" - Just (maybeHttpFwdUndo, deliverHttpAccept) -> do - forkWorker "deckUndoF Accept HTTP delivery" deliverHttpAccept - case maybeHttpFwdUndo of - Nothing -> return "Undid, no inbox-forwarding to do" - Just forwardHttpUndo -> do - forkWorker "deckUndoF inbox-forwarding" forwardHttpUndo - return "Undid and ran inbox-forwarding of the Undo" - - where - - tryUnfollow _ _ (Left _) = mzero - tryUnfollow deckID deckFollowersID (Right remoteActivityID) = do - Entity remoteFollowID remoteFollow <- - MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID - let followerID = remoteFollowActor remoteFollow - followerSetID = remoteFollowTarget remoteFollow - if followerSetID == deckFollowersID - then pure () - else do - ticketID <- - MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID - TicketDeck _ d <- - MaybeT $ getValBy $ UniqueTicketDeck ticketID - guard $ d == deckID - return (remoteFollowID, followerID) - - tryUnresolve deckID undone = do - (deleteFromDB, ticketID) <- findTicket undone - Entity taskID (TicketDeck _ d) <- - MaybeT $ getBy $ UniqueTicketDeck ticketID - guard $ d == deckID - return (deleteFromDB, taskID) - where - findTicket (Left (_actorByKey, _actorEntity, itemID)) = do - Entity resolveLocalID resolveLocal <- - MaybeT $ getBy $ UniqueTicketResolveLocalActivity itemID - let resolveID = ticketResolveLocalTicket resolveLocal - resolve <- lift $ getJust resolveID - let ticketID = ticketResolveTicket resolve - return - ( delete resolveLocalID >> delete resolveID - , ticketID - ) - findTicket (Right remoteActivityID) = do - Entity resolveRemoteID resolveRemote <- - MaybeT $ getBy $ - UniqueTicketResolveRemoteActivity remoteActivityID - let resolveID = ticketResolveRemoteTicket resolveRemote - resolve <- lift $ getJust resolveID - let ticketID = ticketResolveTicket resolve - return - ( delete resolveRemoteID >> delete resolveID - , ticketID - ) - - prepareAccept audience = do - encodeRouteHome <- getEncodeRouteHome - - let ObjURI hAuthor _ = remoteAuthorURI author - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience audience - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luUndo - , AP.acceptResult = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - loomUndoF :: UTCTime -> KeyHashid Loom diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 93baa32..bfa4d6f 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,6 +15,7 @@ module Vervis.Persist.Collab ( getCollabTopic + , getCollabTopic' , getGrantRecip , getTopicGrants , getTopicInvites @@ -52,6 +53,23 @@ getCollabTopic collabID = do GrantResourceLoom $ collabTopicLoomLoom l _ -> error "Found Collab with multiple topics" +getCollabTopic' + :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key) +getCollabTopic' collabID = do + maybeRepo <- getBy $ UniqueCollabTopicRepo collabID + maybeDeck <- getBy $ UniqueCollabTopicDeck collabID + maybeLoom <- getBy $ UniqueCollabTopicLoom collabID + return $ + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just (Entity k r), Nothing, Nothing) -> + (delete k, GrantResourceRepo $ collabTopicRepoRepo r) + (Nothing, Just (Entity k d), Nothing) -> + (delete k, GrantResourceDeck $ collabTopicDeckDeck d) + (Nothing, Nothing, Just (Entity k l)) -> + (delete k, GrantResourceLoom $ collabTopicLoomLoom l) + _ -> error "Found Collab with multiple topics" + getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e getTopicGrants diff --git a/stack.yaml b/stack.yaml index 0445528..d117517 100644 --- a/stack.yaml +++ b/stack.yaml @@ -57,6 +57,9 @@ extra-deps: - annotated-exception-0.2.0.4 - retry-0.9.3.1 - base58-bytestring-0.1.0 + - indexed-profunctors-0.1.1 + - indexed-traversable-0.1.2.1 + - optics-core-0.4.1 # Override default flag values for local packages and extra-deps flags: diff --git a/vervis.cabal b/vervis.cabal index 886d838..5f5748c 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -143,6 +143,7 @@ library Vervis.ActivityPub Vervis.Actor Vervis.Actor2 + Vervis.Actor.Common Vervis.Actor.Deck Vervis.Actor.Group Vervis.Actor.Loom @@ -383,6 +384,7 @@ library , mtl , network , network-uri + , optics-core , pandoc , pandoc-types -- for PathPiece instance for CI, Web.PathPieces.Local