blob: 7fc2874628ab935b9264e4ff1fd4fcc81a29445f (
plain)
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
|
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE BlockArguments #-}
module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where
import Data.Functor ((<&>))
import Data.Time (getCurrentTime)
import Persist (EntityField (TickerAnnouncementArchived),
TickerAnnouncement (..))
import Server.Frontend.Routes (FrontendMessage (..), Handler,
Route (..), Widget)
import Yesod hiding ((==.), (=.), update)
import Database.Esqueleto.Experimental hiding ((<&>))
tickerAnnounceForm
:: Maybe TickerAnnouncement
-> Html
-> MForm Handler (FormResult TickerAnnouncement, Widget)
tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement
<$> areq textField (fieldSettingsLabel MsgHeader)
(maybeCurrent <&> tickerAnnouncementHeader)
<*> fmap unTextarea (areq textareaField (fieldSettingsLabel MsgText)
(maybeCurrent <&> (Textarea . tickerAnnouncementMessage)))
<*> pure False
<*> lift (liftIO getCurrentTime)
tickerWidget :: Handler Html
tickerWidget = do
current <- runDB $ selectOne do
ann <- from (table @TickerAnnouncement)
where_ (ann ^. TickerAnnouncementArchived ==. val False)
pure ann
(widget, enctype) <-
generateFormPost (tickerAnnounceForm (current <&> entityVal))
defaultLayout [whamlet|
<h2>_{Msgincident}
<form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
<form method=post action=@{TickerDeleteR}>
<button>_{Msgdelete}
|]
postTickerAnnounceR :: Handler Html
postTickerAnnounceR = do
current <- runDB $ selectOne do
ann <- from (table @TickerAnnouncement)
where_ (ann ^. TickerAnnouncementArchived ==. val False)
pure ann
((result, widget), enctype) <-
runFormPost (tickerAnnounceForm (fmap entityVal current))
case result of
FormSuccess ann -> do
runDB do
update \t ->
set t [ TickerAnnouncementArchived =. val True ]
insert ann
redirect RootR
_ -> defaultLayout
[whamlet|
<p>_{MsgInvalidInput}.
<form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
|]
postTickerDeleteR :: Handler Html
postTickerDeleteR = do
runDB $ update \t ->
set t [TickerAnnouncementArchived =. val True]
redirect RootR
|
