diff --git a/default.nix b/default.nix index 4534041..7320cc2 100644 --- a/default.nix +++ b/default.nix @@ -1,13 +1,16 @@ -{ mkDerivation, base, hashable, hspec, hspec-discover, lib -, QuickCheck, unordered-containers +{ mkDerivation, aeson, autodocodec, base, bytestring, hashable +, hspec, hspec-discover, lib, QuickCheck, unordered-containers +, yaml }: mkDerivation { pname = "richenv"; version = "0.1.0.0"; src = ./.; - libraryHaskellDepends = [ base hashable unordered-containers ]; + libraryHaskellDepends = [ + aeson autodocodec base hashable unordered-containers + ]; testHaskellDepends = [ - base hspec QuickCheck unordered-containers + base bytestring hspec QuickCheck unordered-containers yaml ]; testToolDepends = [ hspec-discover ]; doHaddock = false; diff --git a/internal/RichEnv/Filters.hs b/internal/RichEnv/Filters.hs index 2e091f5..703e4a7 100644 --- a/internal/RichEnv/Filters.hs +++ b/internal/RichEnv/Filters.hs @@ -8,8 +8,9 @@ import RichEnv.Types (RichEnv, RichEnvItem (..), VarMap (..), VarPrefix (..), Va -- -- >>> varValues S.empty == S.empty -- True --- >>> let richEnv = S.fromList [EnvVarValue (VarValue "foo" "bar"), EnvVarNameMap (VarMap "bar" "baz"), EnvVarPrefix (VarPrefix "qux" "quux")] --- >>> varValues richEnv == S.fromList [VarValue "foo" "bar"] +-- >>> import Data.List.NonEmpty (fromList) +-- >>> let richEnv = S.fromList [EnvVarValue (VarValue (fromList "foo") "bar"), EnvVarNameMap (VarMap (fromList "bar") (fromList "baz")), EnvVarPrefix (VarPrefix "qux" "quux")] +-- >>> varValues richEnv == S.fromList [VarValue (fromList "foo") "bar"] -- True varMaps :: RichEnv -> HashSet VarMap varMaps = S.foldr f S.empty @@ -21,8 +22,9 @@ varMaps = S.foldr f S.empty -- -- >>> varValues S.empty == S.empty -- True --- >>> let richEnv = S.fromList [EnvVarValue (VarValue "foo" "bar"), EnvVarNameMap (VarMap "bar" "baz"), EnvVarPrefix (VarPrefix "qux" "quux")] --- >>> varValues richEnv == S.fromList [VarValue "foo" "bar"] +-- >>> import Data.List.NonEmpty (fromList) +-- >>> let richEnv = S.fromList [EnvVarValue (VarValue (fromList "foo") "bar"), EnvVarNameMap (VarMap (fromList "bar") (fromList "baz")), EnvVarPrefix (VarPrefix "qux" "quux")] +-- >>> varValues richEnv == S.fromList [VarValue (fromList "foo") "bar"] -- True varValues :: RichEnv -> HashSet VarValue varValues = S.foldr f S.empty @@ -34,7 +36,8 @@ varValues = S.foldr f S.empty -- -- >>> varPrefixes S.empty == S.empty -- True --- >>> let richEnv = S.fromList [EnvVarValue (VarValue "foo" "bar"), EnvVarNameMap (VarMap "bar" "baz"), EnvVarPrefix (VarPrefix "qux" "quux")] +-- >>> import Data.List.NonEmpty (fromList) +-- >>> let richEnv = S.fromList [EnvVarValue (VarValue (fromList "foo") "bar"), EnvVarNameMap (VarMap (fromList "bar") (fromList "baz")), EnvVarPrefix (VarPrefix "qux" "quux")] -- >>> varPrefixes richEnv == S.fromList [VarPrefix "qux" "quux"] -- True varPrefixes :: RichEnv -> HashSet VarPrefix diff --git a/internal/RichEnv/Setters.hs b/internal/RichEnv/Setters.hs index e7029b3..daf1191 100644 --- a/internal/RichEnv/Setters.hs +++ b/internal/RichEnv/Setters.hs @@ -13,20 +13,16 @@ import System.Environment (setEnv) -- | Takes 'VarValue's and sets them as environment variables. It is a no-op if the variable name is empty. -- -- >>> import System.Environment --- >>> value <- setVarValueEnv (VarValue "foo" "bar") >> getEnv "foo" +-- >>> import Data.List.NonEmpty (fromList) +-- >>> value <- setVarValueEnv (VarValue (fromList "foo") "bar") >> getEnv "foo" -- >>> value == "bar" -- True -- >>> import System.Environment +-- >>> import Data.List.NonEmpty (fromList) -- >>> getEnvironment >>= mapM_ (unsetEnv . fst) --- >>> value <- setVarValueEnv (VarValue "foo" "bar") >> getEnv "foo" +-- >>> value <- setVarValueEnv (VarValue (fromList "foo") "bar") >> getEnv "foo" -- >>> value == "bar" -- True --- >>> import System.Environment --- >>> env <- getEnvironment --- >>> setVarValueEnv (VarValue "" "bar") --- >>> newEnv <- getEnvironment --- >>> env == newEnv --- True setVarValueEnv :: VarValue -> IO () setVarValueEnv vv = do let name = toList $ vvName vv diff --git a/internal/RichEnv/Types.hs b/internal/RichEnv/Types.hs index 554f3fe..0abc0f0 100644 --- a/internal/RichEnv/Types.hs +++ b/internal/RichEnv/Types.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} -module RichEnv.Types (RichEnvItem (..), VarMap (..), VarPrefix (..), VarValue (..), RichEnv, Environment) where +module RichEnv.Types (RichEnvItem (..), VarMap (..), VarPrefix (..), VarValue (..), RichEnv, Environment, NonEmptyString) where +import Data.Aeson (Encoding, FromJSON, ToJSON (..), Value, withObject, (.:), (.:?)) +import Data.Aeson.Types (FromJSON (..), Parser) import Data.HashSet (HashSet) import Data.Hashable (Hashable) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, fromList) import GHC.Generics (Generic) type RichEnv = HashSet RichEnvItem @@ -21,6 +25,39 @@ data RichEnvItem | -- | Maps all environment variables with a certain prefix to a new set of environment variables with a different prefix. EnvVarPrefix VarPrefix deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +instance FromJSON RichEnvItem where + parseJSON :: Value -> Parser RichEnvItem + parseJSON = withObject "RichEnvItem" $ \o -> do + name <- o .: "name" + from <- o .:? "from" + value <- o .:? "value" + case (name, from, value) of + (Just n, Nothing, Just v) -> pure $ EnvVarValue $ VarValue (fromList n) v + (Just n, Just f, Nothing) -> do + if '*' `notElem` n && '*' `notElem` f + then pure $ EnvVarNameMap $ VarMap (fromList n) (fromList f) + else do + let n' = init n + f' = init f + if '*' `notElem` n' && '*' `notElem` f' + then pure $ EnvVarPrefix $ VarPrefix n' f' + else fail "VarMap `name` and `from` must end with a `*` and not contain `*` anywhere else." + (Nothing, _, _) -> fail "RichEnvItem must have field `name`" + (_, Nothing, Nothing) -> fail "RichEnvItem must have field `name` and at least one of `from` or `value`" + _ -> fail "RichEnvItem must have only one of `from` or `value`" + +instance ToJSON RichEnvItem where + toJSON :: RichEnvItem -> Value + toJSON (EnvVarValue vv) = toJSON vv + toJSON (EnvVarNameMap vm) = toJSON vm + toJSON (EnvVarPrefix vp) = toJSON vp + + toEncoding :: RichEnvItem -> Encoding + toEncoding (EnvVarValue vv) = toEncoding vv + toEncoding (EnvVarNameMap vm) = toEncoding vm + toEncoding (EnvVarPrefix vp) = toEncoding vp -- | A mapping from one environment variable name to another. data VarMap = VarMap @@ -30,6 +67,7 @@ data VarMap = VarMap vmFrom :: NonEmptyString } deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable, ToJSON) data VarValue = VarValue { -- | The name of the environment variable. @@ -38,6 +76,7 @@ data VarValue = VarValue vvValue :: String } deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable, ToJSON) -- | A prefix to add to all environment variables. data VarPrefix = VarPrefix @@ -47,13 +86,4 @@ data VarPrefix = VarPrefix vpFrom :: String } deriving stock (Eq, Show, Generic) - --- Hashable instances for using HashSet. Requires instances of Generic. - -instance Hashable RichEnvItem - -instance Hashable VarMap - -instance Hashable VarValue - -instance Hashable VarPrefix + deriving anyclass (Hashable, ToJSON) diff --git a/richenv.cabal b/richenv.cabal index ffb196a..2fcf0a2 100644 --- a/richenv.cabal +++ b/richenv.cabal @@ -126,10 +126,16 @@ library richenv-internal RichEnv.Setters RichEnv.Types + -- RichEnv.Types.TOML + build-depends: + , aeson + , autodocodec , hashable , unordered-containers + -- , toml-parser + hs-source-dirs: internal default-language: Haskell2010 @@ -158,11 +164,13 @@ test-suite richenv-test -- Test dependencies. build-depends: + , bytestring , hspec , QuickCheck , richenv , richenv-internal , unordered-containers + , yaml -- , base ^>=4.16.4.0 build-tool-depends: hspec-discover:hspec-discover diff --git a/src/RichEnv.hs b/src/RichEnv.hs index 95c17ff..d05111d 100644 --- a/src/RichEnv.hs +++ b/src/RichEnv.hs @@ -29,10 +29,17 @@ setRichEnv re = do -- | Clears all environment variables of the current process. -- -- >>> import System.Environment --- >>> (getEnvironment >>= clearEnvironment) >> getEnvironment >>= pure . null +-- >>> env <- getEnvironment +-- >>> clearEnvironment env +-- >>> env' <- getEnvironment +-- >>> null env' -- True -- >>> import System.Environment --- >>> (getEnvironment >>= clearEnvironment) >> setEnv "FOO" "bar" >> getEnvironment >>= \s -> pure (s == [("FOO", "bar")]) +-- >>> env <- getEnvironment +-- >>> clearEnvironment env +-- >>> setEnv "FOO" "bar" +-- >>> env' <- getEnvironment +-- >>> env' == [("FOO", "bar")] -- True clearEnvironment :: Environment -> IO () clearEnvironment = mapM_ (unsetEnv . fst) diff --git a/test/RichEnvSpec.hs b/test/RichEnvSpec.hs index 1b6ae55..12cea6c 100644 --- a/test/RichEnvSpec.hs +++ b/test/RichEnvSpec.hs @@ -1,44 +1,64 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module RichEnvSpec (spec) where +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C8 import Data.HashSet qualified as S import Data.List (sort) +import Data.Yaml (FromJSON, ParseException, decodeEither') +import GHC.Generics (Generic) import RichEnv (clearEnvironment, setRichEnv, toEnvList) import RichEnv.Types (RichEnv, RichEnvItem (..), VarPrefix (..)) import System.Environment (getEnvironment, setEnv) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) -import Test.QuickCheck () import Utils (nonEmptyVarMap, nonEmptyVarValue) spec :: Spec spec = do - describe "RichEnv ops" $ do + describe "RichEnv ops: set environment" $ do it "set a single environment variable through RichEnv" $ do getEnvironment >>= clearEnvironment - setRichEnv richEnv1 - testEnv expectedEnv1 + setRichEnv $ S.singleton (EnvVarValue (nonEmptyVarValue "SOME" "var")) + testEnv [("SOME", "var")] it "set multiple environment variables through RichEnv" $ do getEnvironment >>= clearEnvironment - setRichEnv richEnv2 - testEnv expectedEnv2 + setRichEnv $ S.fromList [EnvVarValue (nonEmptyVarValue "SOME" "var"), EnvVarValue (nonEmptyVarValue "OTHER" "othervar")] + testEnv [("SOME", "var"), ("OTHER", "othervar")] it "remaps existing environment variables" $ do getEnvironment >>= clearEnvironment setTestEnv exampleEnv - setRichEnv richEnvMapping - testEnv expectedMapped + setRichEnv $ S.singleton $ EnvVarNameMap (nonEmptyVarMap "SOME" "FOO") + testEnv [("SOME", "bar")] it "remaps prefixed variables" $ do getEnvironment >>= clearEnvironment setTestEnv exampleEnv - setRichEnv richEnvPrefix - testEnv expectedNewPrefix - describe "getting the environment variable list" $ do + setRichEnv $ S.singleton $ EnvVarPrefix (VarPrefix "NEW_" "PREFIXED_") + testEnv [("NEW_VAR", "content"), ("NEW_VAR2", "content2")] + describe "RichEnv ops: getting the environment variable list" $ do it "gets the environment variable list" $ do getEnvironment >>= clearEnvironment setTestEnv exampleEnv - testEnvList richEnvMapping expectedMapped + testEnvList + [("SOME", "bar")] + (S.singleton $ EnvVarNameMap (nonEmptyVarMap "SOME" "FOO")) it "gets the environment variable list with prefixes" $ do getEnvironment >>= clearEnvironment setTestEnv exampleEnv - testEnvList richEnvPrefix expectedNewPrefix + testEnvList + [("NEW_VAR", "content"), ("NEW_VAR2", "content2")] + (S.singleton $ EnvVarPrefix (VarPrefix "NEW_" "PREFIXED_")) + describe "RichEnv ops: From YAML" $ do + it "parses a YAML file into expected results" $ do + getEnvironment >>= clearEnvironment + setTestEnv yamlBaseEnv + let res = decodeEither' yamlTestCase :: Either ParseException YamlTest + case res of + Left err -> fail $ show err + Right actual -> testEnvList yamlTestCaseExpected (env actual) + where + exampleEnv = [("FOO", "bar"), ("BAZ", "qux"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] setTestEnv :: [(String, String)] -> IO () setTestEnv = mapM_ (uncurry setEnv) @@ -46,34 +66,38 @@ setTestEnv = mapM_ (uncurry setEnv) testEnv :: [(String, String)] -> Expectation testEnv expected = getEnvironment >>= (`shouldBe` sort expected) . sort -testEnvList :: RichEnv -> [(String, String)] -> Expectation -testEnvList re expected = toEnvList re >>= (`shouldBe` sort expected) . sort - --- Test cases - -richEnv1 :: RichEnv -richEnv1 = S.singleton (EnvVarValue (nonEmptyVarValue "SOME" "var")) - -expectedEnv1 :: [(String, String)] -expectedEnv1 = [("SOME", "var")] - -richEnv2 :: RichEnv -richEnv2 = S.fromList [EnvVarValue (nonEmptyVarValue "SOME" "var"), EnvVarValue (nonEmptyVarValue "OTHER" "othervar")] - -expectedEnv2 :: [(String, String)] -expectedEnv2 = [("SOME", "var"), ("OTHER", "othervar")] +testEnvList :: [(String, String)] -> RichEnv -> Expectation +testEnvList expected re = toEnvList re >>= (`shouldBe` sort expected) . sort -exampleEnv :: [(String, String)] -exampleEnv = [("FOO", "bar"), ("BAZ", "qux"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] +-- YAML test cases that use the JSON conversion instances from Aeson -richEnvMapping :: RichEnv -richEnvMapping = S.singleton $ EnvVarNameMap (nonEmptyVarMap "SOME" "FOO") +newtype YamlTest = YamlTest {env :: RichEnv} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) -expectedMapped :: [(String, String)] -expectedMapped = [("SOME", "bar")] +yamlTestCase :: B.ByteString +yamlTestCase = + C8.pack $ + unlines + [ "env:", + " - name: SOME", -- This is the same as `EnvVarValue (VarValue "SOME" "var")` + " value: somevar", + " - name: OTHER", -- This is the same as `EnvVarValue (VarValue "OTHER" "othervar")` + " value: othervar", + " - name: FOO", -- This is the same as `EnvVarNameMap (VarMap "SOME" "FOO")` + " from: SOME", + " - name: NEW_*", -- This is the same as `EnvVarPrefix (VarPrefix "NEW_" "PREFIXED_")` + " from: PREFIXED_*" + ] -richEnvPrefix :: RichEnv -richEnvPrefix = S.singleton $ EnvVarPrefix (VarPrefix "NEW_" "PREFIXED_") +yamlBaseEnv :: [(String, String)] +yamlBaseEnv = [("SOME", "bar"), ("OTHER", "othervar"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] -expectedNewPrefix :: [(String, String)] -expectedNewPrefix = [("NEW_VAR", "content"), ("NEW_VAR2", "content2")] +yamlTestCaseExpected :: [(String, String)] +yamlTestCaseExpected = + [ ("FOO", "bar"), + ("OTHER", "othervar"), + ("SOME", "somevar"), + ("NEW_VAR", "content"), + ("NEW_VAR2", "content2") + ]