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-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 diff --git a/conferer-snap.cabal b/conferer-snap.cabal --- a/conferer-snap.cabal +++ b/conferer-snap.cabal @@ -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 diff --git a/src/Conferer/FromConfig/Snap.hs b/src/Conferer/FromConfig/Snap.hs --- a/src/Conferer/FromConfig/Snap.hs +++ b/src/Conferer/FromConfig/Snap.hs @@ -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 +-- 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{..} diff --git a/test/Conferer/FromConfig/SnapSpec.hs b/test/Conferer/FromConfig/SnapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/SnapSpec.hs @@ -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 +