diff options
Diffstat (limited to '')
| -rw-r--r-- | app/Main.hs | 35 | ||||
| -rw-r--r-- | default.nix | 32 | ||||
| -rw-r--r-- | lib/Config.hs | 114 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 17 | ||||
| -rw-r--r-- | todo.org | 8 | ||||
| -rw-r--r-- | tracktrain.cabal | 7 |
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 @@ -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 |