From 8f3ac509639c2dbed25c89d0ea6ab23264b0f9f1 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 24 Feb 2020 15:36:43 +0000 Subject: [PATCH] Verify TUP existence (when relevant) in all project-hosted ticket routes --- src/Vervis/Handler/Ticket.hs | 257 ++++++++--------------------------- 1 file changed, 60 insertions(+), 197 deletions(-) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 6a84641..ec14b45 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -103,7 +103,7 @@ import Database.Persist.Sql.Graph.TransitiveReduction (trrFix) import Data.Aeson.Encode.Pretty.ToEncoding import Data.MediaType import Network.FedURI -import Web.ActivityPub hiding (Ticket (..), TicketDependency) +import Web.ActivityPub hiding (Ticket (..), Project, TicketDependency) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -266,6 +266,31 @@ getTicketNewR shr prj = do ((_result, widget), enctype) <- runFormPost $ newTicketForm wid defaultLayout $(widgetFile "ticket/new") +getProjectTicket :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB (Entity Sharer, Entity Project, Entity Ticket, Entity LocalTicket, Entity TicketProjectLocal, Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)) +getProjectTicket shr prj ltkhid = do + es@(Entity sid _) <- getBy404 $ UniqueSharer shr + ej@(Entity jid _) <- getBy404 $ UniqueProject prj sid + ltid <- decodeKeyHashid404 ltkhid + lt <- get404 ltid + let tid = localTicketTicket lt + t <- get404 tid + etpl@(Entity tplid tpl) <- getBy404 $ UniqueTicketProjectLocal tid + unless (ticketProjectLocalProject tpl == jid) notFound + author <- + requireEitherAlt + (do mtal <- getBy $ UniqueTicketAuthorLocal ltid + for mtal $ \ tal@(Entity talid _) -> do + tupid1 <- getKeyBy404 $ UniqueTicketUnderProjectProject tplid + tupid2 <- getKeyBy404 $ UniqueTicketUnderProjectAuthor talid + unless (tupid1 == tupid2) $ + error "TAL and TPL used by different TUPs!" + return tal + ) + (getBy $ UniqueTicketAuthorRemote tplid) + "Ticket doesn't have author" + "Ticket has both local and remote author" + return (es, ej, Entity tid t, Entity ltid lt, etpl, author) + getTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent getTicketR shar proj ltkhid = do mpid <- maybeAuthId @@ -273,43 +298,28 @@ getTicketR shar proj ltkhid = do author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, deps, rdeps) <- runDB $ do - (jid, wshr, wid, wfl) <- do - Entity s sharer <- getBy404 $ UniqueSharer shar - Entity p project <- getBy404 $ UniqueProject proj s + (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket shar proj ltkhid + (wshr, wid, wfl) <- do w <- get404 $ projectWorkflow project wsharer <- - if workflowSharer w == s + if workflowSharer w == sid then return sharer else get404 $ workflowSharer w return - ( p - , sharerIdent wsharer + ( sharerIdent wsharer , projectWorkflow project , workflowIdent w ) - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - Entity tplid tpl <- getBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound - author <- - requireEitherAlt - (do mtal <- getValBy $ UniqueTicketAuthorLocal ltid - for mtal $ \ tal -> do - _ <- getBy404 $ UniqueTicketUnderProjectProject tplid - p <- getJust $ ticketAuthorLocalAuthor tal - getJust $ personIdent p - ) - (do mtar <- getValBy $ UniqueTicketAuthorRemote tplid - for mtar $ \ tar -> do - ra <- getJust $ ticketAuthorRemoteAuthor tar - ro <- getJust $ remoteActorIdent ra - i <- getJust $ remoteObjectInstance ro - return (i, ro, ra) - ) - "Ticket doesn't have author" - "Ticket has both local and remote author" - ticket <- get404 tid + author' <- + case author of + Left (Entity _ tal) -> Left <$> do + p <- getJust $ ticketAuthorLocalAuthor tal + getJust $ personIdent p + Right (Entity _ tar) -> Right <$> do + ra <- getJust $ ticketAuthorRemoteAuthor tar + ro <- getJust $ remoteActorIdent ra + i <- getJust $ remoteObjectInstance ro + return (i, ro, ra) massignee <- for (ticketAssignee ticket) $ \ apid -> do person <- get404 apid sharer <- get404 $ personIdent person @@ -341,7 +351,7 @@ getTicketR shar proj ltkhid = do return (lt E.^. LocalTicketId, t) return ( wshr, wfl - , author, massignee, mcloser, ticket, lticket + , author', massignee, mcloser, ticket, lticket , tparams, eparams, cparams , deps, rdeps ) @@ -418,14 +428,7 @@ getTicketR shar proj ltkhid = do putTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html putTicketR shr prj ltkhid = do (tid, ticket, wid) <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharer shr - Entity pid project <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == pid) notFound + (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid return (tid, ticket, projectWorkflow project) ((result, widget), enctype) <- runFormPost $ editTicketContentForm tid ticket wid @@ -499,14 +502,7 @@ postTicketR shr prj ltkhid = do getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getTicketEditR shr prj ltkhid = do (tid, ticket, wid) <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharer shr - Entity pid project <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == pid) notFound + (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid return (tid, ticket, projectWorkflow project) ((_result, widget), enctype) <- runFormPost $ editTicketContentForm tid ticket wid @@ -516,16 +512,7 @@ postTicketAcceptR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postTicketAcceptR shr prj ltkhid = do succ <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case ticketStatus ticket of TSNew -> do update tid [TicketStatus =. TSTodo] @@ -543,16 +530,7 @@ postTicketCloseR shr prj ltkhid = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case ticketStatus ticket of TSClosed -> return False _ -> do @@ -575,16 +553,7 @@ postTicketOpenR shr prj ltkhid = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case ticketStatus ticket of TSClosed -> do update tid @@ -604,16 +573,7 @@ postTicketClaimR postTicketClaimR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case (ticketStatus ticket, ticketAssignee ticket) of (TSNew, _) -> return $ @@ -635,16 +595,7 @@ postTicketUnclaimR postTicketUnclaimR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." @@ -668,16 +619,7 @@ getTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getTicketAssignR shr prj ltkhid = do vpid <- requireAuthId - (jid, Entity tid ticket) <- runDB $ do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity j _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == j) notFound - return (j, Entity tid ticket) + (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid let msg t = do setMessage t redirect $ TicketR shr prj ltkhid @@ -694,16 +636,7 @@ postTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postTicketAssignR shr prj ltkhid = do vpid <- requireAuthId - (jid, Entity tid ticket) <- runDB $ do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity j _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == j) notFound - return (j, Entity tid ticket) + (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid let msg t = do setMessage t redirect $ TicketR shr prj ltkhid @@ -735,16 +668,7 @@ postTicketUnassignR postTicketUnassignR shr prj ltkhid = do pid <- requireAuthId mmsg <- runDB $ do - Entity tid ticket <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity p _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - ticket <- getJust tid - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == p) notFound - return $ Entity tid ticket + (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." @@ -823,13 +747,7 @@ getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getClaimRequestsTicketR shr prj ltkhid = do rqs <- runDB $ do - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity jid _ <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound + (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket 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 @@ -853,15 +771,7 @@ postClaimRequestsTicketR shr prj ltkhid = do now <- liftIO getCurrentTime pid <- requireAuthId runDB $ do - tid <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity j _ <- getBy404 $ UniqueProject prj s - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == j) notFound - return tid + (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid let cr = TicketClaimRequest { ticketClaimRequestPerson = pid , ticketClaimRequestTicket = tid @@ -881,13 +791,7 @@ postClaimRequestsTicketR shr prj ltkhid = do selectDiscussionId :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId selectDiscussionId shr prj ltkhid = do - Entity sid _sharer <- getBy404 $ UniqueSharer shr - Entity jid _project <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound + (_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket shr prj ltkhid return $ localTicketDiscuss lticket getTicketDiscussionR @@ -974,13 +878,7 @@ getTicketDeps forward shr prj ltkhid = do if forward then TicketDependencyParent else TicketDependencyChild to' = if forward then TicketDependencyChild else TicketDependencyParent - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity jid _ <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound + (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid fmap (map toRow) $ E.select $ E.from $ \ ( td `E.InnerJoin` t @@ -1050,15 +948,7 @@ getTicketDepsR = getTicketDeps True postTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postTicketDepsR shr prj ltkhid = do - (jid, tid) <- runDB $ do - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity jid _ <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound - return (jid, tid) + (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid case result of FormSuccess ctid -> do @@ -1086,15 +976,7 @@ postTicketDepsR shr prj ltkhid = do getTicketDepNewR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html getTicketDepNewR shr prj ltkhid = do - (jid, tid) <- runDB $ do - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity jid _ <- getBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lticket <- get404 ltid - let tid = localTicketTicket lticket - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound - return (jid, tid) + (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid defaultLayout $(widgetFile "ticket/dep/new") @@ -1110,14 +992,7 @@ deleteTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html deleteTicketDepOldR shr prj pnum cnum = do runDB $ do - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity jid _ <- getBy404 $ UniqueProject prj sid - - pltid <- decodeKeyHashid404 pnum - plt <- get404 pltid - let ptid = localTicketTicket plt - ptpl <- getValBy404 $ UniqueTicketProjectLocal ptid - unless (ticketProjectLocalProject ptpl == jid) notFound + (_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket shr prj pnum cltid <- decodeKeyHashid404 cnum clt <- get404 cltid @@ -1194,26 +1069,14 @@ getTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFsid where here = TicketParticipantsR shr prj ltkhid getFsid = do - sid <- getKeyBy404 $ UniqueSharer shr - jid <- getKeyBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lt <- get404 ltid - let tid = localTicketTicket lt - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound + (_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket shr prj ltkhid return $ localTicketFollowers lt getTicketTeamR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent getTicketTeamR shr prj ltkhid = do memberShrs <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - jid <- getKeyBy404 $ UniqueProject prj sid - ltid <- decodeKeyHashid404 ltkhid - lt <- get404 ltid - let tid = localTicketTicket lt - tpl <- getValBy404 $ UniqueTicketProjectLocal tid - unless (ticketProjectLocalProject tpl == jid) notFound + (Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid id_ <- requireEitherAlt (getKeyBy $ UniquePersonIdent sid)