diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 13 |
1 files changed, 6 insertions, 7 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 8cab47a..6b32826 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -57,7 +57,6 @@ import Server.Util (Service, ServiceM, runService, sendErrorMsg) import Yesod (toWaiAppPlain) -import Conferer (fetch, mkConfig) import Extrapolation (Extrapolator (..), LinearExtrapolator (..)) import System.IO.Unsafe @@ -68,14 +67,14 @@ import Data.ByteString.Lazy (toStrict) import Prometheus import Prometheus.Metric.GHC -application :: GTFS -> Pool SqlBackend -> IO Application -application gtfs dbpool = do +application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application +application gtfs dbpool settings = do doMigration dbpool metrics <- Metrics <$> register (gauge (Info "ws_connections" "Number of WS Connections")) register ghcMetrics subscribers <- atomically $ newTVar mempty - pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool + pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings -- databaseMigration :: ConnectionString -> IO () doMigration pool = runSql pool $ @@ -84,14 +83,14 @@ doMigration pool = runSql pool $ -- returns an empty list runMigration migrateAll -server :: GTFS -> Metrics -> TVar (M.Map TripID ([TQueue (Maybe TrainPing)])) -> Pool SqlBackend -> Service CompleteAPI -server gtfs@GTFS{..} Metrics{..} subscribers dbpool = handleDebugAPI +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 :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool) :<|> metrics - :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool))) + :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) |