Ticket tree view page

config/routes

@@ -93,6 +93,7 @@
 /s/#ShrIdent/p/#PrjIdent/d/#ShrIdent         ProjectDevR           GET DELETE POST
 
 /s/#ShrIdent/p/#PrjIdent/t                   TicketsR              GET POST
+/s/#ShrIdent/p/#PrjIdent/t/!tree             TicketTreeR           GET
 /s/#ShrIdent/p/#PrjIdent/t/!new              TicketNewR            GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int              TicketR               GET PUT DELETE POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/edit         TicketEditR           GET

src/Data/Graph/DirectedAcyclic/View/Tree.hs

@@ -87,8 +87,8 @@ edgeView
     -- ^ New edge label. For a full edge, 'Nothing'. For a link edge, 'Just' an
     -- updated choice map that chooses this edge as the new full edge for the
     -- child.
-edgeView _       (_,     _,      False) = Nothing
-edgeView choices (child, parent, True)  = Just $ M.insert child parent choices
+edgeView _       (_,     _,      True)  = Nothing
+edgeView choices (child, parent, False) = Just $ M.insert child parent choices
 
 reverseEdge :: (n, n, a) -> (n, n, a)
 reverseEdge (x, y, l) = (y, x, l)

src/Vervis/Foundation.hs

@@ -455,6 +455,7 @@ instance YesodBreadcrumbs App where
         TicketsR shar proj               -> ( "Tickets"
                                             , Just $ ProjectR shar proj
                                             )
+        TicketTreeR shr prj              -> ( "Tree", Just $ TicketsR shr prj)
         TicketNewR shar proj             -> ("New", Just $ TicketsR shar proj)
         TicketR shar proj num            -> ( T.pack $ '#' : show num
                                             , Just $ TicketsR shar proj

src/Vervis/Handler/Ticket.hs

@@ -16,6 +16,7 @@
 module Vervis.Handler.Ticket
     ( getTicketsR
     , postTicketsR
+    , getTicketTreeR
     , getTicketNewR
     , getTicketR
     , putTicketR
@@ -51,6 +52,7 @@ where
 
 import Prelude
 
+import Control.Applicative (liftA2)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
 import Data.Default.Class (def)
@@ -84,6 +86,7 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Render (renderSourceT)
 import Vervis.Settings (widgetFile)
+import Vervis.Ticket
 import Vervis.TicketFilter (filterTickets)
 import Vervis.Time (showDate)
 import Vervis.Widget.Discussion (discussionW)
@@ -154,6 +157,16 @@ postTicketsR shar proj = do
             setMessage "Ticket creation failed, see errors below."
             defaultLayout $(widgetFile "ticket/new")
 
+getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
+getTicketTreeR shr prj = do
+    (summaries, deps) <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity jid _ <- getBy404 $ UniqueProject prj sid
+        liftA2 (,)
+            (getTicketSummaries jid)
+            (getTicketDepEdges jid)
+    defaultLayout $ ticketTreeDW shr prj summaries deps
+
 getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
 getTicketNewR shar proj = do
     ((_result, widget), enctype) <- runFormPost newTicketForm

src/Vervis/Ticket.hs

@@ -0,0 +1,71 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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/>.
+ -}
+
+module Vervis.Ticket
+    ( getTicketSummaries
+    , getTicketDepEdges
+    )
+where
+
+import Prelude
+
+import Control.Arrow ((***))
+import Database.Esqueleto
+
+import Vervis.Foundation (AppDB)
+import Vervis.Model
+import Vervis.Widget.Ticket (TicketSummary (..))
+
+-- | Get summaries of all the tickets in the given project.
+getTicketSummaries :: ProjectId -> AppDB [TicketSummary]
+getTicketSummaries jid = do
+    let toSummary (Value n, Entity _ s, Value c, Value t, Value d, Value r) =
+            TicketSummary
+                { tsNumber    = n
+                , tsCreatedBy = s
+                , tsCreatedAt = c
+                , tsTitle     = t
+                , tsDone      = d
+                , tsComments  = r
+                }
+    fmap (map toSummary) $ select $ from $
+        \ (t `InnerJoin` p `InnerJoin` s `InnerJoin` d) -> do
+            on $ t ^. TicketDiscuss ==. d ^. DiscussionId
+            on $ p ^. PersonIdent ==. s ^. SharerId
+            on $ t ^. TicketCreator ==. p ^. PersonId
+            where_ $ t  ^. TicketProject ==. val jid
+            return
+                ( t ^. TicketNumber
+                , s
+                , t ^. TicketCreated
+                , t ^. TicketTitle
+                , t ^. TicketDone
+                , d ^. DiscussionNextMessage -. val 1
+                )
+
+-- | 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.
+getTicketDepEdges :: ProjectId -> AppDB [(Int, Int)]
+getTicketDepEdges jid =
+    fmap (map $ unValue *** unValue) $
+    select $ from $ \ (t1 `InnerJoin` td `InnerJoin` t2) -> do
+        on $ t2 ^. TicketId ==. td ^. TicketDependencyParent
+        on $ t1 ^. TicketId ==. td ^. TicketDependencyChild
+        where_ $
+            t1 ^. TicketProject ==. val jid &&.
+            t2 ^. TicketProject ==. val jid
+        orderBy [asc $ t1 ^. TicketNumber, asc $ t2 ^. TicketNumber]
+        return (t1 ^. TicketNumber, t2 ^. TicketNumber)

templates/ticket/list.hamlet

@@ -15,6 +15,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <p>
   <a href=@{TicketNewR shar proj}>Create new…
 
+<p>
+  <a href=@{TicketTreeR shar proj}>View as tree…
+
 <form method=GET action=@{TicketsR shar proj} enctype=#{filtEnctype}>
   ^{filtWidget}
   <input type="submit" value="Filter">

vervis.cabal

@@ -156,6 +156,7 @@ library
                        Vervis.SourceTree
                        Vervis.Ssh
                        Vervis.Style
+                       Vervis.Ticket
                        Vervis.TicketFilter
                        Vervis.Time
                        Vervis.Widget