From 403c2c7ade31861c36334f0185b644e38d2dd71f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 May 2024 22:07:35 +0200
Subject: 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.
---
lib/API.hs | 1 +
lib/Persist.hs | 7 +++++
lib/Server.hs | 13 ++++++++-
lib/Server/Frontend.hs | 1 +
lib/Server/Frontend/Routes.hs | 3 ++
lib/Server/Frontend/Ticker.hs | 63 ++++++++++++++++++++++++++++++++++++++++++
lib/Server/Frontend/Tickets.hs | 5 ++++
messages/de.msg | 1 +
messages/en.msg | 1 +
tracktrain.cabal | 1 +
10 files changed, 95 insertions(+), 1 deletion(-)
create mode 100644 lib/Server/Frontend/Ticker.hs
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|
+ _{MsgTicker}
+