diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 9797f9a..50321c9 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -25,12 +25,12 @@ module Vervis.API , createPatchTrackerC , createRepositoryC , createTicketTrackerC - --, followC + , followC , inviteC , offerTicketC --, offerDepC - --, resolveC - --, undoC + , resolveC + , undoC --, pushCommitsC ) where @@ -102,6 +102,7 @@ import Vervis.Darcs import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Discussion +import Vervis.Data.Follow import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Fetch @@ -116,13 +117,13 @@ import Vervis.Path import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion +import Vervis.Persist.Follow import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Query import Vervis.Ticket -import Vervis.WorkItem import Vervis.Web.Delivery import Vervis.Web.Repo @@ -1666,16 +1667,6 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] -{- -data Followee - = FolloweePerson (KeyHashid Person) - | FolloweeGroup (KeyHashid Group) - | FolloweeRepo (KeyHashid Repo) - | FolloweeDeck (KeyHashid Deck) - | FolloweeLoom (KeyHashid Loom) - | FolloweeTicket (KeyHashid Deck) (KeyHashid TicketDeck) - | FolloweeCloth (KeyHashid Loom) (KeyHashid TicketLoom) - followC :: Entity Person -> Actor @@ -1690,158 +1681,130 @@ followC -> AP.Action URIMode -> AP.Follow URIMode -> ExceptT Text Handler OutboxItemId -followC (Entity pidSender personSender) _senderActor maybeCap localRecips remoteRecips fwdHosts action follow@(AP.Follow uObject muContext hide) = do +followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action follow = do + + -- Check input verifyNothingE maybeCap "Capability not needed" + (followee, hide) <- parseFollow follow + case followee of + Left (FolloweeActor (LocalActorPerson personID)) + | personID == senderPersonID -> + throwE "Trying to follow yourself" + _ -> pure () + + -- Verify that followee's actor is addressed + case followee of + Left f -> do + actorByHash <- hashLocalActor $ followeeActor f + unless (actorIsAddressed localRecips actorByHash) $ + throwE "Followee's actor not addressed by the Follow" + Right (h, luActor, luObject) -> + verifyRemoteAddressed remoteRecips $ ObjURI h luActor + now <- liftIO getCurrentTime - senderHash <- encodeKeyHashid pidSender - mfollowee <- do - let ObjURI h luObject = uObject - local <- hostIsLocal h - if local - then Just <$> do - route <- - fromMaybeE - (decodeRouteLocal luObject) - "Follow object isn't a valid route" - followee <- - fromMaybeE - (parseFollowee route) - "Follow object isn't a followee route" - let actor = followeeActor followee - unless (actorRecips actor == localRecips) $ - throwE "Follow object isn't the recipient" - case followee of - FolloweePerson p | p == senderHash -> - throwE "User trying to follow themselves" - _ -> return () - return (followee, actor) - else do - unless (localRecips == RecipientRoutes [] [] [] [] []) $ - throwE "Follow object is remote but local recips listed" - return Nothing - (obiidFollow, doc, remotesHttp) <- runDBExcept $ do - let actorSenderID = personActor personSender - actorSender <- lift $ getJust actorSenderID - let ibidSender = actorInbox actorSender - obidSender = actorOutbox actorSender - obiidFollow <- lift $ insertEmptyOutboxItem obidSender now - luFollow <- lift $ updateOutboxItem (LocalActorPerson pidSender) obiidFollow action - case mfollowee of - Nothing -> lift $ insert_ $ FollowRemoteRequest pidSender uObject muContext (not hide) obiidFollow - Just (followee, actorRecip) -> do - (actorRecipID, mfsid, unread) <- getFollowee followee - actorRecipDB <- lift $ getJust actorRecipID - let obidRecip = actorOutbox actorRecipDB - obiidAccept <- lift $ insertAcceptToOutbox senderHash luFollow actorRecip obidRecip - let ibidRecip = actorInbox actorRecipDB - fsid = fromMaybe (actorFollowers actorRecipDB) mfsid - deliverFollowLocal now actorSenderID fsid unread obiidFollow obiidAccept ibidRecip - lift $ deliverAcceptLocal now obiidAccept ibidSender - remotesHttp <- lift $ deliverRemoteDB fwdHosts obiidFollow remoteRecips [] - return (obiidFollow, doc, remotesHttp) - lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp - return obiidFollow + senderHash <- encodeKeyHashid senderPersonID + + (followID, deliverHttpFollow, maybeDeliverHttpAccept) <- runDBExcept $ do + + -- If followee is local, find it in our DB + followeeDB <- bitraverse getFollowee pure followee + + -- Insert Follow activity to author's outbox + followID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + luFollow <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) followID action + + -- Deliver the Follow activity to local recipients, and schedule + -- delivery for unavailable remote recipients + deliverHttpFollow <- do + sieve <- do + (actors, stages) <- + case followeeDB of + Left (actorByKey, _, _) -> do + actorByHash <- hashLocalActor actorByKey + return + ( [actorByHash] + , [localActorFollowers actorByHash] + ) + Right _ -> pure ([], []) + let stages' = LocalStagePersonFollowers senderHash : stages + return $ makeRecipientSet actors stages' + let localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts followID action + + maybeDeliverHttpAccept <- + case followeeDB of + Right (h, luActor, luObject) -> lift $ do + + -- For remote followee, just remember the request in our DB + let uObject = ObjURI h luObject + muContext = + if luActor == luObject + then Nothing + else Just $ ObjURI h luActor + insert_ $ FollowRemoteRequest senderPersonID uObject muContext (not hide) followID + return Nothing + + Left (actorByKey, actorID, maybeFollowerSetID) -> Just <$> do + + -- Verify followee's actor has received the Accept + verifyActorHasItem actorID followID "Followee's actor didn't receive the Follow" + + -- Insert an Accept activity to followee's outbox + actor <- lift $ getJust actorID + acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now + let acceptActors = [LocalActorPerson senderHash] + acceptStages = [] + actionAccept <- prepareAccept luFollow acceptActors acceptStages + _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept + + -- Insert author to followee's followers collection + let fsid = + fromMaybe (actorFollowers actor) maybeFollowerSetID + mfid <- + lift $ insertUnique $ + Follow (personActor senderPerson) fsid (not hide) followID acceptID + _ <- fromMaybeE mfid "Already following this object" + + -- Deliver the Accept activity to local recipients, and + -- schedule delivery for unavailable remote recipients + let localRecipsAccept = makeRecipientSet acceptActors acceptStages + actorByHash <- hashLocalActor actorByKey + deliverActivityDB + actorByHash actorID localRecipsAccept [] [] + acceptID actionAccept + + -- Return instructions for HTTP delivery to remote recipients + return (followID, deliverHttpFollow, maybeDeliverHttpAccept) + + -- Launch asynchronous HTTP delivery of Follow and Accept + lift $ do + forkWorker "followC: async HTTP Follow delivery" deliverHttpFollow + for_ maybeDeliverHttpAccept $ + forkWorker "followC: async HTTP Accept delivery" + + return followID + where - parseFollowee (PersonR p) = Just $ FolloweePerson p - parseFollowee (GroupR g) = Just $ FolloweeGroup g - parseFollowee (RepoR r) = Just $ FolloweeRepo r - parseFollowee (DeckR d) = Just $ FolloweeDeck d - parseFollowee (LoomR l) = Just $ FolloweeLoom l - parseFollowee (TicketR d t) = Just $ FolloweeTicket d t - parseFollowee (ClothR l c) = Just $ FolloweeCloth l c - parseFollowee _ = Nothing - followeeActor (FolloweePerson p) = LocalActorPerson p - followeeActor (FolloweeGroup g) = LocalActorGroup g - followeeActor (FolloweeRepo r) = LocalActorRepo r - followeeActor (FolloweeDeck d) = LocalActorDeck d - followeeActor (FolloweeLoom l) = LocalActorLoom l - followeeActor (FolloweeTicket d _) = LocalActorDeck d - followeeActor (FolloweeCloth l _) = LocalActorLoom l - - getFollowee (FolloweePerson personHash) = do - personID <- decodeKeyHashidE personHash "Follow object: No such person hash" - (,Nothing,True) . personActor <$> getE personID "Follow object: No such person in DB" - getFollowee (FolloweeGroup groupHash) = do - groupID <- decodeKeyHashidE groupHash "Follow object: No such group hash" - (,Nothing,False) . groupActor <$> getE groupID "Follow object: No such group in DB" - getFollowee (FolloweeRepo repoHash) = do - repoID <- decodeKeyHashidE repoHash "Follow object: No such repo hash" - (,Nothing,False) . repoActor <$> getE repoID "Follow object: No such repo in DB" - getFollowee (FolloweeDeck deckHash) = do - deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash" - (,Nothing,False) . deckActor <$> getE deckID "Follow object: No such deck in DB" - getFollowee (FolloweeLoom loomHash) = do - loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash" - (,Nothing,False) . loomActor <$> getE loomID "Follow object: No such loom in DB" - getFollowee (FolloweeTicket deckHash ticketHash) = do - deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash" - actor <- deckActor <$> getE deckID "Follow object: No such deck in DB" - ticketID <- decodeKeyHashidE ticketHash "Follow object: No such ticket hash" - (_, _, Entity _ ticket, _, _) <- do - mticket <- lift $ getTicket deckID ticketID - fromMaybeE mticket "Follow object: No such ticket in DB" - return (actor, Just $ ticketFollowers ticket, False) - getFollowee (FolloweeCloth loomHash clothHash) = do - loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash" - actor <- loomActor <$> getE loomID "Follow object: No such loom in DB" - clothID <- decodeKeyHashidE clothHash "Follow object: No such cloth hash" - (_, _, Entity _ ticket, _, _, _) <- do - mticket <- lift $ getCloth loomID clothID - fromMaybeE mticket "Follow object: No such cloth in DB" - return (actor, Just $ ticketFollowers ticket, False) - - insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do - now <- liftIO getCurrentTime - summary <- - renderHTML <$> - withUrlRenderer - [hamlet| -

