From 7798666c81b390183e2e227232d936abf0cc4a65 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 11 Mar 2023 01:36:35 +0100
Subject: simple on-board tools

these are just enough to send train positions to tracktrain with the
current API, but are somewhat brittle (e.g. will fail if not restarted
between trips, etc.)
---
 lib/Server.hs | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

(limited to 'lib/Server.hs')

diff --git a/lib/Server.hs b/lib/Server.hs
index 8d81127..7fdfd71 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE DataKinds #-}
 
 
 -- Implementation of the API. This module is the main point of the program.
@@ -23,6 +24,7 @@ import           Control.Monad.Logger        (LoggingT, logWarnN)
 import           Control.Monad.Reader        (forM)
 import           Control.Monad.Trans         (lift)
 import qualified Data.Aeson                  as A
+import           Data.Aeson                  ((.=))
 import qualified Data.ByteString.Char8       as C8
 import           Data.Coerce                 (coerce)
 import           Data.Functor                ((<&>))
@@ -85,7 +87,7 @@ doMigration pool = runSql pool $
 
 server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
 server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
-  :<|> (handleStations :<|> handleTimetable :<|> handleTrip
+  :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip
         :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
         :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain
         :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool)
@@ -93,13 +95,22 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
   :<|> serveDirectoryFileServer (serverConfigAssets settings)
   :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
   where handleStations = pure stations
-        handleTimetable station maybeDay = do
-          -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
-          day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
-          pure
-            -- don't send stations ending at this station
-            . M.filter ((==) station . stationId . stopStation . V.last . tripStops)
-            $ tripsOnDay gtfs day
+        handleTimetable station maybeDay =
+          M.filter isLastStop . tripsOnDay gtfs <$> liftIO day
+          where isLastStop = (==) station . stationId . stopStation . V.last . tripStops
+                day = maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+        handleTimetableStops day =
+          pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day
+          where mkJson :: Trip Deep Deep -> A.Value
+                mkJson Trip {..} = A.object
+                  [ "trip" .= tripTripID
+                  , "stops" .= fmap (\Stop{..} -> A.object
+                    [ "departure" .= stopDeparture
+                    , "station" .= stationId stopStation
+                    , "lat" .= stationLat stopStation
+                    , "lon" .= stationLon stopStation
+                    ]) tripStops
+                  ]
         handleTrip trip = case M.lookup trip trips of
           Just res -> pure res
           Nothing  -> throwError err404
-- 
cgit v1.2.3