conferer-warp 0.4.0.1 → 1.0.0.0

raw patch · 4 files changed

+183/−80 lines, 4 filesdep ~confererPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: conferer

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• conferer-warp.cabal +14/−6
• src/Conferer/FromConfig/Warp.hs +129/−49
• test/Conferer/FromConfig/WarpSpec.hs +24/−25

@@ -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

@@ -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

@@ -1,81 +1,161 @@-{-# LANGUAGE FlexibleInstances #-}+-- |+-- Copyright: (c) 2019 Lucas David Traverso+-- License: MPL-2.0+-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>+-- 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{..}

@@ -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")