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) ^_^
2020-01-16 10:29:47 +00:00 · 2020-01-16 10:29:47 +00:00 · f4a5866dec
commit f4a5866dec
parent 031a4c0930
11 changed files with 188 additions and 80 deletions
--- a/config/models
+++ b/config/models
@ -303,6 +303,7 @@ WorkflowField
    filterNew    Bool
    filterTodo   Bool
    filterClosed Bool
+    color        Int            Maybe

    UniqueWorkflowField workflow ident

--- a/src/Vervis/Form/Workflow.hs
+++ b/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
--- a/src/Vervis/Handler/Ticket.hs
+++ b/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 shr prj = do
-    ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
-    let tf =
-            case filtResult of
-                FormSuccess filt -> filt
-                FormMissing      -> def
-                FormFailure l    ->
-                    error $ "Ticket filter form failed: " ++ show l
-    rows <- runDB $ do
-        Entity sid _ <- getBy404 $ UniqueSharer shr
-        Entity jid _ <- getBy404 $ UniqueProject prj sid
-        getTicketSummaries
-            (filterTickets tf)
-            (Just $ \ t -> [E.asc $ t E.^. TicketNumber])
-            jid
-    defaultLayout $(widgetFile "ticket/list")
+getTicketsR :: ShrIdent -> PrjIdent -> Handler TypedContent
+getTicketsR shr prj = selectRep $ do
+    provideRep $ do
+        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
+        let tf =
+                case filtResult of
+                    FormSuccess filt -> filt
+                    FormMissing      -> def
+                    FormFailure l    ->
+                        error $ "Ticket filter form failed: " ++ show l
+        (total, pages, mpage) <- runDB $ do
+            Entity sid _ <- getBy404 $ UniqueSharer shr
+            Entity jid _ <- getBy404 $ UniqueProject prj sid
+            let countAllTickets = count [TicketProject ==. jid]
+                selectTickets off lim =
+                    getTicketSummaries
+                        (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

--- a/src/Vervis/Handler/Workflow.hs
+++ b/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
--- a/src/Vervis/Migration.hs
+++ b/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
--- a/src/Vervis/Ticket.hs
+++ b/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 $
-    \ ( t
-        `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
-        `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
-        `InnerJoin` d
-        `LeftOuterJoin` m
-        `LeftOuterJoin` (tpc `InnerJoin` wf)
-      ) -> do
-        on $ tpc ?. TicketParamClassField ==. wf ?. WorkflowFieldId
-        on $ just (t ^. TicketId) ==. tpc ?. TicketParamClassTicket
-        on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
-        on $ t ^. TicketDiscuss ==. d ^. DiscussionId
-        on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
-        on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
-        on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
-        on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
-        on $ p ?. PersonIdent ==. s ?. SharerId
-        on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
-        on $ just (t ^. TicketId) ==. tal ?. TicketAuthorLocalTicket
-        where_ $ t ^. TicketProject ==. val jid
-        groupBy
-            ( t ^. TicketId, s ?. SharerId
-            , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
-            )
-        for_ mfilt $ \ filt -> where_ $ filt t
-        for_ morder $ \ order -> orderBy $ order t
-        return
-            ( t ^. TicketNumber
-            , s
-            , i
-            , ro
-            , ra
-            , t ^. TicketCreated
-            , t ^. TicketTitle
-            , t ^. TicketStatus
-            , count $ m ?. MessageId
-            , arrayRemoveNull $ maybeArray $ arrayAgg $ wf ?. WorkflowFieldName
-            )
-    where
-    toSummary (Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r, Value wfs) =
-        TicketSummary
-            { tsNumber    = n
-            , tsCreatedBy =
-                case (ms, mi, mro, mra) of
-                    (Just s, Nothing, Nothing, Nothing) ->
-                        Left $ entityVal s
-                    (Nothing, Just i, Just ro, Just ra) ->
-                        Right (entityVal i, entityVal ro, entityVal ra)
-                    _ -> error "Ticket author DB invalid state"
-            , tsCreatedAt = c
-            , tsTitle     = t
-            , tsLabels    = wfs
-            , tsStatus    = d
-            , tsComments  = r
-            }
+getTicketSummaries mfilt morder offlim jid = do
+    tickets <- select $ from $
+        \ ( t
+            `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
+            `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
+            `InnerJoin` d
+            `LeftOuterJoin` m
+          ) -> do
+            on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
+            on $ t ^. TicketDiscuss ==. d ^. DiscussionId
+            on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
+            on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
+            on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
+            on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
+            on $ p ?. PersonIdent ==. s ?. SharerId
+            on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
+            on $ just (t ^. TicketId) ==. tal ?. TicketAuthorLocalTicket
+            where_ $ t ^. TicketProject ==. val jid
+            groupBy
+                ( t ^. TicketId, s ?. SharerId
+                , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
+                )
+            for_ mfilt $ \ filt -> where_ $ filt t
+            for_ morder $ \ order -> orderBy $ order t
+            for_ offlim $ \ (off, lim) -> do
+                offset $ fromIntegral off
+                limit $ fromIntegral lim
+            return
+                ( t ^. TicketId
+                , t ^. TicketNumber
+                , s
+                , i
+                , ro
+                , ra
+                , t ^. TicketCreated
+                , t ^. TicketTitle
+                , t ^. TicketStatus
+                , count $ m ?. MessageId
+                )
+    for tickets $
+        \ (Value tid, Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
+            labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
+                on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
+                where_ $ tpc ^. TicketParamClassTicket ==. val tid
+                return wf
+            return TicketSummary
+                { tsNumber    = n
+                , tsCreatedBy =
+                    case (ms, mi, mro, mra) of
+                        (Just s, Nothing, Nothing, Nothing) ->
+                            Left $ entityVal s
+                        (Nothing, Just i, Just ro, Just ra) ->
+                            Right (entityVal i, entityVal ro, entityVal ra)
+                        _ -> 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
--- a/src/Vervis/Widget/Ticket.hs
+++ b/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
    }
--- a/templates/ticket/list.hamlet
+++ b/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}
--- a/templates/ticket/widget/summary.cassius
+++ b/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}
--- a/templates/ticket/widget/summary.hamlet
+++ b/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
-      \ [#{wfname}]
+  $forall wf <- tsLabels ts
+    $maybe wfcol <- workflowFieldColor wf
+      <span .label#{wfcol}>
+        [#{workflowFieldName wf}]
+    $nothing
+      <span .label-nocolor>
+        [#{workflowFieldName wf}]

 <span .ticket-tree-column>
  $if tsComments ts > 0
--- a/templates/workflow/field/one.hamlet
+++ b/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