diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown index cedff35..c586b92 100644 --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +0.4 +=== + + * Supported GHC 8.0.1. + + * On GHC 7.8 and newer, as a secutiry measure, all declared variables are unset by the end of + a successful parsing. If you want to keep the variable in the environment, use the `keep` modifier. + (https://github.com/supki/envparse/pull/7) + 0.3.4 ===== diff --git a/envparse.cabal b/envparse.cabal index 7563168..4d1ec27 100644 --- a/envparse.cabal +++ b/envparse.cabal @@ -1,5 +1,5 @@ name: envparse -version: 0.3.3 +version: 0.4 synopsis: Parse environment variables description: Here's a simple example of a program that uses @envparse@'s parser: @@ -69,7 +69,7 @@ source-repository head source-repository this type: git location: https://github.com/supki/envparse - tag: 0.3.3 + tag: 0.4 library default-language: diff --git a/src/Env.hs b/src/Env.hs index 286abfa..ce2659d 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -69,6 +69,8 @@ module Env , Flag , HasHelp , help + , HasKeep + , keep , Help.helpDoc , Error(..) , Error.AsUnset(..) @@ -84,13 +86,16 @@ module Env import Control.Applicative import Control.Monad ((>=>), (<=<)) -import Data.Foldable (asum) +import Data.Foldable (asum, for_) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..), (<>)) #else import Data.Monoid ((<>)) #endif import System.Environment (getEnvironment) +#if __GLASGOW_HASKELL__ >= 708 +import System.Environment (unsetEnv) +#endif import System.Exit (exitFailure) import qualified System.IO as IO @@ -121,11 +126,18 @@ parse m = -- -- Use this if simply dying on failure (the behavior of 'parse') is inadequate for your needs. parseOr :: (String -> IO a) -> (Help.Info Error -> Help.Info e) -> Parser e b -> IO (Either a b) -parseOr f g p = - traverseLeft (f . Help.helpInfo (g Help.defaultInfo) p) . parsePure p =<< getEnvironment +parseOr onFailure helpMod parser = do + b <- fmap (parsePure parser) getEnvironment +#if __GLASGOW_HASKELL__ >= 708 + for_ b $ \_ -> + eachUnsetVar parser unsetEnv +#endif + traverseLeft (onFailure . Help.helpInfo (helpMod Help.defaultInfo) parser) b die :: String -> IO a -die m = do IO.hPutStrLn IO.stderr m; exitFailure +die m = + do IO.hPutStrLn IO.stderr m; exitFailure traverseLeft :: Applicative f => (a -> f b) -> Either a t -> f (Either b t) -traverseLeft f = either (fmap Left . f) (pure . Right) +traverseLeft f = + either (fmap Left . f) (pure . Right) diff --git a/src/Env/Generic.hs b/src/Env/Generic.hs index 0e8c140..c1c9b80 100644 --- a/src/Env/Generic.hs +++ b/src/Env/Generic.hs @@ -175,7 +175,7 @@ data ConType = Plain | Record instance (G.Selector c, Type c ~ 'Record, GRecord e a) => GRecord e (G.S1 c a) where #else -instance (G.Selector c, c ~ ('G.MetaSel ('Just x1) x2 x3 x4), GRecord e a) => GRecord e (G.S1 c a) where +instance (G.Selector c, c ~ 'G.MetaSel ('Just x1) x2 x3 x4, GRecord e a) => GRecord e (G.S1 c a) where #endif gr state@State {statePrefix, stateCon} = fmap G.M1 (gr state {stateVar=statePrefix ++ suffix}) diff --git a/src/Env/Internal/Parser.hs b/src/Env/Internal/Parser.hs index 8723bac..213da87 100644 --- a/src/Env/Internal/Parser.hs +++ b/src/Env/Internal/Parser.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Env.Internal.Parser ( Parser(..) , VarF(..) , parsePure + , eachUnsetVar , Mod(..) , prefixed , var @@ -25,13 +25,17 @@ module Env.Internal.Parser , Flag , HasHelp , help + , HasKeep + , keep ) where import Control.Applicative import Control.Arrow (left) import Control.Monad ((<=<)) +import Data.Foldable (for_) import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Set as Set #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif @@ -43,12 +47,16 @@ import Env.Internal.Val -- | Try to parse a pure environment -parsePure :: Parser e b -> [(String, String)] -> Either [(String, e)] b +parsePure :: Parser e a -> [(String, String)] -> Either [(String, e)] a parsePure (Parser p) (Map.fromList -> env) = toEither (runAlt go p) where go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v env)) +eachUnsetVar :: Applicative m => Parser e a -> (String -> m b) -> m () +eachUnsetVar Parser {unParser} = + for_ (foldAlt (\VarF {varfKeep, varfName} -> if varfKeep then Set.empty else Set.singleton varfName) unParser) + readVar :: VarF e a -> Map String String -> Either [(String, e)] a readVar VarF {varfName, varfReader} = left (pure . (\err -> (varfName, err))) . varfReader varfName @@ -82,6 +90,7 @@ data VarF e a = VarF , varfHelp :: Maybe String , varfDef :: Maybe a , varfHelpDef :: Maybe String + , varfKeep :: Bool } deriving (Functor) liftVarF :: VarF e a -> Parser e a @@ -108,9 +117,10 @@ var r n (Mod f) = , varfHelp = varHelp , varfDef = varDef , varfHelpDef = varHelpDef <*> varDef + , varfKeep = varKeep } where - Var {varHelp, varDef, varHelpDef} = f defaultVar + Var {varHelp, varDef, varHelpDef, varKeep} = f defaultVar -- | A flag that takes the active value if the environment variable -- is set and non-empty and the default value otherwise @@ -130,9 +140,10 @@ flag f t n (Mod g) = , varfHelp = flagHelp , varfDef = Just f , varfHelpDef = Nothing + , varfKeep = flagKeep } where - Flag {flagHelp} = g defaultFlag + Flag {flagHelp, flagKeep} = g defaultFlag -- | A simple boolean 'flag' -- @@ -184,6 +195,7 @@ data Var a = Var { varHelp :: Maybe String , varHelpDef :: Maybe (a -> String) , varDef :: Maybe a + , varKeep :: Bool } defaultVar :: Var a @@ -191,8 +203,12 @@ defaultVar = Var { varHelp = Nothing , varDef = Nothing , varHelpDef = Nothing + , varKeep = defaultKeep } +defaultKeep :: Bool +defaultKeep = False + -- | The default value of the variable -- -- /Note:/ specifying it means the parser won't ever fail. @@ -203,11 +219,14 @@ def d = -- | Flag metadata data Flag a = Flag { flagHelp :: Maybe String + , flagKeep :: Bool } defaultFlag :: Flag a -defaultFlag = - Flag {flagHelp=Nothing} +defaultFlag = Flag + { flagHelp = Nothing + , flagKeep = defaultKeep + } -- | Show the default value of the variable in help. helpDef :: (a -> String) -> Mod Var a @@ -234,3 +253,19 @@ instance HasHelp Flag where help :: HasHelp t => String -> Mod t a help = Mod . setHelp + +-- | A class of things that can be still kept in an environment when the +-- parsing has been completed. +class HasKeep t where + setKeep :: t a -> t a + +instance HasKeep Var where + setKeep v = v {varKeep=True} + +instance HasKeep Flag where + setKeep v = v {flagKeep=True} + +-- | Keep a variable. +keep :: HasKeep t => Mod t a +keep = + Mod setKeep diff --git a/test/EnvSpec.hs b/test/EnvSpec.hs index e91ff73..9cecfcc 100644 --- a/test/EnvSpec.hs +++ b/test/EnvSpec.hs @@ -9,6 +9,9 @@ import Control.Monad import Data.Monoid (mempty) #endif import Prelude hiding (pi) +#if __GLASGOW_HASKELL__ >= 708 +import System.Environment (lookupEnv, setEnv) +#endif import Test.Hspec import Text.Read (readMaybe) @@ -83,6 +86,31 @@ spec = `shouldBe` Just "zygohistomorphic" +#if __GLASGOW_HASKELL__ >= 708 + it "unsets parsed variables" $ do + setEnv "FOO" "4" + setEnv "BAR" "7" + parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a")) (var auto "BAR" (help "b"))) `shouldReturn` (11 :: Int) + lookupEnv "FOO" `shouldReturn` Nothing + lookupEnv "BAR" `shouldReturn` Nothing + + context "some variables are marked as kept" $ + it "does not unset them" $ do + setEnv "FOO" "4" + setEnv "BAR" "7" + parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a" <> keep)) (var auto "BAR" (help "b"))) `shouldReturn` (11 :: Int) + lookupEnv "FOO" `shouldReturn` Just "4" + lookupEnv "BAR" `shouldReturn` Nothing + + context "parsing fails" $ + it "does not unset any variables" $ do + setEnv "FOO" "4" + setEnv "BAR" "bar" + parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a" <> keep)) (var auto "BAR" (help "b"))) `shouldThrow` anyException + lookupEnv "FOO" `shouldReturn` Just "4" + lookupEnv "BAR" `shouldReturn` Just "bar" +#endif + greaterThan5 :: AsUnread e => Reader e Int greaterThan5 s =