diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index b711dc4..143f2f3 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -485,6 +485,166 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: An actor is asking to close a ticket +-- Behavior: +-- * Verify it's my ticket +-- * Verify the Resolve is authorized +-- * Insert the Resolve to my inbox +-- * Close the ticket in my DB +-- * Forward the Resolve to my followers & ticket followers +-- * Publish an Accept to: +-- - My followers +-- - Ticket's followers +-- - Resolve sender+followers +deckResolve + :: UTCTime + -> DeckId + -> Verse + -> AP.Resolve URIMode + -> ActE (Text, Act (), Next) +deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do + + -- Check input + deckHash <- encodeKeyHashid deckID + taskHash <- nameExceptT "Resolve.object" $ do + route <- do + routeOrRemote <- parseFedURI uObject + case routeOrRemote of + Left route -> pure route + Right _ -> throwE "Remote, so definitely not mine" + case route of + TicketR deckHash' taskHash | deckHash' == deckHash -> + return taskHash + _ -> throwE "Local route but not a ticket of mine" + taskID <- decodeKeyHashidE taskHash "Invalid TicketDeck keyhashid" + + -- 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 "Resolve.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" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (deckRecip, actorRecip) <- lift $ do + d <- getJust deckID + (d,) <$> getJust (deckActor d) + + -- Find ticket in DB, verify it's not resolved + ticketID <- do + maybeTicket <- lift $ getTicket deckID taskID + (_deck, _task, Entity ticketID _, _author, maybeResolve) <- + fromMaybeE maybeTicket "I don't have such a ticket in DB" + unless (isNothing maybeResolve) $ + throwE "Ticket is already resolved" + return ticketID + + -- Insert the Resolve to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for mractid $ \ resolveDB -> do + + -- Verify the sender is authorized by the tracker to resolve a ticket + verifyCapability' + capability + authorIdMsig + (GrantResourceDeck deckID) + AP.RoleTriage + + -- Prepare forwarding the Resolve to my followers & ticket + -- followers + let sieve = + makeRecipientSet [] + [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash + ] + + -- Mark ticket in DB as resolved by the Resolve + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now + lift $ insertResolve ticketID resolveDB acceptID + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- lift $ prepareAccept taskID + let recipByKey = LocalActorDeck deckID + _luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept + + return (deckActor deckRecip, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (deckActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity + authorIdMsig body (LocalActorDeck deckID) deckActorID sieve + lift $ sendActivity + (LocalActorDeck deckID) deckActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Resolved ticket and forwarded the Resolve" + + where + + insertResolve ticketID resolveDB acceptID = do + trid <- insert TicketResolve + { ticketResolveTicket = ticketID + , ticketResolveAccept = acceptID + } + case resolveDB of + Left (_actorByKey, _, resolveID) -> + insert_ TicketResolveLocal + { ticketResolveLocalTicket = trid + , ticketResolveLocalActivity = resolveID + } + Right (author, _, resolveID) -> + insert_ TicketResolveRemote + { ticketResolveRemoteTicket = trid + , ticketResolveRemoteActivity = resolveID + , ticketResolveRemoteActor = remoteAuthorId author + } + + prepareAccept taskID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + audSender <- makeAudSenderWithFollowers authorIdMsig + deckHash <- encodeKeyHashid deckID + taskHash <- encodeKeyHashid taskID + let audDeck = + AudLocal + [] + [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash + ] + uResolve <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audSender, audDeck] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uResolve] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uResolve + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + ------------------------------------------------------------------------------ -- Following ------------------------------------------------------------------------------ @@ -920,6 +1080,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = AP.OfferActivity offer -> deckOffer now deckID verse offer AP.RejectActivity reject -> deckReject now deckID verse reject AP.RemoveActivity remove -> deckRemove now deckID verse remove + AP.ResolveActivity resolve -> deckResolve now deckID verse resolve AP.UndoActivity undo -> deckUndo now deckID verse undo _ -> throwE "Unsupported activity type for Deck" deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck" diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 837515c..5f65c57 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -409,10 +409,171 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: An actor is asking to close a MR +-- Behavior: +-- * Verify it's my MR +-- * Verify the Resolve is authorized +-- * Insert the Resolve to my inbox +-- * Close the MR in my DB +-- * Forward the Resolve to my followers & MR followers +-- * Publish an Accept to: +-- - My followers +-- - MR's followers +-- - Resolve sender+followers +loomResolve + :: UTCTime + -> LoomId + -> Verse + -> AP.Resolve URIMode + -> ActE (Text, Act (), Next) +loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do + + -- Check input + loomHash <- encodeKeyHashid loomID + clothHash <- nameExceptT "Resolve.object" $ do + route <- do + routeOrRemote <- parseFedURI uObject + case routeOrRemote of + Left route -> pure route + Right _ -> throwE "Remote, so definitely not mine" + case route of + ClothR loomHash' clothHash | loomHash' == loomHash -> + return clothHash + _ -> throwE "Local route but not a MR of mine" + clothID <- decodeKeyHashidE clothHash "Invalid TicketLoom keyhashid" + + -- 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 "Resolve.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" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (loomRecip, actorRecip) <- lift $ do + d <- getJust loomID + (d,) <$> getJust (loomActor d) + + -- Find ticket in DB, verify it's not resolved + ticketID <- do + maybeCloth <- lift $ getCloth loomID clothID + (_loom, _cloth, Entity ticketID _, _author, maybeResolve, _merge) <- + fromMaybeE maybeCloth "I don't have such a MR in DB" + unless (isNothing maybeResolve) $ + throwE "MR is already resolved" + return ticketID + + -- Insert the Resolve to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for mractid $ \ resolveDB -> do + + -- Verify the sender is authorized by the tracker to resolve a ticket + verifyCapability' + capability + authorIdMsig + (GrantResourceLoom loomID) + AP.RoleTriage + + -- Prepare forwarding the Resolve to my followers & ticket + -- followers + let sieve = + makeRecipientSet [] + [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + + -- Mark ticket in DB as resolved by the Resolve + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now + lift $ insertResolve ticketID resolveDB acceptID + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- lift $ prepareAccept clothID + let recipByKey = LocalActorLoom loomID + _luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept + + return (loomActor loomRecip, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (loomActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity + authorIdMsig body (LocalActorLoom loomID) loomActorID sieve + lift $ sendActivity + (LocalActorLoom loomID) loomActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Resolved ticket and forwarded the Resolve" + + where + + insertResolve ticketID resolveDB acceptID = do + trid <- insert TicketResolve + { ticketResolveTicket = ticketID + , ticketResolveAccept = acceptID + } + case resolveDB of + Left (_actorByKey, _, resolveID) -> + insert_ TicketResolveLocal + { ticketResolveLocalTicket = trid + , ticketResolveLocalActivity = resolveID + } + Right (author, _, resolveID) -> + insert_ TicketResolveRemote + { ticketResolveRemoteTicket = trid + , ticketResolveRemoteActivity = resolveID + , ticketResolveRemoteActor = remoteAuthorId author + } + + prepareAccept clothID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + audSender <- makeAudSenderWithFollowers authorIdMsig + loomHash <- encodeKeyHashid loomID + clothHash <- encodeKeyHashid clothID + let audLoom = + AudLocal + [] + [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + uResolve <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audSender, audLoom] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uResolve] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uResolve + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next) loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of - AP.OfferActivity offer -> loomOffer now loomID verse offer + AP.OfferActivity offer -> loomOffer now loomID verse offer + AP.ResolveActivity resolve -> loomResolve now loomID verse resolve _ -> throwE "Unsupported activity type for Loom" loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom" diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 7963d6a..f473fbe 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -25,9 +25,6 @@ module Vervis.Federation.Ticket --, deckOfferDepF --, repoOfferDepF - - , deckResolveF - , loomResolveF ) where @@ -1387,251 +1384,3 @@ insertResolve author ltid ractid obiidAccept = do , ticketResolveRemoteActor = remoteAuthorId author } -} - -trackerResolveF - :: ( PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r - , ToBackendKey SqlBackend wi - ) - => (Route App -> Maybe (KeyHashid wi)) - -> (r -> ActorId) - -> ( Key r - -> Key wi - -> ExceptT Text AppDB - ( TicketId - , Maybe - ( Entity TicketResolve - , Either - (Entity TicketResolveLocal) - (Entity TicketResolveRemote) - ) - ) - ) - -> (Key r -> GrantResourceBy Key) - -> (KeyHashid r -> LocalStageBy KeyHashid) - -> (KeyHashid r -> KeyHashid wi -> LocalStageBy KeyHashid) - -> (forall f. f r -> LocalActorBy f) - -> UTCTime - -> KeyHashid r - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Resolve URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do - error "trackerResolveF disabled for refactoring" -{- - -- Check input - recipID <- decodeKeyHashid404 recipHash - wiID <- nameExceptT "Resolve object" $ do - route <- do - routeOrRemote <- parseFedURIOld uObject - case routeOrRemote of - Left route -> pure route - Right _ -> throwE "Remote, so definitely not mine" - case maybeWorkItem route of - Nothing -> throwE "Local route but not a work item of mine" - Just wiHash -> - decodeKeyHashidE wiHash "Invalid work item keyhashid" - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - capID <- do - uCap <- do - fromMaybeE - (activityCapability $ actbActivity body) - "Asking to resolve ticket but no capability provided" - nameExceptT "Resolve capability" $ parseActivityURI uCap - - maybeHttp <- runDBExcept $ do - - -- Find recipient tracker in DB, returning 404 if doesn't exist because - -- we're in the tracker's inbox post handler - recip <- lift $ get404 recipID - let recipActorID = grabActor recip - recipActor <- lift $ getJust recipActorID - - -- Insert the Resolve to tracker's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luResolve False - for mractid $ \ resolveID -> do - - -- Find ticket in DB, verify it's not resolved - ticketID <- do - (ticketID, maybeResolve) <- getWorkItem recipID wiID - unless (isNothing maybeResolve) $ - throwE "Work item is already resolved" - return ticketID - - -- Verify the sender is authorized by the tracker to resolve a ticket - capability <- - case capID of - Left (capActor, _, capItem) -> return (capActor, capItem) - Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker" - verifyCapability - capability - (Right $ remoteAuthorId author) - (makeResource recipID) - - -- Forward the Resolve activity to relevant local stages, and - -- schedule delivery for unavailable remote members of them - maybeHttpFwdResolve <- lift $ for mfwd $ \ (localRecips, sig) -> do - wiHash <- encodeKeyHashid wiID - let sieve = - makeRecipientSet - [] - [ trackerFollowers recipHash - , itemFollowers recipHash wiHash - ] - forwardActivityDB - (actbBL body) localRecips sig recipActorID - (makeLocalActor recipHash) sieve resolveID - - -- Mark ticket in DB as resolved by the Resolve - acceptID <- - lift $ insertEmptyOutboxItem (actorOutbox recipActor) now - lift $ insertResolve ticketID resolveID acceptID - - -- Prepare an Accept activity and insert to tracker's outbox - (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ prepareAccept wiID - _luAccept <- lift $ updateOutboxItem (makeLocalActor recipID) acceptID actionAccept - - -- Deliver the Accept to local recipients, and schedule delivery - -- for unavailable remote recipients - deliverHttpAccept <- - deliverActivityDB - (makeLocalActor recipHash) recipActorID - localRecipsAccept remoteRecipsAccept fwdHostsAccept - acceptID actionAccept - - -- Return instructions for HTTP inbox-forwarding of the Resolve - -- activity, and for HTTP delivery of the Accept activity to - -- remote recipients - return (maybeHttpFwdResolve, deliverHttpAccept) - - -- Launch asynchronous HTTP forwarding of the Resolve activity and HTTP - -- delivery of the Accept activity - case maybeHttp of - Nothing -> - return "I already have this activity in my inbox, doing nothing" - Just (maybeHttpFwdResolve, deliverHttpAccept) -> do - for_ maybeHttpFwdResolve $ - forkWorker "trackerResolveF inbox-forwarding" - forkWorker "trackerResolveF Accept HTTP delivery" deliverHttpAccept - return $ - case maybeHttpFwdResolve of - Nothing -> "Resolved ticket, no inbox-forwarding to do" - Just _ -> - "Resolved ticket and ran inbox-forwarding of the Resolve" - - where - - insertResolve ticketID resolveID acceptID = do - trid <- insert TicketResolve - { ticketResolveTicket = ticketID - , ticketResolveAccept = acceptID - } - insert_ TicketResolveRemote - { ticketResolveRemoteTicket = trid - , ticketResolveRemoteActivity = resolveID - , ticketResolveRemoteActor = remoteAuthorId author - } - - prepareAccept wiID = do - encodeRouteHome <- getEncodeRouteHome - - wiHash <- encodeKeyHashid wiID - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audSender = - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) - audTracker = - AudLocal - [] - [ trackerFollowers recipHash - , itemFollowers recipHash wiHash - ] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audSender, audTracker] - - 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 luResolve - , AP.acceptResult = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) --} - -deckResolveF - :: UTCTime - -> KeyHashid Deck - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Resolve URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckResolveF now deckHash = - trackerResolveF - (\case - TicketR trackerHash taskHash | trackerHash == deckHash -> - Just taskHash - _ -> Nothing - ) - deckActor - (\ deckID taskID -> do - maybeTicket <- lift $ getTicket deckID taskID - (_deck, _task, Entity ticketID _, _author, maybeResolve) <- - fromMaybeE maybeTicket "I don't have such a ticket in DB" - return (ticketID, maybeResolve) - ) - GrantResourceDeck - LocalStageDeckFollowers - LocalStageTicketFollowers - LocalActorDeck - now - deckHash - -loomResolveF - :: UTCTime - -> KeyHashid Loom - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Resolve URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -loomResolveF now loomHash = - trackerResolveF - (\case - ClothR trackerHash clothHash | trackerHash == loomHash -> - Just clothHash - _ -> Nothing - ) - loomActor - (\ loomID clothID -> do - maybeCloth <- lift $ getCloth loomID clothID - (_loom, _cloth, Entity ticketID _, _author, maybeResolve, _merge) <- - fromMaybeE maybeCloth "I don't have such a MR in DB" - return (ticketID, maybeResolve) - ) - GrantResourceLoom - LocalStageLoomFollowers - LocalStageClothFollowers - LocalActorLoom - now - loomHash