diff options
| author | stuebinm | 2023-01-22 01:37:20 +0100 |
|---|---|---|
| committer | stuebinm | 2023-01-22 01:47:31 +0100 |
| commit | 3d0980811d61a78f265ec06dd5bd4ef2cde1cbdf (patch) | |
| tree | 00bea044e80ca5eebc730a23edf0b13f0d019091 /lib/Server.hs | |
| parent | 6c0f21b276ad73f383a80fe00729c6520a6b874a (diff) | |
oauth2 via uffd
this is unfortunately uffd-specific, since oauth2 is apparently sort of
a vague standard. But since it doesn't actually do much it should
probably be possible to make it fully configurable & generic if needed.
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?) |