diff --git a/config/models b/config/models index 676a070..8264a10 100644 --- a/config/models +++ b/config/models @@ -385,13 +385,24 @@ RemoteTicket UniqueRemoteTicketIdent ident UniqueRemoteTicketDiscuss discuss -TicketProjectLocal +TicketContextLocal ticket TicketId - project ProjectId accept OutboxItemId - UniqueTicketProjectLocal ticket - UniqueTicketProjectLocalAccept accept + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +TicketProjectLocal + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context + +TicketRepoLocal + context TicketContextLocalId + repo RepoId + + UniqueTicketRepoLocal context TicketProjectRemote ticket TicketAuthorLocalId @@ -418,7 +429,7 @@ TicketAuthorLocal UniqueTicketAuthorLocalOpen open TicketAuthorRemote - ticket TicketProjectLocalId + ticket TicketContextLocalId author RemoteActorId open RemoteActivityId @@ -426,7 +437,7 @@ TicketAuthorRemote UniqueTicketAuthorRemoteOpen open TicketUnderProject - project TicketProjectLocalId + project TicketContextLocalId author TicketAuthorLocalId UniqueTicketUnderProjectProject project diff --git a/migrations/2020_05_16_tcl.model b/migrations/2020_05_16_tcl.model new file mode 100644 index 0000000..4822321 --- /dev/null +++ b/migrations/2020_05_16_tcl.model @@ -0,0 +1,11 @@ +TicketProjectLocal + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context + +TicketRepoLocal + context TicketContextLocalId + repo RepoId + + UniqueTicketRepoLocal context diff --git a/migrations/2020_05_16_tcl_mig.model b/migrations/2020_05_16_tcl_mig.model new file mode 100644 index 0000000..95f1491 --- /dev/null +++ b/migrations/2020_05_16_tcl_mig.model @@ -0,0 +1,19 @@ +Ticket + +Project + +OutboxItem + +TicketContextLocal + ticket TicketId + project ProjectId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +TicketProjectLocal + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 81e56f7..9a501a1 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -343,11 +343,11 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx fromMaybeE mticket "Note context no such local sharer-hosted ticket" mproj <- case project of - Left (Entity _ tpl) -> lift $ Just <$> getProject tpl + Left (_, Entity _ tpl) -> lift $ Just <$> getProject tpl Right _ -> return Nothing return (mproj, localTicketDiscuss lt) NoteContextProjectTicket shr prj ltid -> do - (_, _, _, Entity _ lt, _, _) <- do + (_, _, _, Entity _ lt, _, _, _) <- do mticket <- lift $ getProjectTicket shr prj ltid fromMaybeE mticket "Note context no such local project-hosted ticket" return (Just (shr, prj), localTicketDiscuss lt) @@ -373,12 +373,13 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx merd <- getBy $ UniqueRemoteDiscussionIdent roid case merd of Just (Entity rdid rd) -> do - mproj <- do - mrt <- getValBy $ UniqueRemoteTicketDiscuss rdid - for mrt $ \ rt -> do - tar <- getJust $ remoteTicketTicket rt - tpl <- getJust $ ticketAuthorRemoteTicket tar - getProject tpl + mproj <- runMaybeT $ do + rt <- MaybeT $ getValBy $ UniqueRemoteTicketDiscuss rdid + tar <- lift $ getJust $ remoteTicketTicket rt + let tclid = ticketAuthorRemoteTicket tar + tpl <- + MaybeT $ getValBy $ UniqueTicketProjectLocal tclid + lift $ getProject tpl return (mproj, rd, False) Nothing -> do did <- insert Discussion @@ -627,11 +628,14 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , ticketAuthorLocalOpen = obiidCreate } case project of - Left (_shr, Entity jid _j, obiidAccept) -> + Left (_shr, Entity jid _j, obiidAccept) -> do + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } insert_ TicketProjectLocal - { ticketProjectLocalTicket = tid + { ticketProjectLocalContext = tclid , ticketProjectLocalProject = jid - , ticketProjectLocalAccept = obiidAccept } Right (Entity raid _ra, mroid) -> insert_ TicketProjectRemote @@ -836,9 +840,10 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = run Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid ltid <- decodeKeyHashidM ltkhid lticket <- MaybeT $ get ltid - tpl <- - MaybeT $ getValBy $ - UniqueTicketProjectLocal $ localTicketTicket lticket + tclid <- + MaybeT $ getKeyBy $ + UniqueTicketContextLocal $ localTicketTicket lticket + tpl <- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid guard $ ticketProjectLocalProject tpl == jid return (lticket, project) (lticket, project) <- fromMaybeE mproject "Follow object: No such project ticket in DB" @@ -1159,10 +1164,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , localTicketDiscuss = did , localTicketFollowers = fsid } - tplid <- insert TicketProjectLocal - { ticketProjectLocalTicket = tid + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } + insert_ TicketProjectLocal + { ticketProjectLocalContext = tclid , ticketProjectLocalProject = jid - , ticketProjectLocalAccept = obiidAccept } talid <- insert TicketAuthorLocal { ticketAuthorLocalTicket = ltid @@ -1170,7 +1178,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , ticketAuthorLocalOpen = obiid } insert_ TicketUnderProject - { ticketUnderProjectProject = tplid + { ticketUnderProjectProject = tclid , ticketUnderProjectAuthor = talid } --insertMany_ $ map (TicketDependency tid) tidsDeps diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 68076bb..e890b59 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -947,10 +947,11 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci , localRecipTicketFollowers t ] ltids <- catMaybes <$> traverse decodeKeyHashid ltkhids - E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tpl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do - E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tar E.?. TicketAuthorRemoteTicket - E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tup E.?. TicketUnderProjectProject - E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket + E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tcl `E.InnerJoin` tpl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tup E.?. TicketUnderProjectProject + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid E.&&. diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 76e7c6d..f4b80d5 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -413,11 +413,14 @@ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee = ltid <- decodeKeyHashidE numFollowee "Invalid hashid for context" mlt <- lift $ get ltid lt <- fromMaybeE mlt "Unfollow target no such local ticket" + tclid <- do + mtclid <- + lift $ getKeyBy $ + UniqueTicketContextLocal $ localTicketTicket lt + fromMaybeE mtclid "Unfollow target ticket isn't of local context" tpl <- do - mtpl <- - lift $ getValBy $ - UniqueTicketProjectLocal $ localTicketTicket lt - fromMaybeE mtpl "Unfollow target ticket isn't of local project" + mtpl <- lift $ getValBy $ UniqueTicketProjectLocal tclid + fromMaybeE mtpl "Unfollow target ticket local ctx isn't a project" unless (ticketProjectLocalProject tpl == jid) $ throwE "Hashid doesn't match sharer/project" return $ localTicketFollowers lt diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 28758ee..0932553 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -305,7 +305,7 @@ sharerCreateNoteF now shrRecip author body note = do personRecip <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip getValBy404 $ UniquePersonIdent sid - (_, _, _, Entity _ lt, _, _) <- do + (_, _, _, Entity _ lt, _, _, _) <- do mticket <- lift $ getProjectTicket shr prj ltid fromMaybeE mticket "Context: No such project-ticket" let did = localTicketDiscuss lt @@ -368,7 +368,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do mticket <- lift $ getSharerTicket shr talid fromMaybeE mticket "Context: No such sharer-ticket" case project of - Left (Entity _ tpl) + Left (_, Entity _ tpl) | ticketProjectLocalProject tpl == jid -> do mractid <- lift $ insertToInbox now author body ibid luCreate False case mractid of @@ -399,7 +399,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do Left (NoteContextProjectTicket shr prj ltid) -> do mremotesHttp <- runDBExcept $ do (jid, ibid) <- lift getProjectRecip404 - (_, _, _, Entity _ lt, Entity _ tpl, _) <- do + (_, _, _, Entity _ lt, _, Entity _ tpl, _) <- do mticket <- lift $ getProjectTicket shr prj ltid fromMaybeE mticket "Context: No such project-ticket" if ticketProjectLocalProject tpl == jid diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 84d23b3..cc04966 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -430,8 +430,10 @@ projectFollowF shr prj = mt <- for mltkhid $ \ ltkhid -> do ltid <- decodeKeyHashid404 ltkhid lt <- get404 ltid + tclid <- + getKeyBy404 $ UniqueTicketContextLocal $ localTicketTicket lt tpl <- - getValBy404 $ UniqueTicketProjectLocal $ localTicketTicket lt + getValBy404 $ UniqueTicketProjectLocal tclid unless (ticketProjectLocalProject tpl == jid) notFound return lt return (j, mt) @@ -590,7 +592,9 @@ projectUndoF shr prj = case mlt of Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this project" Just lt -> do - mtpl <- getValBy $ UniqueTicketProjectLocal $ localTicketTicket lt + mtpl <- runMaybeT $ do + tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt + MaybeT $ getValBy $ UniqueTicketProjectLocal tclid return $ case mtpl of Just tpl diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 8b8eedf..3e6e654 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -310,13 +310,16 @@ projectOfferTicketF , localTicketDiscuss = did , localTicketFollowers = fsid } - tplid <- insert TicketProjectLocal - { ticketProjectLocalTicket = tid + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } + insert_ TicketProjectLocal + { ticketProjectLocalContext = tclid , ticketProjectLocalProject = jid - , ticketProjectLocalAccept = obiidAccept } insert_ TicketAuthorRemote - { ticketAuthorRemoteTicket = tplid + { ticketAuthorRemoteTicket = tclid , ticketAuthorRemoteAuthor = raidAuthor , ticketAuthorRemoteOpen = ractid } @@ -689,19 +692,23 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 , ticketCloser = Nothing } + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } tplid <- insert TicketProjectLocal - { ticketProjectLocalTicket = tid + { ticketProjectLocalContext = tclid , ticketProjectLocalProject = jid - , ticketProjectLocalAccept = obiidAccept } mtarid <- insertUnique TicketAuthorRemote - { ticketAuthorRemoteTicket = tplid + { ticketAuthorRemoteTicket = tclid , ticketAuthorRemoteAuthor = remoteAuthorId author , ticketAuthorRemoteOpen = ractidCreate } case mtarid of Nothing -> do delete tplid + delete tclid delete tid return $ Left False Just tarid -> do @@ -724,6 +731,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do Nothing -> do delete tarid delete tplid + delete tclid delete tid return $ Left True Just _rtid -> return $ Right () diff --git a/src/Vervis/Field/Ticket.hs b/src/Vervis/Field/Ticket.hs index fe16295..17f2d1b 100644 --- a/src/Vervis/Field/Ticket.hs +++ b/src/Vervis/Field/Ticket.hs @@ -71,8 +71,9 @@ selectTicketDep jid tid = checkDep tid $ checkNotSelf tid $ selectField $ do - ts <- runDB $ select $ from $ \ (t `InnerJoin` tpl) -> do - on $ t ^. TicketId ==. tpl ^. TicketProjectLocalTicket + ts <- runDB $ select $ from $ \ (t `InnerJoin` tcl `InnerJoin` tpl) -> do + on $ tcl ^. TicketContextLocalId ==. tpl ^. TicketProjectLocalContext + on $ t ^. TicketId ==. tcl ^. TicketContextLocalTicket where_ $ tpl ^. TicketProjectLocalProject ==. val jid &&. t ^. TicketId !=. val tid diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 843cbf9..9b1ad41 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -26,6 +26,7 @@ where import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Maybe import Data.Time.Clock (getCurrentTime) import Database.Persist @@ -136,7 +137,9 @@ getDiscussionMessage shr lmid = do (Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts" (Just (Entity ltid lt), Nothing) -> do tpl <- do - mtpl <- getValBy $ UniqueTicketProjectLocal $ localTicketTicket lt + mtpl <- runMaybeT $ do + tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt + MaybeT $ getValBy $ UniqueTicketProjectLocal tclid case mtpl of Nothing -> error "No TPL" Just v -> return v diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index 65561a3..d380e2d 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -150,12 +150,14 @@ getSharerFollowingR shr = do E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` + tcl `E.InnerJoin` tpl `E.InnerJoin` j `E.InnerJoin` s) -> do E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId E.on $ tpl E.^. TicketProjectLocalProject E.==. j E.^. ProjectId - E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId E.where_ $ lt E.^. LocalTicketId `E.in_` E.valList ltids return diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 01f286d..d50f8fc 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -175,20 +175,20 @@ getProjectTicketsR shr prj = selectRep $ do Entity jid _ <- getBy404 $ UniqueProject prj sid let countAllTickets = count [TicketProjectLocalProject ==. jid] selectTickets off lim = do - tids <- - map (ticketProjectLocalTicket . entityVal) <$> - selectList - [TicketProjectLocalProject ==. jid] - [ Desc TicketProjectLocalTicket - , OffsetBy off - , LimitTo lim - ] + tids <- E.select $ E.from $ \ (tcl `E.InnerJoin` tpl) -> do + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid + E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket] + E.offset $ fromIntegral off + E.limit $ fromIntegral lim + return $ tcl E.^. TicketContextLocalTicket + let tids' = map E.unValue tids locals <- E.select $ E.from $ \ (lt `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)) -> do E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor E.on $ p E.?. PersonIdent E.==. s E.?. SharerId E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket - E.where_ $ lt E.^. LocalTicketTicket `E.in_` E.valList tids + E.where_ $ lt E.^. LocalTicketTicket `E.in_` E.valList tids' E.orderBy [E.desc $ lt E.^. LocalTicketTicket] return ( lt E.^. LocalTicketTicket @@ -198,15 +198,15 @@ getProjectTicketsR shr prj = selectRep $ do , tup E.?. TicketUnderProjectId ) ) - remotes <- E.select $ E.from $ \ (tpl `E.InnerJoin` tar `E.InnerJoin` rt `E.InnerJoin` ro `E.InnerJoin` i) -> do + remotes <- E.select $ E.from $ \ (tcl `E.InnerJoin` tar `E.InnerJoin` rt `E.InnerJoin` ro `E.InnerJoin` i) -> do E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId E.on $ rt E.^. RemoteTicketIdent E.==. ro E.^. RemoteObjectId E.on $ tar E.^. TicketAuthorRemoteId E.==. rt E.^. RemoteTicketTicket - E.on $ tpl E.^. TicketProjectLocalId E.==. tar E.^. TicketAuthorRemoteTicket - E.where_ $ tpl E.^. TicketProjectLocalTicket `E.in_` E.valList tids - E.orderBy [E.desc $ tpl E.^. TicketProjectLocalTicket] + E.on $ tcl E.^. TicketContextLocalId E.==. tar E.^. TicketAuthorRemoteTicket + E.where_ $ tcl E.^. TicketContextLocalTicket `E.in_` E.valList tids' + E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket] return - ( tpl E.^. TicketProjectLocalTicket + ( tcl E.^. TicketContextLocalTicket , ( i E.^. InstanceHost , ro E.^. RemoteObjectIdent ) @@ -298,7 +298,7 @@ getProjectTicketR shar proj ltkhid = do author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, deps, rdeps) <- runDB $ do - (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket404 shar proj ltkhid + (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid (wshr, wid, wfl) <- do w <- get404 $ projectWorkflow project wsharer <- @@ -428,7 +428,7 @@ getProjectTicketR shar proj ltkhid = do putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html putProjectTicketR shr prj ltkhid = do (tid, ticket, wid) <- runDB $ do - (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, Entity _ project, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid return (tid, ticket, projectWorkflow project) ((result, widget), enctype) <- runFormPost $ editTicketContentForm tid ticket wid @@ -502,7 +502,7 @@ postProjectTicketR shr prj ltkhid = do getProjectTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getProjectTicketEditR shr prj ltkhid = do (tid, ticket, wid) <- runDB $ do - (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, Entity _ project, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid return (tid, ticket, projectWorkflow project) ((_result, widget), enctype) <- runFormPost $ editTicketContentForm tid ticket wid @@ -512,7 +512,7 @@ postProjectTicketAcceptR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketAcceptR shr prj ltkhid = do succ <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case ticketStatus ticket of TSNew -> do update tid [TicketStatus =. TSTodo] @@ -530,7 +530,7 @@ postProjectTicketCloseR shr prj ltkhid = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case ticketStatus ticket of TSClosed -> return False _ -> do @@ -553,7 +553,7 @@ postProjectTicketOpenR shr prj ltkhid = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case ticketStatus ticket of TSClosed -> do update tid @@ -573,7 +573,7 @@ postProjectTicketClaimR postProjectTicketClaimR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case (ticketStatus ticket, ticketAssignee ticket) of (TSNew, _) -> return $ @@ -595,7 +595,7 @@ postProjectTicketUnclaimR postProjectTicketUnclaimR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." @@ -619,7 +619,7 @@ getProjectTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getProjectTicketAssignR shr prj ltkhid = do vpid <- requireAuthId - (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid + (_es, Entity jid _, Entity tid ticket, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid let msg t = do setMessage t redirect $ ProjectTicketR shr prj ltkhid @@ -636,7 +636,7 @@ postProjectTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketAssignR shr prj ltkhid = do vpid <- requireAuthId - (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid + (_es, Entity jid _, Entity tid ticket, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid let msg t = do setMessage t redirect $ ProjectTicketR shr prj ltkhid @@ -668,7 +668,7 @@ postProjectTicketUnassignR postProjectTicketUnassignR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." @@ -694,10 +694,11 @@ getClaimRequestsPersonR :: Handler Html getClaimRequestsPersonR = do pid <- requireAuthId rqs <- runDB $ E.select $ E.from $ - \ (tcr `E.InnerJoin` ticket `E.InnerJoin` lticket `E.InnerJoin` tpl `E.InnerJoin` project `E.InnerJoin` sharer) -> do + \ (tcr `E.InnerJoin` ticket `E.InnerJoin` lticket `E.InnerJoin` tcl `E.InnerJoin` tpl `E.InnerJoin` project `E.InnerJoin` sharer) -> do E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId E.on $ tpl E.^. TicketProjectLocalProject E.==. project E.^. ProjectId - E.on $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ ticket E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid @@ -722,13 +723,15 @@ getClaimRequestsProjectR shr prj = do \ ( tcr `E.InnerJoin` ticket `E.InnerJoin` lticket `E.InnerJoin` + tcl `E.InnerJoin` tpl `E.InnerJoin` person `E.InnerJoin` sharer ) -> do E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId - E.on $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ ticket E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid @@ -747,7 +750,7 @@ getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getClaimRequestsTicketR shr prj ltkhid = do rqs <- runDB $ do - (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId @@ -771,7 +774,7 @@ postClaimRequestsTicketR shr prj ltkhid = do now <- liftIO getCurrentTime pid <- requireAuthId runDB $ do - (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid let cr = TicketClaimRequest { ticketClaimRequestPerson = pid , ticketClaimRequestTicket = tid @@ -791,7 +794,7 @@ postClaimRequestsTicketR shr prj ltkhid = do selectDiscussionId :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId selectDiscussionId shr prj ltkhid = do - (_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, _et, Entity _ lticket, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid return $ localTicketDiscuss lticket getProjectTicketDiscussionR @@ -878,11 +881,12 @@ getTicketDeps forward shr prj ltkhid = do if forward then TicketDependencyParent else TicketDependencyChild to' = if forward then TicketDependencyChild else TicketDependencyParent - (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, Entity tid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid fmap (map toRow) $ E.select $ E.from $ \ ( td `E.InnerJoin` t `E.InnerJoin` lt + `E.InnerJoin` tcl `E.InnerJoin` tpl `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s) `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) @@ -890,11 +894,12 @@ getTicketDeps forward shr prj ltkhid = do E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId - E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tar E.?. TicketAuthorRemoteTicket + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket E.on $ p E.?. PersonIdent E.==. s E.?. SharerId E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket - E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket E.on $ td E.^. to' E.==. t E.^. TicketId E.where_ $ td E.^. from' E.==. E.val tid @@ -951,7 +956,7 @@ getProjectTicketDepsR = getTicketDeps True postProjectTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketDepsR shr prj ltkhid = do - (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid + (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid case result of FormSuccess ctid -> do @@ -979,7 +984,7 @@ postProjectTicketDepsR shr prj ltkhid = do getProjectTicketDepNewR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getProjectTicketDepNewR shr prj ltkhid = do - (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid + (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid defaultLayout $(widgetFile "ticket/dep/new") @@ -995,12 +1000,13 @@ deleteTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html deleteTicketDepOldR shr prj pnum cnum = do runDB $ do - (_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj pnum + (_es, Entity jid _, Entity ptid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj pnum cltid <- decodeKeyHashid404 cnum clt <- get404 cltid let ctid = localTicketTicket clt - ctpl <- getValBy404 $ UniqueTicketProjectLocal ctid + ctclid <- getKeyBy404 $ UniqueTicketContextLocal ctid + ctpl <- getValBy404 $ UniqueTicketProjectLocal ctclid unless (ticketProjectLocalProject ctpl == jid) notFound Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid @@ -1053,8 +1059,13 @@ getTicketDepR tdkhid = do case mltid of Nothing -> error "No LocalTicket" Just v -> return v + tclid <- do + mtclid <- getKeyBy $ UniqueTicketContextLocal tid + case mtclid of + Nothing -> error "No TicketContextLocal" + Just v -> return v tpl <- do - mtpl <- getValBy $ UniqueTicketProjectLocal tid + mtpl <- getValBy $ UniqueTicketProjectLocal tclid case mtpl of Nothing -> error "No TicketProjectLocal" Just v -> return v @@ -1072,14 +1083,14 @@ getProjectTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFs where here = ProjectTicketParticipantsR shr prj ltkhid getFsid = do - (_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (_es, _ej, _et, Entity _ lt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid return $ localTicketFollowers lt getProjectTicketTeamR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent getProjectTicketTeamR shr prj ltkhid = do memberShrs <- runDB $ do - (Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid + (Entity sid _, _ej, _et, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid id_ <- requireEitherAlt (getKeyBy $ UniquePersonIdent sid) @@ -1195,7 +1206,7 @@ getSharerTicketR shr talkhid = do (_, _, Entity _ t, tp) <- getSharerTicket404 shr talkhid (,,) t <$> bitraverse - (\ (Entity _ tpl) -> do + (\ (_, Entity _ tpl) -> do j <- getJust $ ticketProjectLocalProject tpl s <- getJust $ projectSharer j return (s, j) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 037af95..08d8c66 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1562,6 +1562,22 @@ changes hLocal ctx = insertMany_ $ map makeSender fwds -- 242 , removeField "Forwarding" "sender" + -- 243 + , renameEntity "TicketProjectLocal" "TicketContextLocal" + -- 244 + , renameUnique "TicketContextLocal" "UniqueTicketProjectLocal" "UniqueTicketContextLocal" + -- 245 + , renameUnique "TicketContextLocal" "UniqueTicketProjectLocalAccept" "UniqueTicketContextLocalAccept" + -- 246 + , addEntities model_2020_05_16 + -- 247 + , unchecked $ lift $ do + tcls <- selectList ([] :: [Filter TicketContextLocal247]) [] + let makeTPL (Entity tclid tcl) = + TicketProjectLocal247 tclid (ticketContextLocal247Project tcl) + insertMany_ $ map makeTPL tcls + -- 248 + , removeField "TicketContextLocal" "project" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index bc8037f..9bce159 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -193,6 +193,10 @@ module Vervis.Migration.Model , Forwarding241 , Forwarding241Generic (..) , ForwarderProject241Generic (..) + , model_2020_05_16 + , TicketContextLocal247 + , TicketContextLocal247Generic (..) + , TicketProjectLocal247Generic (..) ) where @@ -381,3 +385,9 @@ model_2020_05_12 = $(schema "2020_05_12_fwd_sender") makeEntitiesMigration "241" $(modelFile "migrations/2020_05_12_fwd_sender_mig.model") + +model_2020_05_16 :: [Entity SqlBackend] +model_2020_05_16 = $(schema "2020_05_16_tcl") + +makeEntitiesMigration "247" + $(modelFile "migrations/2020_05_16_tcl_mig.model") diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 910aa05..1e196c9 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -68,6 +68,7 @@ getTicketSummaries mfilt morder offlim jid = do tickets <- select $ from $ \ ( t `InnerJoin` lt + `InnerJoin` tcl `InnerJoin` tpl `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup) `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i) @@ -79,12 +80,13 @@ getTicketSummaries mfilt morder offlim jid = do on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId - on $ just (tpl ^. TicketProjectLocalId) ==. tar ?. TicketAuthorRemoteTicket + on $ just (tcl ^. TicketContextLocalId) ==. tar ?. TicketAuthorRemoteTicket on $ tal ?. TicketAuthorLocalId ==. tup ?. TicketUnderProjectAuthor on $ p ?. PersonIdent ==. s ?. SharerId on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket - on $ t ^. TicketId ==. tpl ^. TicketProjectLocalTicket + on $ tcl ^. TicketContextLocalId ==. tpl ^. TicketProjectLocalContext + on $ t ^. TicketId ==. tcl ^. TicketContextLocalTicket on $ t ^. TicketId ==. lt ^. LocalTicketTicket where_ $ tpl ^. TicketProjectLocalProject ==. val jid groupBy @@ -142,16 +144,22 @@ getTicketSummaries mfilt morder offlim jid = do getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)] getTicketDepEdges jid = fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $ - select $ from $ \ (t1 `InnerJoin` tpl1 `InnerJoin` td `InnerJoin` t2 `InnerJoin` tpl2) -> do - on $ t2 ^. TicketId ==. tpl2 ^. TicketProjectLocalTicket - on $ t2 ^. TicketId ==. td ^. TicketDependencyParent - on $ t1 ^. TicketId ==. td ^. TicketDependencyChild - on $ t1 ^. TicketId ==. tpl1 ^. TicketProjectLocalTicket - where_ $ - tpl1 ^. TicketProjectLocalProject ==. val jid &&. - tpl2 ^. TicketProjectLocalProject ==. val jid - orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId] - return (t1 ^. TicketId, t2 ^. TicketId) + select $ from $ + \ (t1 `InnerJoin` tcl1 `InnerJoin` tpl1 `InnerJoin` + td `InnerJoin` + t2 `InnerJoin` tcl2 `InnerJoin` tpl2 + ) -> do + on $ tcl2 ^. TicketContextLocalId ==. tpl2 ^. TicketProjectLocalContext + on $ t2 ^. TicketId ==. tcl2 ^. TicketContextLocalTicket + on $ t2 ^. TicketId ==. td ^. TicketDependencyParent + on $ t1 ^. TicketId ==. td ^. TicketDependencyChild + on $ tcl1 ^. TicketContextLocalId ==. tpl1 ^. TicketProjectLocalContext + on $ t1 ^. TicketId ==. tcl1 ^. TicketContextLocalTicket + where_ $ + tpl1 ^. TicketProjectLocalProject ==. val jid &&. + tpl2 ^. TicketProjectLocalProject ==. val jid + orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId] + return (t1 ^. TicketId, t2 ^. TicketId) data WorkflowFieldFilter = WorkflowFieldFilter { wffNew :: Bool @@ -431,7 +439,9 @@ getSharerTicket , Entity LocalTicket , Entity Ticket , Either - (Entity TicketProjectLocal) + ( Entity TicketContextLocal + , Entity TicketProjectLocal + ) ( Entity TicketProjectRemote , Maybe (Entity TicketProjectRemoteAccept) ) @@ -449,14 +459,15 @@ getSharerTicket shr talid = runMaybeT $ do t <- lift $ getJust tid project <- requireEitherAlt - (do mtpl <- lift $ getBy $ UniqueTicketProjectLocal tid - for mtpl $ \ etpl@(Entity tplid tpl) -> do - mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tplid + (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid + for mtcl $ \ etcl@(Entity tclid tcl) -> do + etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid + mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid unless (isJust mtup1 == isJust mtup2) $ - error "TUP points to unrelated TAL and TPL!" + error "TUP points to unrelated TAL and TCL!" guard $ not $ isJust mtup1 - return etpl + return (etcl, etpl) ) (do mtpr <- lift $ getBy $ UniqueTicketProjectRemote talid lift $ for mtpr $ \ etpr@(Entity tprid _) -> @@ -474,7 +485,9 @@ getSharerTicket404 , Entity LocalTicket , Entity Ticket , Either - (Entity TicketProjectLocal) + ( Entity TicketContextLocal + , Entity TicketProjectLocal + ) ( Entity TicketProjectRemote , Maybe (Entity TicketProjectRemoteAccept) ) @@ -496,6 +509,7 @@ getProjectTicket , Entity Project , Entity Ticket , Entity LocalTicket + , Entity TicketContextLocal , Entity TicketProjectLocal , Either (Entity TicketAuthorLocal, Entity TicketUnderProject) @@ -508,22 +522,23 @@ getProjectTicket shr prj ltid = runMaybeT $ do lt <- MaybeT $ get ltid let tid = localTicketTicket lt t <- MaybeT $ get tid - etpl@(Entity tplid tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tid + etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid + etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid guard $ ticketProjectLocalProject tpl == jid author <- requireEitherAlt (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid for mtal $ \ tal@(Entity talid _) -> do - tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tplid + tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tclid tup@(Entity tupid2 _) <- MaybeT $ getBy $ UniqueTicketUnderProjectAuthor talid unless (tupid1 == tupid2) $ error "TAL and TPL used by different TUPs!" return (tal, tup) ) - (lift $ getBy $ UniqueTicketAuthorRemote tplid) + (lift $ getBy $ UniqueTicketAuthorRemote tclid) "Ticket doesn't have author" "Ticket has both local and remote author" - return (es, ej, Entity tid t, Entity ltid lt, etpl, author) + return (es, ej, Entity tid t, Entity ltid lt, etcl, etpl, author) getProjectTicket404 :: ShrIdent @@ -534,6 +549,7 @@ getProjectTicket404 , Entity Project , Entity Ticket , Entity LocalTicket + , Entity TicketContextLocal , Entity TicketProjectLocal , Either (Entity TicketAuthorLocal, Entity TicketUnderProject)