Very basic support for ticket label colors

- WorkflowField now has a color, it's a simple `Maybe Int` for now. Valid
  values are only 1-4
- That color is used for displaying ticket class params a.k.a labels in ticket
  list view
- Ticket list now also serves a paged OrderedCollection

I tried to use a single SQL query to grab the tickets along with their labels,
but couldn't figure out a way to aggregate tuples/rows into an array (it seems
only single values are supported in Esqueleto). Instead of doing manual SQL or
adding Esqueleto functions, I just switched from 1 query to O(n) queries: Each
ticket has its own query selecting its labels. I guess it's slower, but also,
ticket list is paged now with fixed page size so it's really O(1) ^_^

config/models

@@ -303,6 +303,7 @@ WorkflowField
     filterNew    Bool
     filterTodo   Bool
     filterClosed Bool
+    color        Int            Maybe
 
     UniqueWorkflowField workflow ident
 

src/Vervis/Form/Workflow.hs

@@ -65,6 +65,7 @@ data NewField = NewField
     , nfNew    :: Bool
     , nfTodo   :: Bool
     , nfClosed :: Bool
+    , nfColor  :: Maybe Int
     }
 
 newFieldAForm :: WorkflowId -> AForm Handler NewField
@@ -79,12 +80,15 @@ newFieldAForm wid = NewField
     <*> areq checkBoxField             "Applies to New*"    (Just True)
     <*> areq checkBoxField             "Applies to Todo*"   (Just True)
     <*> areq checkBoxField             "Applies to Closed*" (Just True)
+    <*> aopt (selectField selectColor) "Color"              Nothing
     where
     selectEnum =
         optionsPersistKey
             [WorkflowEnumWorkflow ==. wid]
             [Asc WorkflowEnumName]
             workflowEnumName
+    selectColor =
+        optionsPairs [("red" :: Text, 1), ("green", 2), ("yellow", 3), ("blue", 4)]
 
 newFieldForm :: WorkflowId -> Form NewField
 newFieldForm wid = renderDivs $ newFieldAForm wid

src/Vervis/Handler/Ticket.hs

@@ -59,6 +59,7 @@ import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
 import Control.Monad.Trans.Except
+import Data.Aeson (encode)
 import Data.Bifunctor
 import Data.Bool (bool)
 import Data.Default.Class (def)
@@ -82,6 +83,7 @@ import Yesod.Form.Functions (runFormGet, runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text as T (filter, intercalate, pack)
 import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
@@ -95,11 +97,13 @@ import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
 import Data.Either.Local
 import Data.Maybe.Local (partitionMaybePairs)
+import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
@@ -114,6 +118,7 @@ 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
@@ -125,23 +130,84 @@ import Vervis.Widget.Discussion (discussionW)
 import Vervis.Widget.Sharer
 import Vervis.Widget.Ticket
 
-getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
+getTicketsR :: ShrIdent -> PrjIdent -> Handler TypedContent
-getTicketsR shr prj = do
+getTicketsR shr prj = selectRep $ do
-    ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
+    provideRep $ do
-    let tf =
+        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
-            case filtResult of
+        let tf =
-                FormSuccess filt -> filt
+                case filtResult of
-                FormMissing      -> def
+                    FormSuccess filt -> filt
-                FormFailure l    ->
+                    FormMissing      -> def
-                    error $ "Ticket filter form failed: " ++ show l
+                    FormFailure l    ->
-    rows <- runDB $ do
+                        error $ "Ticket filter form failed: " ++ show l
-        Entity sid _ <- getBy404 $ UniqueSharer shr
+        (total, pages, mpage) <- runDB $ do
-        Entity jid _ <- getBy404 $ UniqueProject prj sid
+            Entity sid _ <- getBy404 $ UniqueSharer shr
-        getTicketSummaries
+            Entity jid _ <- getBy404 $ UniqueProject prj sid
-            (filterTickets tf)
+            let countAllTickets = count [TicketProject ==. jid]
-            (Just $ \ t -> [E.asc $ t E.^. TicketNumber])
+                selectTickets off lim =
-            jid
+                    getTicketSummaries
-    defaultLayout $(widgetFile "ticket/list")
+                        (filterTickets tf)
+                        (Just $ \ t -> [E.asc $ t E.^. TicketNumber])
+                        (Just (off, lim))
+                        jid
+            getPageAndNavCount countAllTickets selectTickets
+        case mpage of
+            Nothing -> redirectFirstPage here
+            Just (rows, navModel) ->
+                let pageNav = navWidget navModel
+                in  defaultLayout $(widgetFile "ticket/list")
+    provideAP' $ do
+        (total, pages, mpage) <- runDB $ do
+            Entity sid _ <- getBy404 $ UniqueSharer shr
+            Entity jid _ <- getBy404 $ UniqueProject prj sid
+            let countAllTickets = count [TicketProject ==. jid]
+                selectTickets off lim = selectList [TicketProject ==. jid] [Desc TicketNumber, OffsetBy off, LimitTo lim]
+            getPageAndNavCount countAllTickets selectTickets
+
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRoutePageLocal <- getEncodeRoutePageLocal
+        let pageUrl = encodeRoutePageLocal here
+        host <- asksSite siteInstanceHost
+
+        return $
+            case mpage of
+                Nothing -> encodeStrict $ Doc host $ 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  encodeStrict $ Doc host $ 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 . entityVal)
+                                    tickets
+                            }
+    where
+    here = TicketsR shr prj
+    ticketUrl = TicketR shr prj . ticketNumber
+    encodeStrict = BL.toStrict . encode
 
 getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
 getTicketTreeR shr prj = do
