conferer-snap 0.4.0.1 → 1.0.0.0

raw patch · 4 files changed

+174/−65 lines, 4 filesdep ~confererdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: conferer, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• conferer-snap.cabal +15/−6
• src/Conferer/FromConfig/Snap.hs +96/−59
• test/Conferer/FromConfig/SnapSpec.hs +47/−0

@@ -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-snap_v1.0.0.0...HEAD+[v1.0.0.0]: https://github.com/ludat/conferer/compare/v0.0.0.0...conferer-snap_v1.0.0.0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3c94ff4a22ea0dcad9dc74aa9e27cbf97632fd596c350ba985c8207fbae1726e+-- hash: 4414eb451bb8d5126f926c37ca9f4d24ba71d78a11538666358097fdc900ef1d  name:           conferer-snap-version:        0.4.0.1+version:        1.0.0.0 synopsis:       conferer's FromConfig instances for snap Config  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,29 +31,36 @@       Paths_conferer_snap   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     , snap-core >=1.0 && <2.0     , snap-server >=1.0 && <2.0     , text >=1.1 && <1.3+  if impl(ghc >= 8.4.1)+    ghc-options: -Wpartial-fields   default-language: Haskell2010  test-suite specs   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Conferer.FromConfig.SnapSpec       Paths_conferer_snap   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-snap     , hspec     , snap-core >=1.0 && <2.0     , snap-server >=1.0 && <2.0     , text >=1.1 && <1.3+  if impl(ghc >= 8.4.1)+    ghc-options: -Wpartial-fields   default-language: Haskell2010

