diff --git a/config/routes b/config/routes index 481c9cf..761397e 100644 --- a/config/routes +++ b/config/routes @@ -1,6 +1,6 @@ -- This file is part of Vervis. -- --- Written in 2016, 2018, 2019 by fr33domlover . +-- Written in 2016, 2018, 2019, 2020 by fr33domlover . -- -- ♡ Copying is an act of love. Please copy, reuse and share. -- @@ -184,5 +184,11 @@ /s/#ShrIdent/t SharerTicketsR GET /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid SharerTicketR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/d SharerTicketDiscussionR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/deps SharerTicketDepsR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/rdeps SharerTicketReverseDepsR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/followers SharerTicketFollowersR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET +/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events SharerTicketEventsR GET /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 5fca42c..a066b21 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -54,6 +54,12 @@ module Vervis.Handler.Ticket , getSharerTicketsR , getSharerTicketR + , getSharerTicketDiscussionR + , getSharerTicketDepsR + , getSharerTicketReverseDepsR + , getSharerTicketFollowersR + , getSharerTicketTeamR + , getSharerTicketEventsR ) where @@ -64,10 +70,11 @@ import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Data.Aeson (encode) import Data.Bifunctor +import Data.Bitraversable import Data.Bool (bool) import Data.Default.Class (def) import Data.Foldable (traverse_) -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text) import Data.Time.Calendar (Day (..)) @@ -1225,6 +1232,43 @@ getTicketEventsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented" +getSharerTicket + :: ShrIdent + -> KeyHashid TicketAuthorLocal + -> AppDB + ( Entity TicketAuthorLocal + , Entity LocalTicket + , Entity Ticket + , Either (Entity TicketProjectLocal) () + ) +getSharerTicket shr talkhid = do + pid <- do + sid <- getKeyBy404 $ UniqueSharer shr + getKeyBy404 $ UniquePersonIdent sid + talid <- decodeKeyHashid404 talkhid + tal <- get404 talid + unless (ticketAuthorLocalAuthor tal == pid) notFound + let ltid = ticketAuthorLocalTicket tal + lt <- getJust ltid + let tid = localTicketTicket lt + t <- getJust tid + project <- + requireEitherAlt + (do mtpl <- getBy $ UniqueTicketProjectLocal tid + for mtpl $ \ etpl@(Entity tplid tpl) -> do + mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid + mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid + unless (isJust mtup1 == isJust mtup2) $ + error "TUP points to unrelated TAL and TPL!" + unless (isNothing mtup1) notFound + return etpl + ) + (return Nothing + ) + "Ticket doesn't have project" + "Ticket has both local and remote project" + return (Entity talid tal, Entity ltid lt, Entity tid t, project) + getSharerTicketsR :: ShrIdent -> Handler TypedContent getSharerTicketsR shr = do (total, pages, mpage) <- runDB $ do @@ -1298,4 +1342,198 @@ getSharerTicketsR shr = do getSharerTicketR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketR shr talkhid = error "Not implemented yet" +getSharerTicketR shr talkhid = do + (ticket, project, massignee) <- runDB $ do + (_, _, Entity _ t, tp) <- getSharerTicket shr talkhid + (,,) t + <$> bitraverse + (\ (Entity _ tpl) -> do + j <- getJust $ ticketProjectLocalProject tpl + s <- getJust $ projectSharer j + return (s, j) + ) + return + tp + <*> (for (ticketAssignee t) $ \ pidAssignee -> do + p <- getJust pidAssignee + getJust $ personIdent p + ) + hLocal <- getsYesod siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let ticketAP = AP.Ticket + { AP.ticketLocal = Just + ( hLocal + , AP.TicketLocal + { AP.ticketId = + encodeRouteLocal $ SharerTicketR shr talkhid + , AP.ticketContext = + encodeRouteLocal $ + case project of + Left (s, j) -> + ProjectR (sharerIdent s) (projectIdent j) + Right () -> error "No TPR yet!" + , AP.ticketReplies = + encodeRouteLocal $ SharerTicketDiscussionR shr talkhid + , AP.ticketParticipants = + encodeRouteLocal $ SharerTicketFollowersR shr talkhid + , AP.ticketTeam = + encodeRouteLocal $ SharerTicketTeamR shr talkhid + , AP.ticketEvents = + encodeRouteLocal $ SharerTicketEventsR shr talkhid + , AP.ticketDeps = + encodeRouteLocal $ SharerTicketDepsR shr talkhid + , AP.ticketReverseDeps = + encodeRouteLocal $ SharerTicketReverseDepsR shr talkhid + } + ) + , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr + , AP.ticketPublished = Just $ ticketCreated ticket + , AP.ticketUpdated = Nothing + , AP.ticketSummary = TextHtml $ ticketTitle ticket + , AP.ticketContent = TextHtml $ ticketDescription ticket + , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket + , AP.ticketAssignedTo = + encodeRouteHome . SharerR . sharerIdent <$> massignee + , AP.ticketIsResolved = ticketStatus ticket == TSClosed + } + provideHtmlAndAP ticketAP $ redirectToPrettyJSON here + where + here = SharerTicketR shr talkhid + +getSharerTicketDiscussionR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketDiscussionR shr talkhid = do + (locals, remotes) <- runDB $ do + (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid + let did = localTicketDiscuss lt + (,) <$> selectLocals did <*> selectRemotes did + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let localUri' = localUri encodeRouteHome encodeHid + replies = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length locals + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map localUri' locals ++ map remoteUri remotes + } + provideHtmlAndAP replies $ redirectToPrettyJSON here + where + here = SharerTicketDiscussionR shr talkhid + selectLocals did = + E.select $ E.from $ + \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do + E.on $ p E.^. PersonIdent E.==. s E.^. SharerId + E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId + E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (lm E.^. LocalMessageUnlinkedParent) + return (s E.^. SharerIdent, lm E.^. LocalMessageId) + selectRemotes did = + E.select $ E.from $ + \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId + E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (rm E.^. RemoteMessageLostParent) + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + localUri encR encH (E.Value shrAuthor, E.Value lmid) = + encR $ MessageR shrAuthor (encH lmid) + remoteUri (E.Value h, E.Value lu) = ObjURI h lu + +getSharerTicketDeps + :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketDeps forward shr talkhid = do + tdids <- runDB $ do + (_, _, Entity tid _, _) <- getSharerTicket shr talkhid + let (from, to) = + if forward + then (TicketDependencyParent, TicketDependencyChild) + else (TicketDependencyChild, TicketDependencyParent) + E.select $ E.from $ \ (td `E.InnerJoin` t) -> do + E.on $ td E.^. to E.==. t E.^. TicketId + E.where_ $ td E.^. from E.==. E.val tid + return $ td E.^. TicketDependencyId + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let deps = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length tdids + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) + tdids + } + provideHtmlAndAP deps $ redirectToPrettyJSON here + where + here = + let route = + if forward then SharerTicketDepsR else SharerTicketReverseDepsR + in route shr talkhid + +getSharerTicketDepsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketDepsR = getSharerTicketDeps True + +getSharerTicketReverseDepsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketReverseDepsR = getSharerTicketDeps False + +getSharerTicketFollowersR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid + where + here = SharerTicketFollowersR shr talkhid + getFsid = do + (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid + return $ localTicketFollowers lt + +getSharerTicketTeamR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketTeamR shr talkhid = do + _ <- runDB $ getSharerTicket shr talkhid + encodeRouteLocal <- getEncodeRouteLocal + let team = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just 0 + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = [] :: [Text] + } + provideHtmlAndAP team $ redirectToPrettyJSON here + where + here = SharerTicketTeamR shr talkhid + +getSharerTicketEventsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerTicketEventsR shr talkhid = do + _ <- runDB $ getSharerTicket shr talkhid + encodeRouteLocal <- getEncodeRouteLocal + let team = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just 0 + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = [] :: [Text] + } + provideHtmlAndAP team $ redirectToPrettyJSON here + where + here = SharerTicketEventsR shr talkhid