Implement sharer ticket JSON view, including discussion, followers, deps etc.

config/routes

@@ -1,6 +1,6 @@
 -- This file is part of Vervis.
 --
--- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+-- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
 --
 -- ♡ 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

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