diff --git a/config/models b/config/models index 23933f6..1c08621 100644 --- a/config/models +++ b/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 diff --git a/migrations/2020_07_27_ticket_resolve.model b/migrations/2020_07_27_ticket_resolve.model new file mode 100644 index 0000000..6a2da4b --- /dev/null +++ b/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 diff --git a/migrations/2020_07_27_ticket_resolve_mig.model b/migrations/2020_07_27_ticket_resolve_mig.model new file mode 100644 index 0000000..e630fd8 --- /dev/null +++ b/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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 9f02b32..208c698 100644 --- a/src/Vervis/Federation.hs +++ b/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) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 16684c0..254f632 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/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) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 73362c7..ac5bbed 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 5d28195..6596d88 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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") diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 70a90ac..4e44341 100644 --- a/src/Vervis/Ticket.hs +++ b/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