Experimental changes to Vervis.

[[ 🗃 ^KrXYo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/KrXYo

SSH: darcs clone USERNAME@vervis.peers.community:KrXYo

Tags

TODO

src / Vervis / Widget /

Ticket.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

{- 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.Widget.Ticket
    ( TicketSummary (..)
    , ticketDepW
    , ticketSummaryW
    , ticketTreeVW
    , ticketTreeDW
    )
where

import Prelude

import Control.Arrow ((&&&), (***))
import Data.HashMap.Lazy (HashMap)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Yesod.Core (MonadHandler, newIdent)
import Yesod.Core.Handler (getCurrentRoute, getRequest, YesodRequest (..))
import Yesod.Core.Widget (whamlet)

import qualified Data.HashMap.Lazy as M (toList)
import qualified Data.Text as T (null, pack, unpack)
import qualified Data.Text.Read as TR (decimal)

import Data.Graph.DirectedAcyclic.View.Tree
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 (personLinkW)

data TicketSummary = TicketSummary
    { tsNumber    :: Int
    , tsCreatedBy :: Sharer
    , tsCreatedAt :: UTCTime
    , tsTitle     :: Text
    , tsStatus    :: TicketStatus
    , tsComments  :: Int
    }

ticketDepW :: ShrIdent -> PrjIdent -> Ticket -> Widget
ticketDepW shr prj ticket = do
    cNew <- newIdent
    cTodo <- newIdent
    cClosed <- newIdent
    $(widgetFile "ticket/widget/dep")

ticketSummaryW
    :: ShrIdent
    -> PrjIdent
    -> TicketSummary
    -> Maybe (HashMap Int Int)
    -> Widget
ticketSummaryW shr prj ts mcs = do
    cNew <- newIdent
    cTodo <- newIdent
    cClosed <- newIdent
    let tshow = T.pack . show
        mparams = map (tshow *** tshow) . M.toList <$> mcs
    mroute <- getCurrentRoute
    $(widgetFile "ticket/widget/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
-- IO actions, especially DB access.
--
-- So here's an idea to try. Instead of the W suffix, have 3 suffixes:
--
-- * /VW/ - view widget, direct data to HTML conversion
-- * /DW/ - data widget, takes more general data and picks some for the view
-- * /PW/ - persistent widget, takes data from filesystem or DB
ticketTreeVW
    :: ShrIdent
    -> PrjIdent
    -> Text
    -> DagViewTree TicketSummary (TicketSummary, HashMap Int Int)
    -> Widget
ticketTreeVW shr prj cDeps t = go t
    where
    summary = ticketSummaryW shr prj
    go (FullNode ts trees) = do
        summary ts Nothing
        [whamlet|
            <div .#{cDeps}>
              $forall tree <- trees
                ^{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 [(Int, Int)]
getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest
    where
    readInts (ct, pt) =
        case (TR.decimal ct, TR.decimal pt) of
            (Right (c, cr), Right (p, pr)) ->
                if T.null cr && T.null pr
                    then Just (c, p)
                    else Nothing
            _ -> Nothing

ticketTreeDW
    :: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int, Int)] -> Widget
ticketTreeDW shr prj summaries deps = do
    cDeps <- newIdent
    choices <- getParentChoices
    let nodes = map (tsNumber &&& id) summaries
        oneTree = ticketTreeVW shr prj cDeps
        forest = map oneTree $ dagViewTree nodes deps choices
    $(widgetFile "ticket/widget/tree")
[See repo JSON]