F/#6 unset vars

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
 =====
 

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:

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)

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})

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,15 +195,20 @@ data Var a = Var
   { varHelp    :: Maybe String
   , varHelpDef :: Maybe (a -> String)
   , varDef     :: Maybe a
+  , varKeep    :: Bool
   }
 
 defaultVar :: Var a
 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

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 =