diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 13 |
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 |