diff options
author | stuebinm | 2024-05-16 22:07:35 +0200 |
---|---|---|
committer | stuebinm | 2024-05-16 22:07:35 +0200 |
commit | 403c2c7ade31861c36334f0185b644e38d2dd71f (patch) | |
tree | 9a752a80c1081807cbef22e65fbbfbd37ab8807c /lib/Server/Frontend/Ticker.hs | |
parent | f7b461e244b825b443eee429bbafa8797d7dc56c (diff) |
new feature: Server.Frontend.Ticker
A simple way to have "announcements" available via API, and otherwise
distinct from the service announcements which show up in Gtfs Realtime.
These are meant to go e.g. be embedded on the operator's website, or in
other places where it's not as easy to display per-trip specific messages.
Diffstat (limited to '')
-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 |