diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Lucas David Traverso + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# conferer-snap diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/conferer-snap.cabal b/conferer-snap.cabal new file mode 100644 --- /dev/null +++ b/conferer-snap.cabal @@ -0,0 +1,58 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b78259781709e8fcbc9fc0c4285a9ebe20786658ca1e4f0928429c6650d4d1d9 + +name: conferer-snap +version: 0.1.0.1 +synopsis: Configuration for reading json files + +description: Library to abstract the parsing of many haskell config values from different config sources +category: Configuration +homepage: https://github.com/ludat/conferer#readme +author: Lucas David Traverso +maintainer: lucas6246@gmail.com +copyright: MIT +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-doc-files: + README.md + LICENSE + +library + exposed-modules: + Conferer.FetchFromConfig.Snap + other-modules: + Paths_conferer_snap + hs-source-dirs: + src + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + build-depends: + base >=4.3 && <5 + , conferer ==0.1.0.1 + , snap-core >=1.0 && <2.0 + , snap-server >=1.0 && <2.0 + , text >=1.1 && <1.3 + default-language: Haskell2010 + +test-suite conferer-snap-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_conferer_snap + hs-source-dirs: + test + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + build-depends: + base >=4.3 && <5 + , conferer ==0.1.0.1 + , conferer-snap + , hspec + , snap-core >=1.0 && <2.0 + , snap-server >=1.0 && <2.0 + , text >=1.1 && <1.3 + default-language: Haskell2010 diff --git a/src/Conferer/FetchFromConfig/Snap.hs b/src/Conferer/FetchFromConfig/Snap.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/FetchFromConfig/Snap.hs @@ -0,0 +1,80 @@ +module Conferer.FetchFromConfig.Snap + ( + -- * How to use this + -- | FetchFromConfig instance for snap server configuration + -- + -- @ + -- import Conferer + -- import Conferer.FetchFromConfig.Snap () -- from package conferer-snap + -- + -- main = do + -- config <- 'defaultConfig' \"awesomeapp\" + -- snapConfig <- 'getFromConfig' \"warp\" config + -- @ + -- + -- * Internal utility functions + -- | These may be useful for someone but are subject to change at any point so + -- use with care + findKeyAndApplyConfig + ) where + +import Conferer.Core +import Conferer.Types +import Conferer.FetchFromConfig.Basics +import Data.Either (rights) +import Data.String (fromString) +import Data.Text (Text, unpack) + +import qualified Snap.Http.Server.Config as Snap +import qualified Snap.Core as Snap + +instance FetchFromConfig Snap.ConfigLog where + fetch k config = do + getKey k config + >>= \case + Right "NoLog" -> return $ Right $ Snap.ConfigNoLog + Right t -> return $ Right $ Snap.ConfigFileLog $ unpack t + Left e -> return $ Left e + +instance (FetchFromConfig a, Snap.MonadSnap m) => FetchFromConfig (Snap.Config m a) where + fetch k config = do + pure (Right Snap.defaultConfig) + >>= findKeyAndApplyConfig config k "default-timeout" Snap.setDefaultTimeout + >>= findKeyAndApplyConfig config k "access-log" Snap.setAccessLog + >>= findKeyAndApplyConfig config k "bind" Snap.setBind + >>= findKeyAndApplyConfig config k "compression" Snap.setCompression + >>= findKeyAndApplyConfig config k "error-log" Snap.setErrorLog + >>= findKeyAndApplyConfig config k "hostname" Snap.setHostname + >>= findKeyAndApplyConfig config k "locale" Snap.setLocale + >>= findKeyAndApplyConfig config k "other" Snap.setOther + >>= findKeyAndApplyConfig config k "port" Snap.setPort + -- >>= findKeyAndApplyConfig config k "proxy-type" Snap.setProxyType + >>= findKeyAndApplyConfig config k "ssl-bind" Snap.setSSLBind + >>= findKeyAndApplyConfig config k "ssl-cert" Snap.setSSLCert + >>= findKeyAndApplyConfig config k "ssl-key" Snap.setSSLKey + >>= findKeyAndApplyConfig config k "ssl-chain-cert" Snap.setSSLChainCert + >>= findKeyAndApplyConfig config k "ssl-port" Snap.setSSLPort + >>= findKeyAndApplyConfig config k "verbose" Snap.setVerbose + >>= findKeyAndApplyConfig config k "unix-socket" Snap.setUnixSocket + >>= findKeyAndApplyConfig config k "unix-socket-access-mode" Snap.setUnixSocketAccessMode + +-- | Concatenate many transformations to the config based on keys and functions +-- +-- TODO: This should probably be on @conferer@ and maybe should use a +-- transformer stack to avoid so much repeated code +findKeyAndApplyConfig :: + FetchFromConfig newvalue + => Config -- ^ Complete config + -> Key -- ^ Key that indicates the part of the config that we care about + -> Key -- ^ Key that we use to find the config (usually concatenating with the + -- other key) + -> (newvalue -> config -> config) -- ^ Function that knows how to use the + -- value to update the config + -> Either Text config -- ^ Result of the last config updating + -> IO (Either Text config) -- ^ Updated config +findKeyAndApplyConfig config k relativeKey f (Right customConfig) = + fetch (k /. relativeKey) config + >>= \case + Left a -> return $ Right customConfig + Right a -> return $ Right $ f a customConfig +findKeyAndApplyConfig config k relativeKey f (Left e) = return $ Left e diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}