From 9317e514b222fed989c4a9dbbe82cfad2275729b Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 5 Aug 2020 08:28:58 +0000 Subject: [PATCH] S2S unresolve, C2S resolve & unresolve, use C2S in the UI buttons --- config/models | 2 - src/Vervis/API.hs | 447 +++++++++++++++++++++++-------- src/Vervis/ActivityPub.hs | 57 ++++ src/Vervis/Client.hs | 123 ++++++++- src/Vervis/Federation/Offer.hs | 457 ++++++++++++++++++++++---------- src/Vervis/Federation/Ticket.hs | 4 - src/Vervis/Form/Ticket.hs | 2 - src/Vervis/Handler/Client.hs | 70 ++++- src/Vervis/Handler/Ticket.hs | 62 +---- src/Vervis/Migration.hs | 4 + src/Vervis/WorkItem.hs | 4 + src/Web/ActivityPub.hs | 6 +- src/Yesod/MonadSite.hs | 5 + templates/ticket/one.hamlet | 4 +- 14 files changed, 897 insertions(+), 350 deletions(-) diff --git a/config/models b/config/models index 1c08621..5c86469 100644 --- a/config/models +++ b/config/models @@ -368,8 +368,6 @@ Ticket description Text -- HTML assignee PersonId Maybe status TicketStatus - closed UTCTime - closer PersonId Maybe -- UniqueTicket project number diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 668013f..bcebe91 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -20,6 +20,7 @@ module Vervis.API , followC , offerTicketC , offerDepC + , resolveC , undoC , pushCommitsC , getFollowersCollection @@ -855,8 +856,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , ticketDescription = unTextHtml desc , ticketAssignee = Nothing , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing } ltid <- insert LocalTicket { localTicketTicket = tid @@ -1514,8 +1513,6 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar , ticketDescription = unTextHtml desc , ticketAssignee = Nothing , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing } ltid <- insert LocalTicket { localTicketTicket = tid @@ -1585,6 +1582,59 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, makeRecipientSet actors collections) +verifyHosterRecip _ _ (Right _) = return () +verifyHosterRecip localRecips name (Left wi) = + fromMaybeE (verify wi) $ + name <> " ticket hoster actor isn't listed as a recipient" + where + verify (WorkItemSharerTicket shr _ _) = do + sharerSet <- lookup shr localRecips + guard $ localRecipSharer $ localRecipSharerDirect sharerSet + verify (WorkItemProjectTicket shr prj _) = do + sharerSet <- lookup shr localRecips + projectSet <- lookup prj $ localRecipProjectRelated sharerSet + guard $ localRecipProject $ localRecipProjectDirect projectSet + verify (WorkItemRepoPatch shr rp _) = do + sharerSet <- lookup shr localRecips + repoSet <- lookup rp $ localRecipRepoRelated sharerSet + guard $ localRecipRepo $ localRecipRepoDirect repoSet + +workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = + let authorC = + case author of + Left shr -> [LocalPersonCollectionSharerFollowers shr] + Right _ -> [] + ticketC = + case ident of + Left (wi, _) -> [wiFollowers wi] + Right _ -> [] + (contextA, contextC) = + case context of + Left local -> + case local of + Left (shr, prj) -> + ( [LocalActorProject shr prj] + , [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + ) + Right (shr, rp) -> + ( [LocalActorRepo shr rp] + , [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] + ) + Right _ -> ([], []) + in (contextA, authorC ++ ticketC ++ contextC) + +workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr +workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj +workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp + +actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr +actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj +actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp + offerDepC :: Entity Person -> Sharer @@ -1698,25 +1748,6 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = forkWorker "offerDepC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept return obiidOffer where - runWorkerExcept action = do - site <- askSite - ExceptT $ liftIO $ runWorker (runExceptT action) site - verifyHosterRecip _ _ (Right _) = return () - verifyHosterRecip localRecips name (Left wi) = - fromMaybeE (verify wi) $ - name <> " ticket hoster actor isn't listed as a recipient" - where - verify (WorkItemSharerTicket shr _ _) = do - sharerSet <- lookup shr localRecips - guard $ localRecipSharer $ localRecipSharerDirect sharerSet - verify (WorkItemProjectTicket shr prj _) = do - sharerSet <- lookup shr localRecips - projectSet <- lookup prj $ localRecipProjectRelated sharerSet - guard $ localRecipProject $ localRecipProjectDirect projectSet - verify (WorkItemRepoPatch shr rp _) = do - sharerSet <- lookup shr localRecips - repoSet <- lookup rp $ localRecipRepoRelated sharerSet - guard $ localRecipRepo $ localRecipRepoDirect repoSet insertOfferToOutbox shrUser now obid blinded = do hLocal <- asksSite siteInstanceHost obiid <- insertEmptyOutboxItem obid now @@ -1733,33 +1764,6 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = } update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) - workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = - let authorC = - case author of - Left shr -> [LocalPersonCollectionSharerFollowers shr] - Right _ -> [] - ticketC = - case ident of - Left (wi, _) -> [wiFollowers wi] - Right _ -> [] - (contextA, contextC) = - case context of - Left local -> - case local of - Left (shr, prj) -> - ( [LocalActorProject shr prj] - , [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - ) - Right (shr, rp) -> - ( [LocalActorRepo shr rp] - , [ LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - ] - ) - Right _ -> ([], []) - in (contextA, authorC ++ ticketC ++ contextC) insertDep now pidAuthor obiidOffer ltidParent child obiidAccept = do tdid <- insert LocalTicketDependency { localTicketDependencyParent = ltidParent @@ -1839,91 +1843,306 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) - where - authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] - authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] - actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr - actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj - actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp + +insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve obiidAccept = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + wiFollowers <- askWorkItemFollowers + hLocal <- asksSite siteInstanceHost + + obikhidResolve <- encodeKeyHashid obiidResolve + obikhidAccept <- encodeKeyHashid obiidAccept + + let audAuthor = + AudLocal + [LocalActorSharer shrUser] + [LocalPersonCollectionSharerFollowers shrUser] + audTicketContext = contextAudience ctx + audTicketAuthor = authorAudience author + audTicketFollowers = AudLocal [] [wiFollowers wi] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ + audAuthor : + audTicketAuthor : + audTicketFollowers : + audTicketContext + + actor = workItemActor wi + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + actorOutboxItem actor obikhidAccept + , activityActor = encodeRouteLocal $ renderLocalActor actor + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + encodeRouteHome $ SharerOutboxItemR shrUser obikhidResolve + , acceptResult = Nothing + } + } + + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + +resolveC + :: Entity Person + -> Sharer + -> Maybe TextHtml + -> Audience URIMode + -> Resolve URIMode + -> ExceptT Text Handler OutboxItemId +resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObject) = do + 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 + 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) + return (projectOutbox j, projectInbox j) + WorkItemRepoPatch 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 + , activitySummary = summary + , activityAudience = blinded + , activitySpecific = ResolveActivity $ Resolve uObject + } + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (obiid, doc, luAct) + + insertResolve ltid obiidResolve obiidAccept = do + trid <- insert TicketResolve + { ticketResolveTicket = ltid + , ticketResolveAccept = obiidAccept + } + insert_ TicketResolveLocal + { ticketResolveLocalTicket = trid + , ticketResolveLocalActivity = obiidResolve + } + tid <- localTicketTicket <$> getJust ltid + update tid [TicketStatus =. TSClosed] undoC - :: ShrIdent + :: Entity Person + -> Sharer -> Maybe TextHtml -> Audience URIMode -> Undo URIMode -> ExceptT Text Handler OutboxItemId -undoC shrUser summary audience undo@(Undo luObject) = do +undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObject) = do + let shrUser = sharerIdent sharerUser + object <- parseActivity uObject ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience - fromMaybeE mrecips "Follow with no recipients" + fromMaybeE mrecips "Undo with no recipients" federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients specified" - route <- - fromMaybeE - (decodeRouteLocal luObject) - "Undo object isn't a valid route" - obiidOriginal <- case route of - SharerOutboxItemR shr obikhid - | shr == shrUser -> - decodeKeyHashidE obikhid "Undo object invalid obikhid" - _ -> throwE "Undo object isn't actor's outbox item route" - (obiidUndo, doc, remotesHttp) <- runDBExcept $ do - Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser - obi <- do - mobi <- lift $ get obiidOriginal - fromMaybeE mobi "Undo object obiid doesn't exist in DB" - unless (outboxItemOutbox obi == personOutbox personAuthor) $ - throwE "Undo object obiid belongs to different actor" - lift $ do - deleteFollow obiidOriginal - deleteFollowRemote obiidOriginal - deleteFollowRemoteRequest obiidOriginal - let obidAuthor = personOutbox personAuthor - (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded - let ibidAuthor = personInbox personAuthor - fsidAuthor = personFollowers personAuthor - knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips - remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes - return (obiidUndo, doc, remotesHttp) - lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidUndo doc remotesHttp - return obiidUndo + 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 <- + 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) + return (projectOutbox j, projectInbox j) + WorkItemRepoPatch 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) + 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 where - getAuthor shr = do - sid <- getKeyBy404 $ UniqueSharer shr - getBy404 $ UniquePersonIdent sid - deleteFollow obiid = do - mfid <- getKeyBy $ UniqueFollowFollow obiid - traverse_ delete mfid - deleteFollowRemote obiid = do - mfrid <- getKeyBy $ UniqueFollowRemoteFollow obiid - traverse_ delete mfrid - deleteFollowRemoteRequest obiid = do - mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid - traverse_ delete mfrrid - insertUndoToOutbox obid blinded = do + insertUndoToOutbox shrUser now obid blinded = do hLocal <- asksSite siteInstanceHost + obiid <- insertEmptyOutboxItem obid now encodeRouteLocal <- getEncodeRouteLocal - let activity mluAct = Doc hLocal Activity - { activityId = mluAct + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = Doc hLocal Activity + { activityId = Just luAct , activityActor = encodeRouteLocal $ SharerR shrUser , activitySummary = summary , activityAudience = blinded - , activitySpecific = UndoActivity undo + , activitySpecific = UndoActivity $ Undo uObject } - now <- liftIO getCurrentTime - obiid <- insert OutboxItem - { outboxItemOutbox = obid - , outboxItemActivity = - persistJSONObjectFromDoc $ activity Nothing - , outboxItemPublished = now - } - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = activity $ Just luAct 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 + return $ Just $ ticketResolveTicket tr + 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 + return $ Just $ ticketResolveTicket tr + pushCommitsC :: (Entity Person, Sharer) -> Html diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 4ec400a..6545b41 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -52,6 +52,8 @@ module Vervis.ActivityPub , insertEmptyOutboxItem , verifyContentTypeAP , verifyContentTypeAP_E + , parseActivity + , getActivity ) where @@ -1208,3 +1210,58 @@ verifyContentTypeAP_E = do typeAS2 = "application/ld+json; \ \profile=\"https://www.w3.org/ns/activitystreams\"" + +parseActivity u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "Object isn't a valid route" + case route of + SharerOutboxItemR shr obikhid -> + (LocalActorSharer shr,) <$> + decodeKeyHashidE obikhid "No such obikhid" + ProjectOutboxItemR shr prj obikhid -> do + (LocalActorProject shr prj,) <$> + decodeKeyHashidE obikhid "No such obikhid" + RepoOutboxItemR shr rp obikhid -> do + (LocalActorRepo shr rp,) <$> + decodeKeyHashidE obikhid "No such obikhid" + else return $ Right u + +getActivity (Left (actor, obiid)) = Just . Left <$> do + obid <- getActorOutbox actor + obi <- do + mobi <- lift $ get obiid + fromMaybeE mobi "No such obiid" + unless (outboxItemOutbox obi == obid) $ + throwE "Actor/obiid mismatch" + return (actor, obiid) + where + getActorOutbox (LocalActorSharer shr) = do + sid <- do + msid <- lift $ getKeyBy $ UniqueSharer shr + fromMaybeE msid "No such sharer" + p <- do + mp <- lift $ getValBy $ UniquePersonIdent sid + fromMaybeE mp "No such person" + return $ personOutbox p + getActorOutbox (LocalActorProject shr prj) = do + sid <- do + msid <- lift $ getKeyBy $ UniqueSharer shr + fromMaybeE msid "No such sharer" + j <- do + mj <- lift $ getValBy $ UniqueProject prj sid + fromMaybeE mj "No such project" + return $ projectOutbox j + getActorOutbox (LocalActorRepo shr rp) = do + sid <- do + msid <- lift $ getKeyBy $ UniqueSharer shr + fromMaybeE msid "No such sharer" + r <- do + mr <- lift $ getValBy $ UniqueRepo rp sid + fromMaybeE mr "No such repo" + return $ repoOutbox r +getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do + iid <- MaybeT $ getKeyBy $ UniqueInstance h + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu + MaybeT $ getKeyBy $ UniqueRemoteActivity roid diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 8d3b64a..2963178 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -23,10 +23,12 @@ module Vervis.Client , followRepo , offerTicket , createTicket + , resolve , undoFollowSharer , undoFollowProject , undoFollowTicket , undoFollowRepo + , unresolve ) where @@ -47,7 +49,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Network.FedURI -import Web.ActivityPub hiding (Follow, Ticket) +import Web.ActivityPub hiding (Follow, Ticket, Project, Repo) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -57,13 +59,17 @@ import Yesod.RenderSource import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local import Vervis.ActivityPub +import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Ticket +import Vervis.WorkItem createThread :: (MonadSite m, SiteEnv m ~ App) @@ -315,6 +321,37 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context return (summary, audience, create) +resolve + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> FedURI + -> m (Either Text (Maybe TextHtml, Audience URIMode, Resolve URIMode)) +resolve shrUser uObject = runExceptT $ do + encodeRouteHome <- getEncodeRouteHome + wiFollowers <- askWorkItemFollowers + object <- parseWorkItem "Resolve object" uObject + WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" object + let audAuthor = + AudLocal + [LocalActorSharer shrUser] + [LocalPersonCollectionSharerFollowers shrUser] + audTicketContext = contextAudience context + audTicketAuthor = authorAudience author + audTicketFollowers = + case ident of + Left (wi, _ltid) -> AudLocal [] [wiFollowers wi] + Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] + + (_, _, _, audLocal, audRemote) = + collectAudience $ + audAuthor : + audTicketAuthor : + audTicketFollowers : + audTicketContext + + recips = map encodeRouteHome audLocal ++ audRemote + return (Nothing, Audience recips [] [] [] [] [], Resolve uObject) + undoFollow :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent @@ -347,7 +384,7 @@ undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do |] let undo = Undo { undoObject = - encodeRouteLocal $ SharerOutboxItemR shrAuthor obikhidFollow + encodeRouteHome $ SharerOutboxItemR shrAuthor obikhidFollow } audience = Audience [encodeRouteHome recipRoute] [] [] [] [] [] return (summary, audience, undo) @@ -442,3 +479,85 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = mr <- lift $ getValBy $ UniqueRepo rpFollowee sidFollowee repoFollowers <$> fromMaybeE mr "Unfollow target no such local repo" + +data ActorEntity + = ActorPerson (Entity Person) + | ActorProject (Entity Project) + | ActorRepo (Entity Repo) + +unresolve + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> WorkItem + -> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode)) +unresolve shrUser wi = runExceptT $ do + encodeRouteHome <- getEncodeRouteHome + wiFollowers <- askWorkItemFollowers + WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" $ Left wi + ltid <- + case ident of + Left (_, ltid) -> return ltid + Right _ -> error "Local WorkItem expected!" + uResolve <- runSiteDBExcept $ do + mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid + trid <- fromMaybeE mtrid "Ticket already isn't resolved" + trx <- + lift $ + requireEitherAlt + (getValBy $ UniqueTicketResolveLocal trid) + (getValBy $ UniqueTicketResolveRemote trid) + "No TRX" + "Both TRL and TRR" + case trx of + Left trl -> lift $ do + let obiid = ticketResolveLocalActivity trl + obid <- outboxItemOutbox <$> getJust obiid + ent <- getOutboxActorEntity obid + obikhid <- encodeKeyHashid obiid + encodeRouteHome . flip outboxItemRoute obikhid <$> + actorEntityPath ent + Right trr -> lift $ do + roid <- + remoteActivityIdent <$> + getJust (ticketResolveRemoteActivity trr) + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return $ ObjURI (instanceHost i) (remoteObjectIdent ro) + let audAuthor = + AudLocal + [LocalActorSharer shrUser] + [LocalPersonCollectionSharerFollowers shrUser] + audTicketContext = contextAudience context + audTicketAuthor = authorAudience author + audTicketFollowers = AudLocal [] [wiFollowers wi] + + (_, _, _, audLocal, audRemote) = + collectAudience $ + audAuthor : + audTicketAuthor : + audTicketFollowers : + audTicketContext + + recips = map encodeRouteHome audLocal ++ audRemote + return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) + where + getOutboxActorEntity obid = do + mp <- getBy $ UniquePersonOutbox obid + mj <- getBy $ UniqueProjectOutbox obid + mr <- getBy $ UniqueRepoOutbox obid + case (mp, mj, mr) of + (Nothing, Nothing, Nothing) -> error "obid not in use" + (Just p, Nothing, Nothing) -> return $ ActorPerson p + (Nothing, Just j, Nothing) -> return $ ActorProject j + (Nothing, Nothing, Just r) -> return $ ActorRepo r + actorEntityPath (ActorPerson (Entity _ p)) = + LocalActorSharer . sharerIdent <$> getJust (personIdent p) + actorEntityPath (ActorProject (Entity _ j)) = + flip LocalActorProject (projectIdent j) . sharerIdent <$> + getJust (projectSharer j) + actorEntityPath (ActorRepo (Entity _ r)) = + flip LocalActorRepo (repoIdent r) . sharerIdent <$> + getJust (repoSharer r) + outboxItemRoute (LocalActorSharer shr) = SharerOutboxItemR shr + outboxItemRoute (LocalActorProject shr prj) = ProjectOutboxItemR shr prj + outboxItemRoute (LocalActorRepo shr rp) = RepoOutboxItemR shr rp diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 544bc91..987d3cc 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -39,6 +39,7 @@ import Data.Aeson import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) +import Data.Either import Data.Foldable import Data.Function import Data.List (nub, union) @@ -533,73 +534,77 @@ repoFollowF shr rp = followers (r, Nothing) = repoFollowers r followers (_, Just lt) = localTicketFollowers lt -undoF - :: Route App - -> AppDB (Entity a) - -> (a -> InboxId) - -> (a -> FollowerSetId) - -> (Key a -> FollowerSetId -> AppDB (Maybe Text)) - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> Undo URIMode - -> ExceptT Text Handler Text -undoF - recipRoute getRecip recipInbox recipFollowers trySubObjects - now author body mfwd luUndo (Undo luObj) = do - lift $ runDB $ do - Entity idRecip recip <- getRecip - ractid <- insertActivity luUndo - mreason <- deleteRemoteFollow idRecip (recipFollowers recip) - case mreason of - Just reason -> return $ "Not using this Undo: " <> reason - Nothing -> do - inserted <- insertToInbox (recipInbox recip) ractid - encodeRouteLocal <- getEncodeRouteLocal - let me = localUriPath $ encodeRouteLocal recipRoute - return $ - if inserted - then "Undo applied and inserted to inbox of " <> me - else "Undo applied and already exists in inbox of " <> me +getFollow (Left _) = return Nothing +getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid + +getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid) +getResolve (Right ractid) = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid) + +deleteResolve myWorkItem prepareAccept tr = do + let (trid, trxid) = + case tr of + Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid) + Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid) + ltid <- ticketResolveTicket <$> getJust trid + wi <- getWorkItem ltid + case myWorkItem wi of + Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing) + Just wiData -> do + bitraverse delete delete trxid + delete trid + (colls, accept) <- prepareAccept wiData + return ("Ticket unresolved", Just colls, Just accept) + +deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf) + | remoteFollowActor rf /= remoteAuthorId author = + return "Undo sent by different actor than the one who sent the Follow" + | remoteFollowTarget rf == fsidRecip = do + delete rfid + return "Undo applied to sharer RemoteFollow" + | otherwise = do + r <- tryTicket $ remoteFollowTarget rf + when (isRight r) $ delete rfid + return $ either id id r where - insertActivity luUndo = do - let iidAuthor = remoteAuthorInstance author - roid <- - either entityKey id <$> insertBy' (RemoteObject iidAuthor luUndo) - let jsonObj = persistJSONFromBL $ actbBL body - ract = RemoteActivity roid jsonObj now - either entityKey id <$> insertBy' ract - deleteRemoteFollow idRecip fsidRecip = do - let iidAuthor = remoteAuthorInstance author - mractidObj <- runMaybeT $ do - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iidAuthor luObj - MaybeT $ getKeyBy $ UniqueRemoteActivity roid - case mractidObj of - Nothing -> return $ Just "Undo object isn't a known activity" - Just ractidObj -> do - merf <- getBy $ UniqueRemoteFollowFollow ractidObj - case merf of - Nothing -> return $ Just "Undo object doesn't match an active RemoteFollow" - Just (Entity rfid rf) - | remoteFollowActor rf /= remoteAuthorId author -> - return $ Just "Undo sent by different actor than the one who sent the Follow" - | remoteFollowTarget rf == fsidRecip -> do - delete rfid - return Nothing - | otherwise -> do - mr <- trySubObjects idRecip (remoteFollowTarget rf) - when (isNothing mr) $ delete rfid - return mr - insertToInbox ibidRecip ractid = do - ibiid <- insert $ InboxItem False - mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid - case mibrid of - Nothing -> do - delete ibiid - return False - Just _ -> return True + tryTicket fsid = do + mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid + case mltid of + Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket" + Just ltid -> do + wi <- getWorkItem ltid + return $ + if myWorkItem wi + then Right "Undo applied to RemoteFollow of my ticket" + else Left "Undo is of RemoteFollow of a ticket that isn't mine" + +insertAcceptOnUndo actor author luUndo obiid auds = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhid <- encodeKeyHashid obiid + let hAuthor = objUriAuthority $ remoteAuthorURI author + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience auds + + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ actorOutboxItem actor obikhid + , activityActor = encodeRouteLocal $ renderLocalActor actor + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hAuthor luUndo + , acceptResult = Nothing + } + } + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + where + actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr + actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj + actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp sharerUndoF :: ShrIdent @@ -610,32 +615,88 @@ sharerUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -sharerUndoF shr = - undoF - (SharerR shr) - getRecip - personInbox - personFollowers - tryTicket +sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do + object <- parseActivity uObj + mmmhttp <- runDBExcept $ do + p <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getValBy404 $ UniquePersonIdent sid + mractid <- lift $ insertToInbox now author body (personInbox p) luUndo True + for mractid $ \ ractid -> do + mobject' <- getActivity object + lift $ for mobject' $ \ object' -> do + mobject'' <- runMaybeT $ + Left <$> MaybeT (getFollow object') <|> + Right <$> MaybeT (getResolve object') + for mobject'' $ \ object'' -> do + (result, mfwdColl, macceptAuds) <- + case object'' of + Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (personFollowers p) erf + Right tr -> deleteResolve myWorkItem prepareAccept tr + mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do + let sieve = makeRecipientSet [] colls + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent p) sig remoteRecips + mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do + obiidAccept <- insertEmptyOutboxItem (personOutbox p) now + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptOnUndo (LocalActorSharer shrRecip) author luUndo obiidAccept acceptAuds + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorSharer shrRecip) + (personInbox p) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (result, mremotesHttpFwd, mremotesHttpAccept) + case mmmhttp of + Nothing -> return "Activity already in my inbox" + Just mmhttp -> + case mmhttp of + Nothing -> return "Undo object isn't a known activity" + Just mhttp -> + case mhttp of + Nothing -> return "Undo object isn't in use" + Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "sharerUndoF inbox-forwarding" $ + deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes + for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> + forkWorker "sharerUndoF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + let fwdMsg = + case mremotesHttpFwd of + Nothing -> "No inbox-forwarding" + Just _ -> "Did inbox-forwarding" + acceptMsg = + case mremotesHttpAccept of + Nothing -> "Didn't send Accept" + Just _ -> "Sent Accept" + return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg where - getRecip = do - sid <- getKeyBy404 $ UniqueSharer shr - getBy404 $ UniquePersonIdent sid - tryTicket pid fsid = do - mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid - case mltid of - Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this sharer" - Just ltid -> do - mtal <- getBy $ UniqueTicketAuthorLocal ltid - case mtal of - Just (Entity talid tal) - | ticketAuthorLocalAuthor tal == pid -> do - mtup <- getBy $ UniqueTicketUnderProjectAuthor talid - return $ - case mtup of - Nothing -> Nothing - Just _ -> Just "Undo object is a RemoteFollow of a ticket authored by this sharer, but is hosted by the project" - _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another author" + myWorkItem (WorkItemSharerTicket shr talid patch) + | shr == shrRecip = Just (talid, patch) + myWorkItem _ = Nothing + + prepareAccept (talid, patch) = do + talkhid <- encodeKeyHashid talid + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + ticketFollowers = + if patch + then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid + else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + audTicket = + AudLocal [] [ticketFollowers] + return ([ticketFollowers], [audAuthor, audTicket]) projectUndoF :: ShrIdent @@ -647,35 +708,86 @@ projectUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -projectUndoF shr prj = - undoF - (ProjectR shr prj) - getRecip - projectInbox - projectFollowers - tryTicket +projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do + object <- parseActivity uObj + mmmhttp <- runDBExcept $ do + Entity jid j <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueProject prjRecip sid + mractid <- lift $ insertToInbox now author body (projectInbox j) luUndo False + for mractid $ \ ractid -> do + mobject' <- getActivity object + lift $ for mobject' $ \ object' -> do + mobject'' <- runMaybeT $ + Left <$> MaybeT (getFollow object') <|> + Right <$> MaybeT (getResolve object') + for mobject'' $ \ object'' -> do + (result, mfwdColl, macceptAuds) <- + case object'' of + Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (projectFollowers j) erf + Right tr -> deleteResolve myWorkItem prepareAccept tr + mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do + let sieve = makeRecipientSet [] colls + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips + mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do + obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorProject shrRecip prjRecip) + (projectInbox j) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (result, mremotesHttpFwd, mremotesHttpAccept) + case mmmhttp of + Nothing -> return "Activity already in my inbox" + Just mmhttp -> + case mmhttp of + Nothing -> return "Undo object isn't a known activity" + Just mhttp -> + case mhttp of + Nothing -> return "Undo object isn't in use" + Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "projectUndoF inbox-forwarding" $ + deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes + for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> + forkWorker "projectUndoF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + let fwdMsg = + case mremotesHttpFwd of + Nothing -> "No inbox-forwarding" + Just _ -> "Did inbox-forwarding" + acceptMsg = + case mremotesHttpAccept of + Nothing -> "Didn't send Accept" + Just _ -> "Sent Accept" + return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg where - getRecip = do - sid <- getKeyBy404 $ UniqueSharer shr - getBy404 $ UniqueProject prj sid - tryTicket jid fsid = do - mlt <- getValBy $ UniqueLocalTicketFollowers fsid - case mlt of - Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this project" - Just lt -> do - mtpl <- runMaybeT $ do - tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt - tpl <- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid - return (tclid, tpl) - case mtpl of - Just (tclid, tpl) - | ticketProjectLocalProject tpl == jid -> do - mtup <- getBy $ UniqueTicketUnderProjectProject tclid - return $ - case mtup of - Nothing -> Just "Undo object is a RemoteFollow of a ticket under this project, but is hosted by the author" - Just _ -> Nothing - _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project" + myWorkItem (WorkItemProjectTicket shr prj ltid) + | shr == shrRecip && prj == prjRecip = Just ltid + myWorkItem _ = Nothing + + prepareAccept ltid = do + ltkhid <- encodeKeyHashid ltid + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + ticketFollowers = + LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + audTicket = + AudLocal [] [ticketFollowers] + return ([ticketFollowers], [audAuthor, audTicket]) repoUndoF :: ShrIdent @@ -687,32 +799,83 @@ repoUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -repoUndoF shr rp = - undoF - (RepoR shr rp) - getRecip - repoInbox - repoFollowers - tryPatch +repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do + object <- parseActivity uObj + mmmhttp <- runDBExcept $ do + Entity rid r <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueRepo rpRecip sid + mractid <- lift $ insertToInbox now author body (repoInbox r) luUndo False + for mractid $ \ ractid -> do + mobject' <- getActivity object + lift $ for mobject' $ \ object' -> do + mobject'' <- runMaybeT $ + Left <$> MaybeT (getFollow object') <|> + Right <$> MaybeT (getResolve object') + for mobject'' $ \ object'' -> do + (result, mfwdColl, macceptAuds) <- + case object'' of + Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (repoFollowers r) erf + Right tr -> deleteResolve myWorkItem prepareAccept tr + mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do + let sieve = makeRecipientSet [] colls + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips + mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do + obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptOnUndo (LocalActorRepo shrRecip rpRecip) author luUndo obiidAccept acceptAuds + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorRepo shrRecip rpRecip) + (repoInbox r) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (result, mremotesHttpFwd, mremotesHttpAccept) + case mmmhttp of + Nothing -> return "Activity already in my inbox" + Just mmhttp -> + case mmhttp of + Nothing -> return "Undo object isn't a known activity" + Just mhttp -> + case mhttp of + Nothing -> return "Undo object isn't in use" + Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "repoUndoF inbox-forwarding" $ + deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes + for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> + forkWorker "repoUndoF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + let fwdMsg = + case mremotesHttpFwd of + Nothing -> "No inbox-forwarding" + Just _ -> "Did inbox-forwarding" + acceptMsg = + case mremotesHttpAccept of + Nothing -> "Didn't send Accept" + Just _ -> "Sent Accept" + return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg where - getRecip = do - sid <- getKeyBy404 $ UniqueSharer shr - getBy404 $ UniqueRepo rp sid - tryPatch rid fsid = do - mlt <- getValBy $ UniqueLocalTicketFollowers fsid - case mlt of - Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this repo" - Just lt -> do - mtrl <- runMaybeT $ do - tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt - trl <- MaybeT $ getValBy $ UniqueTicketRepoLocal tclid - return (tclid, trl) - case mtrl of - Just (tclid, trl) - | ticketRepoLocalRepo trl == rid -> do - mtup <- getBy $ UniqueTicketUnderProjectProject tclid - return $ - case mtup of - Nothing -> Just "Undo object is a RemoteFollow of a patch under this repo, but is hosted by the author" - Just _ -> Nothing - _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project" + myWorkItem (WorkItemRepoPatch shr rp ltid) + | shr == shrRecip && rp == rpRecip = Just ltid + myWorkItem _ = Nothing + + prepareAccept ltid = do + ltkhid <- encodeKeyHashid ltid + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + ticketFollowers = + LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + audTicket = + AudLocal [] [ticketFollowers] + return ([ticketFollowers], [audAuthor, audTicket]) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 254f632..3d10789 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -256,8 +256,6 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept , ticketDescription = unTextHtml content , ticketAssignee = Nothing , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing } ltid <- insert LocalTicket { localTicketTicket = tid @@ -804,8 +802,6 @@ insertRemoteTicket mktxl author luTicket published summary content source ractid , ticketDescription = unTextHtml content , ticketAssignee = Nothing , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing } tclid <- insert TicketContextLocal { ticketContextLocalTicket = tid diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index f0666ea..d751976 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -156,8 +156,6 @@ editTicketContentAForm ticket = Ticket <*> pure (ticketDescription ticket) <*> pure (ticketAssignee ticket) <*> pure (ticketStatus ticket) - <*> pure (ticketClosed ticket) - <*> pure (ticketCloser ticket) tEditField :: TicketTextParam diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index ae967e2..18eac4e 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -34,6 +34,8 @@ module Vervis.Handler.Client , postNotificationsR , postProjectTicketsR + , postProjectTicketCloseR + , postProjectTicketOpenR ) where @@ -90,6 +92,7 @@ import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Path import Vervis.Settings +import Vervis.Ticket import qualified Vervis.Client as C import qualified Vervis.Darcs as D @@ -244,6 +247,12 @@ getUser = do s <- runDB $ getJust $ personIdent p return (sharerIdent s, pid) +getUser' :: Handler (Entity Person, Sharer) +getUser' = do + ep@(Entity _ p) <- requireVerifiedAuth + s <- runDB $ getJust $ personIdent p + return (ep, s) + getUserShrIdent :: Handler ShrIdent getUserShrIdent = fst <$> getUser @@ -305,8 +314,10 @@ postSharerOutboxR shr = do OfferDep dep -> offerDepC eperson sharer summary audience dep target _ -> throwE "Unsupported Offer 'object' type" + ResolveActivity resolve -> + resolveC eperson sharer summary audience resolve UndoActivity undo -> - undoC shr summary audience undo + undoC eperson sharer summary audience undo _ -> throwE "Unsupported activity type" postPublishR :: Handler Html @@ -572,41 +583,45 @@ setUnfollowMessage shr (Right obiid) = do postSharerUnfollowR :: ShrIdent -> Handler () postSharerUnfollowR shrFollowee = do - (shrAuthor, pidAuthor) <- getUser + (ep@(Entity pid _), s) <- getUser' + let shrAuthor = sharerIdent s eid <- runExceptT $ do (summary, audience, undo) <- - ExceptT $ undoFollowSharer shrAuthor pidAuthor shrFollowee - undoC shrAuthor (Just summary) audience undo + ExceptT $ undoFollowSharer shrAuthor pid shrFollowee + undoC ep s (Just summary) audience undo setUnfollowMessage shrAuthor eid redirect $ SharerR shrFollowee postProjectUnfollowR :: ShrIdent -> PrjIdent -> Handler () postProjectUnfollowR shrFollowee prjFollowee = do - (shrAuthor, pidAuthor) <- getUser + (ep@(Entity pid _), s) <- getUser' + let shrAuthor = sharerIdent s eid <- runExceptT $ do (summary, audience, undo) <- - ExceptT $ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee - undoC shrAuthor (Just summary) audience undo + ExceptT $ undoFollowProject shrAuthor pid shrFollowee prjFollowee + undoC ep s (Just summary) audience undo setUnfollowMessage shrAuthor eid redirect $ ProjectR shrFollowee prjFollowee postProjectTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler () postProjectTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do - (shrAuthor, pidAuthor) <- getUser + (ep@(Entity pid _), s) <- getUser' + let shrAuthor = sharerIdent s eid <- runExceptT $ do (summary, audience, undo) <- - ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee - undoC shrAuthor (Just summary) audience undo + ExceptT $ undoFollowTicket shrAuthor pid shrFollowee prjFollowee tkhidFollowee + undoC ep s (Just summary) audience undo setUnfollowMessage shrAuthor eid redirect $ ProjectTicketR shrFollowee prjFollowee tkhidFollowee postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler () postRepoUnfollowR shrFollowee rpFollowee = do - (shrAuthor, pidAuthor) <- getUser + (ep@(Entity pid _), s) <- getUser' + let shrAuthor = sharerIdent s eid <- runExceptT $ do (summary, audience, undo) <- - ExceptT $ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee - undoC shrAuthor (Just summary) audience undo + ExceptT $ undoFollowRepo shrAuthor pid shrFollowee rpFollowee + undoC ep s (Just summary) audience undo setUnfollowMessage shrAuthor eid redirect $ RepoR shrFollowee rpFollowee @@ -836,3 +851,32 @@ postProjectTicketsR shr prj = do Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e Right _ -> setMessage "Ticket created." redirect $ ProjectTicketR shr prj ltkhid + +postProjectTicketCloseR + :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html +postProjectTicketCloseR shr prj ltkhid = do + encodeRouteHome <- getEncodeRouteHome + ep@(Entity _ p) <- requireVerifiedAuth + s <- runDB $ getJust $ personIdent p + let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid + result <- runExceptT $ do + (summary, audience, specific) <- ExceptT $ resolve (sharerIdent s) uTicket + resolveC ep s summary audience specific + case result of + Left e -> setMessage $ toHtml $ "Error: " <> e + Right _obiid -> setMessage "Ticket closed" + redirect $ ProjectTicketR shr prj ltkhid + +postProjectTicketOpenR + :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html +postProjectTicketOpenR shr prj ltkhid = do + ep@(Entity _ p) <- requireVerifiedAuth + ltid <- decodeKeyHashid404 ltkhid + s <- runDB $ getJust $ personIdent p + result <- runExceptT $ do + (summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) (WorkItemProjectTicket shr prj ltid) + undoC ep s summary audience specific + case result of + Left e -> setMessage $ toHtml $ "Error: " <> e + Right _obiid -> setMessage "Ticket reopened" + redirect $ ProjectTicketR shr prj ltkhid diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index d02c3b6..50787a3 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -23,8 +23,6 @@ module Vervis.Handler.Ticket , postProjectTicketR , getProjectTicketEditR , postProjectTicketAcceptR - , postProjectTicketCloseR - , postProjectTicketOpenR , postProjectTicketClaimR , postProjectTicketUnclaimR , getProjectTicketAssignR @@ -299,7 +297,7 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty getProjectTicketR shar proj ltkhid = do mpid <- maybeAuthId ( wshr, wfl, - author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <- + author, massignee, ticket, lticket, tparams, eparams, cparams) <- runDB $ do (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid (wshr, wid, wfl) <- do @@ -327,24 +325,12 @@ getProjectTicketR shar proj ltkhid = do person <- get404 apid sharer <- get404 $ personIdent person return (sharer, fromMaybe False $ (== apid) <$> mpid) - mcloser <- - case ticketStatus ticket of - TSClosed -> - case ticketCloser ticket of - Just pidCloser -> Just <$> do - person <- getJust pidCloser - getJust $ personIdent person - Nothing -> error "Closer not set for closed ticket" - _ -> - case ticketCloser ticket of - Just _ -> error "Closer set for open ticket" - Nothing -> return Nothing tparams <- getTicketTextParams tid wid eparams <- getTicketEnumParams tid wid cparams <- getTicketClasses tid wid return ( wshr, wfl - , author', massignee, mcloser, ticket, lticket + , author', massignee, ticket, lticket , tparams, eparams, cparams ) encodeHid <- getEncodeKeyHashid @@ -517,50 +503,6 @@ postProjectTicketAcceptR shr prj ltkhid = do else "Ticket is already accepted." redirect $ ProjectTicketR shr prj ltkhid -postProjectTicketCloseR - :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -postProjectTicketCloseR shr prj ltkhid = do - pid <- requireAuthId - now <- liftIO getCurrentTime - succ <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid - case ticketStatus ticket of - TSClosed -> return False - _ -> do - update tid - [ TicketAssignee =. Nothing - , TicketStatus =. TSClosed - , TicketClosed =. now - , TicketCloser =. Just pid - ] - return True - setMessage $ - if succ - then "Ticket closed." - else "Ticket is already closed." - redirect $ ProjectTicketR shr prj ltkhid - -postProjectTicketOpenR - :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -postProjectTicketOpenR shr prj ltkhid = do - pid <- requireAuthId - now <- liftIO getCurrentTime - succ <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid - case ticketStatus ticket of - TSClosed -> do - update tid - [ TicketStatus =. TSTodo - , TicketCloser =. Nothing - ] - return True - _ -> return False - setMessage $ - if succ - then "Ticket reopened" - else "Ticket is already open." - redirect $ ProjectTicketR shr prj ltkhid - postProjectTicketClaimR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketClaimR shr prj ltkhid = do diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index ac5bbed..5f15223 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1748,6 +1748,10 @@ changes hLocal ctx = obiidAccept <- insert $ OutboxItem276 obidHoster doc closed trid <- insert $ TicketResolve276 ltid obiidAccept insert_ $ TicketResolveLocal276 trid obiidResolve + -- 277 + , removeField "Ticket" "closed" + -- 278 + , removeField "Ticket" "closer" ] migrateDB diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs index 7616ece..5d7f73c 100644 --- a/src/Vervis/WorkItem.hs +++ b/src/Vervis/WorkItem.hs @@ -18,6 +18,7 @@ module Vervis.WorkItem , getWorkItemAuthorDetail , askWorkItemFollowers , contextAudience + , authorAudience , getWorkItemDetail , WorkItemTarget (..) ) @@ -133,6 +134,9 @@ contextAudience ctx = , AudRemote hProject [] (catMaybes [luFollowers, luTeam]) ] +authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] +authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] + getWorkItemDetail :: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail getWorkItemDetail name v = do diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 716f633..f8f3125 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1344,14 +1344,14 @@ encodeResolve :: UriMode u => Resolve u -> Series encodeResolve (Resolve obj) = "object" .= obj data Undo u = Undo - { undoObject :: LocalURI + { undoObject :: ObjURI u } parseUndo :: UriMode u => Authority u -> Object -> Parser (Undo u) -parseUndo a o = Undo <$> withAuthorityO a (o .: "object") +parseUndo a o = Undo <$> o .: "object" encodeUndo :: UriMode u => Authority u -> Undo u -> Series -encodeUndo a (Undo obj) = "object" .= ObjURI a obj +encodeUndo a (Undo obj) = "object" .= obj data SpecificActivity u = AcceptActivity (Accept u) diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs index d5ec64d..731eedc 100644 --- a/src/Yesod/MonadSite.hs +++ b/src/Yesod/MonadSite.hs @@ -28,6 +28,7 @@ module Yesod.MonadSite , runWorkerT , WorkerFor , runWorker + , runWorkerExcept , forkWorker , asyncWorker ) @@ -198,6 +199,10 @@ type WorkerFor site = WorkerT site IO runWorker :: (Yesod site, Site site) => WorkerFor site a -> site -> IO a runWorker = runWorkerT +runWorkerExcept action = do + site <- askSite + ExceptT $ liftIO $ runWorker (runExceptT action) site + forkWorker :: (MonadSite m, Yesod site, Site site, SiteEnv m ~ site) => Text diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index e541407..3ec8786 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -77,9 +77,7 @@ $if ticketStatus ticket /= TSClosed ^{buttonW POST "Close this ticket" (ProjectTicketCloseR shar proj ltkhid)} $of TSClosed - Closed on #{showDate $ ticketClosed ticket} - $maybe closer <- mcloser - by ^{sharerLinkW closer}. + Closed on ___ by ___. ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR shar proj ltkhid)}