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.

1 files changed, 12 insertions, 1 deletions

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