diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 6545b41..cb5948f 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -54,6 +54,10 @@ module Vervis.ActivityPub , verifyContentTypeAP_E , parseActivity , getActivity + , ActorEntity (..) + , getOutboxActorEntity + , actorEntityPath + , outboxItemRoute ) where @@ -105,7 +109,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Author (..), Ticket) +import Web.ActivityPub hiding (Author (..), Ticket, Project, Repo) import Yesod.ActivityPub import Yesod.MonadSite import Yesod.FedURI @@ -1265,3 +1269,31 @@ 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 + +data ActorEntity + = ActorPerson (Entity Person) + | ActorProject (Entity Project) + | ActorRepo (Entity Repo) + +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/Client.hs b/src/Vervis/Client.hs index ce8b932..727cfd9 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -480,11 +480,6 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = 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 @@ -540,24 +535,3 @@ unresolve shrUser wi = runExceptT $ do 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/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index a9b0498..32eaca2 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -404,9 +404,9 @@ getRepoPatchesR shr rp = do getRepoPatchR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent getRepoPatchR shr rp ltkhid = do - (ticket, ptid, trl, author, massignee) <- runDB $ do - (_, _, Entity tid t, _, _, Entity _ trl, ta, _, ptid :| _) <- getRepoPatch404 shr rp ltkhid - (,,,,) t ptid trl + (ticket, ptid, trl, author, massignee, mresolved) <- runDB $ do + (_, _, Entity tid t, _, _, Entity _ trl, ta, tr, ptid :| _) <- getRepoPatch404 shr rp ltkhid + (,,,,,) t ptid trl <$> bitraverse (\ (Entity _ tal, _) -> do p <- getJust $ ticketAuthorLocalAuthor tal @@ -423,10 +423,30 @@ getRepoPatchR shr rp ltkhid = do p <- getJust pidAssignee getJust $ personIdent p ) + <*> (for tr $ \ (_, etrx) -> + bitraverse + (\ (Entity _ trl) -> do + let obiid = ticketResolveLocalActivity trl + obid <- outboxItemOutbox <$> getJust obiid + ent <- getOutboxActorEntity obid + actor <- actorEntityPath ent + return (actor, obiid) + ) + (\ (Entity _ trr) -> do + roid <- + remoteActivityIdent <$> + getJust (ticketResolveRemoteActivity trr) + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + etrx + ) hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome encodePatchId <- getEncodeKeyHashid + encodeObiid <- getEncodeKeyHashid let host = case author of Left _ -> hLocal @@ -465,9 +485,12 @@ getRepoPatchR shr rp ltkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee , AP.ticketResolved = - if ticketStatus ticket == TSClosed - then Just (Nothing, Nothing) - else Nothing + let u (Left (actor, obiid)) = + encodeRouteHome $ + outboxItemRoute actor $ encodeObiid obiid + u (Right (i, ro)) = + ObjURI (instanceHost i) (remoteObjectIdent ro) + in (,Nothing) . Just . u <$> mresolved , AP.ticketAttachment = Just ( hLocal , MergeRequest diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 95682eb..16cc293 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -297,9 +297,9 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty getProjectTicketR shar proj ltkhid = do mpid <- maybeAuthId ( wshr, wfl, - author, massignee, ticket, lticket, tparams, eparams, cparams) <- + author, massignee, mresolved, 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 + (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author, resolved) <- getProjectTicket404 shar proj ltkhid (wshr, wid, wfl) <- do w <- get404 $ projectWorkflow project wsharer <- @@ -325,12 +325,30 @@ getProjectTicketR shar proj ltkhid = do person <- get404 apid sharer <- get404 $ personIdent person return (sharer, fromMaybe False $ (== apid) <$> mpid) + mresolved <- for resolved $ \ (_, etrx) -> + bitraverse + (\ (Entity _ trl) -> do + let obiid = ticketResolveLocalActivity trl + obid <- outboxItemOutbox <$> getJust obiid + ent <- getOutboxActorEntity obid + actor <- actorEntityPath ent + return (actor, obiid) + ) + (\ (Entity _ trr) -> do + roid <- + remoteActivityIdent <$> + getJust (ticketResolveRemoteActivity trr) + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + etrx tparams <- getTicketTextParams tid wid eparams <- getTicketEnumParams tid wid cparams <- getTicketClasses tid wid return ( wshr, wfl - , author', massignee, ticket, lticket + , author', massignee, mresolved, ticket, lticket , tparams, eparams, cparams ) encodeHid <- getEncodeKeyHashid @@ -352,6 +370,7 @@ getProjectTicketR shar proj ltkhid = do hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome + encodeKeyHashid <- getEncodeKeyHashid let host = case author of Left _ -> hLocal @@ -394,9 +413,12 @@ getProjectTicketR shar proj ltkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent . fst <$> massignee , AP.ticketResolved = - if ticketStatus ticket == TSClosed - then Just (Nothing, Nothing) - else Nothing + let u (Left (actor, obiid)) = + encodeRouteHome $ + outboxItemRoute actor $ encodeKeyHashid obiid + u (Right (i, ro)) = + ObjURI (instanceHost i) (remoteObjectIdent ro) + in (,Nothing) . Just . u <$> mresolved , AP.ticketAttachment = Nothing } provideHtmlAndAP' host ticketAP $ @@ -1051,9 +1073,9 @@ getSharerTicketsR = getSharerTicketR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerTicketR shr talkhid = do - (ticket, project, massignee) <- runDB $ do - (_, _, Entity _ t, tp, _) <- getSharerTicket404 shr talkhid - (,,) t + (ticket, project, massignee, mresolved) <- runDB $ do + (_, _, Entity _ t, tp, tr) <- getSharerTicket404 shr talkhid + (,,,) t <$> bitraverse (\ (_, Entity _ tpl) -> do j <- getJust $ ticketProjectLocalProject tpl @@ -1076,9 +1098,29 @@ getSharerTicketR shr talkhid = do p <- getJust pidAssignee getJust $ personIdent p ) + <*> (for tr $ \ (_, etrx) -> + bitraverse + (\ (Entity _ trl) -> do + let obiid = ticketResolveLocalActivity trl + obid <- outboxItemOutbox <$> getJust obiid + ent <- getOutboxActorEntity obid + actor <- actorEntityPath ent + return (actor, obiid) + ) + (\ (Entity _ trr) -> do + roid <- + remoteActivityIdent <$> + getJust (ticketResolveRemoteActivity trr) + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + etrx + ) hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome + encodeKeyHashid <- getEncodeKeyHashid let ticketAP = AP.Ticket { AP.ticketLocal = Just ( hLocal @@ -1116,9 +1158,12 @@ getSharerTicketR shr talkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee , AP.ticketResolved = - if ticketStatus ticket == TSClosed - then Just (Nothing, Nothing) - else Nothing + let u (Left (actor, obiid)) = + encodeRouteHome $ + outboxItemRoute actor $ encodeKeyHashid obiid + u (Right (i, ro)) = + ObjURI (instanceHost i) (remoteObjectIdent ro) + in (,Nothing) . Just . u <$> mresolved , AP.ticketAttachment = Nothing } provideHtmlAndAP ticketAP $ redirectToPrettyJSON here