From 2943327863bfe5c6e793e5c40e473a2755d45642 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Fri, 5 Jul 2024 22:56:52 +0200
Subject: Config: switch conferer → conftrack

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
---
 lib/Config.hs | 114 +++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 73 insertions(+), 41 deletions(-)

(limited to 'lib/Config.hs')

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