aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2024-07-05 22:56:52 +0200
committerstuebinm2024-07-05 22:58:16 +0200
commit2943327863bfe5c6e793e5c40e473a2755d45642 (patch)
treef3fe224fc47203d962319f4f9cc5a43d29346f9a
parentbf52f12fd1710df52abd104622ea63cf2c26ff59 (diff)
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
Diffstat (limited to '')
-rw-r--r--app/Main.hs35
-rw-r--r--default.nix32
-rw-r--r--lib/Config.hs114
-rw-r--r--lib/Server/Frontend/Routes.hs17
-rw-r--r--todo.org8
-rw-r--r--tracktrain.cabal7
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