S2S unresolve, C2S resolve & unresolve, use C2S in the UI buttons

config/models

@@ -368,8 +368,6 @@ Ticket
     description Text                -- HTML
     assignee    PersonId      Maybe
     status      TicketStatus
-    closed      UTCTime
-    closer      PersonId      Maybe
 
     -- UniqueTicket project number
 

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] []
+insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve obiidAccept = do
-        authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] []
+    encodeRouteLocal <- getEncodeRouteLocal
-        actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
+    encodeRouteHome <- getEncodeRouteHome
-        actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
+    wiFollowers <- askWorkItemFollowers
-        actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
+    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 <-
+    now <- liftIO getCurrentTime
-        fromMaybeE
+    (obiid, doc, _lu, mwi) <- runDBExcept $ do
-            (decodeRouteLocal luObject)
+        (obiidUndo, docUndo, luUndo) <- lift $ insertUndoToOutbox shrUser now (personOutbox personUser) blinded
-            "Undo object isn't a valid route"
+        mltid <- fmap join $ runMaybeT $ do
-    obiidOriginal <- case route of
+            object' <- MaybeT $ getActivity object
-        SharerOutboxItemR shr obikhid
+            deleteFollow shrUser object' <|> deleteResolve object'
-            | shr == shrUser ->
+        mwi <- lift $ traverse getWorkItem mltid
-                decodeKeyHashidE obikhid "Undo object invalid obikhid"
+        return (obiidUndo, docUndo, luUndo, mwi)
-        _ -> throwE "Undo object isn't actor's outbox item route"
+    mticketDetail <-
-    (obiidUndo, doc, remotesHttp) <- runDBExcept $ do
+        for mwi $ \ wi ->
-        Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser
+            (wi,) <$> runWorkerExcept (getWorkItemDetail "Object" $ Left wi)
-        obi <- do
+    wiFollowers <- askWorkItemFollowers
-            mobi <- lift $ get obiidOriginal
+    let sieve =
-            fromMaybeE mobi "Undo object obiid doesn't exist in DB"
+            case mticketDetail of
-        unless (outboxItemOutbox obi == personOutbox personAuthor) $
+                Nothing -> makeRecipientSet [] [LocalPersonCollectionSharerFollowers shrUser]
-            throwE "Undo object obiid belongs to different actor"
+                Just (_wi, ticketDetail) ->
-        lift $ do
+                    let (actors, colls) =
-            deleteFollow obiidOriginal
+                            workItemRecipSieve wiFollowers ticketDetail
-            deleteFollowRemote obiidOriginal
+                    in  makeRecipientSet
-            deleteFollowRemoteRequest obiidOriginal
+                            actors
-            let obidAuthor = personOutbox personAuthor
+                            (LocalPersonCollectionSharerFollowers shrUser :
-            (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded
+                             colls
-            let ibidAuthor = personInbox personAuthor
+                            )
-                fsidAuthor = personFollowers personAuthor
+    (remotes, maybeAccept) <- runDBExcept $ do
-            knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips
+        remotesHttpUndo <- do
-            remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes
+            moreRemoteRecips <-
-            return (obiidUndo, doc, remotesHttp)
+                lift $
-    lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidUndo doc remotesHttp
+                    deliverLocal'
-    return obiidUndo
+                        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
+    insertUndoToOutbox shrUser now obid blinded = 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
         hLocal <- asksSite siteInstanceHost
+        obiid <- insertEmptyOutboxItem obid now
         encodeRouteLocal <- getEncodeRouteLocal
-        let activity mluAct = Doc hLocal Activity
+        obikhid <- encodeKeyHashid obiid
-                { activityId       = mluAct
+        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

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

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

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
+getFollow (Left _)        = return Nothing
-    :: Route App
+getFollow (Right ractid)  = getBy $ UniqueRemoteFollowFollow ractid
-    -> AppDB (Entity a)
+
-    -> (a -> InboxId)
+getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid)
-    -> (a -> FollowerSetId)
+getResolve (Right ractid)    = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid)
-    -> (Key a -> FollowerSetId -> AppDB (Maybe Text))
+
-    -> UTCTime
+deleteResolve myWorkItem prepareAccept tr = do
-    -> RemoteAuthor
+    let (trid, trxid) =
-    -> ActivityBody
+            case tr of
-    -> Maybe (LocalRecipientSet, ByteString)
+                Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid)
-    -> LocalURI
+                Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid)
-    -> Undo URIMode
+    ltid <- ticketResolveTicket <$> getJust trid
-    -> ExceptT Text Handler Text
+    wi <- getWorkItem ltid
-undoF
+    case myWorkItem wi of
-    recipRoute getRecip recipInbox recipFollowers trySubObjects
+        Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing)
-    now author body mfwd luUndo (Undo luObj) = do
+        Just wiData -> do
-        lift $ runDB $ do
+            bitraverse delete delete trxid
-            Entity idRecip recip <- getRecip
+            delete trid
-            ractid <- insertActivity luUndo
+            (colls, accept) <- prepareAccept wiData
-            mreason <- deleteRemoteFollow idRecip (recipFollowers recip)
+            return ("Ticket unresolved", Just colls, Just accept)
-            case mreason of
+
-                Just reason -> return $ "Not using this Undo: " <> reason
+deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf)
-                Nothing -> do
+    | remoteFollowActor rf /= remoteAuthorId author =
-                    inserted <- insertToInbox (recipInbox recip) ractid
+        return "Undo sent by different actor than the one who sent the Follow"
-                    encodeRouteLocal <- getEncodeRouteLocal
+    | remoteFollowTarget rf == fsidRecip = do
-                    let me = localUriPath $ encodeRouteLocal recipRoute
+        delete rfid
-                    return $
+        return "Undo applied to sharer RemoteFollow"
-                        if inserted
+    | otherwise = do
-                            then "Undo applied and inserted to inbox of " <> me
+        r <- tryTicket $ remoteFollowTarget rf
-                            else "Undo applied and already exists in inbox of " <> me
+        when (isRight r) $ delete rfid
+        return $ either id id r
     where
