diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for richenv + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2023 David Sánchez + +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,100 @@ +# RichEnv + +[![Tests](https://github.com/DavSanchez/richenv/actions/workflows/tests.yml/badge.svg)](https://github.com/DavSanchez/richenv/actions/workflows/tests.yml) +![Hackage Version](https://img.shields.io/hackage/v/:richenv?style=round-square&logo=haskell) + + +Rich environment variable setup for Haskell + +[![built with nix](https://builtwithnix.org/badge.svg)](https://builtwithnix.org) + +This package exposes a type that captures a set of rules that modify an existing environment variable set, be it a provided list of key-value pairs (list of tuples) or the system's environment variable set. + +Each rule can be either a prefix, a mapping or a value. Prefixes take environment variable names and prepend a prefix to them, replacing existing prefixes (i.e. fist removing old prefix, then adding the new one) if desired. Mappings replace the name of the environment variable with a different one, and values create the environment variable with the provided value. + +## Getting started + +The idea behind this library is that you can find a set of rules for setting environment variables that may or may not use the current environment as starting stage, to replace the ones in the current process or pass a custom env to [`System.Process.CreateProcess`](https://hackage.haskell.org/package/process/docs/System-Process.html#t:CreateProcess) to spawn some sub-process. + +If your application uses a configuration file, for example in YAML format, you could add a new field to your config like this: + +```yaml +# example.yaml +env: + values: + VERBOSE: "true" + mappings: + NEWNAME: OLDNAME + prefixes: + NEW_PREFIX_: + - PREFIXED_ + - OTHER_PREFIXED_ + OTHER_NEW_PREFIX_: [OTHER_PREFIXED_] +# More configs ... +``` + +When parsing this new `env` field as the `RichEnv` type (it provides `FromJSON`/`ToJSON` instances), this defines a set of rules: + +- `values`: these are simple environment variable definitions with a value (in textual format). +- `mappings`: these will create new environment variables from existing environment variables on an 1-1 basis. In the YAML config above, a `NEWNAME` var will be created with the contents of the `OLDNAME` var. +- `prefixes`: these will create new environment variables from existing environment variable by prefix substitution. In the example, environment variables with the prefixes `OLD_PREFIX_*` and `OTHER_OLD_PREFIX_*` will all be stripped of the prefix and created with the `NEW_PREFIX_*` instead. + +Thus, after parsing, you will end up with a set of environment variables that you can: + +- Apply to an externally provided list of environment variables and values and then apply the result them to the current process with functions like `setRichEnv`. +- Generate an environment variable list of type `[(Text, Text)]` with `toEnvList`. +- Generate a `[(String, String)]` (with something like `fromEnvironment . toEnvList`) to pass to `System.Process.CreateProcess`. +- etc + +You can either provide a list of environment variables (normally of type `[(Text, Text)]`) to apply `RichEnv` rules or use the environment variables from the current process. + +### Code example + +Assuming you are using the previous YAML example (and a controlled set of environment variables for the current process, see steps 1 and 2 below), you could use `RichEnv` modify the environment variables like this: + +```haskell +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Yaml (decodeFileEither) +import Data.Yaml.Aeson (ParseException) +import GHC.Generics (Generic) +import RichEnv (RichEnv (..), clearEnvironment, setRichEnvFromCurrent) +import System.Environment (getEnvironment, setEnv) + +newtype SomeConfig = SomeConfig {env :: RichEnv} deriving (Show, Eq, Generic, FromJSON, ToJSON) + +main :: IO () +main = do + decodedYaml <- decodeFileEither "./example.yaml" :: IO (Either ParseException SomeConfig) + case decodedYaml of + Left err -> error $ show err + Right rEnv -> do + -- Successfully parsed. Now we can use the RichEnv + -- 1. clear the environment of the current process + getEnvironment >>= clearEnvironment + -- 2. Set an example environment for the current process + mapM_ (uncurry setEnv) [("FOO", "bar"), ("OLDNAME", "qux"), ("PREFIXED_VAR", "content"), ("OTHER_PREFIXED_VAR2", "content2")] + -- 3. modify the current environment with the RichEnv + setRichEnvFromCurrent (env rEnv) + -- 4. check the environment again + getEnvironment >>= print + +-- printedOutput = +-- [ ("OTHER_NEW_PREFIX_VAR2", "content2"), +-- ("VERBOSE", "true"), +-- ("NEWNAME", "qux"), +-- ("NEW_PREFIX_VAR", "content"), +-- ("NEW_PREFIX_VAR2", "content2") +-- ] + -- ... +``` + +As mentioned before, instead of modifying the current process, you use `RichEnv` to spawn processes with custom environments (for example with System.Process' [`proc`](https://hackage.haskell.org/package/process/docs/System-Process.html#v:proc) and [`CreateProcess`](https://hackage.haskell.org/package/process/docs/System-Process.html#t:CreateProcess)' `env` field) defined with your rules, effectively controlling how the environment is forwarded from the current process to the spawned ones. + +See the Hackage documentation and [the tests](./test/RichEnvSpec.hs) for more details and examples. diff --git a/richenv.cabal b/richenv.cabal new file mode 100644 --- /dev/null +++ b/richenv.cabal @@ -0,0 +1,169 @@ +cabal-version: 3.0 + +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'richenv' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: richenv + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Rich environment variable setup for Haskell + +-- A longer description of the package. +description: + This package exposes a type that captures a set of rules to modify an existing environment variable set, be it a provided list of key-value pairs (list of duples) or the system's environment variable set itself. Each rule can be either a prefix, a mapping or a value. See README.md for more details. + +-- URL for the project homepage or repository. +homepage: https://github.com/DavSanchez/richenv + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: David Sánchez + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: davidslt+git@pm.me + +-- A copyright notice. +copyright: 2023 David Sánchez +category: Configuration +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: + CHANGELOG.md + README.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +tested-with: GHC ==9.2.8 || ==9.4.6 + +source-repository head + type: git + location: https://github.com/DavSanchez/richenv.git + +common common-options + build-depends: + , aeson >=2.1.0 && <2.3 + , base >=4.14 && <5 + , text >=2.0 && <3 + , unordered-containers >=0.2.19 && <0.3 + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -Wnoncanonical-monad-instances + + if impl(ghc >=8.2) + ghc-options: -fhide-source-paths + + if impl(ghc >=8.4) + ghc-options: -Wmissing-export-lists -Wpartial-fields + + if impl(ghc >=8.8) + ghc-options: -Wmissing-deriving-strategies -fwrite-ide-info -hiedir=.hie + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + + if impl(ghc >=9.0) + ghc-options: -Winvalid-haddock + + if impl(ghc >=9.2) + ghc-options: -Wredundant-bang-patterns -Woperator-whitespace + + if impl(ghc >=9.4) + ghc-options: -Wredundant-strictness-flags + + -- Base language which the package is written in. + default-language: Haskell2010 + default-extensions: + DeriveAnyClass + DeriveGeneric + DerivingStrategies + ImportQualifiedPost + InstanceSigs + OverloadedStrings + +library + -- Import common options. + import: common-options + + -- Modules exported by the library. + exposed-modules: + RichEnv + RichEnv.Setters + RichEnv.Types + + -- Modules included in this library but not exported. + other-modules: + RichEnv.Types.Mappings + RichEnv.Types.Prefixes + RichEnv.Types.Values + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + -- build-depends: + + -- Directories containing source files. + hs-source-dirs: src + +test-suite richenv-test + -- Import common options. + import: common-options + + -- Modules included in this executable, other than Main. + other-modules: + ArbitraryInstances + RichEnv.SettersSpec + RichEnvSpec + SpecHook + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Spec.hs + + -- Test dependencies. + build-depends: + , aeson + , bytestring >=0.11 && <0.13 + , hspec >=2.10 && <2.12 + , QuickCheck >=2.14 && <2.15 + , quickcheck-instances >=0.3.29 && <0.4 + , richenv + , yaml >=0.11 && <0.12 + + -- , process >=1.6 && <1.7 + build-tool-depends: hspec-discover:hspec-discover diff --git a/src/RichEnv.hs b/src/RichEnv.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv.hs @@ -0,0 +1,81 @@ +-- | This module provides functions to set environment variables or retrieve an environment variable list according to a 'RichEnv' object input, which defines: +-- +-- * A list of environment variables to be set with their values. +-- * Mapping the name from one existing environment variable name to another (If there's an environment variable @__FOO=bar__@, a mapping @__(\"SOME\", \"FOO\")__@ will generate an environment variable definition @__SOME__@ with the contents of the variable @__FOO__@). +-- * Mapping the prefixes of existing environment variables to a new prefix (If there's an environment variable @__FOO_VAR=bar__@, a prefix mapping @__(\"SOME\", [\"FOO\"])__@ will generate an environment variable definition @__SOME_VAR__@ with the contents of the variable @__FOO_VAR__@). +module RichEnv + ( -- * Types + RichEnv (..), + Environment, + + -- * Environment transformations + toEnvList, + toEnvMap, + + -- * Functions using 'IO' to get the environment from the current process + setRichEnv, + setRichEnvFromCurrent, + toEnvListFromCurrent, + toEnvMapFromCurrent, + clearEnvironment, + ) +where + +import Data.HashMap.Strict qualified as HM +import Data.Text (Text) +import RichEnv.Setters (richEnvToValues, valuesToEnv, valuesToEnvList) +import RichEnv.Types (Environment, RichEnv (..), fromEnvironment, toEnvironment) +import RichEnv.Types.Values (Values (unValues)) +import System.Environment (getEnvironment, unsetEnv) + +-- | Get a key-value list of environment variables processing the passed environment with the 'RichEnv' input. +-- +-- > toEnvList re env = valuesToEnvList (toEnvValues re env) +toEnvList :: RichEnv -> Environment -> Environment +toEnvList re = valuesToEnvList . toEnvValues re + +-- | Get a hashmap of environment variables processing the passed environment with the 'RichEnv' input. The idea is that the output could be passed to functions like [Yaml](https://hackage.haskell.org/package/yaml)'s [applyEnvValue](https://hackage.haskell.org/package/yaml/docs/Data-Yaml-Config.html#v:applyEnvValue). +-- +-- > toEnvMap re env = unValues (toEnvValues re env) +toEnvMap :: RichEnv -> Environment -> HM.HashMap Text Text +toEnvMap re = unValues . toEnvValues re + +-- | Builds a 'Values' object from the 'RichEnv' input and a list of environment variables. +toEnvValues :: RichEnv -> Environment -> Values +toEnvValues = richEnvToValues + +-- | Sets the environment variables available for the current process abiding to the 'RichEnv' rules. +setRichEnv :: RichEnv -> Environment -> IO () +setRichEnv re env = do + clearEnvironment $ fromEnvironment env + valuesToEnv (richEnvToValues re env) + +-- | Sets the environment variables available for the current process by checking the current environment variables and applying the 'RichEnv' rules. +-- +-- > setRichEnvFromCurrent re = getEnvironment >>= setRichEnv re . toEnvironment +setRichEnvFromCurrent :: RichEnv -> IO () +setRichEnvFromCurrent re = getEnvironment >>= setRichEnv re . toEnvironment + +-- | Get a key-value list of environment variables processing the current environment with the 'RichEnv' input. +-- +-- > toEnvListFromCurrent re = toEnvList re . toEnvironment <$> getEnvironment +toEnvListFromCurrent :: RichEnv -> IO Environment +toEnvListFromCurrent re = toEnvList re . toEnvironment <$> getEnvironment + +-- | Get a hashmap of environment variables processing the current environment with the 'RichEnv' input. The idea is that the output could be passed to functions like [Yaml](https://hackage.haskell.org/package/yaml)'s [applyEnvValue](https://hackage.haskell.org/package/yaml/docs/Data-Yaml-Config.html#v:applyEnvValue). +-- +-- > toEnvMapFromCurrent re = toEnvMap re . toEnvironment <$> getEnvironment +toEnvMapFromCurrent :: RichEnv -> IO (HM.HashMap Text Text) +toEnvMapFromCurrent re = toEnvMap re . toEnvironment <$> getEnvironment + +-- | Builds a 'Values' object from the 'RichEnv' input and the current environment variables. +-- +-- > toEnvValuesFromCurrent re = toEnvValues re . toEnvironment <$> getEnvironment +_toEnvValuesFromCurrent :: RichEnv -> IO Values +_toEnvValuesFromCurrent re = toEnvValues re . toEnvironment <$> getEnvironment + +-- | Clears all environment variables of the current process. +clearEnvironment :: + [(String, String)] -> + IO () +clearEnvironment = mapM_ (unsetEnv . fst) diff --git a/src/RichEnv/Setters.hs b/src/RichEnv/Setters.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv/Setters.hs @@ -0,0 +1,105 @@ +-- | This module contains functions for setting environment variables from the 'RichEnv' types as well as functions for transforming between the different types used by this library ('Values', 'Mappings' and 'Prefixes'). +module RichEnv.Setters (mappingsToValues, prefixesToValues, valuesToEnv, valuesToEnvList, richEnvToValues) where + +import Data.Bifunctor (first) +import Data.HashMap.Strict qualified as HM +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import RichEnv.Types (Environment, RichEnv (..), fromEnvironment) +import RichEnv.Types.Mappings (Mappings (Mappings, unMappings)) +import RichEnv.Types.Prefixes (Prefixes (Prefixes, unPrefixes)) +import RichEnv.Types.Values (Values (Values, unValues)) +import System.Environment (setEnv) + +-- | Takes a 'Values' object and sets its contents as environment variables. +valuesToEnv :: Values -> IO () +valuesToEnv = mapM_ (uncurry setEnv) . fromEnvironment . HM.toList . unValues + +-- | Takes a 'Values' object and transforms it into a list of key-value pairs representing environment variables. +-- +-- > valuesToEnvList = Data.HashMap.Strict.toList . unValues +valuesToEnvList :: Values -> Environment +valuesToEnvList = HM.toList . unValues + +-- | Takes an environment variable list and all the name mappings and prepares a set of environment variables according to the RichEnv rules. +-- +-- >>> mappingsToValues [("FOO", "bar"), ("SOME", "thing")] (Mappings $ HM.fromList [("OTHER", "FOO")]) +-- Values {unValues = fromList [("OTHER","bar")]} +mappingsToValues :: Environment -> Mappings -> Values +mappingsToValues _ (Mappings m) | null m = mempty +mappingsToValues currentEnv m = + let mappings' = unMappings m + value from = lookup from currentEnv + setMappingValue _ Nothing = id + setMappingValue k (Just v) = HM.insert k v + mappingsToValues' k v = setMappingValue k (value v) + in Values $ HM.foldrWithKey' mappingsToValues' mempty mappings' + +-- | Takes an environment variable list and all the prefix mappings and prepares a set of environment variables according to the 'RichEnv' rules. +-- +-- >>> prefixesToValues [("FOO", "bar"), ("SOME", "thing")] (Prefixes $ HM.fromList [("OTHER", ["FOO"])]) +-- Values {unValues = fromList [("OTHER","bar")]} +prefixesToValues :: Environment -> Prefixes -> Values +prefixesToValues _ (Prefixes p) | null p = mempty +prefixesToValues currentEnv p = + let prefixes' = unPrefixes p + prefixesToValues' k v env = env <> setNewPrefix k v currentEnv + res = if null prefixes' then currentEnv else HM.foldrWithKey' prefixesToValues' mempty prefixes' + in toValues res + +-- | Replace the prefixes of the environment variables with a new prefix. +setNewPrefix :: + -- | New prefix + Text -> + -- | Old prefixes + [Text] -> + -- | Current environment list + Environment -> + -- | Updated environment list + Environment +setNewPrefix newPrefix [] currentEnv = fmap (first (newPrefix <>)) currentEnv +setNewPrefix newPrefix [""] currentEnv = fmap (first (newPrefix <>)) currentEnv +setNewPrefix newPrefix oldPrefixes currentEnv = + let varsWithoutPrefixes = removePrefix currentEnv <$> oldPrefixes + newPrefixedVars = (fmap . fmap) (first (newPrefix <>)) varsWithoutPrefixes + in mconcat newPrefixedVars + +-- | Remove a prefix from the environment variables. +removePrefix :: Environment -> Text -> Environment +removePrefix currentEnv oldPrefix = + let getWithoutPrefix old (k, v) = T.stripPrefix old k >>= \sk -> pure (sk, v) + in mapMaybe (getWithoutPrefix oldPrefix) currentEnv + +-- | Create a 'Values' object from an 'Environment'. +toValues :: Environment -> Values +toValues = Values . HM.fromList + +-- | Takes an environment variable list and a 'RichEnv' object and generates a 'Values' object. +-- +-- >>> richEnvToValues RichEnv.Types.defaultRichEnv [("FOO", "bar"), ("SOME", "thing")] +-- Values {unValues = fromList []} +-- +-- >>> import RichEnv.Types.Values as V +-- >>> let richEnvValue = RichEnv.Types.defaultRichEnv { values = V.fromList [("OTHER", "var")]} +-- >>> let envList = [("FOO", "bar"), ("SOME", "thing")] +-- >>> richEnvToValues richEnvValue envList +-- Values {unValues = fromList [("OTHER","var")]} +-- +-- >>> import RichEnv.Types.Mappings as M +-- >>> let richEnvValue = RichEnv.Types.defaultRichEnv { mappings = M.fromList [("SOME", "FOO")]} +-- >>> let envList = [("FOO", "bar"), ("SOME", "thing"), ("SOME", "other")] +-- >>> richEnvToValues richEnvValue envList +-- Values {unValues = fromList [("SOME","bar")]} +-- +-- >>> import RichEnv.Types.Prefixes as P +-- >>> let richEnvValue = RichEnv.Types.defaultRichEnv { prefixes = P.fromList [("NEW_", ["PREFIXED_"])]} +-- >>> let envList = [("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] +-- >>> richEnvToValues richEnvValue envList +-- Values {unValues = fromList [("NEW_VAR","content"),("NEW_VAR2","content2")]} +richEnvToValues :: RichEnv -> Environment -> Values +richEnvToValues re currentEnv = + let vvs = values re + vms = flip mappingsToValues (mappings re) + vps = flip prefixesToValues (prefixes re) + in vvs <> vms currentEnv <> vps currentEnv diff --git a/src/RichEnv/Types.hs b/src/RichEnv/Types.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv/Types.hs @@ -0,0 +1,59 @@ +-- | This module contains the basic types used by the library and their typeclass instances. +module RichEnv.Types + ( -- * Types + RichEnv (..), + defaultRichEnv, + Environment, + Mappings (..), + Values (..), + Prefixes (..), + + -- * Environment transformations + toEnvironment, + fromEnvironment, + ) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (bimap) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import RichEnv.Types.Mappings (Mappings (..)) +import RichEnv.Types.Prefixes (Prefixes (..)) +import RichEnv.Types.Values (Values (..)) + +-- | A list of key-value pairs representing environment variables. +type Environment = [(Text, Text)] + +-- | Get back a @[(String, String)]@ from an 'Environment'. +fromEnvironment :: Environment -> [(String, String)] +fromEnvironment = fmap (bimap T.unpack T.unpack) + +-- | Transform the type returned from 'System.Environment.getEnvironment' (@[(String, String)]@) to use 'Text' instead. +toEnvironment :: [(String, String)] -> Environment +toEnvironment = fmap (bimap T.pack T.pack) + +-- | Type that represents a set of rules that generate environment variables. A value of this type can be retrieved from a configuration file (e.g. YAML) due to its 'FromJSON' instance, or persisted into one with 'ToJSON'. +data RichEnv = RichEnv + { -- | A list of environment variables to be set with their values. + values :: Values, + -- | Mappings from one existing environment variable name to another. + mappings :: Mappings, + -- | Mappings from different prefixes of existing environment variables to new prefixes. + prefixes :: Prefixes + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Semigroup RichEnv where + (<>) :: RichEnv -> RichEnv -> RichEnv + (<>) (RichEnv a b c) (RichEnv d e f) = RichEnv (a <> d) (b <> e) (c <> f) + +instance Monoid RichEnv where + mempty :: RichEnv + mempty = RichEnv mempty mempty mempty + +-- | Default 'RichEnv' value. With everything empty. +defaultRichEnv :: RichEnv +defaultRichEnv = mempty diff --git a/src/RichEnv/Types/Mappings.hs b/src/RichEnv/Types/Mappings.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv/Types/Mappings.hs @@ -0,0 +1,32 @@ +-- | This module contains the 'Mappings' type, which is used to store environment variable name mappings, and its typeclass instances. +module RichEnv.Types.Mappings (Mappings (Mappings, unMappings), fromList) where + +import Data.Aeson (FromJSON (parseJSON), Options (unwrapUnaryRecords), ToJSON (toJSON), Value, defaultOptions, genericParseJSON) +import Data.Aeson.Types (Parser) +import Data.HashMap.Strict qualified as HM +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | A list of key-value pairs representing environment variable name mappings. The internal representation is a 'HashMap Text Text', where the key is the final variable name and the value is the current one which will be replaced. +newtype Mappings = Mappings {unMappings :: HM.HashMap Text Text} + deriving stock (Eq, Show, Generic) + +instance FromJSON Mappings where + parseJSON :: Value -> Parser Mappings + parseJSON = genericParseJSON $ defaultOptions {unwrapUnaryRecords = True} + +instance ToJSON Mappings where + toJSON :: Mappings -> Value + toJSON = toJSON . unMappings + +instance Semigroup Mappings where + (<>) :: Mappings -> Mappings -> Mappings + (<>) (Mappings a) (Mappings b) = Mappings (a <> b) + +instance Monoid Mappings where + mempty :: Mappings + mempty = Mappings mempty + +-- | Build a 'Mappings' object from a list of key-value pairs. +fromList :: [(Text, Text)] -> Mappings +fromList = Mappings . HM.fromList diff --git a/src/RichEnv/Types/Prefixes.hs b/src/RichEnv/Types/Prefixes.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv/Types/Prefixes.hs @@ -0,0 +1,32 @@ +-- | This module contains the 'Prefixes' type, which is used to store environment variable name prefix mappings, and its typeclass instances. +module RichEnv.Types.Prefixes (Prefixes (Prefixes, unPrefixes), fromList) where + +import Data.Aeson (FromJSON (parseJSON), Options (unwrapUnaryRecords), ToJSON (toJSON), Value, defaultOptions, genericParseJSON) +import Data.Aeson.Types (Parser) +import Data.HashMap.Strict qualified as HM +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | A list of key-value pairs representing environment variable name prefix mappings. The internal representation is a 'HashMap Text [Text]', where the key is the final prefix and the value is the list of prefixes that will be replaced. +newtype Prefixes = Prefixes {unPrefixes :: HM.HashMap Text [Text]} + deriving stock (Eq, Show, Generic) + +instance FromJSON Prefixes where + parseJSON :: Value -> Parser Prefixes + parseJSON = genericParseJSON $ defaultOptions {unwrapUnaryRecords = True} + +instance ToJSON Prefixes where + toJSON :: Prefixes -> Value + toJSON = toJSON . unPrefixes + +instance Semigroup Prefixes where + (<>) :: Prefixes -> Prefixes -> Prefixes + (<>) (Prefixes a) (Prefixes b) = Prefixes (a <> b) + +instance Monoid Prefixes where + mempty :: Prefixes + mempty = Prefixes mempty + +-- | Build a 'Prefixes' object from a list of key-value pairs. +fromList :: [(Text, [Text])] -> Prefixes +fromList = Prefixes . HM.fromList diff --git a/src/RichEnv/Types/Values.hs b/src/RichEnv/Types/Values.hs new file mode 100644 --- /dev/null +++ b/src/RichEnv/Types/Values.hs @@ -0,0 +1,32 @@ +-- | This module contains the 'Values' type, which stores environment variable names and values, and its typeclass instances. +module RichEnv.Types.Values (Values (Values, unValues), fromList) where + +import Data.Aeson (FromJSON (parseJSON), Options (unwrapUnaryRecords), ToJSON (toJSON), Value, defaultOptions, genericParseJSON) +import Data.Aeson.Types (Parser) +import Data.HashMap.Strict qualified as HM +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | A list of key-value pairs representing environment variables. The internal representation is a 'HashMap Text Text', where the key is the variable name and the value is the variable value. +newtype Values = Values {unValues :: HM.HashMap Text Text} + deriving stock (Eq, Show, Generic) + +instance FromJSON Values where + parseJSON :: Value -> Parser Values + parseJSON = genericParseJSON $ defaultOptions {unwrapUnaryRecords = True} + +instance ToJSON Values where + toJSON :: Values -> Value + toJSON = toJSON . unValues + +instance Semigroup Values where + (<>) :: Values -> Values -> Values + (<>) (Values a) (Values b) = Values (a <> b) + +instance Monoid Values where + mempty :: Values + mempty = Values mempty + +-- | Build a 'Values' object from a list of key-value pairs. +fromList :: [(Text, Text)] -> Values +fromList = Values . HM.fromList diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs new file mode 100644 --- /dev/null +++ b/test/ArbitraryInstances.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module ArbitraryInstances () where + +import Data.HashMap.Strict qualified as HM +import RichEnv.Types (Mappings (..), Prefixes (..), RichEnv (..), Values (..)) +import Test.QuickCheck (Arbitrary (arbitrary), Gen) +import Test.QuickCheck.Instances.Text () + +instance Arbitrary RichEnv where + arbitrary :: Gen RichEnv + arbitrary = RichEnv <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Values where + arbitrary :: Gen Values + arbitrary = Values . HM.fromList <$> arbitrary + +instance Arbitrary Mappings where + arbitrary :: Gen Mappings + arbitrary = Mappings . HM.fromList <$> arbitrary + +instance Arbitrary Prefixes where + arbitrary :: Gen Prefixes + arbitrary = Prefixes . HM.fromList <$> arbitrary diff --git a/test/RichEnv/SettersSpec.hs b/test/RichEnv/SettersSpec.hs new file mode 100644 --- /dev/null +++ b/test/RichEnv/SettersSpec.hs @@ -0,0 +1,44 @@ +module RichEnv.SettersSpec (spec) where + +import Data.HashMap.Strict qualified as HM +import RichEnv.Setters (mappingsToValues, prefixesToValues) +import RichEnv.Types (Environment, Mappings (..), Prefixes (..), Values (..)) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "mappings" $ do + it "returns an empty environment when given an empty set" $ + mappingsToValues mempty mempty + `shouldBe` mempty + it "remaps a single environment variable" $ + mappingsToValues exampleEnv (Mappings $ HM.singleton "SOME" "FOO") + `shouldBe` Values (HM.singleton "SOME" "bar") + describe "prefixes" $ do + it "returns an empty environment when given an empty set" $ + prefixesToValues mempty mempty + `shouldBe` mempty + it "remaps a single environment variable" $ + prefixesToValues exampleEnv (Prefixes $ HM.singleton "NEW_" ["PREFIXED_"]) + `shouldBe` Values (HM.fromList [("NEW_VAR", "content"), ("NEW_VAR2", "content2")]) + it "passes all environment variables adding a prefix" $ + prefixesToValues exampleEnv (Prefixes $ HM.singleton "NEWPREFIX_" [""]) + `shouldBe` Values (HM.fromList [("NEWPREFIX_FOO", "bar"), ("NEWPREFIX_BAZ", "qux"), ("NEWPREFIX_PREFIXED_VAR", "content"), ("NEWPREFIX_PREFIXED_VAR2", "content2")]) + it "remaps prefixed environment variables removing the prefix" $ + prefixesToValues exampleEnv (Prefixes $ HM.singleton "" ["PREFIXED_"]) + `shouldBe` Values (HM.fromList [("VAR", "content"), ("VAR2", "content2")]) + it "passes only prefixed environment variables preserving the prefix" $ + prefixesToValues exampleEnv (Prefixes $ HM.singleton "PREFIXED_" ["PREFIXED_"]) + `shouldBe` Values (HM.fromList [("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")]) + it "passes all environment variables" $ + prefixesToValues exampleEnv mempty + `shouldBe` Values mempty + it "passes multiple prefixes to multiple new prefixes" $ + prefixesToValues exampleEnv (Prefixes $ HM.fromList [("NEWPREFIX_", [""]), ("", ["PREFIXED_"])]) + `shouldBe` Values (HM.fromList [("NEWPREFIX_FOO", "bar"), ("NEWPREFIX_BAZ", "qux"), ("NEWPREFIX_PREFIXED_VAR", "content"), ("NEWPREFIX_PREFIXED_VAR2", "content2"), ("VAR", "content"), ("VAR2", "content2")]) + it "passes multiple prefixes to a single new prefix" $ + prefixesToValues exampleEnv (Prefixes $ HM.fromList [("NEWPREFIX_", ["BA", "PREFIXED_"])]) + `shouldBe` Values (HM.fromList [("NEWPREFIX_Z", "qux"), ("NEWPREFIX_VAR", "content"), ("NEWPREFIX_VAR2", "content2")]) + where + exampleEnv :: Environment + exampleEnv = [("FOO", "bar"), ("BAZ", "qux"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] diff --git a/test/RichEnvSpec.hs b/test/RichEnvSpec.hs new file mode 100644 --- /dev/null +++ b/test/RichEnvSpec.hs @@ -0,0 +1,194 @@ +module RichEnvSpec (spec) where + +import ArbitraryInstances () +import Control.Exception (displayException) +import Data.Aeson qualified as JSON +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C8 +import Data.HashMap.Strict qualified as HM +import Data.List (sort) +import Data.Text qualified as T +import Data.Yaml qualified as Yaml +import GHC.Generics (Generic) +import RichEnv (clearEnvironment, setRichEnvFromCurrent, toEnvListFromCurrent) +import RichEnv.Types (Environment, Mappings (Mappings), Prefixes (Prefixes), RichEnv (..), Values (Values), defaultRichEnv, fromEnvironment, toEnvironment) +import System.Environment (getEnvironment, setEnv) +-- import System.Process (CreateProcess (env, std_out), StdStream (CreatePipe), proc, readCreateProcess) +import Test.Hspec (Expectation, Spec, context, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (arbitrary), Gen) + +spec :: Spec +spec = describe "RichEnv ops" $ do + context "setting environment" $ do + it "set a single environment variable through RichEnv" $ do + clearEnv + setRichEnvFromCurrent + RichEnv + { values = Values $ HM.fromList [("SOME", "var")], + mappings = mempty, + prefixes = mempty + } + testEnv [("SOME", "var")] + it "set multiple environment variables through RichEnv" $ do + clearEnv + setRichEnvFromCurrent + defaultRichEnv + { values = Values $ HM.fromList [("SOME", "var"), ("OTHER", "othervar")] + } + testEnv [("SOME", "var"), ("OTHER", "othervar")] + it "remaps existing environment variables" $ do + clearEnv + setTestEnv exampleEnv + setRichEnvFromCurrent + defaultRichEnv + { mappings = Mappings $ HM.fromList [("SOME", "FOO")] + } + testEnv [("SOME", "bar")] + it "remaps prefixed variables" $ do + clearEnv + setTestEnv exampleEnv + setRichEnvFromCurrent + defaultRichEnv + { prefixes = Prefixes $ HM.fromList [("NEW_", ["PREFIXED_"])] + } + testEnv [("NEW_VAR", "content"), ("NEW_VAR2", "content2")] + context "getting the environment variable list" $ do + it "gets the environment variable list" $ do + clearEnv + setTestEnv exampleEnv + testEnvList + [("SOME", "bar")] + defaultRichEnv + { mappings = Mappings $ HM.fromList [("SOME", "FOO")] + } + it "gets the environment variable list with prefixes" $ do + clearEnv + setTestEnv exampleEnv + testEnvList + [("NEW_VAR", "content"), ("NEW_VAR2", "content2")] + ( defaultRichEnv + { prefixes = Prefixes $ HM.fromList [("NEW_", ["PREFIXED_"])] + } + ) + + context "working with YAML" $ it "parses a YAML file into expected results" $ do + clearEnv + setTestEnv fileTestsBaseEnv + let res = Yaml.decodeEither' yamlTestCase :: Either Yaml.ParseException TestType + case res of + Left err -> fail $ show err + Right actual -> testEnvList fileTestsCaseExpected (environ actual) + + context "working with JSON" $ it "parses a JSON file into expected results" $ do + clearEnv + setTestEnv fileTestsBaseEnv + let res = JSON.eitherDecodeStrict jsonTestCase :: Either String TestType + case res of + Left err -> fail err + Right actual -> testEnvList fileTestsCaseExpected (environ actual) + + context "invariants" $ do + prop "parsing YAML from and to a RichEnv should end in the original value" $ \re -> do + let yaml = Yaml.encode re + res = Yaml.decodeEither' yaml :: Either Yaml.ParseException RichEnv + in case res of + Left err -> fail $ displayException err + Right actual -> do + actual `shouldBe` re + prop "parsing JSON from and to a RichEnv should end in the original value" $ \re -> do + let json = JSON.encode re + res = JSON.eitherDecode' json :: Either String RichEnv + in case res of + Left err -> fail err + Right actual -> do + actual `shouldBe` re + +-- context "Working with System.Process" $ do +-- it "should work with System.Process" $ do +-- clearEnv +-- setTestEnv exampleEnv +-- envList <- +-- toEnvListFromCurrent +-- ( RichEnv +-- { prefixes = Prefixes $ HM.singleton "NEW_" ["PREFIXED_"], +-- mappings = Mappings $ HM.singleton "SOME" "FOO", +-- values = Values $ HM.singleton "OTHER" "othervar" +-- } +-- ) +-- let envProcess = (proc "env" []) {env = Just (fromEnvironment envList), std_out = CreatePipe} +-- out <- lines <$> readCreateProcess envProcess mempty +-- sort out `shouldBe` sort ["NEW_VAR=content", "NEW_VAR2=content2", "OTHER=othervar", "SOME=bar"] + +exampleEnv :: [(T.Text, T.Text)] +exampleEnv = [("FOO", "bar"), ("BAZ", "qux"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] + +clearEnv :: IO () +clearEnv = getEnvironment >>= clearEnvironment + +setTestEnv :: Environment -> IO () +setTestEnv = mapM_ (uncurry setEnv) . fromEnvironment + +testEnv :: Environment -> Expectation +testEnv expected = getEnvironment >>= (`shouldBe` sort expected) . sort . toEnvironment + +testEnvList :: Environment -> RichEnv -> Expectation +testEnvList expected re = toEnvListFromCurrent re >>= (`shouldBe` sort expected) . sort + +newtype TestType = TestType + { environ :: RichEnv + } + deriving stock (Eq, Show, Generic) + deriving anyclass (JSON.FromJSON, JSON.ToJSON) + +instance Arbitrary TestType where + arbitrary :: Gen TestType + arbitrary = TestType <$> arbitrary + +-- Test cases that use Aeson's FromJSON/ToJSON instances + +yamlTestCase :: B.ByteString +yamlTestCase = + C8.pack $ + unlines + [ "environ:", + " values:", + " SOME: somevar", + " OTHER: othervar", + " mappings:", + " FOO: SOME", + " prefixes:", + " NEW_: [PREFIXED_]" + ] + +jsonTestCase :: B.ByteString +jsonTestCase = + C8.pack $ + unlines + [ "{", + " \"environ\": {", + " \"values\": {", + " \"SOME\": \"somevar\",", + " \"OTHER\": \"othervar\"", + " },", + " \"mappings\": {", + " \"FOO\": \"SOME\"", + " },", + " \"prefixes\": {", + " \"NEW_\": [\"PREFIXED_\"]", + " }", + " }", + "}" + ] + +fileTestsBaseEnv :: Environment +fileTestsBaseEnv = [("SOME", "bar"), ("OTHER", "othervar"), ("PREFIXED_VAR", "content"), ("PREFIXED_VAR2", "content2")] + +fileTestsCaseExpected :: Environment +fileTestsCaseExpected = + [ ("FOO", "bar"), + ("OTHER", "othervar"), + ("SOME", "somevar"), + ("NEW_VAR", "content"), + ("NEW_VAR2", "content2") + ] 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 #-} diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/test/SpecHook.hs @@ -0,0 +1,6 @@ +module SpecHook (hook) where + +import Test.Hspec (Spec, parallel) + +hook :: Spec -> Spec +hook = parallel