Config: switch conferer → conftrackHEADmain

conftrack is a configuration library that I wrote to replace conferer,
as dealing with its idiosyncrasies became increasingly annoying.

It is currently very much still alpha-state software, but far enough
along to be tested in my own projects, and hopefully will soon be in a
state that is publishable on hackage.

For now, it can be found at
  https://stuebinm.eu/git/conftrack

6 files changed, 132 insertions, 81 deletions

diff --git a/app/Main.hs b/app/Main.hs
index a61140a..3856a67 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,15 +1,15 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE RecordWildCards #-}
 
 -- | The main module. Does little more than handle some basic ocnfic, then
 -- call the server
 module Main where
 
-import           Conferer                             (fetch)
-import           Conferer.Config                      (addSource, emptyConfig)
-import qualified Conferer.Source.Aeson                as ConfAeson
-import qualified Conferer.Source.CLIArgs              as ConfCLI
-import qualified Conferer.Source.Env                  as ConfEnv
-import qualified Conferer.Source.Yaml                 as ConfYaml
+import           Conftrack
+import           Conftrack.Pretty
+import           Conftrack.Source.Env                 (mkEnvSource)
+import           Conftrack.Source.Yaml                (mkYamlFileSource)
 import           Control.Monad.Extra                  (ifM)
 import           Control.Monad.IO.Class               (MonadIO (liftIO))
 import           Control.Monad.Logger                 (runStderrLoggingT)
@@ -20,6 +20,7 @@ import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
                                                        RequestLoggerSettings (..),
                                                        mkRequestLogger)
 import           System.Directory                     (doesFileExist)
+import           System.OsPath                        (osp)
 
 import           Config                               (ServerConfig (..))
 import           GTFS                                 (loadGtfs)
@@ -27,19 +28,15 @@ import           Server                               (application)
 
 main :: IO ()
 main = do
-  confconfig <- pure emptyConfig
-    >>= addSource ConfCLI.fromConfig
-    >>= addSource (ConfEnv.fromConfig "tracktrain")
-    -- for some reason the yaml source fails if the file does not exist, but json works fine
-    >>= (\c -> ifM (doesFileExist "./config.yaml")
-          (addSource (ConfYaml.fromFilePath "./config.yaml") c)
-          (pure c))
-    >>= (\c -> ifM (doesFileExist "./config.yml")
-          (addSource (ConfYaml.fromFilePath "./config.yml") c)
-          (pure c))
-    >>= addSource (ConfAeson.fromFilePath "./config.json")
-
-  settings@ServerConfig{..} <- fetch confconfig
+
+  Right ymlsource <- mkYamlFileSource [osp|./config.yaml|]
+
+  Right (settings@ServerConfig{..}, origins, warnings) <-
+    runFetchConfig [mkEnvSource "tracktrain", ymlsource]
+
+  putStrLn "reading configs .."
+  printConfigOrigins origins
+  printConfigWarnings warnings
 
   gtfs <- loadGtfs serverConfigGtfs serverConfigZoneinfoPath
   loggerMiddleware <- mkRequestLogger
diff --git a/default.nix b/default.nix
index 4b317b9..b3fcdef 100644
--- a/default.nix
+++ b/default.nix
@@ -4,9 +4,32 @@ let
 
   inherit (nixpkgs) pkgs;
 