-    insertActivity luUndo = do
+    tryTicket fsid = do
-        let iidAuthor = remoteAuthorInstance author
+        mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
-        roid <-
+        case mltid of
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luUndo)
+            Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket"
-        let jsonObj = persistJSONFromBL $ actbBL body
+            Just ltid -> do
-            ract = RemoteActivity roid jsonObj now
+                wi <- getWorkItem ltid
-        either entityKey id <$> insertBy' ract
+                return $
-    deleteRemoteFollow idRecip fsidRecip = do
+                    if myWorkItem wi
-        let iidAuthor = remoteAuthorInstance author
+                        then Right "Undo applied to RemoteFollow of my ticket"
-        mractidObj <- runMaybeT $ do
+                        else Left "Undo is of RemoteFollow of a ticket that isn't mine"
-            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iidAuthor luObj
+
-            MaybeT $ getKeyBy $ UniqueRemoteActivity roid
+insertAcceptOnUndo actor author luUndo obiid auds = do
-        case mractidObj of
+    encodeRouteLocal <- getEncodeRouteLocal
-            Nothing -> return $ Just "Undo object isn't a known activity"
+    encodeRouteHome <- getEncodeRouteHome
-            Just ractidObj -> do
+    hLocal <- asksSite siteInstanceHost
-                merf <- getBy $ UniqueRemoteFollowFollow ractidObj
+    obikhid <- encodeKeyHashid obiid
-                case merf of
+    let hAuthor = objUriAuthority $ remoteAuthorURI author
-                    Nothing -> return $ Just "Undo object doesn't match an active RemoteFollow"
+
-                    Just (Entity rfid rf)
+        (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                        | remoteFollowActor rf /= remoteAuthorId author ->
+            collectAudience auds
-                            return $ Just "Undo sent by different actor than the one who sent the Follow"
+
-                        | remoteFollowTarget rf == fsidRecip -> do
+        recips = map encodeRouteHome audLocal ++ audRemote
-                            delete rfid
+        doc = Doc hLocal Activity
-                            return Nothing
+            { activityId       =
-                        | otherwise -> do
+                Just $ encodeRouteLocal $ actorOutboxItem actor obikhid
-                            mr <- trySubObjects idRecip (remoteFollowTarget rf)
+            , activityActor    = encodeRouteLocal $ renderLocalActor actor
-                            when (isNothing mr) $ delete rfid
+            , activitySummary  = Nothing
-                            return mr
+            , activityAudience = Audience recips [] [] [] [] []
-    insertToInbox ibidRecip ractid = do
+            , activitySpecific = AcceptActivity Accept
-        ibiid <- insert $ InboxItem False
+                { acceptObject = ObjURI hAuthor luUndo
-        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+                , acceptResult = Nothing
-        case mibrid of
+                }
-            Nothing -> do
+            }
-                delete ibiid
+    update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-                return False
+    return (doc, recipientSet, remoteActors, fwdHosts)
-            Just _ -> return True
+    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 =
+sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do
-    undoF
+    object <- parseActivity uObj
-        (SharerR shr)
+    mmmhttp <- runDBExcept $ do
-        getRecip
+        p <- lift $ do
-        personInbox
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-        personFollowers
+            getValBy404 $ UniquePersonIdent sid
-        tryTicket
+        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
+    myWorkItem (WorkItemSharerTicket shr talid patch)
-        sid <- getKeyBy404 $ UniqueSharer shr
+        | shr == shrRecip = Just (talid, patch)
-        getBy404 $ UniquePersonIdent sid
+    myWorkItem _ = Nothing
-    tryTicket pid fsid = do
+
-        mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
+    prepareAccept (talid, patch) = do
-        case mltid of
+        talkhid <- encodeKeyHashid talid
-            Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this sharer"
+        ra <- getJust $ remoteAuthorId author
-            Just ltid -> do
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-                mtal <- getBy $ UniqueTicketAuthorLocal ltid
+            ticketFollowers =
-                case mtal of
+                if patch
-                    Just (Entity talid tal)
+                    then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid
-                        | ticketAuthorLocalAuthor tal == pid -> do
+                    else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
-                            mtup <- getBy $ UniqueTicketUnderProjectAuthor talid
+            audAuthor =
-                            return $
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-                                case mtup of
+            audTicket =
-                                    Nothing -> Nothing
+                AudLocal [] [ticketFollowers]
-                                    Just _ -> Just "Undo object is a RemoteFollow of a ticket authored by this sharer, but is hosted by the project"
+        return ([ticketFollowers], [audAuthor, audTicket])
-                    _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another author"
 
 projectUndoF
     :: ShrIdent
@@ -647,35 +708,86 @@ projectUndoF
     -> LocalURI
     -> Undo URIMode
     -> ExceptT Text Handler Text
-projectUndoF shr prj =
+projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do
-    undoF
+    object <- parseActivity uObj
-        (ProjectR shr prj)
+    mmmhttp <- runDBExcept $ do
-        getRecip
+        Entity jid j <- lift $ do
-        projectInbox
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-        projectFollowers
+            getBy404 $ UniqueProject prjRecip sid
-        tryTicket
+        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
+    myWorkItem (WorkItemProjectTicket shr prj ltid)
-        sid <- getKeyBy404 $ UniqueSharer shr
+        | shr == shrRecip && prj == prjRecip = Just ltid
-        getBy404 $ UniqueProject prj sid
+    myWorkItem _ = Nothing
-    tryTicket jid fsid = do
+
-        mlt <- getValBy $ UniqueLocalTicketFollowers fsid
+    prepareAccept ltid = do
-        case mlt of
+        ltkhid <- encodeKeyHashid ltid
-            Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this project"
+        ra <- getJust $ remoteAuthorId author
-            Just lt -> do
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-                mtpl <- runMaybeT $ do
+            ticketFollowers =
-                    tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt
+                LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
-                    tpl <- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid
+            audAuthor =
-                    return (tclid, tpl)
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-                case mtpl of
+            audTicket =
-                    Just (tclid, tpl)
+                AudLocal [] [ticketFollowers]
-                        | ticketProjectLocalProject tpl == jid -> do
+        return ([ticketFollowers], [audAuthor, audTicket])
-                            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"
 
 repoUndoF
     :: ShrIdent
@@ -687,32 +799,83 @@ repoUndoF
     -> LocalURI
     -> Undo URIMode
     -> ExceptT Text Handler Text
-repoUndoF shr rp =
+repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do
-    undoF
+    object <- parseActivity uObj
-        (RepoR shr rp)
+    mmmhttp <- runDBExcept $ do
-        getRecip
+        Entity rid r <- lift $ do
-        repoInbox
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-        repoFollowers
+            getBy404 $ UniqueRepo rpRecip sid
-        tryPatch
+        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
+    myWorkItem (WorkItemRepoPatch shr rp ltid)
-        sid <- getKeyBy404 $ UniqueSharer shr
+        | shr == shrRecip && rp == rpRecip = Just ltid
-        getBy404 $ UniqueRepo rp sid
+    myWorkItem _ = Nothing
-    tryPatch rid fsid = do
+
-        mlt <- getValBy $ UniqueLocalTicketFollowers fsid
+    prepareAccept ltid = do
-        case mlt of
+        ltkhid <- encodeKeyHashid ltid
-            Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this repo"
+        ra <- getJust $ remoteAuthorId author
-            Just lt -> do
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-                mtrl <- runMaybeT $ do
+            ticketFollowers =
-                    tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt
+                LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
-                    trl <- MaybeT $ getValBy $ UniqueTicketRepoLocal tclid
+            audAuthor =
-                    return (tclid, trl)
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-                case mtrl of
+            audTicket =
-                    Just (tclid, trl)
+                AudLocal [] [ticketFollowers]
-                        | ticketRepoLocalRepo trl == rid -> do
+        return ([ticketFollowers], [audAuthor, audTicket])
-                            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"

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

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

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
+            ExceptT $ undoFollowSharer shrAuthor pid shrFollowee
-        undoC shrAuthor (Just summary) audience undo
+        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
+            ExceptT $ undoFollowProject shrAuthor pid shrFollowee prjFollowee
-        undoC shrAuthor (Just summary) audience undo
+        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
+            ExceptT $ undoFollowTicket shrAuthor pid shrFollowee prjFollowee tkhidFollowee
-        undoC shrAuthor (Just summary) audience undo
+        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
+            ExceptT $ undoFollowRepo shrAuthor pid shrFollowee rpFollowee
-        undoC shrAuthor (Just summary) audience undo
+        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

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

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

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

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)

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

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}
+      Closed on ___ by ___.
-      $maybe closer <- mcloser
-        by ^{sharerLinkW closer}.
 
       ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR shar proj ltkhid)}