@@ -1,69 +1,106 @@-module Conferer.FromConfig.Snap-  (-  -- * How to use this-  -- | FromConfig instance for snap server configuration-  ---  -- @-  -- import Conferer-  -- import Conferer.FromConfig.Snap ()-  ---  -- main = do-  --   config <- 'defaultConfig' \"awesomeapp\"-  --   snapConfig <- 'getFromConfig' \"snap\" config-  -- @-  ---  -- * Internal utility functions-  -- | These may be useful for someone but are subject to change at any point so-  -- use with care-  ) where+-- |+-- Copyright: (c) 2019 Lucas David Traverso+-- License: MPL-2.0+-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>+-- Stability: stable+-- Portability: portable+--+-- FromConfig instance for snap+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Conferer.FromConfig.Snap where -import Conferer.Core-import Conferer.Types-import Conferer.FromConfig.Basics+import Conferer.FromConfig -import Data.Either (rights)-import Data.String (fromString)-import Data.Text (Text, unpack)-import Data.Typeable+import Data.Data (Typeable)+import Data.Dynamic (toDyn, Dynamic)+import Data.Text (unpack, toLower) -import qualified Snap.Http.Server.Config as Snap import qualified Snap.Core as Snap+import qualified Snap.Http.Server.Config as Snap+import qualified Snap.Internal.Http.Server.Config as Snap  instance FromConfig Snap.ConfigLog where-  updateFromConfig = updateAllAtOnceUsingFetch-  fetchFromConfig k config = do-    getKey k config-      >>= \case-        Just "NoLog" -> return $ Just $ Snap.ConfigNoLog-        Just t -> return $ Just $ Snap.ConfigFileLog $ unpack t-        Nothing -> return $ Nothing+  fetchFromConfig =+    fetchFromConfigWith $+      (\case+        "nolog" -> pure Snap.ConfigNoLog+        "none" -> pure Snap.ConfigNoLog+        "no" -> pure Snap.ConfigNoLog+        "false" -> pure Snap.ConfigNoLog+        t -> pure $ Snap.ConfigFileLog $ unpack t+      ) . toLower -instance (Snap.MonadSnap m, DefaultConfig a) => DefaultConfig (Snap.Config m a) where+instance FromConfig Snap.ProxyType where+  fetchFromConfig =+    fetchFromConfigWith $+      (\case+        "noproxy" -> pure Snap.NoProxy+        "none" -> pure Snap.NoProxy+        "false" -> pure Snap.NoProxy++        "haproxy" -> pure Snap.HaProxy+        "ha" -> pure Snap.HaProxy++        "xforwardedfor" -> pure Snap.X_Forwarded_For+        "forwarded" -> pure Snap.X_Forwarded_For+        "x-forwarded-for" -> pure Snap.X_Forwarded_For+        "x_forwarded_for" -> pure Snap.X_Forwarded_For+        _ -> Nothing+      ) . toLower++instance (Snap.MonadSnap m) => DefaultConfig (Snap.Config m a) where   configDef = Snap.defaultConfig -withMaybe f (Just a) c = f a c-withMaybe f (Nothing) c = c+-- | Deconstruct a 'Snap.Config' into a many key/dynamic pairs to+-- provide valid defaults for downstream 'fetchFromConfig'+desconstructSnapConfigToDefaults :: (Typeable a, Typeable m) => Snap.Config m a -> [(Key, Dynamic)]+desconstructSnapConfigToDefaults Snap.Config{..} =+  [ ("defaultTimeout", toDyn defaultTimeout)+  , ("accessLog", toDyn accessLog)+  , ("bind", toDyn bind)+  , ("compression", toDyn compression)+  , ("errorLog", toDyn errorLog)+  , ("hostname", toDyn hostname)+  , ("locale", toDyn locale)+  , ("port", toDyn port)+  , ("proxyType", toDyn proxyType)+  , ("sslBind", toDyn sslbind)+  , ("sslCert", toDyn sslcert)+  , ("sslKey", toDyn sslkey)+  , ("sslChainCert", toDyn sslchaincert)+  , ("sslPort", toDyn sslport)+  , ("verbose", toDyn verbose)+  , ("unixSocket", toDyn unixsocket)+  , ("unixSocketAccessMode", toDyn unixaccessmode)+  , ("errorHandler", toDyn errorHandler)+  , ("startupHook", toDyn startupHook)+  , ("other", toDyn other)+  ] -instance forall a m. (Typeable m, FromConfig a, Snap.MonadSnap m) => FromConfig (Snap.Config m a) where-  fetchFromConfig k config = return Nothing-  updateFromConfig k config snapConfig = do-    pure snapConfig-      >>= findKeyAndApplyConfig config k "defaultTimeout" Snap.getDefaultTimeout (withMaybe Snap.setDefaultTimeout)-      >>= findKeyAndApplyConfig config k "accessLog" Snap.getAccessLog (withMaybe Snap.setAccessLog)-      >>= findKeyAndApplyConfig config k "bind" Snap.getBind (withMaybe Snap.setBind)-      >>= findKeyAndApplyConfig config k "compression" Snap.getCompression (withMaybe Snap.setCompression)-      >>= findKeyAndApplyConfig config k "errorLog" Snap.getErrorLog (withMaybe Snap.setErrorLog)-      >>= findKeyAndApplyConfig config k "hostname" Snap.getHostname (withMaybe Snap.setHostname)-      >>= findKeyAndApplyConfig config k "locale" Snap.getLocale (withMaybe Snap.setLocale)-      >>= findKeyAndApplyConfig config k "port" Snap.getPort (withMaybe Snap.setPort)-      -- >>= findKeyAndApplyConfig config k "proxy-type" (withMaybe Snap.setProxyType)-      >>= findKeyAndApplyConfig config k "sslBind" Snap.getSSLBind (withMaybe Snap.setSSLBind)-      >>= findKeyAndApplyConfig config k "sslCert" Snap.getSSLCert (withMaybe Snap.setSSLCert)-      >>= findKeyAndApplyConfig config k "sslKey" Snap.getSSLKey (withMaybe Snap.setSSLKey)-      >>= findKeyAndApplyConfig config k "sslChain-cert" Snap.getSSLChainCert (withMaybe Snap.setSSLChainCert)-      >>= findKeyAndApplyConfig config k "sslPort" Snap.getSSLPort (withMaybe Snap.setSSLPort)-      >>= findKeyAndApplyConfig config k "verbose" Snap.getVerbose (withMaybe Snap.setVerbose)-      >>= findKeyAndApplyConfig config k "unixSocket" Snap.getUnixSocket (withMaybe Snap.setUnixSocket)-      >>= findKeyAndApplyConfig config k "unixSocketAccessMode" Snap.getUnixSocketAccessMode (withMaybe Snap.setUnixSocketAccessMode)-      >>= findKeyAndApplyConfig config k "other" Snap.getOther (withMaybe Snap.setOther)-      >>= return+instance forall a m. (FromConfig a, Typeable a, Snap.MonadSnap m, Typeable m) => FromConfig (Snap.Config m a) where+  fetchFromConfig key originalConfig = do+    config <- addDefaultsAfterDeconstructingToDefaults+      (desconstructSnapConfigToDefaults :: Snap.Config m a -> [(Key, Dynamic)])+      key originalConfig+    defaultTimeout <- fetchFromConfig (key /. "defaultTimeout") config+    accessLog <- fetchFromConfig (key /. "accessLog") config+    bind <- fetchFromConfig (key /. "bind") config+    compression <- fetchFromConfig (key /. "compression") config+    errorLog <- fetchFromConfig (key /. "errorLog") config+    hostname <- fetchFromConfig (key /. "hostname") config+    locale <- fetchFromConfig (key /. "locale") config+    port <- fetchFromConfig (key /. "port") config+    proxyType <- fetchFromConfig (key /. "proxyType") config+    sslbind <- fetchFromConfig (key /. "sslBind") config+    sslcert <- fetchFromConfig (key /. "sslCert") config+    sslkey <- fetchFromConfig (key /. "sslKey") config+    sslchaincert <- fetchFromConfig (key /. "sslChainCert") config+    sslport <- fetchFromConfig (key /. "sslPort") config+    verbose <- fetchFromConfig (key /. "verbose") config+    unixsocket <- fetchFromConfig (key /. "unixSocket") config+    unixaccessmode <- fetchFromConfig (key /. "unixSocketAccessMode") config+    errorHandler <- fetchFromConfig (key /. "errorHandler") config+    startupHook <- fetchFromConfig (key /. "startupHook") config+    other <- fetchFromConfig @(Maybe a) (key /. "other") config+    pure Snap.Config{..}

@@ -0,0 +1,47 @@+{-# LANGUAGE TypeApplications #-}+module Conferer.FromConfig.SnapSpec where++import Test.Hspec++import Conferer hiding (Config)+import Conferer.Test+import Conferer.FromConfig.Snap ()+import Snap.Http.Server.Config+import Snap.Internal.Core++spec :: Spec+spec = do+  describe "fetching a snap configuration without a default" $ do+    it "returns snap empty config" $ do+      -- Snap config is based around lots of maybes so it possible to create+      -- one even if there is no default value+      config <- configWith [] []+      fetchedValue <- unsafeFetchKey @(Config Snap ()) config "snap"+      getPort fetchedValue+        `shouldBe` getPort (configDef :: Config Snap ())+  describe "fetching a snap configuration that has the default" $ do+    it "returns snap default config" $ do+      config <- configWith [] []+      fetchedValue <- fetchKey @(Config Snap ()) config "snap" configDef+      getPort fetchedValue+        `shouldBe` getPort (configDef :: Config Snap ())+  describe "fetching a snap configuration overriding its port" $ do+    it "returns a snap config with its port set to the overriden one" $ do+      config <- configWith [] [("snap.port", "5555")]+      fetchedValue <- fetchKey @(Config Snap ()) config "snap" configDef+      getPort fetchedValue+        `shouldBe` Just 5555+  describe "fetching a snap configuration overriding its port" $ do+    it "returns a snap config with its port set to the overriden one" $ do+      config <- configWith [] []+      fetchedValue <- fetchKey @(Config Snap ()) config "snap"+        $ setPort 5555 (configDef :: Config Snap ())+      getPort fetchedValue+        `shouldBe` Just 5555+  describe "fetching a snap configuration overriding its port" $ do+    it "returns a snap config with its port set to the overriden one" $ do+      config <- configWith [] [("snap.other", "55")]+      fetchedValue <- fetchKey @(Config Snap Int) config "snap" configDef+      getOther fetchedValue+        `shouldBe` Just 55+