From e292fb5eb91a3a52853f3ab4f9bc93b070d87dba Mon Sep 17 00:00:00 2001 From: Robert Date: Tue, 4 Jun 2019 22:49:37 +0200 Subject: [PATCH] Replace configurator-ng by configurator-pg (#1312) The change should not affect parse results for valid configuration files. Error messages should be somewhat improved. --- postgrest.cabal | 10 ++-- src/PostgREST/Config.hs | 124 +++++++++++++++++++++------------------- stack.yaml | 3 +- 3 files changed, 71 insertions(+), 66 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index e4771e2d7..276413de3 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -33,17 +33,17 @@ executable postgrest default-language: Haskell2010 build-depends: auto-update , base >= 4.8 && < 4.10 + , base64-bytestring + , bytestring , hasql >= 1.3 && < 1.4 , hasql-pool >= 0.5 && < 0.6 , hasql-transaction >= 0.7 && < 0.8 , postgrest , protolude == 0.2.2 + , retry , text , time , warp - , bytestring - , base64-bytestring - , retry if !os(windows) build-depends: unix @@ -59,10 +59,11 @@ library , bytestring , case-insensitive , cassava - , configurator-ng == 0.0.0.1 + , configurator-pg >= 0.1 && < 0.2 , containers , contravariant , contravariant-extras + , cookie , either , gitrev , hasql >= 1.3 && < 1.4 @@ -92,7 +93,6 @@ library , wai-cors , wai-extra , wai-middleware-static - , cookie Other-Modules: Paths_postgrest Exposed-Modules: PostgREST.ApiRequest diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 59494c6e8..fb20dca20 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -12,8 +12,9 @@ turned in configurable behaviour if needed. Other hardcoded options such as the minimum version number also belong here. -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module PostgREST.Config ( prettyVersion @@ -29,26 +30,23 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import qualified Data.Configurator as C -import qualified Data.Configurator.Parser as C -import Data.Configurator.Types as C import qualified Text.PrettyPrint.ANSI.Leijen as L +import Control.Exception (Handler (..)) import Control.Lens (preview) import Control.Monad (fail) import Crypto.JWT (StringOrURI, stringOrUri) import Data.List (lookup) import Data.Scientific (floatingOrInteger) -import Data.String (String) import Data.Text (dropEnd, dropWhileEnd, intercalate, lines, splitOn, - strip, take) + strip, take, unpack) import Data.Text.Encoding (encodeUtf8) import Data.Text.IO (hPutStrLn) import Data.Version (versionBranch) import Development.GitRev (gitHash) import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Paths_postgrest (version) -import System.IO (hPrint) import System.IO.Error (IOError) import Control.Applicative @@ -131,68 +129,77 @@ readOptions = do -- First read the config file path from command line cfgPath <- customExecParser parserPrefs opts -- Now read the actual config file - conf <- catch - (C.readConfig =<< C.load [C.Required cfgPath]) - configNotfoundHint + conf <- catches (C.load cfgPath) + [ Handler (\(ex :: IOError) -> exitErr $ "Cannot open config file:\n\t" <> show ex) + , Handler (\(C.ParseError err) -> exitErr $ "Error parsing config file:\n\t" <> err) + ] - let (mAppConf, errs) = flip C.runParserM conf $ - AppConfig - <$> C.key "db-uri" - <*> C.key "db-anon-role" - <*> (mfilter (/= "") <$> C.key "server-proxy-uri") - <*> C.key "db-schema" - <*> (fromMaybe "!4" . mfilter (/= "") <$> C.key "server-host") - <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port") - <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret") - <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64") - <*> parseJwtAudience "jwt-aud" - <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool") - <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool-timeout") - <*> (join . fmap coerceInt <$> C.key "max-rows") - <*> (mfilter (/= "") <$> C.key "pre-request") - <*> pure False - <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings") - <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key") - <*> (maybe ["public"] splitExtraSearchPath <$> C.key "db-extra-search-path") - - case mAppConf of - Nothing -> do - forM_ errs $ hPrint stderr - exitFailure - Just appConf -> + case C.runParser parseConfig conf of + Left err -> + exitErr $ "Error parsing config file:\n\t" <> err + Right appConf -> return appConf where - parseJwtAudience :: Name -> C.ConfigParserM (Maybe StringOrURI) + parseConfig = + AppConfig + <$> reqString "db-uri" + <*> reqString "db-anon-role" + <*> (mfilter (/= "") <$> optString "server-proxy-uri") + <*> reqString "db-schema" + <*> (fromMaybe "!4" . mfilter (/= "") <$> optString "server-host") + <*> (fromMaybe 3000 . join . fmap coerceInt <$> optValue "server-port") + <*> (fmap encodeUtf8 . mfilter (/= "") <$> optString "jwt-secret") + <*> (fromMaybe False . join . fmap coerceBool <$> optValue "secret-is-base64") + <*> parseJwtAudience "jwt-aud" + <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool") + <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool-timeout") + <*> (join . fmap coerceInt <$> optValue "max-rows") + <*> (mfilter (/= "") <$> optString "pre-request") + <*> pure False + <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value) + <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key") + <*> (maybe ["public"] splitExtraSearchPath <$> optValue "db-extra-search-path") + + parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI) parseJwtAudience k = - C.key k >>= \case + C.optional k C.string >>= \case Nothing -> pure Nothing -- no audience in config file - Just aud -> case preview stringOrUri (aud :: String) of + Just aud -> case preview stringOrUri (unpack aud) of Nothing -> fail "Invalid Jwt audience. Check your configuration." (Just "") -> pure Nothing aud' -> pure aud' - coerceText :: Value -> Text - coerceText (String s) = s - coerceText v = show v + reqString :: C.Key -> C.Parser C.Config Text + reqString k = C.required k C.string - coerceInt :: (Read i, Integral i) => Value -> Maybe i - coerceInt (Number x) = rightToMaybe $ floatingOrInteger x - coerceInt (String x) = readMaybe $ toS x - coerceInt _ = Nothing + optString :: C.Key -> C.Parser C.Config (Maybe Text) + optString k = C.optional k C.string - coerceBool :: Value -> Maybe Bool - coerceBool (Bool b) = Just b - coerceBool (String b) = readMaybe $ toS b - coerceBool _ = Nothing + optValue :: C.Key -> C.Parser C.Config (Maybe C.Value) + optValue k = C.optional k C.value - parseRoleClaimKey :: Value -> Either ApiRequestError JSPath - parseRoleClaimKey (String s) = pRoleClaimKey s - parseRoleClaimKey v = pRoleClaimKey $ show v + coerceText :: C.Value -> Text + coerceText (C.String s) = s + coerceText v = show v - splitExtraSearchPath :: Value -> [Text] - splitExtraSearchPath (String s) = strip <$> splitOn "," s - splitExtraSearchPath _ = [] + coerceInt :: (Read i, Integral i) => C.Value -> Maybe i + coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x + coerceInt (C.String x) = readMaybe $ toS x + coerceInt _ = Nothing + + coerceBool :: C.Value -> Maybe Bool + coerceBool (C.Bool b) = Just b + coerceBool (C.String b) = readMaybe $ toS b + coerceBool _ = Nothing + + parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath + parseRoleClaimKey (C.String s) = pRoleClaimKey s + parseRoleClaimKey v = pRoleClaimKey $ show v + + splitExtraSearchPath :: C.Value -> [Text] + splitExtraSearchPath (C.String s) = strip <$> splitOn "," s + splitExtraSearchPath _ = [] opts = info (helper <*> pathParser) $ fullDesc @@ -208,10 +215,9 @@ readOptions = do parserPrefs = prefs showHelpOnError - configNotfoundHint :: IOError -> IO a - configNotfoundHint e = do - hPutStrLn stderr $ - "Cannot open config file:\n\t" <> show e + exitErr :: Text -> IO a + exitErr err = do + hPutStrLn stderr err exitFailure exampleCfg :: Doc diff --git a/stack.yaml b/stack.yaml index 26a97c563..36dcad27e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,5 @@ resolver: lts-9.6 extra-deps: - - configurator-ng-0.0.0.1 - - critbit-0.2.0.0 - Ranged-sets-0.3.0 - protolude-0.2.2 - hasql-1.3 @@ -12,6 +10,7 @@ extra-deps: - postgresql-libpq-0.9.4.1 - http-types-0.12.3 - wai-middleware-static-0.8.2 + - configurator-pg-0.1.0.1 ghc-options: postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints nix: