diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, David Johnson +Copyright (c) 2015-2020, David Johnson All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -101,7 +101,7 @@ -- for dealing with connection pool initialization. `env` is equivalent to (.:) in `aeson` -- and `envMaybe` is equivalent to (.:?), except here the lookups are impure. instance FromEnv ConnectInfo where - fromEnv = + fromEnv _ = ConnectInfo <$> envMaybe "PG_HOST" .!= "localhost" <*> env "PG_PORT" <*> env "PG_USER" @@ -130,6 +130,27 @@ -- unsetEnvironment (toEnv :: EnvList ConnectInfo) -- remove when done ``` +Our parser might also make use a set of an optional default values provided by the user, +for dealing with errors when reading from the environment + +```haskell +instance FromEnv ConnectInfo where + fromEnv Nothing = + ConnectInfo <$> envMaybe "PG_HOST" .!= "localhost" + <*> env "PG_PORT" + <*> env "PG_USER" + <*> env "PG_PASS" + <*> env "PG_DB" + + fromEnv (Just def) = + ConnectInfo <$> envMaybe "PG_HOST" .!= (pgHost def) + <*> envMaybe "PG_PORT" .!= (pgPort def) + <*> env "PG_USER" .!= (pgUser def) + <*> env "PG_PASS" .!= (pgPass def) + <*> env "PG_DB" .!= (pgDB def) +``` + + *Note*: As of base 4.7 `setEnv` and `getEnv` throw an `IOException` if a `=` is present in an environment. `envy` catches these synchronous exceptions and delivers them purely to the end user. @@ -144,6 +165,7 @@ import System.Envy import GHC.Generics +import System.Environment.Blank -- This record corresponds to our environment, where the field names become the variable names, and the values the environment variable value data PGConfig = PGConfig { @@ -151,16 +173,29 @@ , pgPort :: Int -- "PG_PORT" } deriving (Generic, Show) --- Default configuration will be used for fields that could not be retrieved from the environment -instance DefConfig PGConfig where - defConfig = PGConfig "localhost" 5432 - instance FromEnv PGConfig -- Generically creates instance for retrieving environment variables (PG_HOST, PG_PORT) main :: IO () +main = do + _ <- setEnv "PG_HOST" "valueFromEnv" True + _ <- setEnv "PG_PORT" "66354651" True + print =<< do decodeEnv :: IO (Either String PGConfig) + -- > PGConfig { pgHost = "valueFromEnv", pgPort = 66354651 } +``` + +If the variables are not found in the environment, the parser will currently fail with an error about the first missing field. + +The user can decide to provide a default value, whose fields will be used by the generic instance, if retrieving them from the environment fails. + +```haskell +defConfig :: PGConfig +defConfig = PGConfig "localhost" 5432 + +main :: IO () main = - print =<< decodeEnv :: IO (Either String PGConfig) + _ <- setEnv "PG_HOST" "customURL" True + print =<< decodeWithDefaults defConfig :: IO (Either String PGConfig) -- > PGConfig { pgHost = "customURL", pgPort = 5432 } ``` @@ -183,14 +218,15 @@ -- All fields will be converted to uppercase instance FromEnv PGConfig where - fromEnv = fromEnvCustom Option { + fromEnv = gFromEnvCustom Option { dropPrefixCount = 7 - , customPrefix = "PG" + , customPrefix = "CUSTOM" } main :: IO () main = - print =<< decodeEnv :: IO (Either String PGConfig) + _ <- setEnv "CUSTOM_HOST" "customUrl" True + print =<< do decodeEnv :: IO (Either String PGConfig) -- PGConfig { pgHost = "customUrl", pgPort = 5432 } ``` @@ -208,18 +244,12 @@ , connectPort :: Int -- "PG_PORT" } deriving (Generic, Show) --- Default PGConfig -instance DefConfig PGConfig where - defConfig = PGConfig "localhost" 5432 - -- All fields will be converted to uppercase getPGEnv :: IO (Either String PGConfig) -getPGEnv = runEnv $ gFromEnvCustom Option { - dropPrefixCount = 7 - , customPrefix = "PG" - } +getPGEnv = runEnv $ gFromEnvCustom defOption + (Just (PGConfig "localhost" 5432)) main :: IO () main = print =<< getPGEnv - -- PGConfig { pgHost = "customUrl", pgPort = 5432 } + -- PGConfig { pgHost = "localhost", pgPort = 5432 } ``` diff --git a/envy.cabal b/envy.cabal --- a/envy.cabal +++ b/envy.cabal @@ -1,11 +1,11 @@ name: envy -version: 1.5.1.0 +version: 2.0.0.0 synopsis: An environmentally friendly way to deal with environment variables license: BSD3 license-file: LICENSE -author: David Johnson, Tim Adams, Eric Mertens +author: David Johnson, Tim Adams, Eric Mertens, Nicolas Rolland maintainer: djohnson.m@gmail.com -copyright: David Johnson (c) 2015 +copyright: David Johnson (c) 2015-2020 category: System build-type: Simple cabal-version: >=1.10 diff --git a/src/System/Envy.hs b/src/System/Envy.hs --- a/src/System/Envy.hs +++ b/src/System/Envy.hs @@ -9,6 +9,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} ------------------------------------------------------------------------------ -- | -- Module : System.Envy @@ -48,10 +50,12 @@ FromEnv (..) , ToEnv (..) , Var (..) - , EnvList + , EnvList (..) + , EnvVar (..) , Parser (..) -- * Functions , decodeEnv + , decodeWithDefaults , decode , showEnv , setEnvironment @@ -66,6 +70,7 @@ -- * Generics , DefConfig (..) , Option (..) + , defOption , runEnv , gFromEnvCustom ) where @@ -78,7 +83,7 @@ import Data.Time import GHC.Generics import Data.Typeable -import System.Environment +import System.Environment.Blank import Text.Read (readMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -123,7 +128,7 @@ => String -- ^ Key to look up. -> Parser a -- ^ Return a value of this type or throw an error. env key = do - result <- liftIO (lookupEnv key) + result <- liftIO (getEnv key) case result of Nothing -> throwError $ "Variable not found for: " ++ key Just dv -> @@ -139,7 +144,7 @@ => String -- ^ Key to look up. -> Parser (Maybe a) -- ^ Return `Nothing` if variable isn't set. envMaybe key = do - val <- liftIO (lookupEnv key) + val <- liftIO (getEnv key) return $ case val of Nothing -> Nothing Just x -> fromVar x @@ -163,25 +168,25 @@ ------------------------------------------------------------------------------ -- | `FromEnv` Typeclass w/ Generic default implementation class FromEnv a where - fromEnv :: Parser a - default fromEnv :: (DefConfig a, Generic a, GFromEnv (Rep a)) => Parser a - fromEnv = gFromEnvCustom defOption + fromEnv :: Maybe a -> Parser a + default fromEnv :: (Generic a, GFromEnv (Rep a)) => Maybe a -> Parser a + fromEnv oa = gFromEnvCustom defOption oa ------------------------------------------------------------------------------ -- | Meant for specifying a custom `Option` for environment retrieval -- -- > instance FromEnv PGConfig where -- > fromEnv = gFromEnvCustom Option { dropPrefixCount = 8, customPrefix = "PG" } --- -gFromEnvCustom :: forall a. (DefConfig a, Generic a, GFromEnv (Rep a)) +gFromEnvCustom :: forall a. (Generic a, GFromEnv (Rep a)) => Option + -> Maybe a -> Parser a -gFromEnvCustom opts = to <$> gFromEnv (from (defConfig :: a)) opts +gFromEnvCustom opts oa = to <$> gFromEnv opts (from <$> oa) ------------------------------------------------------------------------------ -- | `Generic` FromEnv class GFromEnv f where - gFromEnv :: f a -> Option -> Parser (f a) + gFromEnv :: Option -> Maybe (f a) -> Parser (f a) ------------------------------------------------------------------------------ -- | Type class for objects which have a default configuration. @@ -202,24 +207,34 @@ ------------------------------------------------------------------------------ -- | Products instance (GFromEnv a, GFromEnv b) => GFromEnv (a :*: b) where - gFromEnv (a :*: b) opts = liftA2 (:*:) (gFromEnv a opts) (gFromEnv b opts) + gFromEnv opts ox = let (oa, ob) = case ox of + (Just (a :*: b)) -> (Just a, Just b) + _ -> (Nothing, Nothing) in + liftA2 (:*:) (gFromEnv opts oa) (gFromEnv opts ob) ------------------------------------------------------------------------------ -- | Don't absorb meta data instance GFromEnv a => GFromEnv (C1 i a) where - gFromEnv (M1 x) opts = M1 <$> gFromEnv x opts + gFromEnv opts (Just (M1 x))= M1 <$> gFromEnv opts (Just x) + gFromEnv opts _ = M1 <$> gFromEnv opts Nothing ------------------------------------------------------------------------------ -- | Don't absorb meta data instance GFromEnv a => GFromEnv (D1 i a) where - gFromEnv (M1 x) opts = M1 <$> gFromEnv x opts + gFromEnv opts (Just (M1 x)) = M1 <$> gFromEnv opts (Just x) + gFromEnv opts _ = M1 <$> gFromEnv opts Nothing ------------------------------------------------------------------------------ -- | Construct a `Parser` from a `selName` and `DefConfig` record field instance (Selector s, Var a) => GFromEnv (S1 s (K1 i a)) where - gFromEnv m@(M1 (K1 def)) opts = - M1 . K1 <$> envMaybe (toEnvName opts $ selName m) .!= def - where + gFromEnv opts ox = + let p = case ox of + Just (M1 (K1 def)) -> envMaybe envName .!= def + _ -> env envName in + M1 . K1 <$> p + where + envName = toEnvName opts $ selName (SelectorProxy :: SelectorProxy s Proxy ()) + toEnvName :: Option -> String -> String toEnvName Option{..} xs = let name = snake (drop dropPrefixCount xs) @@ -241,6 +256,8 @@ snake :: String -> String snake = map toUpper . snakeCase +data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy + ------------------------------------------------------------------------------ -- | Type class for objects which can be converted to a set of -- environment variable settings. @@ -296,7 +313,7 @@ ------------------------------------------------------------------------------ -- | Environment retrieval with failure info decodeEnv :: FromEnv a => IO (Either String a) -decodeEnv = evalParser fromEnv +decodeEnv = evalParser (fromEnv Nothing) ------------------------------------------------------------------------------ -- | Environment retrieval (with no failure info) @@ -307,6 +324,11 @@ eitherToMaybe (Right x) = Just x ------------------------------------------------------------------------------ +-- | Environment retrieval with default values provided +decodeWithDefaults :: FromEnv a => a -> IO a +decodeWithDefaults def = (\(Right x) -> x) <$> evalParser (fromEnv (Just def)) + +------------------------------------------------------------------------------ -- | Catch an IO exception and return it in an Either. wrapIOException :: IO a -> IO (Either String a) wrapIOException action = try action >>= \case @@ -317,7 +339,7 @@ -- | Set environment via a ToEnv constrained type setEnvironment :: EnvList a -> IO (Either String ()) setEnvironment (EnvList envVars) = wrapIOException $ mapM_ set envVars - where set var = setEnv (variableName var) (variableValue var) + where set var = setEnv (variableName var) (variableValue var) True ------------------------------------------------------------------------------ -- | Set environment directly using a value of class ToEnv diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,30 +1,56 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ module Main ( main ) where ------------------------------------------------------------------------------ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Int +import Data.List (isInfixOf) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Time import Data.Word +import GHC.Generics import System.Envy import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic + + + ------------------------------------------------------------------------------ +data UserInfo = UserInfo { + userName :: String + , userAge :: Int + } deriving (Show, Eq, Generic) + + +-- | Generic instance +instance FromEnv UserInfo + +instance Arbitrary UserInfo where + arbitrary = UserInfo <$> arbitrary <*> arbitrary + +------------------------------------------------------------------------------ data ConnectInfo = ConnectInfo { pgHost :: String , pgPort :: Word16 , pgUser :: String , pgPass :: String , pgDB :: String - } deriving (Show, Eq) + } deriving (Show, Eq, Generic) + +instance DefConfig ConnectInfo where + defConfig = ConnectInfo "localhost" 5432 "user" "pass" "db" + +-- | Generic instance with default values +instance FromEnv ConnectInfo + instance Arbitrary ConnectInfo where arbitrary = ConnectInfo <$> nonulls <*> arbitrary @@ -52,11 +78,11 @@ -- | FromEnv Instances, supports popular aeson combinators *and* IO -- for dealing with connection pools instance FromEnv PGConfig where - fromEnv = PGConfig <$> (ConnectInfo <$> envMaybe "PG_HOST" .!= "localhost" - <*> env "PG_PORT" - <*> env "PG_USER" - <*> env "PG_PASS" - <*> env "PG_DB") + fromEnv _ = PGConfig <$> (ConnectInfo <$> envMaybe "PG_HOST" .!= "localhost" + <*> env "PG_PORT" + <*> env "PG_USER" + <*> env "PG_PASS" + <*> env "PG_DB") ------------------------------------------------------------------------------ -- | To Environment Instances @@ -70,6 +96,7 @@ , "PG_DB" .= pgDB ] + ------------------------------------------------------------------------------ -- | Start tests main :: IO () @@ -107,10 +134,41 @@ \(x :: T.Text) -> Just x == fromVar (toVar x) it "() Var isomorphism" $ property $ \(x :: ()) -> Just x == fromVar (toVar x) - describe "Can set to and from environment" $ + describe "Can set to and from environment" $ do it "Isomorphism through setEnvironment['] and decodeEnv" $ property $ \(pgConf::PGConfig) -> monadicIO $ do res <- run $ do _ <- setEnvironment' pgConf decodeEnv assert $ res == Right pgConf + it "Storing and retrieving var" $ property $ + \(x::String) -> monadicIO $ do + res <- run $ do + _ <- setEnvironment $ makeEnv [ "HSPECENVY_" .= toVar x] + runEnv $ env "HSPECENVY_" + assert $ if isInfixOf "\NUL" x then True else res == Right x + describe "Can use generic FromEnv" $ + it "Isomorphism through setEnvironment and decodeEnv" $ property $ + \(ci::ConnectInfo) -> monadicIO $ do + res <- run $ do + let ConnectInfo{..} = ci + _ <- setEnvironment $ + makeEnv [ "PG_HOST" .= pgHost + , "PG_PORT" .= pgPort + , "PG_USER" .= pgUser + , "PG_PASS" .= pgPass + , "PG_DB" .= pgDB + ] + decodeWithDefaults (defConfig :: ConnectInfo) + assert $ res == ci + describe "Can use generic FromEnvNoDefault" $ + it "Isomorphism through setEnvironment and decodeEnv" $ property $ + \(u::UserInfo) -> monadicIO $ do + res <- run $ do + let UserInfo{..} = u + _ <- setEnvironment $ + makeEnv [ "USER_NAME" .= (userName ++ "") + , "USER_AGE" .= userAge + ] + decodeEnv + assert $ if isInfixOf "\NUL" (userName u) then True else res == Right u