From 59670bdb6f0a3bba898274eadf47707e93bea195 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 15 May 2024 01:04:32 +0200
Subject: config: add a debug mode option

this is meant to be false by default, and otherwise relaxes requirements
on e.g. incoming pings, which are inconvenient when testing by hand.
---
 lib/Config.hs | 2 ++
 lib/Server.hs | 9 ++++++---
 2 files changed, 8 insertions(+), 3 deletions(-)

(limited to 'lib')

diff --git a/lib/Config.hs b/lib/Config.hs
index 94fdd28..4aa62fc 100644
--- a/lib/Config.hs
+++ b/lib/Config.hs
@@ -24,6 +24,7 @@ data ServerConfig = ServerConfig
   , serverConfigGtfs         :: FilePath
   , serverConfigAssets       :: FilePath
   , serverConfigZoneinfoPath :: FilePath
+  , serverConfigDebugMode    :: Bool
   , serverConfigLogin        :: UffdConfig
   , serverConfigLogging      :: LoggingConfig
   } deriving (Generic)
@@ -43,6 +44,7 @@ instance DefaultConfig ServerConfig where
     , serverConfigGtfs = "./gtfs.zip"
     , serverConfigAssets = "./assets"
     , serverConfigZoneinfoPath = "/etc/zoneinfo/"
+    , serverConfigDebugMode = False
     , serverConfigLogin = configDef
     , serverConfigLogging = configDef
     }
diff --git a/lib/Server.hs b/lib/Server.hs
index 055e440..30141af 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -8,9 +8,9 @@ import           API                         (API, CompleteAPI, Metrics (..))
 import           Conduit                     (ResourceT)
 import           Config                      (LoggingConfig, ServerConfig (..))
 import           Control.Concurrent.STM      (newTVarIO)
-import           Control.Monad.Extra         (forM)
+import           Control.Monad.Extra         (forM, when)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
-import           Control.Monad.Logger        (MonadLogger)
+import           Control.Monad.Logger        (MonadLogger, logWarnN)
 import           Control.Monad.Reader        (ReaderT)
 import           Data.ByteString.Lazy        (toStrict)
 import           Data.Functor                ((<&>))
@@ -45,13 +45,16 @@ import           Server.GTFS_RT              (gtfsRealtimeServer)
 import           Server.Ingest               (handleTrackerRegister,
                                               handleTrainPing, handleWS)
 import           Server.Subscribe            (handleSubscribe)
-import           Server.Util                 (Service, runService)
+import           Server.Util                 (Service, runService, runLogging)
 import           System.IO.Unsafe            (unsafePerformIO)
 import           Yesod                       (toWaiAppPlain)
 
 
 application :: GTFS.GTFS -> Pool SqlBackend -> ServerConfig -> IO Application
 application gtfs dbpool settings = do
+  when (serverConfigDebugMode settings) $
+     runLogging (serverConfigLogging settings) $
+       logWarnN "warning: tracktrain running in debug mode"
   doMigration dbpool
   metrics <- Metrics
     <$> register (gauge (Info "ws_connections" "Number of WS Connections"))
-- 
cgit v1.2.3