+  conftrack =
+    { mkDerivation, aeson, base, bytestring, containers, directory
+    , file-io, filepath, lib, mtl, QuickCheck, quickcheck-instances
+    , scientific, template-haskell, text, transformers, yaml
+    }:
+    mkDerivation {
+      pname = "conftrack";
+      version = "0.0.1";
+      src = nixpkgs.fetchgit {
+        url = "https://stuebinm.eu/git/conftrack";
+        rev = "3e71d0ab05c7f5fd71a75b86eeac6f8a1edc3a44";
+        hash = "sha256-gBkzbvKFNhut2XbruqisXLSHFwJPIsf8e5bjrSUgHsI=";
+      };
+      libraryHaskellDepends = [
+        aeson base bytestring containers directory file-io filepath mtl
+        scientific template-haskell text transformers yaml
+      ];
+      testHaskellDepends = [
+        aeson base containers QuickCheck quickcheck-instances text
+      ];
+      description = "Tracable multi-source config management";
+      license = lib.licenses.bsd3;
+    };
+
   f = { mkDerivation, aeson, base, blaze-html, blaze-markup
-      , bytestring, cassava, conduit, conferer, conferer-aeson
-      , conferer-warp, conferer-yaml, containers, data-default-class
+      , bytestring, cassava, conduit, conftrack, containers, data-default-class
       , directory, either, exceptions, extra, filepath, fmt, hoauth2, http-api-data
       , http-media, insert-ordered-containers, lens, lib, monad-logger
       , mtl, path-pieces, persistent, persistent-postgresql
@@ -27,7 +50,7 @@ let
         isExecutable = true;
         libraryHaskellDepends = [
           aeson base blaze-html blaze-markup bytestring cassava conduit
-          conferer conferer-warp containers either exceptions extra fmt filepath
+          conftrack containers either exceptions extra fmt filepath
           hoauth2 http-api-data http-media insert-ordered-containers lens
           monad-logger mtl path-pieces persistent persistent-postgresql
           prometheus-client prometheus-metrics-ghc proto-lens
@@ -39,7 +62,7 @@ let
           zip-archive
         ];
         executableHaskellDepends = [
-          aeson base bytestring conferer conferer-aeson conferer-yaml
+          aeson base bytestring conftrack
           data-default-class directory extra fmt monad-logger
           persistent-postgresql proto-lens time wai-extra warp
         ];
@@ -63,6 +86,7 @@ let
   # (currently kept as a dummy)
   hpkgs = haskellPackages.override {
     overrides = self: super: with pkgs.haskell.lib.compose; {
+      conftrack = self.callPackage conftrack {};
       # filepath = self.filepath_1_4_100_4;
       # conferer-warp = markUnbroken super.conferer-warp;
     };
diff --git a/lib/Config.hs b/lib/Config.hs
index 4c8e3fd..88206f1 100644
--- a/lib/Config.hs
+++ b/lib/Config.hs
@@ -1,17 +1,21 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo     #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module Config (UffdConfig(..), ServerConfig(..), LoggingConfig(..)) where
-import           Conferer                 (DefaultConfig (configDef), fetch,
-                                           unsafeFetchKey)
-import           Conferer.FromConfig
-import           Conferer.FromConfig.Warp ()
+import           Conftrack
+import           Conftrack.Value          (ConfigValue (..))
 import           Data.ByteString          (ByteString)
+import           Data.Function            ((&))
 import           Data.Functor             ((<&>))
+import           Data.String              (IsString (..))
 import           Data.Text                (Text)
 import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8)
 import           GHC.Generics             (Generic)
-import           Network.Wai.Handler.Warp (Settings)
+import qualified Network.Wai.Handler.Warp as Warp
 import           System.OsPath            (OsPath, encodeUtf, osp)
 import           URI.ByteString
 
@@ -23,13 +27,13 @@ data UffdConfig = UffdConfig
   } deriving (Generic, Show)
 
 data ServerConfig = ServerConfig
-  { serverConfigWarp         :: Settings
+  { serverConfigWarp         :: Warp.Settings
   , serverConfigDbString     :: ByteString
   , serverConfigGtfs         :: OsPath
   , serverConfigAssets       :: OsPath
   , serverConfigZoneinfoPath :: OsPath
   , serverConfigDebugMode    :: Bool
-  , serverConfigLogin        :: UffdConfig
+  , serverConfigLogin        :: Maybe UffdConfig
   , serverConfigLogging      :: LoggingConfig
   } deriving (Generic)
 
@@ -39,41 +43,69 @@ data LoggingConfig = LoggingConfig
   , loggingConfigHostname  :: Text
   } deriving (Generic)
 
-instance FromConfig ServerConfig
+instance ConfigValue (URIRef Absolute) where
+  fromConfig val@(ConfigString text) =
+    case parseURI strictURIParserOptions text of
+      Right uri -> Right uri
+      Left err  -> Left $ ParseError (T.pack $ show err)
+  fromConfig val = Left (TypeMismatch "URI" val)
 
-instance FromConfig OsPath where
-  fromConfig = fetchFromConfigWith (encodeUtf . T.unpack)
+  prettyValue uri = decodeUtf8 (serializeURIRef' uri)
 
-instance DefaultConfig ServerConfig where
-  configDef = ServerConfig
-    { serverConfigWarp = configDef
-    , serverConfigDbString = ""
-    , serverConfigGtfs = [osp|./gtfs.zip|]
-    , serverConfigAssets = [osp|./assets|]
-    , serverConfigZoneinfoPath = [osp|/etc/zoneinfo/|]
-    , serverConfigDebugMode = False
-    , serverConfigLogin = configDef
-    , serverConfigLogging = configDef
-    }
+instance Config UffdConfig where
+  readConfig = do
+    uffdConfigUrl <- readRequiredValue [key|url|]
+    uffdConfigClientName <- readRequiredValue [key|clientName|]
+    uffdConfigClientSecret <- readRequiredValue [key|clientSecret|]
+    uffdConfigEnable <- readRequiredValue [key|enable|]
+    pure UffdConfig {..}
 
-instance DefaultConfig UffdConfig where
-  configDef = UffdConfig uri "secret" "uffdclient" False
-    where Right uri = parseURI strictURIParserOptions "http://www.example.org"
+instance Config LoggingConfig where
+  readConfig = LoggingConfig
+    <$> readOptionalValue [key|ntfyToken|]
+    <*> readValue "tracktrain" [key|ntfyTopic|]
+    <*> readValue "tracktrain" [key|name|]
 
-instance FromConfig UffdConfig where
-  fromConfig key config = do
-    url <- fetchFromConfig (key /. "url") config
-    let Right uffdConfigUrl = parseURI strictURIParserOptions url
-    uffdConfigClientName <- fetchFromConfig (key /. "clientName") config
-    uffdConfigClientSecret <- fetchFromConfig (key /. "clientSecret") config
-    uffdConfigEnable <- fetchFromConfig (key /. "enable") config
-    pure UffdConfig {..}
+instance Config Warp.Settings where
+  readConfig = do
+    port <- readOptionalValue [key|port|]
+    host <- readOptionalValue [key|host|]
+    timeout <- readOptionalValue [key|timeout|]
+    fdCacheDuration <- readOptionalValue [key|fdCacheDuration|]
+    fileInfoCacheDuration <- readOptionalValue [key|fileInfoCacheDuration|]
+    noParsePath <- readOptionalValue [key|noParsePath|]
+    serverName <- readOptionalValue [key|serverName|]
+    maximumBodyFlush <- readOptionalValue [key|maximumBodyFlush|]
+    gracefulShutdownTimeout <- readOptionalValue [key|gracefulShutdownTimeout|]
+    altSvc <- readOptionalValue [key|altSvc|]
+
+    pure $ Warp.defaultSettings
+     & doIf port Warp.setPort
+     & doIf host Warp.setHost
+     & doIf timeout Warp.setTimeout
+     & doIf fdCacheDuration Warp.setFdCacheDuration
+     & doIf fileInfoCacheDuration Warp.setFileInfoCacheDuration
+     & doIf noParsePath Warp.setNoParsePath
+     & doIf serverName Warp.setServerName
+     & doIf maximumBodyFlush Warp.setMaximumBodyFlush
+     & doIf gracefulShutdownTimeout Warp.setGracefulShutdownTimeout
+     & doIf altSvc Warp.setAltSvc
+
+    where doIf Nothing _  = id
+          doIf (Just a) f = f a
+
+instance ConfigValue Warp.HostPreference where
+  fromConfig (ConfigString buf) = Right $ fromString (T.unpack (decodeUtf8 buf))
+  fromConfig val                = Left (TypeMismatch "HostPreference" val)
 
-instance FromConfig LoggingConfig where
-  fromConfig key config = LoggingConfig
-    <$> fetchFromConfig (key /. "ntfyToken") config
-    <*> fetchFromConfig (key /. "ntfyTopic") config
-    <*> fetchFromConfig (key /. "name") config
+instance Config ServerConfig where
+  readConfig = ServerConfig
+    <$> readNested [key|warp|]
+    <*> readValue "" [key|dbstring|]
+    <*> readValue [osp|./gtfs.zip|] [key|gtfs|]
+    <*> readValue [osp|./assets|] [key|assets|]
+    <*> readValue [osp|/etc/zoneinfo/|] [key|zoneinfopath|]
+    <*> readValue False [key|debugmode|]
+    <*> readNestedOptional [key|login|]
+    <*> readNested [key|logging|]
 
-instance DefaultConfig LoggingConfig where
-  configDef = LoggingConfig Nothing "tracktrain" ""
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index 18cf0a1..9245e6a 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -69,11 +69,12 @@ instance Yesod Frontend where
   isAuthorized OnboardTrackerR _ = pure Authorized
   isAuthorized (AuthR _) _ = pure Authorized
   isAuthorized _ _ = do
-    UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
-    if uffdConfigEnable then maybeAuthId >>= \case
-      Just _  -> pure Authorized
-      Nothing -> pure AuthenticationRequired
-    else pure Authorized
+    maybeUffd <- getYesod <&> serverConfigLogin . getSettings
+    case maybeUffd of
+      Nothing -> pure Authorized
+      Just UffdConfig{..} -> maybeAuthId >>= \case
+        Just _  -> pure Authorized
+        Nothing -> pure AuthenticationRequired
 
 
   defaultLayout w = do
@@ -118,9 +119,9 @@ instance YesodAuth Frontend where
   type AuthId Frontend = UffdUser
 
   authPlugins cr = case config of
-    UffdConfig {..} -> if uffdConfigEnable
-      then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
-      else []
+    Just UffdConfig {..} ->
+      [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
+    Nothing -> []
     where config = serverConfigLogin (getSettings cr)
 
   maybeAuthId = do
diff --git a/todo.org b/todo.org
index eeed2c4..e3028a8 100644
--- a/todo.org
+++ b/todo.org
@@ -45,10 +45,6 @@ remember to turn it on (at least people were interested today – 2024-05-01)
 ** IDEA display a warning on it if there's another tracker for the same trip
 ** IDEA display a warning on it if it's > 100m away from tracks
 (possibly also make the server discard data in such cases)
-* TODO re-do configuration, replace conferer, possibly write own config library
-conferer is okay-ish, but it cannot (?) give warnings for config items that
-were e.g. misspelled in a yaml file. There's also no easy way to figure out
-where a config value came from afterwards.
 * TODO replace the gtfs-based sequence with my own index during import
 this should enforce that the difference between stations is always exactly 1
 (& possibly also that the first station is 0)
@@ -74,6 +70,10 @@ queries are just unreasonably wordy (& inefficient), requiring lots of mapM.
 It also has horrible mapping for datatypes (almost all i use are natively
 supported by postgres, but persistent stores most things as var char)
 
+* DONE re-do configuration, replace conferer, possibly write own config library
+conferer is okay-ish, but it cannot (?) give warnings for config items that
+were e.g. misspelled in a yaml file. There's also no easy way to figure out
+where a config value came from afterwards.
 * done before 0.0.2
 ** DONE estimate delays
 basically: list of known delays in a db table, either generated from
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 45ba246..c14dc4b 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -27,9 +27,7 @@ executable tracktrain
                     , persistent-postgresql
                     , monad-logger
                     , gtfs-realtime
-                    , conferer
-                    , conferer-aeson
-                    , conferer-yaml
+                    , conftrack
                     , directory
                     , extra
                     , proto-lens
@@ -90,8 +88,7 @@ library
                     , blaze-markup
                     , timezone-olson
                     , timezone-series
-                    , conferer
-                    , conferer-warp
+                    , conftrack
                     , prometheus-client
                     , prometheus-metrics-ghc
                     , exceptions