diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 27 |
1 files changed, 19 insertions, 8 deletions
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 |