diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index bbcf890..10678aa 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -26,6 +26,7 @@ module Vervis.Actor.Common , topicJoin , topicCreateMe , componentGrant + , componentAdd ) where @@ -1887,3 +1888,217 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body } return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: An actor is adding some object to some target +-- Behavior: +-- * If the object is me: +-- * Verify that the object is me +-- * Verify the target is some project's components collection URI +-- * Verify the Add is authorized +-- * For all the Stem records I have for this project: +-- * Verify I'm not yet a member of the project +-- * Verify I haven't already Accepted an our-Add to this project +-- * Verify I haven't already seen an them-Invite-and-Project-accept for +-- this project +-- * Insert the Add to my inbox +-- * Create a Stem record in DB +-- * Forward the Add activity to my followers +-- * Send an Accept on the Add: +-- * To: +-- * The author of the Add +-- * The project +-- * CC: +-- * Author's followers +-- * Project's followers +-- * My followers +componentAdd + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> KomponentId) + -> (forall f. f topic -> ComponentBy f) + -> UTCTime + -> Key topic + -> Verse + -> AP.Add URIMode + -> ActE (Text, Act (), Next) +componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = do + + let meComponent = toComponent meID + meResource = componentResource meComponent + meActor = resourceToActor meResource + + -- Check capability + capability <- do + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- nameExceptT "Add capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + + -- Check input + projectComps <- do + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (component, projectComps, role) <- parseAdd author add + unless (component == Left meActor) $ + throwE "Add object isn't me" + unless (role == AP.RoleAdmin) $ + throwE "Add role isn't admin" + case projectComps of + Left (ATProjectComponents j) -> return $ Left j + Right u -> return $ Right u + _ -> throwE "I'm being added somewhere invalid" + + -- If project is local, find it in our DB + -- If project is remote, HTTP GET it and store in our DB (if it's already + -- there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + projectDB <- + bitraverse + (withDBExcept . flip getEntityE "Project not found in DB") + (\ u@(ObjURI h luComps) -> do + manager <- asksEnv envHttpManager + collection <- + ExceptT $ first T.pack <$> + AP.fetchAPID + manager + (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) + h + luComps + luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context" + project <- + ExceptT $ first T.pack <$> + AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject + unless (AP.projectComponents project == luComps) $ + throwE "The collection isn't the project's components collection" + + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h luProject + case result of + Left Nothing -> throwE "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> do + unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ + throwE "Remote project type isn't Project" + return $ entityKey actor + ) + projectComps + + meHash <- encodeKeyHashid meID + let meComponentHash = toComponent meHash + meResourceHash = componentResource meComponentHash + meActorHash = resourceToActor meResourceHash + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + komponentID <- lift $ grabKomponent <$> getJust meID + Komponent resourceID <- lift $ getJust komponentID + Resource meActorID <- lift $ getJust resourceID + actor <- lift $ getJust meActorID + + -- Find existing Stem records I have for this project + -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept + -- mode + checkExistingStems komponentID projectDB + + -- Verify the specified capability gives relevant access + verifyCapability' capability authorIdMsig meResource AP.RoleAdmin + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Stem record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now + insertStem komponentID projectDB addDB acceptID + + -- Prepare forwarding Add to my followers + let sieve = makeRecipientSet [] [localActorFollowers meActorHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept projectDB + _luAccept <- updateOutboxItem' meActor acceptID actionAccept + + return (meActorID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity authorIdMsig body meActor actorID sieve + lift $ sendActivity + meActor actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept" + + where + + insertStem komponentID projectDB addDB acceptID = do + stemID <- insert $ Stem AP.RoleAdmin komponentID + case projectDB of + Left (Entity projectID _) -> + insert_ $ StemProjectLocal stemID projectID + Right remoteActorID -> + insert_ $ StemProjectRemote stemID remoteActorID + insert_ $ StemOriginAdd stemID + case addDB of + Left (_, _, addID) -> + insert_ $ StemComponentGestureLocal stemID addID + Right (author, _, addID) -> + insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID + insert_ $ StemComponentAccept stemID acceptID + + prepareAccept projectDB = do + encodeRouteHome <- getEncodeRouteHome + + audAdder <- makeAudSenderWithFollowers authorIdMsig + audProject <- + case projectDB of + Left (Entity j _) -> do + jh <- encodeKeyHashid j + return $ + AudLocal + [LocalActorProject jh] + [LocalStageProjectFollowers jh] + Right remoteActorID -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audComponent <- + AudLocal [] . pure . localActorFollowers <$> + hashLocalActor (resourceToActor $ componentResource $ toComponent meID) + uAdd <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAdder, audProject, audComponent] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uAdd] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uAdd + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index c59913b..66d3707 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -105,182 +105,7 @@ deckAdd -> Verse -> AP.Add URIMode -> ActE (Text, Act (), Next) -deckAdd now deckID (Verse authorIdMsig body) add = do - - -- Check capability - capability <- do - - -- Verify that a capability is provided - uCap <- do - let muCap = AP.activityCapability $ actbActivity body - fromMaybeE muCap "No capability provided" - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap - - -- Verify the capability is local - case cap of - Left (actorByKey, _, outboxItemID) -> - return (actorByKey, outboxItemID) - _ -> throwE "Capability is remote i.e. definitely not by me" - - -- Check input - projectComps <- do - let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (component, projectComps, role) <- parseAdd author add - unless (component == Left (LocalActorDeck deckID)) $ - throwE "Add object isn't me" - unless (role == AP.RoleAdmin) $ - throwE "Add role isn't admin" - case projectComps of - Left (ATProjectComponents j) -> return $ Left j - Right u -> return $ Right u - _ -> throwE "I'm being added somewhere invalid" - - -- If project is local, find it in our DB - -- If project is remote, HTTP GET it and store in our DB (if it's already - -- there, no need for HTTP) - -- - -- NOTE: This is a blocking HTTP GET done right here in the handler, - -- which is NOT a good idea. Ideally, it would be done async, and the - -- handler result would be sent later in a separate (e.g. Accept) activity. - -- But for the PoC level, the current situation will hopefully do. - projectDB <- - bitraverse - (withDBExcept . flip getEntityE "Project not found in DB") - (\ u@(ObjURI h luComps) -> do - manager <- asksEnv envHttpManager - collection <- - ExceptT $ first T.pack <$> - AP.fetchAPID - manager - (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) - h - luComps - luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context" - project <- - ExceptT $ first T.pack <$> - AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject - unless (AP.projectComponents project == luComps) $ - throwE "The collection isn't the project's components collection" - - instanceID <- - lift $ withDB $ either entityKey id <$> insertBy' (Instance h) - result <- - ExceptT $ first (T.pack . displayException) <$> - fetchRemoteActor' instanceID h luProject - case result of - Left Nothing -> throwE "Target @id mismatch" - Left (Just err) -> throwE $ T.pack $ displayException err - Right Nothing -> throwE "Target isn't an actor" - Right (Just actor) -> do - unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ - throwE "Remote project type isn't Project" - return $ entityKey actor - ) - projectComps - - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (deck, actor) <- lift $ do - d <- getJust deckID - (d,) <$> getJust (deckActor d) - - -- Find existing Stem records I have for this project - -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept - -- mode - checkExistingStems (deckKomponent deck) projectDB - - -- Verify the specified capability gives relevant access - verifyCapability' - capability authorIdMsig (LocalResourceDeck deckID) AP.RoleAdmin - - -- Insert the Add to my inbox - mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False - lift $ for mractid $ \ (inboxItemID, addDB) -> do - - -- Create a Stem record in DB - acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now - insertStem (deckKomponent deck) projectDB addDB acceptID - - -- Prepare forwarding Add to my followers - sieve <- do - deckHash <- encodeKeyHashid deckID - return $ makeRecipientSet [] [LocalStageDeckFollowers deckHash] - - -- Prepare an Accept activity and insert to my outbox - accept@(actionAccept, _, _, _) <- prepareAccept projectDB - _luAccept <- updateOutboxItem' (LocalActorDeck deckID) acceptID actionAccept - - return (deckActor deck, sieve, acceptID, accept, inboxItemID) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do - forwardActivity - authorIdMsig body (LocalActorDeck deckID) actorID sieve - lift $ sendActivity - (LocalActorDeck deckID) actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID actionAccept - doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept" - - where - - insertStem komponentID projectDB addDB acceptID = do - stemID <- insert $ Stem AP.RoleAdmin komponentID - case projectDB of - Left (Entity projectID _) -> - insert_ $ StemProjectLocal stemID projectID - Right remoteActorID -> - insert_ $ StemProjectRemote stemID remoteActorID - insert_ $ StemOriginAdd stemID - case addDB of - Left (_, _, addID) -> - insert_ $ StemComponentGestureLocal stemID addID - Right (author, _, addID) -> - insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID - insert_ $ StemComponentAccept stemID acceptID - - prepareAccept projectDB = do - encodeRouteHome <- getEncodeRouteHome - - audAdder <- makeAudSenderWithFollowers authorIdMsig - audProject <- - case projectDB of - Left (Entity j _) -> do - jh <- encodeKeyHashid j - return $ - AudLocal - [LocalActorProject jh] - [LocalStageProjectFollowers jh] - Right remoteActorID -> do - ra <- getJust remoteActorID - ObjURI h lu <- getRemoteActorURI ra - return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) - audComponent <- - AudLocal [] . pure . LocalStageDeckFollowers <$> - encodeKeyHashid deckID - uAdd <- lift $ getActivityURI authorIdMsig - - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAdder, audProject, audComponent] - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [uAdd] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = uAdd - , AP.acceptResult = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) +deckAdd = componentAdd deckKomponent ComponentDeck -- Meaning: Someone has created a ticket tracker with my ID URI -- Behavior: