sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 18:04:53 +09:00
Code Issues Activity

UI: Fix and re-enable deck ticket list view

Browse source
This commit is contained in:
fr33domlover 2022-09-17 10:14:27 +00:00
parent c495d78d05
commit e69d775f3f
7 changed files with 91 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
src/Vervis/Form/Ticket.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -14,12 +14,12 @@
-}
module Vervis.Form.Ticket
( NewTicket (..)
, newTicketForm
, editTicketContentForm
, assignTicketForm
, claimRequestForm
, ticketFilterForm
( --NewTicket (..)
--, newTicketForm
--, editTicketContentForm
--, assignTicketForm
--, claimRequestForm
ticketFilterForm
--, ticketDepForm
)
where
@ -39,7 +39,6 @@ import Yesod.Persist.Core (runDB)
import qualified Data.Text as T
import Vervis.Field.Ticket
import Vervis.Foundation (App, Form, Handler)
import Vervis.Model
import Vervis.Model.Ticket
@ -49,6 +48,7 @@ import Vervis.TicketFilter (TicketFilter (..))
--TODO use custom fields to ensure uniqueness or other constraints?
{-
data NewTicket = NewTicket
{ ntTitle :: Text
, ntDesc :: Text
@ -137,7 +137,9 @@ newTicketForm wid html = do
<*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
<*> (catMaybes <$> traverse cfield cfs)
<*> areq checkBoxField "Offer" Nothing
-}
{-
editTicketContentAForm :: Ticket -> AForm Handler Ticket
editTicketContentAForm ticket = Ticket
<$> pure (ticketNumber ticket)
@ -240,19 +242,24 @@ editTicketContentForm tid t wid html = do
<*> traverse tEditField tfs
<*> traverse eEditField efs
<*> traverse cEditField cfs
-}
{-
assignTicketAForm :: PersonId -> ProjectId -> AForm Handler PersonId
assignTicketAForm pid jid =
areq (selectAssigneeFromProject pid jid) "Assignee*" Nothing
assignTicketForm :: PersonId -> ProjectId -> Form PersonId
assignTicketForm pid jid = renderDivs $ assignTicketAForm pid jid
-}
{-
claimRequestAForm :: AForm Handler Text
claimRequestAForm = unTextarea <$> areq textareaField "Message*" Nothing
claimRequestForm :: Form Text
claimRequestForm = renderDivs claimRequestAForm
-}
ticketFilterAForm :: AForm Handler TicketFilter
ticketFilterAForm = mk

20
src/Vervis/Handler/Deck.hs
View file

@ -57,6 +57,7 @@ import Control.Monad
import Control.Monad.Trans.Except
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Default.Class
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@ -67,7 +68,7 @@ import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuth)
import Yesod.Core
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Functions (runFormPost, runFormGet)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
@ -98,13 +99,17 @@ import Vervis.Federation.Auth
import Vervis.Federation.Collab
import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket
import Vervis.TicketFilter
import Vervis.Web.Actor
import Vervis.Widget.Person
import Vervis.Widget.Ticket
import qualified Vervis.Client as C
@ -209,7 +214,6 @@ getDeckFollowersR = getActorFollowersCollection DeckFollowersR deckActor
getDeckTicketsR :: KeyHashid Deck -> Handler TypedContent
getDeckTicketsR deckHash = selectRep $ do
{-
provideRep $ do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf =
@ -218,26 +222,26 @@ getDeckTicketsR deckHash = selectRep $ do
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
deckID <- decodeKeyHashid404 deckHash
(total, pages, mpage) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
let countAllTickets = count [TicketProjectLocalProject ==. jid]
_ <- get404 deckID
let countAllTickets = count [TicketDeckDeck ==. deckID]
selectTickets off lim =
getTicketSummaries
(filterTickets tf)
(Just $ \ t -> [E.asc $ t E.^. TicketId])
(Just $ \ t -> [E.desc $ t E.^. TicketId])
(Just (off, lim))
jid
deckID
getPageAndNavCount countAllTickets selectTickets
case mpage of
Nothing -> redirectFirstPage here
Just (rows, navModel) ->
let pageNav = navWidget navModel
in defaultLayout $(widgetFile "ticket/list")
-}
provideAP' $ do
deckID <- decodeKeyHashid404 deckHash
(total, pages, mpage) <- runDB $ do
_ <- get404 deckID
let countAllTickets = count [TicketDeckDeck ==. deckID]
selectTickets off lim =
selectKeysList

65
src/Vervis/Ticket.hs
View file

@ -16,9 +16,9 @@
module Vervis.Ticket
(
{-
getTicketSummaries
--, getTicketDepEdges
{-
, WorkflowFieldFilter (..)
, WorkflowFieldSummary (..)
, TicketTextParamValue (..)
@ -32,7 +32,7 @@ module Vervis.Ticket
, getTicketClasses
-}
getTicket
, getTicket
, getTicket404
--, getDependencyCollection
@ -88,43 +88,42 @@ import Vervis.Model.Ident
import Vervis.Model.Workflow
import Vervis.Paginate
import Vervis.Recipient
import Vervis.Widget.Ticket
{-
-- | Get summaries of all the tickets in the given project.
getTicketSummaries
:: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool))
-> Maybe (E.SqlExpr (Entity Ticket) -> [E.SqlExpr E.OrderBy])
-> Maybe (Int, Int)
-> ProjectId
-> DeckId
-> AppDB [TicketSummary]
getTicketSummaries mfilt morder offlim jid = do
getTicketSummaries mfilt morder offlim deckID = do
tickets <- E.select $ E.from $
\ ( t
`E.InnerJoin` lt
`E.InnerJoin` tcl
`E.InnerJoin` tpl
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)
`E.InnerJoin` td
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` a)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
`E.InnerJoin` d
`E.LeftOuterJoin` m
) -> do
E.on $ E.just (d E.^. DiscussionId) E.==. m E.?. MessageRoot
E.on $ lt E.^. LocalTicketDiscuss E.==. d E.^. DiscussionId
E.on $ t E.^. TicketDiscuss E.==. d E.^. DiscussionId
E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket
E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
E.on $ p E.?. PersonActor E.==. a E.?. ActorId
E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext
E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
E.on $ t E.^. TicketId E.==. td E.^. TicketDeckTicket
E.where_ $ td E.^. TicketDeckDeck E.==. E.val deckID
E.groupBy
( t E.^. TicketId, lt E.^. LocalTicketId
, tal E.?. TicketAuthorLocalId, s E.?. SharerId, tup E.?. TicketUnderProjectId
( t E.^. TicketId
, tal E.?. TicketAuthorLocalId, p E.?. PersonId, a E.?. ActorId
, ra E.?. RemoteActorId, ro E.?. RemoteObjectId, i E.?. InstanceId
)
for_ mfilt $ \ filt -> E.where_ $ filt t
@ -132,35 +131,30 @@ getTicketSummaries mfilt morder offlim jid = do
for_ offlim $ \ (off, lim) -> do
E.offset $ fromIntegral off
E.limit $ fromIntegral lim
return
( t E.^. TicketId
, lt E.^. LocalTicketId
, tal E.?. TicketAuthorLocalId
, s
, tup E.?. TicketUnderProjectId
, i
, ro
, ra
, td E.^. TicketDeckId
, p, a
, i, ro, ra
, t E.^. TicketCreated
, t E.^. TicketTitle
, t E.^. TicketStatus
, E.count $ m E.?. MessageId
)
for tickets $
\ (E.Value tid, E.Value ltid, E.Value mtalid, ms, E.Value mtupid, mi, mro, mra, E.Value c, E.Value t, E.Value d, E.Value r) -> do
\ (E.Value tid, E.Value tdid, mp, ma, mi, mro, mra, E.Value c, E.Value t, E.Value d, E.Value r) -> do
labels <- E.select $ E.from $ \ (tpc `E.InnerJoin` wf) -> do
E.on $ tpc E.^. TicketParamClassField E.==. wf E.^. WorkflowFieldId
E.where_ $ tpc E.^. TicketParamClassTicket E.==. E.val tid
return wf
return TicketSummary
{ tsId = ltid
{ tsId = tdid
, tsCreatedBy =
case (mtalid, ms, mi, mro, mra) of
(Just talid, Just s, Nothing, Nothing, Nothing) ->
Left
( entityVal s
, if isJust mtupid then Nothing else Just talid
)
case (mp, ma, mi, mro, mra) of
(Just p, Just a, Nothing, Nothing, Nothing) ->
Left (p, entityVal a)
(Nothing, Nothing, Just i, Just ro, Just ra) ->
Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state"
@ -171,6 +165,7 @@ getTicketSummaries mfilt morder offlim jid = do
, 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
-- by parent.

40
src/Vervis/Widget/Ticket.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -15,10 +15,10 @@
module Vervis.Widget.Ticket
( TicketSummary (..)
, ticketDepW
--, ticketDepW
, ticketSummaryW
, ticketTreeVW
, ticketTreeDW
--, ticketTreeVW
--, ticketTreeDW
)
where
@ -45,16 +45,17 @@ import Yesod.Hashids
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Settings (widgetFile)
import Vervis.Style
import Vervis.Time (showDate)
import Vervis.Widget.Sharer
import Vervis.Widget.Person
data TicketSummary = TicketSummary
{ tsId :: LocalTicketId
, tsCreatedBy :: Either (Sharer, Maybe TicketAuthorLocalId) (Instance, RemoteObject, RemoteActor)
{ tsId :: TicketDeckId
, tsCreatedBy :: Either
(Entity Person, Actor)
(Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime
, tsTitle :: Text
, tsLabels :: [WorkflowField]
@ -62,6 +63,7 @@ data TicketSummary = TicketSummary
, tsComments :: Int
}
{-
ticketDepW :: ShrIdent -> PrjIdent -> LocalTicketId -> Ticket -> Widget
ticketDepW shr prj ltid ticket = do
encodeTicketKey <- getEncodeKeyHashid
@ -69,31 +71,28 @@ ticketDepW shr prj ltid ticket = do
cTodo <- newIdent
cClosed <- newIdent
$(widgetFile "ticket/widget/dep")
-}
ticketSummaryW
:: ShrIdent
-> PrjIdent
:: KeyHashid Deck
-> TicketSummary
-> Maybe (HashMap Int64 Int64)
-> Widget
ticketSummaryW shr prj ts mcs = do
encodeLT <- getEncodeKeyHashid
encodeTAL <- getEncodeKeyHashid
ticketSummaryW deckHash ts mcs = do
hashTicket <- getEncodeKeyHashid
cNew <- newIdent
cTodo <- newIdent
cClosed <- newIdent
let tshow = T.pack . show
mparams = map (tshow *** tshow) . M.toList <$> mcs
ticketRoute = ticketRoute' encodeLT encodeTAL
ticketRoute = ticketRoute' hashTicket
mroute <- getCurrentRoute
$(widgetFile "ticket/widget/summary")
where
ticketRoute' encodeLT encodeTAL summary =
case tsCreatedBy summary of
Left (s, Just talid) ->
SharerTicketR (sharerIdent s) (encodeTAL talid)
_ -> ProjectTicketR shr prj $ encodeLT $ tsId summary
ticketRoute' hashTicket summary =
TicketR deckHash (hashTicket $ tsId summary)
{-
-- I'm noticing a pattern. A problem. Some of my widget functions take data and
-- directly represent it in HTML. Others take some other more general
-- structures, then pick the relevant pieces and generate HTML. Others involve
@ -121,7 +120,9 @@ ticketTreeVW shr prj cDeps t = go t
^{go tree}
|]
go (LinkNode (ts, cs)) = summary ts (Just cs)
-}
{-
-- | In the request's GET parameters, find ones of the form @N=M@ where N and M
-- are integers. Return a list of pairs corresponding to those parameters.
getParentChoices :: MonadHandler m => m [(Int64, Int64)]
@ -144,3 +145,4 @@ ticketTreeDW shr prj summaries deps = do
oneTree = ticketTreeVW shr prj cDeps
forest = map oneTree $ dagViewTree nodes deps choices
$(widgetFile "ticket/widget/tree")
-}

14
templates/ticket/list.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2018, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -12,13 +12,13 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
<a href=@{ProjectTicketNewR shr prj}>Create new…
$# <p>
$# <a href=@{ProjectTicketNewR shr prj}>Create new…
<p>
<a href=@{ProjectTicketTreeR shr prj}>View as tree…
$# <p>
$# <a href=@{ProjectTicketTreeR shr prj}>View as tree…
<form method=GET action=@{ProjectTicketsR shr prj} enctype=#{filtEnctype}>
<form method=GET action=@{DeckTicketsR deckHash} enctype=#{filtEnctype}>
^{filtWidget}
<div class="submit">
<input type="submit" value="Filter">
@ -27,6 +27,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div .container>
$forall ts <- rows
^{ticketSummaryW shr prj ts Nothing}
^{ticketSummaryW deckHash ts Nothing}
^{pageNav}

8
templates/ticket/widget/summary.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -32,7 +32,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
#{showDate $ tsCreatedAt ts}
<span .ticket-sharer-column>
^{sharerLinkFedW $ first fst $ tsCreatedBy ts}
^{personLinkFedW $ tsCreatedBy ts}
<span .ticket-title-column>
<a href=@{ticketRoute ts}>
@ -52,11 +52,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$maybe params <- mparams
<span .ticket-node-column>
<a href="#node-#{keyHashidText $ encodeLT $ tsId ts}" title="Jump to subtree">
<a href="#node-#{keyHashidText $ hashTicket $ tsId ts}" title="Jump to subtree">
☝
$maybe route <- mroute
<a href=@?{(route, params)} title="Move subtree here">
☚
$nothing
<span .ticket-node-column>
<a id="node-#{keyHashidText $ encodeLT $ tsId ts}">
<a id="node-#{keyHashidText $ hashTicket $ tsId ts}">

4
vervis.cabal
View file

@ -166,7 +166,7 @@ library
Vervis.Form.Project
Vervis.Form.Repo
--Vervis.Form.Role
--Vervis.Form.Ticket
Vervis.Form.Ticket
-- Vervis.Form.Workflow
Vervis.Formatting
Vervis.Foundation
@ -236,7 +236,7 @@ library
--Vervis.Widget.Project
Vervis.Widget.Repo
--Vervis.Widget.Role
--Vervis.Widget.Ticket
Vervis.Widget.Ticket
-- Vervis.Widget.Workflow
-- Vervis.Wiki
Vervis.WorkItem