diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# Changelog +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to [PVP](https://pvp.haskell.org/). + +## [Unreleased] + +Nothing + +## [v1.0.0.0] 2020-12-29 + +First release + +[Unreleased]: https://github.com/ludat/conferer/compare/conferer-warp_v1.0.0.0...HEAD +[v1.0.0.0]: https://github.com/ludat/conferer/compare/v0.0.0.0...conferer-warp_v1.0.0.0 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: b32d926abd34e1c94d91142970a08b52191ce3273f599f1fb1355564e8634f81 +-- hash: c41ddb23f10259b3f8eaf3b77d7fa02bfa24656e72bc0f3fe30b84b8b28e1c76 name: conferer-warp -version: 0.4.0.1 +version: 1.0.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 @@ -15,11 +15,13 @@ homepage: https://conferer.ludat.io author: Lucas David Traverso maintainer: lucas6246@gmail.com +copyright: (c) 2020 Lucas David Traverso license: MPL-2.0 license-file: LICENSE build-type: Simple extra-doc-files: README.md + CHANGELOG.md LICENSE library @@ -29,14 +31,17 @@ Paths_conferer_warp hs-source-dirs: src - default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables RecordWildCards StrictData + ghc-options: -Wall -Wredundant-constraints -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns build-depends: base >=4.3 && <5 - , conferer >=0.4.0.0 && <0.5.0.0 + , conferer >=1.0.0.0 && <2.0.0.0 , http-types >=0.8.6 && <0.13 , text >=1.1 && <1.3 , wai >=3.0 && <4.0 , warp >=3.0 && <4.0 + if impl(ghc >= 8.4.1) + ghc-options: -Wpartial-fields default-language: Haskell2010 test-suite specs @@ -47,14 +52,17 @@ Paths_conferer_warp hs-source-dirs: test - default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables RecordWildCards StrictData + ghc-options: -Wall -Wredundant-constraints -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns build-depends: base >=4.3 && <5 - , conferer >=0.4.0.0 && <0.5.0.0 + , conferer >=1.0.0.0 && <2.0.0.0 , conferer-warp , hspec , http-types >=0.8.6 && <0.13 , text >=1.1 && <1.3 , wai >=3.0 && <4.0 , warp >=3.0 && <4.0 + if impl(ghc >= 8.4.1) + ghc-options: -Wpartial-fields default-language: Haskell2010 diff --git a/src/Conferer/FromConfig/Warp.hs b/src/Conferer/FromConfig/Warp.hs --- a/src/Conferer/FromConfig/Warp.hs +++ b/src/Conferer/FromConfig/Warp.hs @@ -1,81 +1,161 @@ -{-# LANGUAGE FlexibleInstances #-} +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- FromConfig instance for warp +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE RankNTypes #-} {-# 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 +module Conferer.FromConfig.Warp where -import Conferer.Core -import Conferer.Types -import Conferer.FromConfig.Basics -import Data.Maybe (catMaybes) +import qualified Data.Text as Text +import Data.Dynamic + +import Conferer.FromConfig + 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 - ) + fetchFromConfig = fetchFromConfigWith $ + (\case + "proxyprotocolnone" -> Just ProxyProtocolNone + "none" -> Just ProxyProtocolNone + "proxyprotocolrequired" -> Just ProxyProtocolRequired + "required" -> Just ProxyProtocolRequired + "proxyprotocoloptional" -> Just ProxyProtocolOptional + "optional" -> Just ProxyProtocolOptional + _ -> Nothing + ) . Text.toLower instance DefaultConfig Settings where configDef = defaultSettings +-- | Deconstruct a 'Settings' into a many key/dynamic pairs to +-- provide valid defaults for downstream 'fetchFromConfig' +deconstructSettingsToDefaults :: Settings -> [(Key, Dynamic)] +deconstructSettingsToDefaults Settings{..} = + [ ("port", toDyn settingsPort) + , ("host", toDyn settingsHost) + , ("onException", toDyn settingsOnException) + , ("onExceptionResponse", toDyn settingsOnExceptionResponse) + , ("onOpen", toDyn settingsOnOpen) + , ("onClose", toDyn settingsOnClose) + , ("timeout", toDyn settingsTimeout) + , ("manager", toDyn settingsManager) + , ("fdCacheDuration", toDyn settingsFdCacheDuration) + , ("fileInfoCacheDuration", toDyn settingsFileInfoCacheDuration) + , ("beforeMainLoop", toDyn settingsBeforeMainLoop) +#if MIN_VERSION_warp(3,0,4) + , ("fork", toDyn $ ForkSettings settingsFork) +#endif +#if MIN_VERSION_warp(2,0,3) + , ("noParsePath", toDyn settingsNoParsePath) +#endif +#if MIN_VERSION_warp(3,0,1) + , ("installShutdownHandler", toDyn settingsInstallShutdownHandler) +#endif +#if MIN_VERSION_warp(3,0,2) + , ("serverName", toDyn settingsServerName) +#endif +#if MIN_VERSION_warp(3,0,3) + , ("maximumBodyFlush", toDyn settingsMaximumBodyFlush) +#endif +#if MIN_VERSION_warp(3,0,5) + , ("proxyProtocol", toDyn settingsProxyProtocol) +#endif +#if MIN_VERSION_warp(3,1,2) + , ("slowlorisSize", toDyn settingsSlowlorisSize) +#endif +#if MIN_VERSION_warp(3,1,7) + , ("http2Enabled", toDyn settingsHTTP2Enabled) +#endif +#if MIN_VERSION_warp(3,1,10) + , ("logger", toDyn settingsLogger) +#endif +#if MIN_VERSION_warp(3,2,7) + , ("serverPushLogger", toDyn settingsServerPushLogger) +#endif +#if MIN_VERSION_warp(3,2,8) + , ("gracefulShutdownTimeout", toDyn settingsGracefulShutdownTimeout) +#endif +#if MIN_VERSION_warp(3,3,5) + , ("gracefulCloseTimeout1", toDyn settingsGracefulCloseTimeout1) + , ("gracefulCloseTimeout2", toDyn settingsGracefulCloseTimeout2) +#endif +#if MIN_VERSION_warp(3,3,8) + , ("maxTotalHeaderLength", toDyn settingsMaxTotalHeaderLength) +#endif +#if MIN_VERSION_warp(3,3,11) + , ("altSvc", toDyn settingsAltSvc) +#endif + ] + +-- | Newtype wrapper for the 'settingsFork' value that has too much polymorphism +-- to be typeable +newtype ForkSettings = ForkSettings (((forall a. IO a -> IO a) -> IO ()) -> IO ()) + 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 }) + fetchFromConfig key originalConfig = do + config <- addDefaultsAfterDeconstructingToDefaults deconstructSettingsToDefaults key originalConfig + settingsPort <- fetchFromConfig (key /. "port") config + settingsHost <- fetchFromConfig (key /. "host") config + settingsOnException <- fetchFromConfig (key /. "onException") config + settingsOnExceptionResponse <- fetchFromConfig (key /. "onExceptionResponse") config + settingsOnOpen <- fetchFromConfig (key /. "onOpen") config + settingsOnClose <- fetchFromConfig (key /. "onClose") config + settingsTimeout <- fetchFromConfig (key /. "timeout") config + settingsManager <- fetchFromConfig (key /. "manager") config + settingsFdCacheDuration <- fetchFromConfig (key /. "fdCacheDuration") config + settingsFileInfoCacheDuration <- fetchFromConfig (key /. "fileInfoCacheDuration") config + settingsBeforeMainLoop <- fetchFromConfig (key /. "beforeMainLoop") config +#if MIN_VERSION_warp(3,0,4) + (ForkSettings settingsFork) <- fetchFromConfig (key /. "fork") config +#endif #if MIN_VERSION_warp(2,0,3) - >>= findKeyAndApplyConfig config key "noParsePath" settingsNoParsePath (\v c -> c { settingsNoParsePath = v }) + settingsNoParsePath <- fetchFromConfig (key /. "noParsePath") config #endif +#if MIN_VERSION_warp(3,0,1) + settingsInstallShutdownHandler <- fetchFromConfig (key /. "installShutdownHandler") config +#endif #if MIN_VERSION_warp(3,0,2) - >>= findKeyAndApplyConfig config key "serverName" settingsServerName (\v c -> c { settingsServerName = v }) + settingsServerName <- fetchFromConfig (key /. "serverName") config #endif #if MIN_VERSION_warp(3,0,3) - >>= findKeyAndApplyConfig config key "maximumBodyFlush" settingsMaximumBodyFlush (\v c -> c { settingsMaximumBodyFlush = v }) + settingsMaximumBodyFlush <- fetchFromConfig (key /. "maximumBodyFlush") config #endif #if MIN_VERSION_warp(3,0,5) - >>= findKeyAndApplyConfig config key "proxyProtocol" settingsProxyProtocol (\v c -> c { settingsProxyProtocol = v }) + settingsProxyProtocol <- fetchFromConfig (key /. "proxyProtocol") config #endif #if MIN_VERSION_warp(3,1,2) - >>= findKeyAndApplyConfig config key "slowlorisSize" settingsSlowlorisSize (\v c -> c { settingsSlowlorisSize = v }) + settingsSlowlorisSize <- fetchFromConfig (key /. "slowlorisSize") config #endif #if MIN_VERSION_warp(3,1,7) - >>= findKeyAndApplyConfig config key "http2Enabled" settingsHTTP2Enabled (\v c -> c { settingsHTTP2Enabled = v }) + settingsHTTP2Enabled <- fetchFromConfig (key /. "http2Enabled") config #endif +#if MIN_VERSION_warp(3,1,10) + settingsLogger <- fetchFromConfig (key /. "logger") config +#endif +#if MIN_VERSION_warp(3,2,7) + settingsServerPushLogger <- fetchFromConfig (key /. "serverPushLogger") config +#endif #if MIN_VERSION_warp(3,2,8) - >>= findKeyAndApplyConfig config key "gracefulShutdownTimeout" settingsGracefulShutdownTimeout (\v c -> c { settingsGracefulShutdownTimeout = v }) + settingsGracefulShutdownTimeout <- fetchFromConfig (key /. "gracefulShutdownTimeout") config #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 }) + settingsGracefulCloseTimeout1 <- fetchFromConfig (key /. "gracefulCloseTimeout1") config + settingsGracefulCloseTimeout2 <- fetchFromConfig (key /. "gracefulCloseTimeout2") config #endif #if MIN_VERSION_warp(3,3,8) - >>= findKeyAndApplyConfig config key "maxTotalHeaderLength" settingsMaxTotalHeaderLength (\v c -> c { settingsMaxTotalHeaderLength = v }) + settingsMaxTotalHeaderLength <- fetchFromConfig (key /. "maxTotalHeaderLength") config #endif +#if MIN_VERSION_warp(3,3,11) + settingsAltSvc <- fetchFromConfig (key /. "altSvc") config +#endif + return Settings{..} diff --git a/test/Conferer/FromConfig/WarpSpec.hs b/test/Conferer/FromConfig/WarpSpec.hs --- a/test/Conferer/FromConfig/WarpSpec.hs +++ b/test/Conferer/FromConfig/WarpSpec.hs @@ -1,41 +1,40 @@ +{-# LANGUAGE TypeApplications #-} 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 & addSource (mkMapSource keyValues) +import Test.Hspec +import Network.Wai.Handler.Warp -fetch :: (FromConfig a, Typeable a, DefaultConfig a) => Key -> Config -> IO (Maybe a) -fetch = safeGetFromConfig +import Conferer +import Conferer.Test +import Conferer.FromConfig.Warp () -portAndHostShouldBe :: Maybe Settings -> (Port, HostPreference) -> Expectation +portAndHostShouldBe :: Settings -> (Port, HostPreference) -> Expectation portAndHostShouldBe fetchedSettings (port, host) = do - getPort <$> fetchedSettings `shouldBe` Just port - getHost <$> fetchedSettings `shouldBe` Just host + getPort fetchedSettings `shouldBe` port + getHost fetchedSettings `shouldBe` host spec :: Spec spec = do - let defaultPort = getPort defaultSettings - defaultHost = getHost defaultSettings - describe "fetching a warp configuration without overriding anything" $ do + let defaultPort = getPort configDef + defaultHost = getHost configDef + + describe "fetching a warp configuration from a totally empty config" $ do + it "throws an exception" $ do + config <- configWith [] [] + unsafeFetchKey @Settings config "warp" + `shouldThrow` anyException + describe "fetching a warp configuration that has the default" $ do it "returns warp default config" $ do - let config = emptyConfig - fetchedValue <- fetch "." config + config <- configWith [] [] + fetchedValue <- fetchKey config "warp" configDef 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 + config <- configWith [] [("warp.port", "9999")] + fetchedValue <- fetchKey config "warp" configDef 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 + config <- configWith [] [("warp.host", "!6")] + fetchedValue <- fetchKey config "warp" configDef fetchedValue `portAndHostShouldBe` (defaultPort, "!6")