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) ^_^
This commit is contained in:
fr33domlover
parent
031a4c0930
commit
f4a5866dec
11 changed files with 188 additions and 80 deletions
|
|
@ -303,6 +303,7 @@ WorkflowField
|
|||
filterNew Bool
|
||||
filterTodo Bool
|
||||
filterClosed Bool
|
||||
color Int Maybe
|
||||
|
||||
UniqueWorkflowField workflow ident
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,8 +130,9 @@ import Vervis.Widget.Discussion (discussionW)
|
|||
import Vervis.Widget.Sharer
|
||||
import Vervis.Widget.Ticket
|
||||
|
||||
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getTicketsR shr prj = do
|
||||
getTicketsR :: ShrIdent -> PrjIdent -> Handler TypedContent
|
||||
getTicketsR shr prj = selectRep $ do
|
||||
provideRep $ do
|
||||
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
|
||||
let tf =
|
||||
case filtResult of
|
||||
|
|
@ -134,14 +140,74 @@ getTicketsR shr prj = do
|
|||
FormMissing -> def
|
||||
FormFailure l ->
|
||||
error $ "Ticket filter form failed: " ++ show l
|
||||
rows <- runDB $ 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 =
|
||||
getTicketSummaries
|
||||
(filterTickets tf)
|
||||
(Just $ \ t -> [E.asc $ t E.^. TicketNumber])
|
||||
(Just (off, lim))
|
||||
jid
|
||||
defaultLayout $(widgetFile "ticket/list")
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,18 +46,17 @@ 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
|
||||
tickets <- 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
|
||||
|
|
@ -74,8 +73,12 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
|
|||
)
|
||||
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 ^. TicketNumber
|
||||
( t ^. TicketId
|
||||
, t ^. TicketNumber
|
||||
, s
|
||||
, i
|
||||
, ro
|
||||
|
|
@ -84,11 +87,14 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
|
|||
, 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
|
||||
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
|
||||
|
|
@ -99,7 +105,7 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
|
|||
_ -> error "Ticket author DB invalid state"
|
||||
, tsCreatedAt = c
|
||||
, tsTitle = t
|
||||
, tsLabels = wfs
|
||||
, tsLabels = map entityVal labels
|
||||
, tsStatus = d
|
||||
, tsComments = r
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue