forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Implement inbox handlers for Resolve activity

Browse source
This commit is contained in:
fr33domlover 2020-07-28 09:35:27 +00:00
parent 58c0719370
commit 7f106023b0
8 changed files with 663 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
config/models
View file

@ -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

21
migrations/2020_07_27_ticket_resolve.model Normal file
View file

@ -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

123
migrations/2020_07_27_ticket_resolve_mig.model Normal file
View file

@ -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

6
src/Vervis/Federation.hs
View file

@ -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)

425
src/Vervis/Federation/Ticket.hs
View file

@ -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)

26
src/Vervis/Migration.hs
View file

@ -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

16
src/Vervis/Migration/Model.hs
View file

@ -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")

38
src/Vervis/Ticket.hs
View file

@ -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