- - #{username2text $ personUsername personSender} - 's follow request accepted by # - - #{localUriPath $ objUriLocal uObject} - |] - hLocal <- asksSite siteInstanceHost - encodeRouteLocal <- getEncodeRouteLocal + prepareAccept luFollow actors stages = do encodeRouteHome <- getEncodeRouteHome - let recips = [encodeRouteHome $ PersonR senderHash] - accept mluAct = Doc hLocal Activity - { activityId = mluAct - , activityActor = objUriLocal uObject - , activityCapability = Nothing - , activitySummary = Just summary - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hLocal luFollow - , acceptResult = Nothing - } + hLocal <- asksSite siteInstanceHost + let recips = + map encodeRouteHome $ + map renderLocalActor actors ++ + map renderLocalStage stages + return AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hLocal luFollow + , AP.acceptResult = Nothing } - obiid <- insert OutboxItem - { outboxItemOutbox = obidRecip - , outboxItemActivity = - persistJSONObjectFromDoc $ accept Nothing - , outboxItemPublished = now } - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid - doc = accept $ Just luAct - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return obiid - - deliverFollowLocal now aidSender fsid unread obiidF obiidA ibidRecip = do - mfid <- lift $ insertUnique $ Follow aidSender fsid (not hide) obiidF obiidA - _ <- fromMaybeE mfid "Already following this object" - ibiid <- lift $ insert $ InboxItem unread now - lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid - - deliverAcceptLocal now obiidAccept ibidAuthor = do - ibiid <- insert $ InboxItem True now - insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid --} inviteC :: Entity Person @@ -2042,13 +2005,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re routes <- lookup p $ recipPeople localRecips guard $ routePerson routes - verifyRemoteAddressed remoteRecips u = - fromMaybeE (verify u) "Given remote entity not addressed" - where - verify (ObjURI h lu) = do - lus <- lookup h remoteRecips - guard $ lu `elem` lus - insertCollab resource recipient inviteID = do collabID <- insert Collab case resource of @@ -2740,279 +2696,377 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve resolveC :: Entity Person - -> Maybe HTML - -> Audience URIMode - -> Resolve URIMode + -> Actor + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> AP.Resolve URIMode -> ExceptT Text Handler OutboxItemId -resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do - error "resolveC temporarily disabled" +resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Resolve uObject) = do -{- + -- Check input + maybeLocalWorkItem <- + nameExceptT "Resolve object" $ either Just (const Nothing) <$> do + routeOrRemote <- parseFedURI uObject + bitraverse + (\ r -> do + wiByHash <- + fromMaybeE (parseWorkItem r) "Not a work item route" + unhashWorkItemE wiByHash "Work item invalid keyhashid" + ) + pure + routeOrRemote + capID <- fromMaybeE maybeCap "No capability provided" + -- Verify that the work item's tracker is addressed + for_ maybeLocalWorkItem $ \ wi -> do + trackerByHash <- hashLocalActor $ workItemActor wi + unless (actorIsAddressed localRecips trackerByHash) $ + throwE "Work item's tracker not addressed by the Resolve" - let shrUser = sharerIdent sharerUser - object <- parseWorkItem "Resolve object" uObject - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Offer Ticket with no recipients" - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients specified" - verifyHosterRecip localRecips "Parent" object + senderHash <- encodeKeyHashid senderPersonID now <- liftIO getCurrentTime - ticketDetail <- runWorkerExcept $ getWorkItemDetail "Object" object - (obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do - (obiidResolve, docResolve, luResolve) <- lift $ insertResolveToOutbox shrUser now (personOutbox personUser) blinded - remotesHttpResolve <- do - wiFollowers <- askWorkItemFollowers - let sieve = - let (actors, colls) = - workItemRecipSieve wiFollowers ticketDetail - in makeRecipientSet - actors - (LocalPersonCollectionSharerFollowers shrUser : - colls - ) - moreRemoteRecips <- - lift $ - deliverLocal' - True - (LocalActorSharer shrUser) - (personInbox personUser) - obiidResolve - (localRecipSieve sieve False localRecips) - unless (federation || null moreRemoteRecips) $ - throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB fwdHosts obiidResolve remoteRecips moreRemoteRecips - maccept <- - case widIdent ticketDetail of - Right _ -> return Nothing - Left (wi, ltid) -> Just <$> do - mhoster <- - lift $ runMaybeT $ - case wi of - WorkItemSharerTicket shr _ _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - p <- MaybeT (getValBy $ UniquePersonIdent sid) - return (personOutbox p, personInbox p) - WorkItemProjectTicket shr prj _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - j <- MaybeT $ getValBy $ UniqueProject prj sid - a <- lift $ getJust $ projectActor j - return (actorOutbox a, actorInbox a) - WorkItemRepoProposal shr rp _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - r <- MaybeT (getValBy $ UniqueRepo rp sid) - return (repoOutbox r, repoInbox r) - (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" - obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now - lift $ insertResolve ltid obiidResolve obiidAccept - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiidResolve obiidAccept - knownRemoteRecipsAccept <- - lift $ - deliverLocal' - False - (workItemActor wi) - ibidHoster - obiidAccept - localRecipsAccept - lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - return (obiidResolve, docResolve, remotesHttpResolve, maccept) - lift $ do - forkWorker "resolveC: async HTTP Resolve delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp - for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> - forkWorker "resolveC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept - return obiid - where - insertResolveToOutbox shrUser now obid blinded = do - hLocal <- asksSite siteInstanceHost - obiid <- insertEmptyOutboxItem obid now - encodeRouteLocal <- getEncodeRouteLocal - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = Doc hLocal Activity - { activityId = Just luAct - , activityActor = encodeRouteLocal $ SharerR shrUser - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activitySpecific = ResolveActivity $ Resolve uObject - } - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (obiid, doc, luAct) - insertResolve ltid obiidResolve obiidAccept = do + (resolveID, deliverHttpResolve, maybeDeliverHttpAccept) <- runDBExcept $ do + + workItemDB <- for maybeLocalWorkItem $ \ wi -> do + + -- Find the work item and its tracker in DB, and verify the work + -- item isn't already resolved + (resource, actor, ticketID) <- + case wi of + WorkItemTicket deckID taskID -> do + maybeTicket <- lift $ getTicket deckID taskID + (Entity _ deck, _task, Entity ticketID _, _author, resolve) <- + fromMaybeE maybeTicket "No such ticket in DB" + verifyNothingE resolve "Ticket already resolved" + actor <- lift $ getJustEntity $ deckActor deck + return (GrantResourceDeck deckID, actor, ticketID) + WorkItemCloth loomID clothID -> do + maybeCloth <- lift $ getCloth loomID clothID + (Entity _ loom, _cloth, Entity ticketID _, _author, resolve, _merge) <- + fromMaybeE maybeCloth "No such MR in DB" + verifyNothingE resolve "MR already resolved" + actor <- lift $ getJustEntity $ loomActor loom + return (GrantResourceLoom loomID, actor, ticketID) + + -- Verify the sender is authorized by the tracker to resolve work + -- items + 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 (Left senderPersonID) resource + + return (wi, actor, ticketID) + + -- Insert Resolve to sender's outbox + resolveID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + luResolve <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) resolveID action + + -- Deliver the Resolve activity to local recipients, and schedule + -- delivery for unavailable remote recipients + deliverHttpResolve <- do + sieve <- do + (actors, stages) <- + case maybeLocalWorkItem of + Nothing -> pure ([], []) + Just (WorkItemTicket deckID taskID) -> do + deckHash <- encodeKeyHashid deckID + taskHash <- encodeKeyHashid taskID + return + ( [LocalActorDeck deckHash] + , [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash + ] + ) + Just (WorkItemCloth loomID clothID) -> do + loomHash <- encodeKeyHashid loomID + clothHash <- encodeKeyHashid clothID + return + ( [LocalActorLoom loomHash] + , [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + ) + let stages' = LocalStagePersonFollowers senderHash : stages + return $ makeRecipientSet actors stages' + let localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts resolveID action + + -- Verify that the tracker has received the Resolve, resolve the work + -- item in DB, and publish Accept + maybeDeliverHttpAccept <- for workItemDB $ \ (wi, Entity trackerActorID trackerActor, ticketID) -> do + + -- Verify tracker received the Resolve + verifyActorHasItem + trackerActorID + resolveID + "Local tracker didn't receive the Resolve" + + -- Mark work item in DB as resolved by the Resolve + acceptID <- + lift $ insertEmptyOutboxItem (actorOutbox trackerActor) now + lift $ insertResolve ticketID resolveID acceptID + + -- Insert an Accept activity to tracker's outbox + trackerStages <- + case wi of + WorkItemTicket deckID taskID -> do + deckHash <- encodeKeyHashid deckID + taskHash <- encodeKeyHashid taskID + return + [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash + ] + WorkItemCloth loomID clothID -> do + loomHash <- encodeKeyHashid loomID + clothHash <- encodeKeyHashid clothID + return + [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + let acceptActors = [LocalActorPerson senderHash] + acceptStages = + LocalStagePersonFollowers senderHash : trackerStages + actionAccept <- prepareAccept luResolve acceptActors acceptStages + let trackerByKey = workItemActor wi + _ <- lift $ updateOutboxItem trackerByKey acceptID actionAccept + + -- Deliver the Accept activity to local recipients, and schedule + -- delivery for unavailable remote recipients + let localRecipsAccept = makeRecipientSet acceptActors acceptStages + trackerByHash <- hashLocalActor trackerByKey + deliverActivityDB + trackerByHash trackerActorID localRecipsAccept [] [] + acceptID actionAccept + + -- Return instructions for HTTP delivery of Resolve and Accept to + -- remote recipients + return + ( resolveID + , deliverHttpResolve + , maybeDeliverHttpAccept + ) + + -- Launch asynchronous HTTP delivery of Resolve and Accept + lift $ do + forkWorker "resolveC: async HTTP Resolve delivery" deliverHttpResolve + for_ maybeDeliverHttpAccept $ + forkWorker "resolveC: async HTTP Accept delivery" + + return resolveID + + where + + insertResolve ticketID resolveID acceptID = do trid <- insert TicketResolve - { ticketResolveTicket = ltid - , ticketResolveAccept = obiidAccept + { ticketResolveTicket = ticketID + , ticketResolveAccept = acceptID } insert_ TicketResolveLocal { ticketResolveLocalTicket = trid - , ticketResolveLocalActivity = obiidResolve + , ticketResolveLocalActivity = resolveID + } + + prepareAccept luResolve actors stages = do + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + let recips = + map encodeRouteHome $ + map renderLocalActor actors ++ + map renderLocalStage stages + return AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hLocal luResolve + , AP.acceptResult = Nothing + } } - tid <- localTicketTicket <$> getJust ltid - update tid [TicketStatus =. TSClosed] --} undoC :: Entity Person - -> Maybe HTML - -> Audience URIMode - -> Undo URIMode + -> Actor + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> AP.Undo URIMode -> ExceptT Text Handler OutboxItemId -undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do - error "undoC temporarily disabled" +undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Undo uObject) = do -{- + -- Check input + undone <- + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI uObject - - let shrUser = sharerIdent sharerUser - object <- parseActivity uObject - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Undo with no recipients" - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients specified" now <- liftIO getCurrentTime - (obiid, doc, _lu, mwi) <- runDBExcept $ do - (obiidUndo, docUndo, luUndo) <- lift $ insertUndoToOutbox shrUser now (personOutbox personUser) blinded - mltid <- fmap join $ runMaybeT $ do - object' <- MaybeT $ getActivity object - deleteFollow shrUser object' <|> deleteResolve object' - mwi <- lift $ traverse getWorkItem mltid - return (obiidUndo, docUndo, luUndo, mwi) - mticketDetail <- - for mwi $ \ wi -> - (wi,) <$> runWorkerExcept (getWorkItemDetail "Object" $ Left wi) - wiFollowers <- askWorkItemFollowers - let sieve = - case mticketDetail of - Nothing -> makeRecipientSet [] [LocalPersonCollectionSharerFollowers shrUser] - Just (_wi, ticketDetail) -> - let (actors, colls) = - workItemRecipSieve wiFollowers ticketDetail - in makeRecipientSet - actors - (LocalPersonCollectionSharerFollowers shrUser : - colls - ) - (remotes, maybeAccept) <- runDBExcept $ do - remotesHttpUndo <- do - moreRemoteRecips <- - lift $ - deliverLocal' - True - (LocalActorSharer shrUser) - (personInbox personUser) - obiid - (localRecipSieve sieve True localRecips) - unless (federation || null moreRemoteRecips) $ - throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips - maccept <- for mticketDetail $ \ (wi, ticketDetail) -> do - mhoster <- + senderHash <- encodeKeyHashid senderPersonID + + (undoID, deliverHttpUndo, maybeDeliverHttpAccept) <- runDBExcept $ do + + -- Find the undone activity in our DB + undoneDB <- do + a <- getActivity undone + fromMaybeE a "Can't find undone in DB" + + -- See if the undone activity is a Follow/Resolve on a local target + -- If it is, verify the relevant actor is addressed, verify + -- permissions, and perform the actual undoing in the DB + maybeUndoLocal <- do + maybeUndo <- lift $ runMaybeT $ - case wi of - WorkItemSharerTicket shr _ _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - p <- MaybeT (getValBy $ UniquePersonIdent sid) - return (personOutbox p, personInbox p) - WorkItemProjectTicket shr prj _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - j <- MaybeT $ getValBy $ UniqueProject prj sid - a <- lift $ getJust $ projectActor j - return (actorOutbox a, actorInbox a) - WorkItemRepoProposal shr rp _ -> do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - r <- MaybeT (getValBy $ UniqueRepo rp sid) - return (repoOutbox r, repoInbox r) - (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" - obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiid obiidAccept - knownRemoteRecipsAccept <- - lift $ - deliverLocal' - False - (workItemActor wi) - ibidHoster - obiidAccept - localRecipsAccept - lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - return (remotesHttpUndo, maccept) + Left <$> MaybeT (tryUnfollow undoneDB) <|> + Right <$> MaybeT (tryUnresolve undoneDB) + case maybeUndo of + Nothing -> pure Nothing + Just (Left (updateDB, actorID, Left followerSetID)) -> do + actorByKey <- lift $ getLocalActor actorID + unless (actorByKey == LocalActorPerson senderPersonID) $ + throwE "Tryin to undo a Follow of someone else" + (fByKey, fActorID, _) <- do + followee <- lift $ getFollowee' followerSetID + getFollowee followee + fByHash <- hashLocalActor fByKey + unless (actorIsAddressed localRecips fByHash) $ + throwE "Followee's actor not addressed by the Undo" + lift updateDB + fActor <- lift $ getJust fActorID + return $ Just + ( fByKey + , Entity fActorID fActor + , makeRecipientSet + [fByHash] + [LocalStagePersonFollowers senderHash] + , [LocalActorPerson senderHash] + , [] + ) + Just (Left (updateDB, actorID, Right uTarget)) -> do + actorByKey <- lift $ getLocalActor actorID + unless (actorByKey == LocalActorPerson senderPersonID) $ + throwE "Trying to undo a Follow of someone else" + verifyRemoteAddressed remoteRecips uTarget + lift updateDB + return Nothing + Just (Right (updateDB, ticketID)) -> do + wiByKey <- lift $ getWorkItem ticketID + wiByHash <- hashWorkItem wiByKey + let resource = workItemResource wiByKey + actorByKey = workItemActor wiByKey + actorByHash = workItemActor wiByHash + unless (actorIsAddressed localRecips actorByHash) $ + throwE "Work item's actor not addressed by the Undo" + 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 tracker" + verifyCapability capability (Left senderPersonID) resource + lift updateDB + actorID <- do + maybeActor <- lift $ getLocalActorEntity actorByKey + case localActorID <$> maybeActor of + Nothing -> error "Actor entity not in DB" + Just aid -> pure aid + actor <- lift $ getJust actorID + return $ Just + ( actorByKey + , Entity actorID actor + , makeRecipientSet + [actorByHash] + [ localActorFollowers actorByHash + , workItemFollowers wiByHash + , LocalStagePersonFollowers senderHash + ] + , [LocalActorPerson senderHash] + , [ localActorFollowers actorByHash + , workItemFollowers wiByHash + , LocalStagePersonFollowers senderHash + ] + ) + + -- Insert the Undo activity to author's outbox + undoID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + luUndo <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) undoID action + + -- Deliver the Undo activity to local recipients, and schedule delivery + -- for unavailable remote recipients + deliverHttpUndo <- do + let sieve = + case maybeUndoLocal of + Nothing -> + makeRecipientSet + [] [LocalStagePersonFollowers senderHash] + Just (_, _, s, _, _) -> s + localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts undoID action + + maybeDeliverHttpAccept <- for maybeUndoLocal $ \ (actorByKey, Entity actorID actor, _, acceptActors, acceptStages) -> do + + -- Verify the relevant actor has received the Undp + verifyActorHasItem actorID undoID "Actor didn't receive the Undo" + + -- Insert an Accept activity to actor's outbox + acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now + actionAccept <- prepareAccept luUndo acceptActors acceptStages + _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept + + -- Deliver the Accept activity to local recipients, and schedule + -- delivery for unavailable remote recipients + let localRecipsAccept = makeRecipientSet acceptActors acceptStages + actorByHash <- hashLocalActor actorByKey + deliverActivityDB + actorByHash actorID localRecipsAccept [] [] + acceptID actionAccept + + -- Return instructions for HTTP delivery to remote recipients + return (undoID, deliverHttpUndo, maybeDeliverHttpAccept) + + -- Launch asynchronous HTTP delivery of Undo and Accept lift $ do - forkWorker "undoC: async HTTP Undo delivery" $ - deliverRemoteHttp' fwdHosts obiid doc remotes - for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> - forkWorker "undoC: async HTTP Accept delivery" $ - deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept - return obiid + forkWorker "undoC: async HTTP Undo delivery" deliverHttpUndo + for_ maybeDeliverHttpAccept $ + forkWorker "undoC: async HTTP Accept delivery" + + return undoID + where - insertUndoToOutbox shrUser now obid blinded = do + + prepareAccept luUndo actors stages = do + encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost - obiid <- insertEmptyOutboxItem obid now - encodeRouteLocal <- getEncodeRouteLocal - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = Doc hLocal Activity - { activityId = Just luAct - , activityActor = encodeRouteLocal $ SharerR shrUser - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activitySpecific = UndoActivity $ Undo uObject + let recips = + map encodeRouteHome $ + map renderLocalActor actors ++ + map renderLocalStage stages + return AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hLocal luUndo + , AP.acceptResult = Nothing } - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (obiid, doc, luAct) - - deleteFollow shr (Left (actor, obiid)) = do - deleteFollowLocal <|> deleteFollowRemote <|> deleteFollowRequest - return Nothing - where - deleteFollowLocal = do - fid <- MaybeT $ lift $ getKeyBy $ UniqueFollowFollow obiid - unless (actor == LocalActorSharer shr) $ - lift $ throwE "Undoing someone else's follow" - lift $ lift $ delete fid - deleteFollowRemote = do - frid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteFollow obiid - unless (actor == LocalActorSharer shr) $ - lift $ throwE "Undoing someone else's follow" - lift $ lift $ delete frid - deleteFollowRequest = do - frrid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteRequestActivity obiid - unless (actor == LocalActorSharer shr) $ - lift $ throwE "Undoing someone else's follow" - lift $ lift $ delete frrid - deleteFollow _ (Right _) = mzero - - deleteResolve (Left (_, obiid)) = do - Entity trlid trl <- MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity obiid - lift $ lift $ do - let trid = ticketResolveLocalTicket trl - tr <- getJust trid - delete trlid - delete trid - let ltid = ticketResolveTicket tr - tid <- localTicketTicket <$> getJust ltid - update tid [TicketStatus =. TSTodo] - return $ Just ltid - deleteResolve (Right ractid) = do - Entity trrid trr <- MaybeT $ lift $ getBy $ UniqueTicketResolveRemoteActivity ractid - lift $ lift $ do - let trid = ticketResolveRemoteTicket trr - tr <- getJust trid - delete trrid - delete trid - let ltid = ticketResolveTicket tr - tid <- localTicketTicket <$> getJust ltid - update tid [TicketStatus =. TSTodo] - return $ Just ltid --} + } pushCommitsC :: Entity Person diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index ff6c134..280364d 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -86,7 +86,6 @@ import Vervis.Model import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Ticket -import Vervis.WorkItem makeServerInput :: (MonadSite m, SiteEnv m ~ App) @@ -782,7 +781,7 @@ applyPatches -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode) applyPatches senderHash uObject = do - bundle <- parseProposalBundle "Apply object" uObject + bundle <- parseBundleRoute "Apply object" uObject mrInfo <- bifor bundle (\ (loomID, clothID, _) -> do diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 095daa4..27f0af3 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -20,6 +20,9 @@ module Vervis.Data.Actor , stampRoute , parseStampRoute , localActorID + , parseLocalURI + , parseFedURI + , parseLocalActorE ) where @@ -104,3 +107,18 @@ localActorID (LocalActorGroup (Entity _ g)) = groupActor g localActorID (LocalActorRepo (Entity _ r)) = repoActor r localActorID (LocalActorDeck (Entity _ d)) = deckActor d localActorID (LocalActorLoom (Entity _ l)) = loomActor l + +parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App) +parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route" + +parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI) +parseFedURI u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> parseLocalURI lu + else pure $ Right u + +parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key) +parseLocalActorE route = do + actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" + unhashLocalActorE actorByHash "Invalid actor keyhashid" diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 23b686b..332d0a4 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -39,26 +39,12 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Recipient -parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App) -parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route" - -parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI) -parseFedURI u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> parseLocalURI lu - else pure $ Right u - -parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key) -parseLocalActorE route = do - actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" - unhashLocalActorE actorByHash "Invalid actor keyhashid" - parseCommentId :: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId) parseCommentId (PersonMessageR p m) = diff --git a/src/Vervis/Data/Follow.hs b/src/Vervis/Data/Follow.hs new file mode 100644 index 0000000..15f9985 --- /dev/null +++ b/src/Vervis/Data/Follow.hs @@ -0,0 +1,84 @@ +{- This file is part of Vervis. + - + - Written in 2022 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 + - . + -} + +module Vervis.Data.Follow + ( FolloweeBy (..) + , followeeActor + , parseFollow + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Except +import Data.Bitraversable +import Data.Foldable +import Data.Maybe +import Data.Text (Text) +import Database.Persist.Types + +import Network.FedURI +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local + +import Vervis.Data.Actor +import Vervis.Data.Ticket +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Recipient + +data FolloweeBy f + = FolloweeActor (LocalActorBy f) + | FolloweeWorkItem (WorkItemBy f) + +followeeActor :: FolloweeBy f -> LocalActorBy f +followeeActor (FolloweeActor a) = a +followeeActor (FolloweeWorkItem wi) = workItemActor wi + +unhashFolloweeE (FolloweeActor a) e = FolloweeActor <$> unhashLocalActorE a e +unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE wi e + +parseFollow + :: AP.Follow URIMode + -> ExceptT Text Handler + (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool) +parseFollow (AP.Follow uObject mluContext hide) = do + routeOrRemote <- parseFedURI uObject + (,hide) <$> + bitraverse + (parseLocal mluContext) + (pure . makeRemote mluContext) + routeOrRemote + where + parseFollowee r = + FolloweeActor <$> parseLocalActor r <|> + FolloweeWorkItem <$> parseWorkItem r + parseLocal mlu r = do + byHash <- fromMaybeE (parseFollowee r) "Not a followee route" + byKey <- unhashFolloweeE byHash "Followee invalid keyhashid" + for_ mlu $ \ lu -> nameExceptT "Follow context" $ do + actorR <-parseLocalURI lu + actorByKey <- parseLocalActorE actorR + unless (actorByKey == followeeActor byKey) $ + throwE "Isn't object's actor" + return byKey + makeRemote mlu (ObjURI h lu) = (h, fromMaybe lu mlu, lu) diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index d29ca1d..5c546df 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -22,6 +22,27 @@ module Vervis.Data.Ticket , checkOfferTicket , checkApplyLocalLoom + , parseBundleRoute + + , WorkItemBy (..) + + , hashWorkItemPure + , getHashWorkItem + , hashWorkItem + + , unhashWorkItemPure + , unhashWorkItem + , unhashWorkItemF + , unhashWorkItemM + , unhashWorkItemE + , unhashWorkItem404 + + , workItemResource + , workItemActor + , workItemFollowers + , workItemRoute + , parseWorkItem + -- These are exported only for Vervis.Client , Tracker (..) , checkTracker @@ -30,11 +51,16 @@ where import Control.Monad import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Bifunctor import Data.Foldable import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Traversable +import Web.Hashids +import Yesod.Core + +import qualified Control.Monad.Fail as F import Development.PatchMediaType import Network.FedURI @@ -42,15 +68,17 @@ import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Vervis.Access import Vervis.Foundation import Vervis.FedURI import Vervis.Model -import Vervis.Ticket +import Vervis.Recipient data Tip = TipLocalRepo RepoId @@ -201,12 +229,28 @@ checkOfferTicket host ticket uTarget = do tam <- checkTrackerAndMerge target maybeBundle return $ WorkItemOffer author title desc source tam +parseBundleRoute name u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE (decodeRouteLocal lu) $ + name <> ": Not a valid route" + case route of + BundleR loom ticket bundle -> + (,,) + <$> decodeKeyHashidE loom (name <> ": Invalid lkhid") + <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid") + <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid") + _ -> throwE $ name <> ": not a bundle route" + else return $ Right u + checkApply :: AP.Apply URIMode -> ExceptT Text Handler (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip) checkApply (AP.Apply uObject target) = - (,) <$> parseProposalBundle "Apply object" uObject + (,) <$> parseBundleRoute "Apply object" uObject <*> nameExceptT "Apply target" (checkTip target) checkApplyLocalLoom @@ -227,3 +271,91 @@ checkApplyLocalLoom apply = do Left b -> pure b Right _ -> throwE "Applying a remote bundle on local loom" return (repoID, maybeBranch, loomID, clothID, bundleID) + +data WorkItemBy f + = WorkItemTicket (f Deck) (f TicketDeck) + | WorkItemCloth (f Loom) (f TicketLoom) + +hashWorkItemPure :: HashidsContext -> WorkItemBy Key -> WorkItemBy KeyHashid +hashWorkItemPure ctx = f + where + f (WorkItemTicket d t) = + WorkItemTicket (encodeKeyHashidPure ctx d) (encodeKeyHashidPure ctx t) + f (WorkItemCloth l c) = + WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c) + +getHashWorkItem + :: (MonadSite m, YesodHashids (SiteEnv m)) + => m (WorkItemBy Key -> WorkItemBy KeyHashid) +getHashWorkItem = do + ctx <- asksSite siteHashidsContext + return $ hashWorkItemPure ctx + +hashWorkItem + :: (MonadSite m, YesodHashids (SiteEnv m)) + => WorkItemBy Key -> m (WorkItemBy KeyHashid) +hashWorkItem actor = do + hash <- getHashWorkItem + return $ hash actor + +unhashWorkItemPure + :: HashidsContext -> WorkItemBy KeyHashid -> Maybe (WorkItemBy Key) +unhashWorkItemPure ctx = f + where + f (WorkItemTicket d t) = + WorkItemTicket + <$> decodeKeyHashidPure ctx d + <*> decodeKeyHashidPure ctx t + f (WorkItemCloth l c) = + WorkItemCloth + <$> decodeKeyHashidPure ctx l + <*> decodeKeyHashidPure ctx c + +unhashWorkItem + :: (MonadSite m, YesodHashids (SiteEnv m)) + => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key)) +unhashWorkItem actor = do + ctx <- asksSite siteHashidsContext + return $ unhashWorkItemPure ctx actor + +unhashWorkItemF + :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m)) + => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key) +unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor + +unhashWorkItemM + :: (MonadSite m, YesodHashids (SiteEnv m)) + => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key) +unhashWorkItemM = MaybeT . unhashWorkItem + +unhashWorkItemE + :: (MonadSite m, YesodHashids (SiteEnv m)) + => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key) +unhashWorkItemE actor e = + ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor + +unhashWorkItem404 + :: ( MonadSite m + , MonadHandler m + , HandlerSite m ~ SiteEnv m + , YesodHashids (HandlerSite m) + ) + => WorkItemBy KeyHashid + -> m (WorkItemBy Key) +unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor + +workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck +workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom + +workItemActor (WorkItemTicket deck _) = LocalActorDeck deck +workItemActor (WorkItemCloth loom _) = LocalActorLoom loom + +workItemFollowers (WorkItemTicket d t) = LocalStageTicketFollowers d t +workItemFollowers (WorkItemCloth l c) = LocalStageClothFollowers l c + +workItemRoute (WorkItemTicket d t) = TicketR d t +workItemRoute (WorkItemCloth l c) = ClothR l c + +parseWorkItem (TicketR deck task) = Just $ WorkItemTicket deck task +parseWorkItem (ClothR loom cloth) = Just $ WorkItemCloth loom cloth +parseWorkItem _ = Nothing diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 23f1c05..ff9733c 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -113,7 +113,6 @@ import Vervis.Query import Vervis.Recipient import Vervis.Ticket import Vervis.Web.Repo -import Vervis.WorkItem {- checkBranch diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index 8f69e8e..0393b72 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -102,7 +102,6 @@ import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Query import Vervis.Ticket -import Vervis.WorkItem data Result = ResultSomeException SomeException diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index eb0e4dc..7b7a8ca 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -128,6 +128,7 @@ import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.Paginate import Vervis.Persist.Actor +import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.Settings import Vervis.Style diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 993de83..28c89f1 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -335,10 +335,7 @@ postPersonOutboxR personHash = do addBundleC eperson sharer summary audience patches target _ -> throwE "Unsupported Add 'object' type" -} - {- - FollowActivity follow -> - followC shr summary audience follow - -} + AP.FollowActivity follow -> run followC follow AP.OfferActivity (AP.Offer obj target) -> case obj of AP.OfferTicket ticket -> run offerTicketC ticket target @@ -347,12 +344,8 @@ postPersonOutboxR personHash = do offerDepC eperson sharer summary audience dep target -} _ -> throwE "Unsupported Offer 'object' type" - {- - ResolveActivity resolve -> - resolveC eperson sharer summary audience resolve - UndoActivity undo -> - undoC eperson sharer summary audience undo - -} + AP.ResolveActivity resolve -> run resolveC resolve + AP.UndoActivity undo -> run undoC undo _ -> throwE "Unsupported activity type" getPersonOutboxItemR diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 52882d1..ff4405c 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -151,6 +151,7 @@ import Vervis.Model.Workflow import Vervis.Paginate import Vervis.Persist.Actor import Vervis.Persist.Discussion +import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.Settings import Vervis.Style diff --git a/src/Vervis/Persist/Follow.hs b/src/Vervis/Persist/Follow.hs new file mode 100644 index 0000000..4614a50 --- /dev/null +++ b/src/Vervis/Persist/Follow.hs @@ -0,0 +1,138 @@ +{- This file is part of Vervis. + - + - Written in 2022 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 + - . + -} + +module Vervis.Persist.Follow + ( getFollowee + , getFollowee' + , tryUnfollow + ) +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.Barbie +import Data.Bitraversable +import Data.Functor +import Data.Maybe +import Data.Text (Text) +import Data.Traversable +import Database.Persist +import Database.Persist.Sql + +import qualified Data.Text as T +import qualified Database.Esqueleto as E + +import Crypto.ActorKey +import Database.Persist.JSON +import Network.FedURI +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +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.Cloth +import Vervis.Data.Actor +import Vervis.Data.Follow +import Vervis.Data.Ticket +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +import Vervis.Persist.Ticket +import Vervis.Recipient +import Vervis.Settings +import Vervis.Ticket + +getFollowee + :: MonadIO m + => FolloweeBy Key + -> ExceptT Text (ReaderT SqlBackend m) + (LocalActorBy Key, ActorId, Maybe FollowerSetId) +getFollowee (FolloweeActor actorByKey) = do + actorByEntity <- do + maybeActor <- lift $ getLocalActorEntity actorByKey + fromMaybeE maybeActor "Actor not found in DB" + return (actorByKey, localActorID actorByEntity, Nothing) +getFollowee (FolloweeWorkItem wi) = + case wi of + WorkItemTicket deckID taskID -> do + actorID <- deckActor <$> getE deckID "No such deck in DB" + (_, _, Entity _ ticket, _, _) <- do + mticket <- lift $ getTicket deckID taskID + fromMaybeE mticket "No such ticket in DB" + return + ( LocalActorDeck deckID + , actorID + , Just $ ticketFollowers ticket + ) + WorkItemCloth loomID clothID -> do + actorID <- loomActor <$> getE loomID "No such loom in DB" + (_, _, Entity _ ticket, _, _, _) <- do + mcloth <- lift $ getCloth loomID clothID + fromMaybeE mcloth "No such MR in DB" + return + ( LocalActorLoom loomID + , actorID + , Just $ ticketFollowers ticket + ) + +getFollowee' followerSetID = do + actorOrTicket <- + requireEitherAlt + (getKeyBy $ UniqueActorFollowers followerSetID) + (getKeyBy $ UniqueTicketFollowers followerSetID) + "Can't find who's using this FollowerSet" + "Multi use of FollowerSet" + either FolloweeActor FolloweeWorkItem <$> + bitraverse getLocalActor getWorkItem actorOrTicket + +tryUnfollow (Left (_actorByKey, _actorEntity, itemID)) = + runMaybeT $ + MaybeT forRemoteRequest <|> MaybeT forRemote <|> MaybeT forLocal + where + forRemoteRequest = do + maybeFollow <- getBy $ UniqueFollowRemoteRequestActivity itemID + for maybeFollow $ \ (Entity requestID request) -> do + actorID <- + personActor <$> getJust (followRemoteRequestPerson request) + let uTarget = + fromMaybe (followRemoteRequestTarget request) $ + followRemoteRequestRecip request + return (delete requestID, actorID, Right uTarget) + forRemote = do + maybeFollow <- getBy $ UniqueFollowRemoteFollow itemID + for maybeFollow $ \ (Entity remoteID remote) -> do + let actorID = followRemoteActor remote + uTarget <- getRemoteActorURI =<< getJust (followRemoteRecip remote) + return (delete remoteID, actorID, Right uTarget) + forLocal = do + maybeFollow <- getBy $ UniqueFollowFollow itemID + return $ maybeFollow <&> \ (Entity followID follow) -> + let actorID = followActor follow + followerSetID = followTarget follow + in (delete followID, actorID, Left followerSetID) +tryUnfollow (Right _) = pure Nothing diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs index deee9fe..2531330 100644 --- a/src/Vervis/Persist/Ticket.hs +++ b/src/Vervis/Persist/Ticket.hs @@ -14,19 +14,27 @@ -} module Vervis.Persist.Ticket - ( checkApplyDB + ( getTicketResolve + , getWorkItem + , checkApplyDB + , tryUnresolve ) where import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Bitraversable import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) import Data.These +import Data.Traversable import Database.Persist +import Database.Persist.Sql import qualified Data.List.NonEmpty as NE @@ -34,15 +42,57 @@ import Development.PatchMediaType import Yesod.Hashids import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local import Vervis.Access import Vervis.Cloth +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Foundation import Vervis.Model +import Vervis.Persist.Actor import Vervis.Recipient +getTicketResolve (Entity _ tr, resolve) = do + time <- outboxItemPublished <$> getJust (ticketResolveAccept tr) + closer <- bitraverse getCloserLocal getCloserRemote resolve + return (time, closer) + where + getCloserLocal (Entity _ trl) = do + outboxID <- + outboxItemOutbox <$> + getJust (ticketResolveLocalActivity trl) + Entity actorID actor <- do + maybeActor <- getBy $ UniqueActorOutbox outboxID + case maybeActor of + Nothing -> error "No actor for outbox" + Just a -> pure a + actorByEntity <- getLocalActorEnt actorID + person <- + case actorByEntity of + LocalActorPerson p -> pure p + _ -> error "Surprise! Ticket closer isn't a Person" + return (person, actor) + getCloserRemote (Entity _ trr) = do + ra <- getJust $ ticketResolveRemoteActor trr + ro <- getJust $ remoteActorIdent ra + i <- getJust $ remoteObjectInstance ro + return (i, ro, ra) + +getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m (WorkItemBy Key) +getWorkItem tid = do + tracker <- + requireEitherAlt + (getBy $ UniqueTicketDeck tid) + (getBy $ UniqueTicketLoom tid) + "Neither TD nor TD found" + "Both TD and TL found" + return $ + case tracker of + Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid + Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid + -- | Given: -- -- * A local tip (i.e. a repository or a branch), parsed from a URI @@ -142,3 +192,24 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do else throwE "Patch type mismatch with repo VCS type" return (loom, ticketID, diffs) + +tryUnresolve (Left (_actorByKey, _actorEntity, itemID)) = do + maybeResolve <- getBy $ UniqueTicketResolveLocalActivity itemID + for maybeResolve $ \ (Entity resolveLocalID resolveLocal) -> do + let resolveID = ticketResolveLocalTicket resolveLocal + resolve <- getJust resolveID + let ticketID = ticketResolveTicket resolve + return + ( delete resolveLocalID >> delete resolveID + , ticketID + ) +tryUnresolve (Right remoteActivityID) = do + maybeResolve <- getBy $ UniqueTicketResolveRemoteActivity remoteActivityID + for maybeResolve $ \ (Entity resolveRemoteID resolveRemote) -> do + let resolveID = ticketResolveRemoteTicket resolveRemote + resolve <- getJust resolveID + let ticketID = ticketResolveTicket resolve + return + ( delete resolveRemoteID >> delete resolveID + , ticketID + ) diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 600324b..b9228ea 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -39,16 +39,9 @@ module Vervis.Ticket --, getDependencyCollection --, getReverseDependencyCollection - , WorkItem (..) - , getWorkItemRoute - , askWorkItemRoute - , getWorkItem - , parseWorkItem - , parseProposalBundle + --, getWorkItem - , checkDepAndTarget - - , getTicketResolve + --, checkDepAndTarget ) where @@ -85,6 +78,7 @@ import Data.Paginate.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -690,74 +684,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) -} -data WorkItem - = WorkItemTicket DeckId TicketDeckId - | WorkItemCloth LoomId TicketLoomId - deriving Eq - -getWorkItemRoute - :: (MonadSite m, YesodHashids (SiteEnv m)) => WorkItem -> m (Route App) -getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute - -askWorkItemRoute - :: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App) -askWorkItemRoute = do - hashDID <- getEncodeKeyHashid - hashLID <- getEncodeKeyHashid - hashTDID <- getEncodeKeyHashid - hashTLID <- getEncodeKeyHashid - let route (WorkItemTicket did tdid) = TicketR (hashDID did) (hashTDID tdid) - route (WorkItemCloth lid tlid) = ClothR (hashLID lid) (hashTLID tlid) - return route - -getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m WorkItem -getWorkItem tid = do - tracker <- - requireEitherAlt - (getBy $ UniqueTicketDeck tid) - (getBy $ UniqueTicketLoom tid) - "Neither TD nor TD found" - "Both TD and TL found" - return $ - case tracker of - Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid - Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid - -parseWorkItem name u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE (decodeRouteLocal lu) $ - name <> ": Not a valid route" - case route of - TicketR deck ticket -> - WorkItemTicket - <$> decodeKeyHashidE deck (name <> ": Invalid dkhid") - <*> decodeKeyHashidE ticket (name <> ": Invalid tdkhid") - ClothR loom ticket -> - WorkItemCloth - <$> decodeKeyHashidE loom (name <> ": Invalid lkhid") - <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid") - _ -> throwE $ name <> ": not a work item route" - else return $ Right u - -parseProposalBundle name u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE (decodeRouteLocal lu) $ - name <> ": Not a valid route" - case route of - BundleR loom ticket bundle -> - (,,) - <$> decodeKeyHashidE loom (name <> ": Invalid lkhid") - <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid") - <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid") - _ -> throwE $ name <> ": not a bundle route" - else return $ Right u - +{- checkDepAndTarget :: (MonadSite m, SiteEnv m ~ App) => TicketDependency URIMode @@ -798,29 +725,4 @@ checkDepAndTarget checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target" checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent" checkParentAndTarget (Right _) (Right _) = return () - -getTicketResolve (Entity _ tr, resolve) = do - time <- outboxItemPublished <$> getJust (ticketResolveAccept tr) - closer <- bitraverse getCloserLocal getCloserRemote resolve - return (time, closer) - where - getCloserLocal (Entity _ trl) = do - outboxID <- - outboxItemOutbox <$> - getJust (ticketResolveLocalActivity trl) - Entity actorID actor <- do - maybeActor <- getBy $ UniqueActorOutbox outboxID - case maybeActor of - Nothing -> error "No actor for outbox" - Just a -> pure a - actorByEntity <- getLocalActorEnt actorID - person <- - case actorByEntity of - LocalActorPerson p -> pure p - _ -> error "Surprise! Ticket closer isn't a Person" - return (person, actor) - getCloserRemote (Entity _ trr) = do - ra <- getJust $ ticketResolveRemoteActor trr - ro <- getJust $ remoteActorIdent ra - i <- getJust $ remoteObjectInstance ro - return (i, ro, ra) +-} diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 9a1b533..f895905 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -97,6 +97,7 @@ import qualified Web.ActivityPub as AP import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Foundation @@ -433,10 +434,10 @@ getFollowingCollection here actor hash = do <*> getRemotes followerActorID hashActor <- getHashLocalActor - workItemRoute <- askWorkItemRoute + hashItem <- getHashWorkItem let locals = map (renderLocalActor . hashActor) localActors ++ - map workItemRoute workItems + map (workItemRoute . hashItem) workItems unless (length locals == localTotal) $ error "Bug! List length mismatch" diff --git a/src/Vervis/Web/Discussion.hs b/src/Vervis/Web/Discussion.hs index b21468b..c87c045 100644 --- a/src/Vervis/Web/Discussion.hs +++ b/src/Vervis/Web/Discussion.hs @@ -62,6 +62,7 @@ import Yesod.Persist.Local import Vervis.API import Vervis.Data.Discussion +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Form.Discussion import Vervis.Foundation @@ -69,6 +70,7 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Persist.Actor import Vervis.Persist.Discussion +import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.Settings import Vervis.Ticket @@ -220,7 +222,6 @@ serveMessage authorHash localMessageHash = do localMessageID <- decodeKeyHashid404 localMessageHash encodeRouteHome <- getEncodeRouteHome - workItemRoute <- askWorkItemRoute noteAP <- runDB $ do author <- get404 authorID localMessage <- get404 localMessageID @@ -236,8 +237,10 @@ serveMessage authorHash localMessageHash = do "Neither T nor RD found" "Both T and RD found" case topic of - Left ticketID -> - encodeRouteHome . workItemRoute <$> getWorkItem ticketID + Left ticketID -> do + wiByKey <- getWorkItem ticketID + wiByHash <- hashWorkItem wiByKey + return $ encodeRouteHome $ workItemRoute wiByHash Right rd -> do ro <- getJust $ remoteDiscussionIdent rd i <- getJust $ remoteObjectInstance ro diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 915fd3e..b355269 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1513,21 +1513,21 @@ encodeCreate (Create obj target) data Follow u = Follow { followObject :: ObjURI u - , followContext :: Maybe (ObjURI u) + , followContext :: Maybe LocalURI , followHide :: Bool } parseFollow :: UriMode u => Object -> Parser (Follow u) -parseFollow o = - Follow - <$> o .: "object" - <*> o .:? "context" +parseFollow o = do + u@(ObjURI h _) <- o .: "object" + Follow u + <$> withAuthorityMaybeO h (o .:? "context") <*> o .:? "hide" .!= False encodeFollow :: UriMode u => Follow u -> Series encodeFollow (Follow obj mcontext hide) = "object" .= obj - <> "context" .=? mcontext + <> "context" .=? (ObjURI (objUriAuthority obj) <$> mcontext) <> "hide" .= hide data Grant u = Grant diff --git a/vervis.cabal b/vervis.cabal index 32a37cf..375c6fb 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -143,6 +143,7 @@ library Vervis.Data.Actor Vervis.Data.Collab Vervis.Data.Discussion + Vervis.Data.Follow Vervis.Data.Ticket --Vervis.Federation @@ -211,6 +212,7 @@ library Vervis.Persist.Actor Vervis.Persist.Collab Vervis.Persist.Discussion + Vervis.Persist.Follow Vervis.Persist.Ticket Vervis.Query @@ -246,7 +248,7 @@ library Vervis.Widget.Tracker -- Vervis.Widget.Workflow -- Vervis.Wiki - Vervis.WorkItem + --Vervis.WorkItem default-extensions: TemplateHaskell QuasiQuotes