S2S: Implement inbox handlers for Resolve activity

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,6 +819,29 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do
         s <- getJust $ personIdent p
         return $ WorkItemSharerTicket (sharerIdent s) talid patch
 
+parseWorkItem name u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> do
+            route <-
+                fromMaybeE (decodeRouteLocal lu) $
+                    name <> ": Not a valid route"
+            case route of
+                SharerTicketR shr talkhid -> do
+                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                    return $ WorkItemSharerTicket shr talid False
+                SharerPatchR shr talkhid -> do
+                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                    return $ WorkItemSharerTicket shr talid True
+                ProjectTicketR shr prj ltkhid -> do
+                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
+                    return $ WorkItemProjectTicket shr prj ltid
+                RepoPatchR shr rp ltkhid -> do
+                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
+                    return $ WorkItemRepoPatch shr rp ltid
+                _ -> throwE $ name <> ": not a work item route"
+        else return $ Right u
+
 checkDepAndTarget
     :: (MonadSite m, SiteEnv m ~ App)
     => TicketDependency URIMode
@@ -836,28 +860,6 @@ checkDepAndTarget
         checkParentAndTarget parent target
         return (parent, child)
     where
-    parseWorkItem name u@(ObjURI h lu) = do
-        hl <- hostIsLocal h
-        if hl
-            then Left <$> do
-                route <-
-                    fromMaybeE (decodeRouteLocal lu) $
-                        name <> ": Not a valid route"
-                case route of
-                    SharerTicketR shr talkhid -> do
-                        talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
-                        return $ WorkItemSharerTicket shr talid False
-                    SharerPatchR shr talkhid -> do
-                        talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
-                        return $ WorkItemSharerTicket shr talid True
-                    ProjectTicketR shr prj ltkhid -> do
-                        ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
-                        return $ WorkItemProjectTicket shr prj ltid
-                    RepoPatchR shr rp ltkhid -> do
-                        ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
-                        return $ WorkItemRepoPatch shr rp ltid
-                    _ -> throwE $ name <> ": not a work item route"
-            else return $ Right u
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
         if hl