@@ -149,7 +215,7 @@ getTicketTreeR shr prj = do
         Entity sid _ <- getBy404 $ UniqueSharer shr
         Entity jid _ <- getBy404 $ UniqueProject prj sid
         liftA2 (,)
-            (getTicketSummaries Nothing Nothing jid)
+            (getTicketSummaries Nothing Nothing Nothing jid)
             (getTicketDepEdges jid)
     defaultLayout $ ticketTreeDW shr prj summaries deps
 

src/Vervis/Handler/Workflow.hs

@@ -161,6 +161,7 @@ postWorkflowFieldsR shr wfl = do
                                 , workflowFieldFilterNew    = nfNew nf
                                 , workflowFieldFilterTodo   = nfTodo nf
                                 , workflowFieldFilterClosed = nfClosed nf
+                                , workflowFieldColor        = nfColor nf
                                 }
                         runDB $ insert_ field
                         return $ Right $ nfIdent nf

src/Vervis/Migration.hs

@@ -1226,6 +1226,8 @@ changes hLocal ctx =
     , renameUnique "WorkflowEnumCtor" "UniqueWorkflowFieldEnumCtor" "UniqueWorkflowEnumCtor"
       -- 184
     , addEntities model_2020_01_05
+      -- 185
+    , addFieldPrimOptional "WorkflowField" (Nothing :: Maybe Int) "color"
     ]
 
 migrateDB

src/Vervis/Ticket.hs

@@ -33,8 +33,8 @@ where
 import Control.Arrow ((***))
 import Data.Foldable (for_)
 import Data.Text (Text)
+import Data.Traversable
 import Database.Esqueleto
-import Database.Esqueleto.PostgreSQL
 
 import Vervis.Foundation (AppDB)
 import Vervis.Model
@@ -46,63 +46,69 @@ import Vervis.Widget.Ticket (TicketSummary (..))
 getTicketSummaries
     :: Maybe (SqlExpr (Entity Ticket) -> SqlExpr (Value Bool))
     -> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy])
+    -> Maybe (Int, Int)
     -> ProjectId
     -> AppDB [TicketSummary]
-getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
+getTicketSummaries mfilt morder offlim jid = do
-    \ ( t
+    tickets <- select $ from $
-        `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
+        \ ( t
-        `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
+            `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
-        `InnerJoin` d
+            `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
-        `LeftOuterJoin` m
+            `InnerJoin` d
-        `LeftOuterJoin` (tpc `InnerJoin` wf)
+            `LeftOuterJoin` m
-      ) -> do
+          ) -> do
-        on $ tpc ?. TicketParamClassField ==. wf ?. WorkflowFieldId
+            on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
-        on $ just (t ^. TicketId) ==. tpc ?. TicketParamClassTicket
+            on $ t ^. TicketDiscuss ==. d ^. DiscussionId
-        on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
+            on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
-        on $ t ^. TicketDiscuss ==. d ^. DiscussionId
+            on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
-        on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
+            on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
-        on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
+            on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
-        on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
+            on $ p ?. PersonIdent ==. s ?. SharerId
-        on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
+            on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
-        on $ p ?. PersonIdent ==. s ?. SharerId
+            on $ just (t ^. TicketId) ==. tal ?. TicketAuthorLocalTicket
-        on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
+            where_ $ t ^. TicketProject ==. val jid
-        on $ just (t ^. TicketId) ==. tal ?. TicketAuthorLocalTicket
+            groupBy
-        where_ $ t ^. TicketProject ==. val jid
+                ( t ^. TicketId, s ?. SharerId
-        groupBy
+                , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
-            ( t ^. TicketId, s ?. SharerId
+                )
-            , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
+            for_ mfilt $ \ filt -> where_ $ filt t
-            )
+            for_ morder $ \ order -> orderBy $ order t
-        for_ mfilt $ \ filt -> where_ $ filt t
+            for_ offlim $ \ (off, lim) -> do
-        for_ morder $ \ order -> orderBy $ order t
+                offset $ fromIntegral off
-        return
+                limit $ fromIntegral lim
-            ( t ^. TicketNumber
+            return
-            , s
+                ( t ^. TicketId
-            , i
+                , t ^. TicketNumber
-            , ro
+                , s
-            , ra
+                , i
-            , t ^. TicketCreated
+                , ro
-            , t ^. TicketTitle
+                , ra
-            , t ^. TicketStatus
+                , t ^. TicketCreated
-            , count $ m ?. MessageId
+                , t ^. TicketTitle
-            , arrayRemoveNull $ maybeArray $ arrayAgg $ wf ?. WorkflowFieldName
+                , t ^. TicketStatus
-            )
+                , count $ m ?. MessageId
-    where
+                )
-    toSummary (Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r, Value wfs) =
+    for tickets $
-        TicketSummary
+        \ (Value tid, Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
-            { tsNumber    = n
+            labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
-            , tsCreatedBy =
+                on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
-                case (ms, mi, mro, mra) of
+                where_ $ tpc ^. TicketParamClassTicket ==. val tid
-                    (Just s, Nothing, Nothing, Nothing) ->
+                return wf
-                        Left $ entityVal s
+            return TicketSummary
-                    (Nothing, Just i, Just ro, Just ra) ->
+                { tsNumber    = n
-                        Right (entityVal i, entityVal ro, entityVal ra)
+                , tsCreatedBy =
-                    _ -> error "Ticket author DB invalid state"
+                    case (ms, mi, mro, mra) of
-            , tsCreatedAt = c
+                        (Just s, Nothing, Nothing, Nothing) ->
-            , tsTitle     = t
+                            Left $ entityVal s
-            , tsLabels    = wfs
+                        (Nothing, Just i, Just ro, Just ra) ->
-            , tsStatus    = d
+                            Right (entityVal i, entityVal ro, entityVal ra)
-            , tsComments  = r
+                        _ -> error "Ticket author DB invalid state"
-            }
+                , tsCreatedAt = c
+                , tsTitle     = t
+                , tsLabels    = map entityVal labels
+                , tsStatus    = d
+                , tsComments  = r
+                }
 
 -- | Get the child-parent ticket number pairs of all the ticket dependencies
 -- in the given project, in ascending order by child, and then ascending order

src/Vervis/Widget/Ticket.hs

@@ -50,7 +50,7 @@ data TicketSummary = TicketSummary
     , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
     , tsCreatedAt :: UTCTime
     , tsTitle     :: Text
-    , tsLabels    :: [Text]
+    , tsLabels    :: [WorkflowField]
     , tsStatus    :: TicketStatus
     , tsComments  :: Int
     }

templates/ticket/list.hamlet

@@ -23,6 +23,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <div class="submit">
     <input type="submit" value="Filter">
 
+^{pageNav}
+
 <div .container>
   $forall ts <- rows
     ^{ticketSummaryW shr prj ts Nothing}
+
+^{pageNav}

templates/ticket/widget/summary.cassius

@@ -1,6 +1,7 @@
 /* This file is part of Vervis.
  *
- * Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ * Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>,
+ *            2019       by Jason Harrer <jazzyeagle79@gmail.com>.
  *
  * ♡ Copying is an act of love. Please copy, reuse and share.
  *
@@ -24,7 +25,7 @@
 
 .ticket-status-column
   grid-column: 1 / 1
-"
+
 .ticket-number-column
   grid-column: 2 / 2
 
@@ -42,3 +43,15 @@
 
 .ticket-node-column
   grid-column: 7 / 7
+
+.label1
+    color: #{light red}
+
+.label2
+    color: #{light green}
+
+.label3
+    color: #{light yellow}
+
+.label4
+    color: #{light blue}

templates/ticket/widget/summary.hamlet

@@ -37,8 +37,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <span .ticket-title-column>
   <a href=@{TicketR shr prj $ tsNumber ts}>
     #{tsTitle ts}
-    $forall wfname <- tsLabels ts
+  $forall wf <- tsLabels ts
-      \ [#{wfname}]
+    $maybe wfcol <- workflowFieldColor wf
+      <span .label#{wfcol}>
+        [#{workflowFieldName wf}]
+    $nothing
+      <span .label-nocolor>
+        [#{workflowFieldName wf}]
 
 <span .ticket-tree-column>
   $if tsComments ts > 0

templates/workflow/field/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2020 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -38,3 +38,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     Applies to Todo tickets: #{workflowFieldFilterTodo f}
   <li>
     Applies to Closed tickets: #{workflowFieldFilterClosed f}
+  <li>
+    Color:
+    $maybe c <- workflowFieldColor f
+      #{c}
+    $nothing
+      None