diff options
Diffstat (limited to 'lib/Server/Frontend/Ticker.hs')
-rw-r--r-- | lib/Server/Frontend/Ticker.hs | 63 |
1 files changed, 63 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs new file mode 100644 index 0000000..8861daa --- /dev/null +++ b/lib/Server/Frontend/Ticker.hs @@ -0,0 +1,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 |