S2S: Implement inbox handlers for Resolve activity

config/models

@@ -512,6 +512,28 @@ TicketClaimRequest
 
     UniqueTicketClaimRequest person ticket
 
+TicketResolve
+    ticket LocalTicketId
+    accept OutboxItemId
+
+    UniqueTicketResolve ticket
+    UniqueTicketResolveAccept accept
+
+TicketResolveLocal
+    ticket   TicketResolveId
+    activity OutboxItemId
+
+    UniqueTicketResolveLocal ticket
+    UniqueTicketResolveLocalActivity activity
+
+TicketResolveRemote
+    ticket   TicketResolveId
+    activity RemoteActivityId
+    actor    RemoteActorId
+
+    UniqueTicketResolveRemote ticket
+    UniqueTicketResolveRemoteActivity activity
+
 Discussion
 
 RemoteDiscussion

migrations/2020_07_27_ticket_resolve.model

@@ -0,0 +1,21 @@
+TicketResolve
+    ticket LocalTicketId
+    accept OutboxItemId
+
+    UniqueTicketResolve ticket
+    UniqueTicketResolveAccept accept
+
+TicketResolveLocal
+    ticket   TicketResolveId
+    activity OutboxItemId
+
+    UniqueTicketResolveLocal ticket
+    UniqueTicketResolveLocalActivity activity
+
+TicketResolveRemote
+    ticket   TicketResolveId
+    activity RemoteActivityId
+    actor    RemoteActorId
+
+    UniqueTicketResolveRemote ticket
+    UniqueTicketResolveRemoteActivity activity

migrations/2020_07_27_ticket_resolve_mig.model

@@ -0,0 +1,123 @@
+TicketResolve
+    ticket LocalTicketId
+    accept OutboxItemId
+
+    UniqueTicketResolve ticket
+    UniqueTicketResolveAccept accept
+
+TicketResolveLocal
+    ticket   TicketResolveId
+    activity OutboxItemId
+
+    UniqueTicketResolveLocal ticket
+    UniqueTicketResolveLocalActivity activity
+
+Ticket
+    number      Int           Maybe
+    created     UTCTime
+    title       Text                -- HTML
+    source      Text                -- Pandoc Markdown
+    description Text                -- HTML
+    assignee    PersonId      Maybe
+    status      Text
+    closed      UTCTime
+    closer      PersonId      Maybe
+
+LocalTicket
+    ticket    TicketId
+    discuss   DiscussionId
+    followers FollowerSetId
+
+    UniqueLocalTicket           ticket
+    UniqueLocalTicketDiscussion discuss
+    UniqueLocalTicketFollowers  followers
+
+Discussion
+
+FollowerSet
+
+Sharer
+
+Inbox
+
+Person
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+    inbox               InboxId
+    outbox              OutboxId
+    followers           FollowerSetId
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+    UniquePersonOutbox outbox
+    UniquePersonFollowers followers
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+TicketContextLocal
+    ticket  TicketId
+    accept  OutboxItemId
+
+    UniqueTicketContextLocal       ticket
+    UniqueTicketContextLocalAccept accept
+
+TicketProjectLocal
+    context TicketContextLocalId
+    project ProjectId
+
+    UniqueTicketProjectLocal context
+
+TicketUnderProject
+    project TicketContextLocalId
+    author  TicketAuthorLocalId
+
+    UniqueTicketUnderProjectProject project
+    UniqueTicketUnderProjectAuthor  author
+
+TicketAuthorLocal
+    ticket LocalTicketId
+    author PersonId
+    open   OutboxItemId
+
+    UniqueTicketAuthorLocal     ticket
+    UniqueTicketAuthorLocalOpen open
+
+Project
+    ident      PrjIdent
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   WorkflowId
+    nextTicket Int
+    wiki       RepoId        Maybe
+    collabUser RoleId        Maybe
+    collabAnon RoleId        Maybe
+    inbox      InboxId
+    outbox     OutboxId
+    followers  FollowerSetId
+
+    UniqueProject ident sharer
+    UniqueProjectInbox inbox
+    UniqueProjectOutbox outbox
+    UniqueProjectFollowers followers
+
+Workflow
+
+Repo
+
+Role

