UI: HTML version for getLoomClothsR, copied from getDeckTicketsR

src/Vervis/Handler/Loom.hs

@@ -34,6 +34,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Data.Aeson
 import Data.ByteString (ByteString)
+import Data.Default.Class
 import Data.Foldable
 import Data.Maybe
 import Data.Text (Text)
@@ -44,7 +45,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)
 
@@ -74,12 +75,16 @@ 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.Ticket
 
 import qualified Vervis.Client as C
 
@@ -152,7 +157,6 @@ getLoomFollowersR = getActorFollowersCollection LoomFollowersR loomActor
 
 getLoomClothsR :: KeyHashid Loom -> Handler TypedContent
 getLoomClothsR loomHash = selectRep $ do
-    {-
     provideRep $ do
         ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
         let tf =
@@ -161,23 +165,22 @@ getLoomClothsR loomHash = selectRep $ do
                     FormMissing      -> def
                     FormFailure l    ->
                         error $ "Ticket filter form failed: " ++ show l
+        loomID <- decodeKeyHashid404 loomHash
         (total, pages, mpage) <- runDB $ do
-            Entity sid _ <- getBy404 $ UniqueSharer shr
+            _ <- get404 loomID
-            Entity jid _ <- getBy404 $ UniqueProject prj sid
+            let countAllTickets = count [TicketLoomLoom ==. loomID]
-            let countAllTickets = count [TicketProjectLocalProject ==. jid]
                 selectTickets off lim =
-                    getTicketSummaries
+                    getClothSummaries
                         (filterTickets tf)
-                        (Just $ \ t -> [E.asc $ t E.^. TicketId])
+                        (Just $ \ t -> [E.desc $ t E.^. TicketId])
                         (Just (off, lim))
-                        jid
+                        loomID
             getPageAndNavCount countAllTickets selectTickets
         case mpage of
             Nothing -> redirectFirstPage here
             Just (rows, navModel) ->
                 let pageNav = navWidget navModel
-                in  defaultLayout $(widgetFile "ticket/list")
+                in  defaultLayout $(widgetFile "cloth/list")
-    -}
     AP.provideAP' $ do
         loomID <- decodeKeyHashid404 loomHash
         (total, pages, mpage) <- runDB $ do

src/Vervis/Ticket.hs

@@ -17,6 +17,7 @@
 module Vervis.Ticket
     (
       getTicketSummaries
+    , getClothSummaries
     --, getTicketDepEdges
 
     , WorkflowFieldFilter (..)
@@ -165,6 +166,80 @@ getTicketSummaries mfilt morder offlim deckID = do
                 , tsComments  = r
                 }
 
+getClothSummaries
+    :: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool))
+    -> Maybe (E.SqlExpr (Entity Ticket) -> [E.SqlExpr E.OrderBy])
+    -> Maybe (Int, Int)
+    -> LoomId
+    -> AppDB [ClothSummary]
+getClothSummaries mfilt morder offlim loomID = do
+    tickets <- E.select $ E.from $
+        \ ( t
+            `E.InnerJoin` tl
+            `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 $ 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 (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 (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
+
+            E.on $ t E.^. TicketId E.==. tl E.^. TicketLoomTicket
+
+            E.where_ $ tl E.^. TicketLoomLoom E.==. E.val loomID
+            E.groupBy
+                ( 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
+            for_ morder $ \ order -> E.orderBy $ order t
+            for_ offlim $ \ (off, lim) -> do
+                E.offset $ fromIntegral off
+                E.limit $ fromIntegral lim
+
+            return
+                ( t E.^. TicketId
+                , tl E.^. TicketLoomId
+                , 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 tlid, 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 ClothSummary
+                { csId        = tlid
+                , csCreatedBy =
+                    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"
+                , csCreatedAt = c
+                , csTitle     = t
+                , csLabels    = map entityVal labels
+                , csStatus    = d
+                , csComments  = 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.

src/Vervis/Widget/Ticket.hs

@@ -15,8 +15,10 @@
 
 module Vervis.Widget.Ticket
     ( TicketSummary (..)
+    , ClothSummary (..)
     --, ticketDepW
     , ticketSummaryW
+    , clothSummaryW
     --, ticketTreeVW
     --, ticketTreeDW
     )
@@ -63,6 +65,18 @@ data TicketSummary = TicketSummary
     , tsComments  :: Int
     }
 
+data ClothSummary = ClothSummary
+    { csId        :: TicketLoomId
+    , csCreatedBy :: Either
+                        (Entity Person, Actor)
+                        (Instance, RemoteObject, RemoteActor)
+    , csCreatedAt :: UTCTime
+    , csTitle     :: Text
+    , csLabels    :: [WorkflowField]
+    , csStatus    :: TicketStatus
+    , csComments  :: Int
+    }
+
 {-
 ticketDepW :: ShrIdent -> PrjIdent -> LocalTicketId -> Ticket -> Widget
 ticketDepW shr prj ltid ticket = do
@@ -92,6 +106,25 @@ ticketSummaryW deckHash ts mcs = do
     ticketRoute' hashTicket summary =
         TicketR deckHash (hashTicket $ tsId summary)
 
+clothSummaryW
+    :: KeyHashid Loom
+    -> ClothSummary
+    -> Maybe (HashMap Int64 Int64)
+    -> Widget
+clothSummaryW loomHash cs mcs = do
+    hashTicket <- getEncodeKeyHashid
+    cNew <- newIdent
+    cTodo <- newIdent
+    cClosed <- newIdent
+    let tshow = T.pack . show
+        mparams = map (tshow *** tshow) . M.toList <$> mcs
+        ticketRoute = ticketRoute' hashTicket
+    mroute <- getCurrentRoute
+    $(widgetFile "cloth/widget/summary")
+    where
+    ticketRoute' hashTicket summary =
+        ClothR loomHash (hashTicket $ csId 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

templates/cloth/list.cassius

@@ -0,0 +1,4 @@
+.container
+    display: grid
+    grid-template-columns: 1rem 1rem 2fr 2fr 8fr 1rem 1rem
+    grid-column-gap: 1rem

templates/cloth/list.hamlet

@@ -0,0 +1,32 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2018, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# 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=@{ProjectTicketTreeR shr prj}>View as tree…
+
+<form method=GET action=@{LoomClothsR loomHash} enctype=#{filtEnctype}>
+  ^{filtWidget}
+  <div class="submit">
+    <input type="submit" value="Filter">
+
+^{pageNav}
+
+<div .container>
+  $forall cs <- rows
+    ^{clothSummaryW loomHash cs Nothing}
+
+^{pageNav}

templates/cloth/widget/summary.cassius

@@ -0,0 +1,57 @@
+/* This file is part of Vervis.
+ *
+ * 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.
+ *
+ * The author(s) have dedicated all copyright and related and neighboring
+ * rights to this software to the public domain worldwide. This software is
+ * distributed without any warranty.
+ *
+ * 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/>.
+ */
+
+.#{cNew}
+    color: #{dark yellow}
+
+.#{cTodo}
+    color: #{dark red}
+
+.#{cClosed}
+    color: #{dark green}
+
+.ticket-status-column
+  grid-column: 1 / 1
+
+.ticket-number-column
+  grid-column: 2 / 2
+
+.ticket-date-column
+  grid-column: 3 / 3
+
+.ticket-sharer-column
+  grid-column: 4 / 4
+
+.ticket-title-column
+  grid-column: 5 / 5
+
+.ticket-tree-column
+  grid-column: 6 / 6
+
+.ticket-node-column
+  grid-column: 7 / 7
+
+.label1
+    color: #{light red}
+
+.label2
+    color: #{light green}
+
+.label3
+    color: #{light yellow}
+
+.label4
+    color: #{light blue}

templates/cloth/widget/summary.hamlet

@@ -0,0 +1,62 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# 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/>.
+
+<span .ticket-status-column>
+  $case csStatus cs
+    $of TSNew
+      <span .#{cNew}>
+        ⬚
+    $of TSTodo
+      <span .#{cTodo}>
+        ☐
+    $of TSClosed
+      <span .#{cClosed}>
+        ☒
+
+<span .ticket-number-column>
+  <a href=@{ticketRoute cs}>
+    ### 
+
+<span .ticket-date-column>
+  #{showDate $ csCreatedAt cs}
+
+<span .ticket-sharer-column>
+  ^{personLinkFedW $ csCreatedBy cs}
+
+<span .ticket-title-column>
+  <a href=@{ticketRoute cs}>
+    #{preEscapedToHtml $ csTitle cs}
+  $forall wf <- csLabels cs
+    $maybe wfcol <- workflowFieldColor wf
+      <span .label#{wfcol}>
+        [#{workflowFieldName wf}]
+    $nothing
+      <span .label-nocolor>
+        [#{workflowFieldName wf}]
+
+<span .ticket-tree-column>
+  $if csComments cs > 0
+    💬
+    #{csComments cs}
+
+$maybe params <- mparams
+  <span .ticket-node-column>
+    <a href="#node-#{keyHashidText $ hashTicket $ csId cs}" title="Jump to subtree">
+      ☝
+    $maybe route <- mroute
+      <a href=@?{(route, params)} title="Move subtree here">
+        ☚
+$nothing
+  <span .ticket-node-column>
+    <a id="node-#{keyHashidText $ hashTicket $ csId cs}">