blob: 8861daa893d97515e49b491e2672bf734ee526f3 (
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
|
{-# LANGUAGE QuasiQuotes #-}
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
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 $ selectFirst [ TickerAnnouncementArchived ==. False ] []
(widget, enctype) <-
generateFormPost (tickerAnnounceForm (current <&> entityVal))
defaultLayout [whamlet|
<h2>_{MsgTicker}
<form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
<form method=post action=@{TickerDeleteR}>
<button>_{Msgdelete}
|]
postTickerAnnounceR :: Handler Html
postTickerAnnounceR = do
current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
((result, widget), enctype) <-
runFormPost (tickerAnnounceForm (current <&> entityVal))
case result of
FormSuccess ann -> do
runDB $ do
updateWhere [] [ TickerAnnouncementArchived =. 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 $ updateWhere [] [ TickerAnnouncementArchived =. True ]
redirect RootR
|
