diff --git a/config/routes b/config/routes index 372a773..29a9b8d 100644 --- a/config/routes +++ b/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 diff --git a/src/Data/Graph/DirectedAcyclic/View/Tree.hs b/src/Data/Graph/DirectedAcyclic/View/Tree.hs index 083ab0f..d4a44bf 100644 --- a/src/Data/Graph/DirectedAcyclic/View/Tree.hs +++ b/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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 48a26dc..b76ccef 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 6177df4..50c1916 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs new file mode 100644 index 0000000..0720a88 --- /dev/null +++ b/src/Vervis/Ticket.hs @@ -0,0 +1,71 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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) diff --git a/templates/ticket/list.hamlet b/templates/ticket/list.hamlet index 150c76e..525a11d 100644 --- a/templates/ticket/list.hamlet +++ b/templates/ticket/list.hamlet @@ -15,6 +15,9 @@ $# .

Create new… +

+ View as tree… +

^{filtWidget} diff --git a/vervis.cabal b/vervis.cabal index 04389a5..8c9b069 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -156,6 +156,7 @@ library Vervis.SourceTree Vervis.Ssh Vervis.Style + Vervis.Ticket Vervis.TicketFilter Vervis.Time Vervis.Widget