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