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/API.hs    |  9 +++++++--
 lib/Server.hs | 27 +++++++++++++++++++--------
 2 files changed, 26 insertions(+), 10 deletions(-)

(limited to 'lib')

diff --git a/lib/API.hs b/lib/API.hs
index 79a467a..5bf9877 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -14,7 +14,8 @@ import           Data.Swagger                (MimeList (MimeList),
                                               PathItem (_pathItemGet),
                                               Scheme (Wss), Swagger,
                                               ToSchema (..), _swaggerPaths,
-                                              genericDeclareNamedSchema)
+                                              genericDeclareNamedSchema, type_,
+                                              NamedSchema(..), SwaggerType (SwaggerObject))
 import           Data.Swagger.ParamSchema    (ToParamSchema (..))
 import           Data.Text                   (Text)
 import           Data.Time                   (Day, UTCTime)
@@ -31,7 +32,7 @@ import           Servant.Swagger             (HasSwagger (..))
 import           Web.Internal.FormUrlEncoded (Form)
 
 import           Control.Lens                (At (at), (&), (?~))
-import           Data.Aeson                  (FromJSON (..), genericParseJSON)
+import           Data.Aeson                  (FromJSON (..), genericParseJSON, Value)
 import           Data.ByteString.Lazy        (ByteString)
 import           Data.HashMap.Strict.InsOrd  (singleton)
 import           GHC.Generics                (Generic)
@@ -50,10 +51,14 @@ instance FromJSON RegisterJson where
   parseJSON = genericParseJSON (aesonOptions "register")
 instance ToSchema RegisterJson where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
+instance ToSchema Value where
+  declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
+      & type_ ?~ SwaggerObject
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
+  :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
   :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
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