3 files changed, 71 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index 8dceda5..18cf0a1 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -45,6 +45,9 @@ mkYesodData "Frontend" [parseRoutes|
 /ticket/announce/#UUID AnnounceR POST
 /ticket/del-announce/#UUID DelAnnounceR GET
 
+/ticker/announce TickerAnnounceR POST
+/ticker/delete TickerDeleteR POST
+
 /spacetime SpaceTimeDiagramR GET
 
 /token/block/#Token TokenBlock GET
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
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 1f4ad3f..9b88a48 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -45,6 +45,7 @@ import           Numeric                   (showFFloat)
 import           Persist
 import           Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
                                             mkSpaceTimeDiagramHandler)
+import           Server.Frontend.Ticker    (tickerWidget)
 import           Server.Util               (Service, secondsNow)
 import           Text.Read                 (readMaybe)
 import           Yesod
@@ -77,6 +78,8 @@ getTicketsR = do
 
   let trips = GTFS.tripsOnDay gtfs day
 
+  tickerAnnounceWidget <- tickerWidget
+
   (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
   defaultLayout $ do
     [whamlet|
@@ -91,6 +94,8 @@ $maybe name <- mdisplayname
     <a href="@{TicketsR}">_{Msgtoday}
   <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
 <section>
+  ^{tickerAnnounceWidget}
+<section>
   <h2>_{MsgTickets}
   <ol>
    $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets