From 3d0980811d61a78f265ec06dd5bd4ef2cde1cbdf Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 22 Jan 2023 01:37:20 +0100
Subject: 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.
---
 lib/Server.hs | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

(limited to 'lib/Server.hs')

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?)
-- 
cgit v1.2.3