aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Config.hs114
-rw-r--r--lib/Server/Frontend/Routes.hs17
2 files changed, 82 insertions, 49 deletions
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