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.

10 files changed, 95 insertions, 1 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 7ebfb06..416f71e 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -69,6 +69,7 @@ type API =
        "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
   :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor)
   :<|> "tracker" :> "ping" :> "ws" :> WebSocket
+  :<|> "ticker" :> "current" :> Get '[JSON] Value
   :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
   :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
   :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
diff --git a/lib/Persist.hs b/lib/Persist.hs
index e268455..f722487 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -166,6 +166,13 @@ Announcement json sql=tt_announcements
   url Text Maybe
   announcedAt UTCTime Maybe
   deriving Generic Show
+
+TickerAnnouncement json sql=tt_ticker
+  header Text
+  message Text
+  archived Bool
+  created UTCTime
+  deriving Generic Show
 |]
 
 instance ToSchema TicketId where
diff --git a/lib/Server.hs b/lib/Server.hs
index 30141af..15027b3 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards       #-}
 
@@ -12,6 +13,7 @@ import           Control.Monad.Extra         (forM, when)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
 import           Control.Monad.Logger        (MonadLogger, logWarnN)
 import           Control.Monad.Reader        (ReaderT)
+import qualified Data.Aeson                  as A
 import           Data.ByteString.Lazy        (toStrict)
 import           Data.Functor                ((<&>))
 import qualified Data.Map                    as M
@@ -45,7 +47,7 @@ import           Server.GTFS_RT              (gtfsRealtimeServer)
 import           Server.Ingest               (handleTrackerRegister,
                                               handleTrainPing, handleWS)
 import           Server.Subscribe            (handleSubscribe)
-import           Server.Util                 (Service, runService, runLogging)
+import           Server.Util                 (Service, runLogging, runService)
 import           System.IO.Unsafe            (unsafePerformIO)
 import           Yesod                       (toWaiAppPlain)
 
@@ -80,6 +82,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
   :<|> (handleTrackerRegister dbpool
         :<|> handleTrainPing dbpool subscribers settings (throwError err401)
         :<|> handleWS dbpool subscribers settings metrics
+        :<|> handleCurrentTicker
         :<|> handleSubscribe dbpool subscribers
         :<|> handleDebugState :<|> handleDebugTrain
         :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
@@ -95,6 +98,14 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
          entities <- selectList [TrainPingToken ==. token] []
          pure (uuid, fmap entityVal entities)
        pure (M.fromList pairs)
+    handleCurrentTicker = runSql dbpool $ do
+      selectFirst [ TickerAnnouncementArchived ==. False ] [] <&> \case
+        Nothing -> A.object [ "error" A..= A.String "no message" ]
+        Just (Entity _ TickerAnnouncement{..}) -> A.object
+          [ "error" A..= A.Null
+          , "message" A..= tickerAnnouncementMessage
+          , "header" A..= tickerAnnouncementHeader
+          ]
     handleDebugTrain ticketId = runSql dbpool $ do
       trackers <- getTicketTrackers ticketId
       pings <- forM trackers $ \(Entity token _) -> do
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
index cec4fa7..a9c2f69 100644
--- a/lib/Server/Frontend.hs
+++ b/lib/Server/Frontend.hs
@@ -6,6 +6,7 @@ import           Server.Frontend.Gtfs
 import           Server.Frontend.OnboardUnit
 import           Server.Frontend.Routes
 import           Server.Frontend.SpaceTime
+import           Server.Frontend.Ticker
 import           Server.Frontend.Tickets
 
 import           Yesod
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
diff --git a/messages/de.msg b/messages/de.msg
index 9fa87e7..bded427 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -41,6 +41,7 @@ Tickets: Tickets
 delete: löschen
 AccordingToGtfs: Weitere Fahrten im GTFS
 SpaceTimeDiagram: Weg-Zeit
+Ticker: Ticker-Hinweis
 
 OBU: Onboard-Unit
 ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index 61e8879..77f2f86 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -42,6 +42,7 @@ delete: delete
 AccordingToGtfs: Additional Trips contained in the Gtfs
 StartTracking: Start Tracking
 SpaceTimeDiagram: Space-Time Diagram
+Ticker: Ticker-Message
 
 OBU: Onboard-Unit
 ChooseTrain: Choose a Train
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 074863e..3c3d72f 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -120,6 +120,7 @@ library
                  , Server.Frontend.OnboardUnit
                  , Server.Frontend.Gtfs
                  , Server.Frontend.SpaceTime
+                 , Server.Frontend.Ticker
     default-language: GHC2021
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables