diff --git a/conferer-warp.cabal b/conferer-warp.cabal --- a/conferer-warp.cabal +++ b/conferer-warp.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: cd409fb67d42685960b7b08d341f3d9710dc50d8c228737dcf1f15c384ce6011 +-- hash: b66887279007cbd1851fac75692ac5191a5f310c143b6ca1073fab9981ce1aa6 name: conferer-warp -version: 0.2.0.0 +version: 0.3.0.0 synopsis: conferer's FromConfig instances for warp settings description: Library to abstract the parsing of many haskell config values from different config sources @@ -25,7 +25,7 @@ library exposed-modules: - Conferer.FetchFromConfig.Warp + Conferer.FromConfig.Warp other-modules: Paths_conferer_warp hs-source-dirs: @@ -33,25 +33,25 @@ default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables build-depends: base >=4.3 && <5 - , conferer >=0.2.0.0 && <0.3.0.0 + , conferer >=0.3.0.0 && <0.4.0.0 , http-types >=0.8.6 && <0.13 , text >=1.1 && <1.3 , wai >=3.0 && <4.0 , warp >=3.0 && <4.0 default-language: Haskell2010 -test-suite conferer-warp-test +test-suite specs type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Conferer.FetchFromConfig.WarpSpec + Conferer.FromConfig.WarpSpec Paths_conferer_warp hs-source-dirs: test default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables build-depends: base >=4.3 && <5 - , conferer >=0.2.0.0 && <0.3.0.0 + , conferer >=0.3.0.0 && <0.4.0.0 , conferer-warp , hspec , http-types >=0.8.6 && <0.13 diff --git a/src/Conferer/FetchFromConfig/Warp.hs b/src/Conferer/FetchFromConfig/Warp.hs deleted file mode 100644 --- a/src/Conferer/FetchFromConfig/Warp.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Conferer.FetchFromConfig.Warp - ( - -- * How to use this - -- | FetchFromConfig instance for warp server settings - -- - -- @ - -- import Conferer - -- import Conferer.FetchFromConfig.Warp () - -- - -- main = do - -- config <- 'defaultConfig' \"awesomeapp\" - -- warpSettings <- 'getFromConfig' \"warp\" config - -- @ - ) where - -import Conferer.Core -import Conferer.Types -import Conferer.FetchFromConfig.Basics -import Data.Maybe (catMaybes) -import Network.Wai.Handler.Warp -import Data.String (fromString) -import Data.Text (unpack) -import Data.Maybe (fromMaybe) - -instance FetchFromConfig HostPreference where - fetch = fetchFromConfigWith (pure . fromString . unpack) - -instance FetchFromConfig Settings where - fetch k config = do - port <- fetch (k /. "port") config - timeout <- fetch (k /. "timeout") config - host <- fetch (k /. "host") config - serverName <- fetch (k /. "serverName") config - let overriders = catMaybes [ - setTimeout <$> timeout, - setHost <$> host, - setPort <$> port, - setServerName <$> serverName - ] - return $ return $ foldr ($) defaultSettings overriders diff --git a/src/Conferer/FromConfig/Warp.hs b/src/Conferer/FromConfig/Warp.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/FromConfig/Warp.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +module Conferer.FromConfig.Warp + ( + -- * How to use this + -- | FromConfig instance for warp server settings + -- + -- @ + -- import Conferer + -- import Conferer.FromConfig.Warp () + -- + -- main = do + -- config <- 'defaultConfig' \"awesomeapp\" + -- warpSettings <- 'getFromConfig' \"warp\" config + -- @ + ) where + +import Conferer.Core +import Conferer.Types +import Conferer.FromConfig.Basics +import Data.Maybe (catMaybes) +import Network.Wai.Handler.Warp +import Network.Wai.Handler.Warp.Internal +import Data.String (fromString) +import Data.Text (unpack) +import Data.Maybe (fromMaybe) + +instance FromConfig HostPreference where + updateFromConfig = updateAllAtOnceUsingFetch + fetchFromConfig = fetchFromConfigByIsString + +instance FromConfig ProxyProtocol where + updateFromConfig = updateAllAtOnceUsingFetch + fetchFromConfig = fetchFromConfigWith + (\text -> case text of + "ProxyProtocolNone" -> Just ProxyProtocolNone + "ProxyProtocolRequired" -> Just ProxyProtocolRequired + "ProxyProtocolOptional" -> Just ProxyProtocolOptional + _ -> Nothing + ) + +instance DefaultConfig Settings where + configDef = defaultSettings + +instance FromConfig Settings where + fetchFromConfig key config = return Nothing + updateFromConfig key config settings = do + pure settings + >>= findKeyAndApplyConfig config key "port" settingsPort (\v c -> c { settingsPort = v }) + >>= findKeyAndApplyConfig config key "host" settingsHost (\v c -> c { settingsHost = v }) + >>= findKeyAndApplyConfig config key "timeout" settingsTimeout (\v c -> c { settingsTimeout = v }) + >>= findKeyAndApplyConfig config key "fdCacheDuration" settingsFdCacheDuration (\v c -> c { settingsFdCacheDuration = v }) + >>= findKeyAndApplyConfig config key "fileInfoCacheDuration" settingsFileInfoCacheDuration (\v c -> c { settingsFileInfoCacheDuration = v }) +#if MIN_VERSION_warp(2,0,3) + >>= findKeyAndApplyConfig config key "noParsePath" settingsNoParsePath (\v c -> c { settingsNoParsePath = v }) +#endif +#if MIN_VERSION_warp(3,0,2) + >>= findKeyAndApplyConfig config key "serverName" settingsServerName (\v c -> c { settingsServerName = v }) +#endif +#if MIN_VERSION_warp(3,0,3) + >>= findKeyAndApplyConfig config key "maximumBodyFlush" settingsMaximumBodyFlush (\v c -> c { settingsMaximumBodyFlush = v }) +#endif +#if MIN_VERSION_warp(3,0,5) + >>= findKeyAndApplyConfig config key "proxyProtocol" settingsProxyProtocol (\v c -> c { settingsProxyProtocol = v }) +#endif +#if MIN_VERSION_warp(3,1,2) + >>= findKeyAndApplyConfig config key "slowlorisSize" settingsSlowlorisSize (\v c -> c { settingsSlowlorisSize = v }) +#endif +#if MIN_VERSION_warp(3,1,7) + >>= findKeyAndApplyConfig config key "http2Enabled" settingsHTTP2Enabled (\v c -> c { settingsHTTP2Enabled = v }) +#endif +#if MIN_VERSION_warp(3,2,8) + >>= findKeyAndApplyConfig config key "gracefulShutdownTimeout" settingsGracefulShutdownTimeout (\v c -> c { settingsGracefulShutdownTimeout = v }) +#endif +#if MIN_VERSION_warp(3,3,5) + >>= findKeyAndApplyConfig config key "gracefulCloseTimeout1" settingsGracefulCloseTimeout1 (\v c -> c { settingsGracefulCloseTimeout1 = v }) + >>= findKeyAndApplyConfig config key "gracefulCloseTimeout2" settingsGracefulCloseTimeout2 (\v c -> c { settingsGracefulCloseTimeout2 = v }) +#endif +#if MIN_VERSION_warp(3,3,8) + >>= findKeyAndApplyConfig config key "maxTotalHeaderLength" settingsMaxTotalHeaderLength (\v c -> c { settingsMaxTotalHeaderLength = v }) +#endif diff --git a/test/Conferer/FetchFromConfig/WarpSpec.hs b/test/Conferer/FetchFromConfig/WarpSpec.hs deleted file mode 100644 --- a/test/Conferer/FetchFromConfig/WarpSpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Conferer.FetchFromConfig.WarpSpec where - -import Test.Hspec -import Conferer.Types -import Data.Text -import Conferer -import Conferer.FetchFromConfig.Warp () -import Network.Wai.Handler.Warp - -configWith :: [(Key, Text)] -> IO Config -configWith keyValues = emptyConfig & addProvider (mkMapProvider keyValues) - -portAndHostShouldBe :: Maybe Settings -> (Port, HostPreference) -> Expectation -portAndHostShouldBe fetchedSettings (port, host) = do - getPort <$> fetchedSettings `shouldBe` Just port - getHost <$> fetchedSettings `shouldBe` Just host - -spec :: Spec -spec = do - let defaultPort = getPort defaultSettings - defaultHost = getHost defaultSettings - describe "fetching a warp configuration without overriding anything" $ do - it "returns warp default config" $ do - let config = emptyConfig - fetchedValue <- fetch "." config - fetchedValue `portAndHostShouldBe` (defaultPort, defaultHost) - describe "fetching a warp configuration overridnig its port" $ do - it "returns a warp config with its port set to the overriden one" $ do - config <- configWith [("warp.port", "9999")] - fetchedValue <- fetch "warp" config - fetchedValue `portAndHostShouldBe` (9999, defaultHost) - describe "fetching a warp configuration overriding its host" $ do - it "returns a warp config with its host set to the overriden one" $ do - config <- configWith [("warp.host", "!6")] - fetchedValue <- fetch "warp" config - fetchedValue `portAndHostShouldBe` (defaultPort, "!6") diff --git a/test/Conferer/FromConfig/WarpSpec.hs b/test/Conferer/FromConfig/WarpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/WarpSpec.hs @@ -0,0 +1,41 @@ +module Conferer.FromConfig.WarpSpec where + +import Test.Hspec +import Conferer.Types +import Data.Text +import Conferer +import Conferer.FromConfig.Basics +import Conferer.FromConfig.Warp () +import Network.Wai.Handler.Warp +import Data.Typeable + +configWith :: [(Key, Text)] -> IO Config +configWith keyValues = emptyConfig & addProvider (mkMapProvider keyValues) + +fetch :: (FromConfig a, Typeable a, DefaultConfig a) => Key -> Config -> IO (Maybe a) +fetch = safeGetFromConfig + +portAndHostShouldBe :: Maybe Settings -> (Port, HostPreference) -> Expectation +portAndHostShouldBe fetchedSettings (port, host) = do + getPort <$> fetchedSettings `shouldBe` Just port + getHost <$> fetchedSettings `shouldBe` Just host + +spec :: Spec +spec = do + let defaultPort = getPort defaultSettings + defaultHost = getHost defaultSettings + describe "fetching a warp configuration without overriding anything" $ do + it "returns warp default config" $ do + let config = emptyConfig + fetchedValue <- fetch "." config + fetchedValue `portAndHostShouldBe` (defaultPort, defaultHost) + describe "fetching a warp configuration overridnig its port" $ do + it "returns a warp config with its port set to the overriden one" $ do + config <- configWith [("warp.port", "9999")] + fetchedValue <- fetch "warp" config + fetchedValue `portAndHostShouldBe` (9999, defaultHost) + describe "fetching a warp configuration overriding its host" $ do + it "returns a warp config with its host set to the overriden one" $ do + config <- configWith [("warp.host", "!6")] + fetchedValue <- fetch "warp" config + fetchedValue `portAndHostShouldBe` (defaultPort, "!6")