Add tickets-under-sharer route, just plain JSON view

config/models

@@ -392,7 +392,8 @@ TicketUnderProject
     project TicketProjectLocalId
     author  TicketAuthorLocalId
 
-    UniqueTicketUnderProject project author
+    UniqueTicketUnderProjectProject project
+    UniqueTicketUnderProjectAuthor  author
 
 TicketDependency
     parent  TicketId

config/routes

@@ -181,4 +181,8 @@
 /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/team         TicketTeamR           GET
 /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/events       TicketEventsR         GET
 
+/s/#ShrIdent/t                               SharerTicketsR        GET
+
+/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid   SharerTicketR         GET
+
 /s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET

src/Vervis/Foundation.hs

@@ -134,12 +134,13 @@ data App = App
 
 -- Aliases for the routes file, because it doesn't like spaces in path piece
 -- type names.
-type OutboxItemKeyHashid   = KeyHashid OutboxItem
+type OutboxItemKeyHashid        = KeyHashid OutboxItem
-type SshKeyKeyHashid       = KeyHashid SshKey
+type SshKeyKeyHashid            = KeyHashid SshKey
-type MessageKeyHashid      = KeyHashid Message
+type MessageKeyHashid           = KeyHashid Message
-type LocalMessageKeyHashid = KeyHashid LocalMessage
+type LocalMessageKeyHashid      = KeyHashid LocalMessage
-type LocalTicketKeyHashid  = KeyHashid LocalTicket
+type LocalTicketKeyHashid       = KeyHashid LocalTicket
-type TicketDepKeyHashid    = KeyHashid TicketDependency
+type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal
+type TicketDepKeyHashid         = KeyHashid TicketDependency
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:

src/Vervis/Handler/Ticket.hs

@@ -51,6 +51,9 @@ module Vervis.Handler.Ticket
     , getTicketParticipantsR
     , getTicketTeamR
     , getTicketEventsR
+
+    , getSharerTicketsR
+    , getSharerTicketR
     )
 where
 
@@ -91,6 +94,7 @@ import qualified Database.Esqueleto as E
 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 Yesod.ActivityPub
@@ -98,6 +102,7 @@ import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
+import Yesod.RenderSource
 
 import qualified Web.ActivityPub as AP
 
@@ -109,17 +114,16 @@ import Yesod.Persist.Local
 
 import Vervis.API
 import Vervis.Federation
+import Vervis.FedURI
 import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Handler.Discussion
 import Vervis.GraphProxy (ticketDepGraph)
-import Data.MediaType
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.Model.Workflow
 import Vervis.Paginate
-import Yesod.RenderSource
 import Vervis.Settings
 import Vervis.Style
 import Vervis.Ticket
@@ -1219,3 +1223,78 @@ getTicketTeamR shr prj ltkhid = do
 getTicketEventsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
+
+getSharerTicketsR :: ShrIdent -> Handler TypedContent
+getSharerTicketsR shr = do
+    (total, pages, mpage) <- runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        pid <- getKeyBy404 $ UniquePersonIdent sid
+        getPageAndNavCount (countTickets pid) (selectTickets pid)
+    encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRoutePageLocal <- getEncodeRoutePageLocal
+    let pageUrl = encodeRoutePageLocal here
+    encodeTicketKey <- getEncodeKeyHashid
+    let ticketUrl = SharerTicketR shr . encodeTicketKey
+
+    case mpage of
+        Nothing -> provide $ Collection
+            { collectionId         = encodeRouteLocal here
+            , collectionType       = CollectionTypeOrdered
+            , collectionTotalItems = Just total
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Just $ pageUrl 1
+            , collectionLast       = Just $ pageUrl pages
+            , collectionItems      = [] :: [Text]
+            }
+        Just (tickets, navModel) ->
+            let current = nmCurrent navModel
+            in  provide $ CollectionPage
+                    { collectionPageId         = pageUrl current
+                    , collectionPageType       = CollectionPageTypeOrdered
+                    , collectionPageTotalItems = Nothing
+                    , collectionPageCurrent    = Just $ pageUrl current
+                    , collectionPageFirst      = Just $ pageUrl 1
+                    , collectionPageLast       = Just $ pageUrl pages
+                    , collectionPagePartOf     = encodeRouteLocal here
+                    , collectionPagePrev       =
+                        if current > 1
+                            then Just $ pageUrl $ current - 1
+                            else Nothing
+                    , collectionPageNext       =
+                        if current < pages
+                            then Just $ pageUrl $ current + 1
+                            else Nothing
+                    , collectionPageStartIndex = Nothing
+                    , collectionPageItems      =
+                        map (encodeRouteHome . ticketUrl . E.unValue) tickets
+                    }
+    where
+    here = SharerTicketsR shr
+    provide :: ActivityPub a => a URIMode -> Handler TypedContent
+    provide a = provideHtmlAndAP a $ redirectToPrettyJSON here
+    countTickets pid = fmap toOne $
+        E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
+            E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
+            E.where_ $
+                tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
+                E.isNothing (tup E.?. TicketUnderProjectId)
+            return $ E.count $ tal E.^. TicketAuthorLocalId
+        where
+        toOne [x] = E.unValue x
+        toOne []  = error "toOne = 0"
+        toOne _   = error "toOne > 1"
+    selectTickets pid off lim =
+        E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
+            E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
+            E.where_ $
+                tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
+                E.isNothing (tup E.?. TicketUnderProjectId)
+            E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId]
+            E.offset $ fromIntegral off
+            E.limit $ fromIntegral lim
+            return $ tal E.^. TicketAuthorLocalId
+
+getSharerTicketR
+    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
+getSharerTicketR shr talkhid = error "Not implemented yet"

src/Vervis/Migration.hs

@@ -1464,6 +1464,14 @@ changes hLocal ctx =
                 E.on $ tal E.^. TicketAuthorLocal223Ticket E.==. lt E.^. LocalTicket223Id
                 return (tpl E.^. TicketProjectLocal223Id, tal E.^. TicketAuthorLocal223Id)
         insertMany_ $ map (uncurry TicketUnderProject223 . bimap E.unValue E.unValue) ids
+      -- 224
+    , addUnique "TicketUnderProject" $
+        Unique "UniqueTicketUnderProjectProject" ["project"]
+      -- 225
+    , addUnique "TicketUnderProject" $
+        Unique "UniqueTicketUnderProjectAuthor" ["author"]
+      -- 226
+    , removeUnique "TicketUnderProject" "UniqueTicketUnderProject"
     ]
 
 migrateDB

templates/person/widget/nav.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -39,3 +39,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <span>
     <a href=@{WorkflowsR shr}>
       [🔁 Workflows]
+  <span>
+    <a href=@{SharerTicketsR shr}>
+      [🐛 Tickets]