src/Vervis/Federation.hs

@@ -294,6 +294,8 @@ handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do
             (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
         RejectActivity reject ->
             (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
+        ResolveActivity resolve ->
+            (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
         UndoActivity undo ->
             (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
         _ -> return ("Unsupported activity type for sharers", Nothing)
@@ -334,6 +336,8 @@ handleProjectInbox shrRecip prjRecip now auth body = do
                 OfferDep dep ->
                     projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
                 _ -> return ("Unsupported offer object type for projects", Nothing)
+        ResolveActivity resolve ->
+            (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
         UndoActivity undo ->
             (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
         _ -> return ("Unsupported activity type for projects", Nothing)
@@ -384,6 +388,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do
                 OfferDep dep ->
                     repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
                 _ -> return ("Unsupported offer object type for repos", Nothing)
+        ResolveActivity resolve ->
+            (,Nothing) <$> repoResolveF now shrRecip rpRecip remoteAuthor body mfwd luActivity resolve
         UndoActivity undo->
             (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
         _ -> return ("Unsupported activity type for repos", Nothing)

src/Vervis/Federation/Ticket.hs

@@ -25,6 +25,10 @@ module Vervis.Federation.Ticket
     , sharerOfferDepF
     , projectOfferDepF
     , repoOfferDepF
+
+    , sharerResolveF
+    , projectResolveF
+    , repoResolveF
     )
 where
 
@@ -1608,3 +1612,424 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do
                 \ ltid ->
                     LocalPersonCollectionRepoPatchFollowers
                         shrRecip rpRecip (hashLTID ltid)
+
+verifyWorkItemExists (WorkItemSharerTicket shr talid False) = do
+    mticket <- lift $ getSharerTicket shr talid
+    verifyNothingE mticket $ "Object" <> ": No such sharer-ticket"
+verifyWorkItemExists (WorkItemSharerTicket shr talid True) = do
+    mticket <- lift $ getSharerPatch shr talid
+    verifyNothingE mticket $ "Object" <> ": No such sharer-patch"
+verifyWorkItemExists (WorkItemProjectTicket shr prj ltid) = do
+    mticket <- lift $ getProjectTicket shr prj ltid
+    verifyNothingE mticket $ "Object" <> ": No such project-ticket"
+verifyWorkItemExists (WorkItemRepoPatch shr rp ltid) = do
+    mticket <- lift $ getRepoPatch shr rp ltid
+    verifyNothingE mticket $ "Object" <> ": No such repo-patch"
+
+insertResolve author ltid ractid obiidAccept = do
+    mtrid <- insertUnique TicketResolve
+        { ticketResolveTicket = ltid
+        , ticketResolveAccept = obiidAccept
+        }
+    for mtrid $ \ trid ->
+        insertUnique TicketResolveRemote
+            { ticketResolveRemoteTicket   = trid
+            , ticketResolveRemoteActivity = ractid
+            , ticketResolveRemoteActor    = remoteAuthorId author
+            }
+
+sharerResolveF
+    :: UTCTime
+    -> ShrIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (LocalRecipientSet, ByteString)
+    -> LocalURI
+    -> Resolve URIMode
+    -> ExceptT Text Handler Text
+sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do
+    object <- parseWorkItem "Resolve object" uObject
+    mmmmhttp <- runDBExcept $ do
+        personRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            getValBy404 $ UniquePersonIdent sid
+        mltid <-
+            case relevantObject object of
+                Nothing -> do
+                    case object of
+                        Left wi -> verifyWorkItemExists wi
+                        Right _ -> return ()
+                    return Nothing
+                Just (talid, patch) ->
+                    Just . (talid,patch,) <$> getObjectLtid talid patch
+        mractid <- lift $ insertToInbox now author body (personInbox personRecip) luResolve True
+        lift $ for mractid $ \ ractid -> for mltid $ \ (talid, patch, (ltid, tid)) -> do
+            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+                hashTALID <- getEncodeKeyHashid
+                let followers =
+                        let collection = 
+                                if patch
+                                    then LocalPersonCollectionSharerPatchFollowers
+                                    else LocalPersonCollectionSharerTicketFollowers
+                        in  collection shrRecip $ hashTALID talid
+                    sieve =
+                        makeRecipientSet
+                            []
+                            [ followers
+                            , LocalPersonCollectionSharerFollowers shrRecip
+                            ]
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False ractid $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
+            obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
+            mmtrrid <- insertResolve author ltid ractid obiidAccept
+            case mmtrrid of
+                Just (Just _) -> update tid [TicketStatus =. TSClosed]
+                _ -> delete obiidAccept
+            for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    insertAccept luResolve talid patch obiidAccept
+                knownRemoteRecipsAccept <-
+                    deliverLocal'
+                        False
+                        (LocalActorSharer shrRecip)
+                        (personInbox personRecip)
+                        obiidAccept
+                        localRecipsAccept
+                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+    case mmmmhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just mmmhttp ->
+            case mmmhttp of
+                Nothing -> return "Object not mine, just stored in inbox"
+                Just mmhttp ->
+                    case mmhttp of
+                        Nothing -> return "Ticket already resolved"
+                        Just mhttp ->
+                            case mhttp of
+                                Nothing -> return "Activity already resolved a ticket"
+                                Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
+                                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                                        forkWorker "sharerResolveF inbox-forwarding" $
+                                            deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
+                                    forkWorker "sharerResolveF Accept HTTP delivery" $
+                                        deliverRemoteHttp' fwdHosts obiid doc recips
+                                    return $
+                                        if isJust mremotesHttpFwd
+                                            then "Ticket is mine, now resolved, did inbox-forwarding"
+                                            else "Ticket is mine, now resolved, no inbox-forwarding to do"
+    where
+    relevantObject (Left (WorkItemSharerTicket shr talid patch))
+        | shr == shrRecip = Just (talid, patch)
+    relevantObject _ = Nothing
+
+    getObjectLtid talid True = do
+        (_, Entity ltid _, Entity tid _, _, _) <- do
+            mticket <- lift $ getSharerPatch shrRecip talid
+            fromMaybeE mticket $ "Object" <> ": No such sharer-patch"
+        return (ltid, tid)
+    getObjectLtid talid False = do
+        (_, Entity ltid _, Entity tid _, _) <- do
+            mticket <- lift $ getSharerTicket shrRecip talid
+            fromMaybeE mticket $ "Object" <> ": No such sharer-ticket"
+        return (ltid, tid)
+
+    insertAccept luResolve talid patch obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        talkhid <- encodeKeyHashid talid
+        ra <- getJust $ remoteAuthorId author
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audAuthor =
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+
+            audTicket =
+                let followers = 
+                        if patch
+                            then LocalPersonCollectionSharerPatchFollowers
+                            else LocalPersonCollectionSharerTicketFollowers
+                in  AudLocal [] [followers shrRecip talkhid]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAuthor, audTicket]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId       =
+                    Just $ encodeRouteLocal $
+                        SharerOutboxItemR shrRecip obikhidAccept
+                , activityActor    = encodeRouteLocal $ SharerR shrRecip
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hAuthor luResolve
+                    , acceptResult = Nothing
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
+projectResolveF
+    :: UTCTime
+    -> ShrIdent
+    -> PrjIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (LocalRecipientSet, ByteString)
+    -> LocalURI
+    -> Resolve URIMode
+    -> ExceptT Text Handler Text
+projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObject) = do
+    object <- parseWorkItem "Resolve object" uObject
+    mmmmhttp <- runDBExcept $ do
+        Entity jidRecip projectRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            getBy404 $ UniqueProject prjRecip sid
+        mltid <-
+            case relevantObject object of
+                Nothing -> do
+                    case object of
+                        Left wi -> verifyWorkItemExists wi
+                        Right _ -> return ()
+                    return Nothing
+                Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
+        mractid <- lift $ insertToInbox now author body (projectInbox projectRecip) luResolve False
+        lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
+            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+                ltkhid <- encodeKeyHashid ltid
+                let sieve =
+                        makeRecipientSet
+                            []
+                            [ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
+                            , LocalPersonCollectionProjectTeam shrRecip prjRecip
+                            , LocalPersonCollectionProjectFollowers shrRecip prjRecip
+                            ]
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False ractid $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
+            obiidAccept <- insertEmptyOutboxItem (projectOutbox projectRecip) now
+            mmtrrid <- insertResolve author ltid ractid obiidAccept
+            case mmtrrid of
+                Just (Just _) -> update tid [TicketStatus =. TSClosed]
+                _ -> delete obiidAccept
+            for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    insertAccept luResolve ltid obiidAccept
+                knownRemoteRecipsAccept <-
+                    deliverLocal'
+                        False
+                        (LocalActorProject shrRecip prjRecip)
+                        (projectInbox projectRecip)
+                        obiidAccept
+                        localRecipsAccept
+                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+    case mmmmhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just mmmhttp ->
+            case mmmhttp of
+                Nothing -> return "Object not mine, just stored in inbox"
+                Just mmhttp ->
+                    case mmhttp of
+                        Nothing -> return "Ticket already resolved"
+                        Just mhttp ->
+                            case mhttp of
+                                Nothing -> return "Activity already resolved a ticket"
+                                Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
+                                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                                        forkWorker "projectResolveF inbox-forwarding" $
+                                            deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
+                                    forkWorker "projectResolveF Accept HTTP delivery" $
+                                        deliverRemoteHttp' fwdHosts obiid doc recips
+                                    return $
+                                        if isJust mremotesHttpFwd
+                                            then "Ticket is mine, now resolved, did inbox-forwarding"
+                                            else "Ticket is mine, now resolved, no inbox-forwarding to do"
+    where
+    relevantObject (Left (WorkItemProjectTicket shr prj ltid))
+        | shr == shrRecip && prj == prjRecip = Just ltid
+    relevantObject _ = Nothing
+
+    getObjectLtid ltid = do
+        (_, _, Entity tid _, _, _, _, _) <- do
+            mticket <- lift $ getProjectTicket shrRecip prjRecip ltid
+            fromMaybeE mticket $ "Object" <> ": No such project-ticket"
+        return tid
+
+    insertAccept luResolve ltid obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        ltkhid <- encodeKeyHashid ltid
+        ra <- getJust $ remoteAuthorId author
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audAuthor =
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+
+            audTicket =
+                AudLocal
+                    []
+                    [ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
+                    , LocalPersonCollectionProjectTeam shrRecip prjRecip
+                    , LocalPersonCollectionProjectFollowers shrRecip prjRecip
+                    ]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAuthor, audTicket]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId       =
+                    Just $ encodeRouteLocal $
+                        ProjectOutboxItemR shrRecip prjRecip obikhidAccept
+                , activityActor    = encodeRouteLocal $ ProjectR shrRecip prjRecip
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hAuthor luResolve
+                    , acceptResult = Nothing
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
+repoResolveF
+    :: UTCTime
+    -> ShrIdent
+    -> RpIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (LocalRecipientSet, ByteString)
+    -> LocalURI
+    -> Resolve URIMode
+    -> ExceptT Text Handler Text
+repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = do
+    object <- parseWorkItem "Resolve object" uObject
+    mmmmhttp <- runDBExcept $ do
+        Entity ridRecip repoRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            getBy404 $ UniqueRepo rpRecip sid
+        mltid <-
+            case relevantObject object of
+                Nothing -> do
+                    case object of
+                        Left wi -> verifyWorkItemExists wi
+                        Right _ -> return ()
+                    return Nothing
+                Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
+        mractid <- lift $ insertToInbox now author body (repoInbox repoRecip) luResolve False
+        lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
+            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+                ltkhid <- encodeKeyHashid ltid
+                let sieve =
+                        makeRecipientSet
+                            []
+                            [ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
+                            , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                            , LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                            ]
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False ractid $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
+            obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
+            mmtrrid <- insertResolve author ltid ractid obiidAccept
+            case mmtrrid of
+                Just (Just _) -> update tid [TicketStatus =. TSClosed]
+                _ -> delete obiidAccept
+            for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    insertAccept luResolve ltid obiidAccept
+                knownRemoteRecipsAccept <-
+                    deliverLocal'
+                        False
+                        (LocalActorRepo shrRecip rpRecip)
+                        (repoInbox repoRecip)
+                        obiidAccept
+                        localRecipsAccept
+                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+    case mmmmhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just mmmhttp ->
+            case mmmhttp of
+                Nothing -> return "Object not mine, just stored in inbox"
+                Just mmhttp ->
+                    case mmhttp of
+                        Nothing -> return "Ticket already resolved"
+                        Just mhttp ->
+                            case mhttp of
+                                Nothing -> return "Activity already resolved a ticket"
+                                Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
+                                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                                        forkWorker "repoResolveF inbox-forwarding" $
+                                            deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
+                                    forkWorker "repoResolveF Accept HTTP delivery" $
+                                        deliverRemoteHttp' fwdHosts obiid doc recips
+                                    return $
+                                        if isJust mremotesHttpFwd
+                                            then "Ticket is mine, now resolved, did inbox-forwarding"
+                                            else "Ticket is mine, now resolved, no inbox-forwarding to do"
+    where
+    relevantObject (Left (WorkItemRepoPatch shr rp ltid))
+        | shr == shrRecip && rp == rpRecip = Just ltid
+    relevantObject _ = Nothing
+
+    getObjectLtid ltid = do
+        (_, _, Entity tid _, _, _, _, _, _) <- do
+            mticket <- lift $ getRepoPatch shrRecip rpRecip ltid
+            fromMaybeE mticket $ "Object" <> ": No such repo-patch"
+        return tid
+
+    insertAccept luResolve ltid obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        ltkhid <- encodeKeyHashid ltid
+        ra <- getJust $ remoteAuthorId author
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audAuthor =
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+
+            audTicket =
+                AudLocal
+                    []
+                    [ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
+                    , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                    , LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                    ]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAuthor, audTicket]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId       =
+                    Just $ encodeRouteLocal $
+                        RepoOutboxItemR shrRecip rpRecip obikhidAccept
+                , activityActor    = encodeRouteLocal $ RepoR shrRecip rpRecip
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hAuthor luResolve
+                    , acceptResult = Nothing
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)

src/Vervis/Migration.hs

@@ -1722,6 +1722,32 @@ changes hLocal ctx =
     , removeEntity "RemoteCollection"
       -- 274
     , addEntities model_2020_07_23
+      -- 275
+    , addEntities model_2020_07_27
+      -- 276
+    , unchecked $ lift $ do
+        elts <- selectList ([] :: [Filter LocalTicket276]) []
+        for_ elts $ \ (Entity ltid lt) -> do
+            let tid = localTicket276Ticket lt
+            t <- getJust tid
+            for_ (ticket276Closer t) $ \ pid -> do
+                let unjust s = fromMaybe $ error s
+                obidCloser <- person276Outbox <$> getJust pid
+                obidHoster <- do
+                    tclid <-
+                        unjust "No TCL" <$> getKeyBy (UniqueTicketContextLocal276 tid)
+                    tpl <-
+                        unjust "No TPL" <$> getValBy (UniqueTicketProjectLocal276 tclid)
+                    _ <-
+                        unjust "No TUP" <$> getBy (UniqueTicketUnderProjectProject276 tclid)
+                    project276Outbox <$>
+                        getJust (ticketProjectLocal276Project tpl)
+                let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+                    closed = ticket276Closed t
+                obiidResolve <- insert $ OutboxItem276 obidCloser doc closed
+                obiidAccept <- insert $ OutboxItem276 obidHoster doc closed
+                trid <- insert $ TicketResolve276 ltid obiidAccept
+                insert_ $ TicketResolveLocal276 trid obiidResolve
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -228,6 +228,16 @@ module Vervis.Migration.Model
     , Project266Generic (..)
     , model_2020_06_18
     , model_2020_07_23
+    , model_2020_07_27
+    , TicketResolve276Generic (..)
+    , TicketResolveLocal276Generic (..)
+    , Ticket276Generic (..)
+    , LocalTicket276
+    , LocalTicket276Generic (..)
+    , Person276Generic (..)
+    , OutboxItem276Generic (..)
+    , TicketProjectLocal276Generic (..)
+    , Project276Generic (..)
     )
 where
 
@@ -449,3 +459,9 @@ model_2020_06_18 = $(schema "2020_06_18_tdo")
 
 model_2020_07_23 :: [Entity SqlBackend]
 model_2020_07_23 = $(schema "2020_07_23_remote_collection_reboot")
+
+model_2020_07_27 :: [Entity SqlBackend]
+model_2020_07_27 = $(schema "2020_07_27_ticket_resolve")
+
+makeEntitiesMigration "276"
+    $(modelFile "migrations/2020_07_27_ticket_resolve_mig.model")

src/Vervis/Ticket.hs

@@ -40,6 +40,7 @@ module Vervis.Ticket
     , getWorkItemRoute
     , askWorkItemRoute
     , getWorkItem
+    , parseWorkItem
 
     , checkDepAndTarget
     )
@@ -818,24 +819,6 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do
         s <- getJust $ personIdent p
         return $ WorkItemSharerTicket (sharerIdent s) talid patch
 
-checkDepAndTarget
-    :: (MonadSite m, SiteEnv m ~ App)
-    => TicketDependency URIMode
-    -> FedURI
-    -> ExceptT Text m (Either WorkItem FedURI, Either WorkItem FedURI)
-checkDepAndTarget
-    (TicketDependency id_ uParent uChild _attrib published updated) uTarget = do
-        verifyNothingE id_ "Dep with 'id'"
-        parent <- parseWorkItem "Dep parent" uParent
-        child <- parseWorkItem "Dep child" uChild
-        when (parent == child) $
-            throwE "Parent and child are the same work item"
-        verifyNothingE published "Dep with 'published'"
-        verifyNothingE updated "Dep with 'updated'"
-        target <- parseTarget uTarget
-        checkParentAndTarget parent target
-        return (parent, child)
-    where
 parseWorkItem name u@(ObjURI h lu) = do
     hl <- hostIsLocal h
     if hl
@@ -858,6 +841,25 @@ checkDepAndTarget
                     return $ WorkItemRepoPatch shr rp ltid
                 _ -> throwE $ name <> ": not a work item route"
         else return $ Right u
+
+checkDepAndTarget
+    :: (MonadSite m, SiteEnv m ~ App)
+    => TicketDependency URIMode
+    -> FedURI
+    -> ExceptT Text m (Either WorkItem FedURI, Either WorkItem FedURI)
+checkDepAndTarget
+    (TicketDependency id_ uParent uChild _attrib published updated) uTarget = do
+        verifyNothingE id_ "Dep with 'id'"
+        parent <- parseWorkItem "Dep parent" uParent
+        child <- parseWorkItem "Dep child" uChild
+        when (parent == child) $
+            throwE "Parent and child are the same work item"
+        verifyNothingE published "Dep with 'published'"
+        verifyNothingE updated "Dep with 'updated'"
+        target <- parseTarget uTarget
+        checkParentAndTarget parent target
+        return (parent, child)
+    where
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
         if hl