diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for settei-env + +## 0.1.0.0 — 2026-07-18 + +- Initial experimental release. +- Add explicit environment bindings, injected snapshots, and trusted Kubernetes object + annotations. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2026, shinzui +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/settei-env.cabal b/settei-env.cabal new file mode 100644 --- /dev/null +++ b/settei-env.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.8 +name: settei-env +version: 0.1.0.0 +synopsis: Environment sources for Settei +description: + Translate explicit environment-variable bindings into provenance-aware + Settei sources without decoding application values. + +homepage: https://github.com/shinzui/settei +bug-reports: https://github.com/shinzui/settei/issues +license: BSD-3-Clause +license-file: LICENSE +author: shinzui +maintainer: shinzui +category: Configuration +build-type: Simple +tested-with: GHC ==9.12.4 +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/shinzui/settei.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall -Wcompat + +library + import: common + hs-source-dirs: src + exposed-modules: Settei.Env + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , settei ==0.1.0.0 + , text >=2.1 && <2.2 + +test-suite settei-env-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Settei.EnvTest + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , settei ==0.1.0.0 + , settei-env ==0.1.0.0 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10.2 && <0.11 + , text >=2.1 && <2.2 diff --git a/src/Settei/Env.hs b/src/Settei/Env.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Env.hs @@ -0,0 +1,247 @@ +-- | +-- Module: Settei.Env +-- Description: Explicit, pure environment-variable sources for Settei. +module Settei.Env + ( EnvName (..), + EnvSnapshot (..), + EnvBinding, + EnvError (..), + annotateBinding, + binding, + bindingAnnotations, + bindingKey, + bindingName, + envSnapshot, + envSource, + fromKubernetesObject, + prefixedBindings, + readEnvSource, + ) +where + +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Settei +import Settei.Prelude +import System.Environment qualified as Environment + +-- | An environment-variable name. 'envSource' validates its portable spelling. +newtype EnvName = EnvName Text + deriving stock (Generic, Eq, Ord, Show) + +-- | A complete injectable view of the process environment. +newtype EnvSnapshot = EnvSnapshot (Map EnvName Text) + deriving stock (Generic, Eq) + +-- | One explicit mapping from an environment variable to a structural Settei key. +data EnvBinding = EnvBinding + { name :: !EnvName, + key :: !Key, + annotations :: !(Map Text Text) + } + deriving stock (Generic, Eq) + +-- | Why a set of environment bindings cannot form one hierarchical source. +data EnvError + = InvalidEnvironmentName !EnvName + | DuplicateEnvironmentName !EnvName + | DuplicateTargetKey !Key + | ConflictingTargetKeys !Key !Key + | PrefixedNameCollision !EnvName !(NonEmpty Key) + deriving stock (Generic, Eq, Show) + +-- | Construct one explicit binding with no caller annotations. +binding :: EnvName -> Key -> EnvBinding +binding name key = EnvBinding {name, key, annotations = Map.empty} + +-- | Add trusted descriptive metadata to a binding. +-- +-- Adapter-owned metadata such as @environment.variable@ still takes precedence. +annotateBinding :: Map Text Text -> EnvBinding -> EnvBinding +annotateBinding annotations bindingValue = + bindingValue & #annotations %~ (annotations <>) + +-- | Return the variable name used by a binding. +bindingName :: EnvBinding -> EnvName +bindingName value = value ^. #name + +-- | Return the structural key targeted by a binding. +bindingKey :: EnvBinding -> Key +bindingKey value = value ^. #key + +-- | Return trusted annotations supplied by the caller. +bindingAnnotations :: EnvBinding -> Map Text Text +bindingAnnotations value = value ^. #annotations + +-- | Build an injectable snapshot from textual name/value pairs. +-- +-- Repeated names use the final supplied value, matching the behavior of a map snapshot. +envSnapshot :: [(Text, Text)] -> EnvSnapshot +envSnapshot values = + EnvSnapshot + (Map.fromList [(EnvName name, value) | (name, value) <- values]) + +-- | Translate explicitly bound variables from one snapshot into a Settei source. +-- +-- Missing variables are absent leaves. Values remain 'RawText'; target decoding and +-- sensitivity handling stay in the core declaration and resolver. +envSource :: Text -> [EnvBinding] -> EnvSnapshot -> Either (NonEmpty EnvError) Source +envSource sourceLabel bindings (EnvSnapshot snapshot) = + case NonEmpty.nonEmpty (bindingErrors bindings) of + Just errors -> Left errors + Nothing -> + Right + ( annotateSourceAt + annotationsFor + (source sourceLabel EnvironmentSource root) + ) + where + presentBindings = + [ (bindingValue, rawValue) + | bindingValue <- bindings, + Just value <- [Map.lookup (bindingValue ^. #name) snapshot], + let rawValue = RawText value + ] + root = + foldl + (\tree (bindingValue, rawValue) -> insertRawValue (bindingValue ^. #key) rawValue tree) + (RawObject Map.empty) + presentBindings + perKeyAnnotations = + Map.fromList + [ ( bindingValue ^. #key, + Map.singleton "environment.variable" (renderEnvName (bindingValue ^. #name)) + <> bindingValue ^. #annotations + ) + | (bindingValue, _) <- presentBindings + ] + annotationsFor key = Map.findWithDefault Map.empty key perKeyAnnotations + +-- | Snapshot the process environment once and pass it through the pure translator. +readEnvSource :: Text -> [EnvBinding] -> IO (Either (NonEmpty EnvError) Source) +readEnvSource sourceLabel bindings = do + values <- Environment.getEnvironment + pure + ( envSource + sourceLabel + bindings + (envSnapshot [(Text.pack name, Text.pack value) | (name, value) <- values]) + ) + +-- | Derive explicit bindings using @PREFIX_KEY_SEGMENTS@ names. +-- +-- Non-alphanumeric characters become underscores and letters become uppercase. Any +-- collision introduced by that normalization is returned instead of being guessed away. +prefixedBindings :: Text -> [Key] -> Either (NonEmpty EnvError) [EnvBinding] +prefixedBindings prefix keys = + case NonEmpty.nonEmpty errors of + Just found -> Left found + Nothing -> Right generated + where + generated = fmap (\key -> binding (prefixedName prefix key) key) keys + invalidErrors = + [ InvalidEnvironmentName name + | bindingValue <- generated, + let name = bindingValue ^. #name, + not (validEnvName name) + ] + duplicateKeyErrors = fmap DuplicateTargetKey (duplicates keys) + groupedByName = + Map.fromListWith + (<>) + [ (bindingValue ^. #name, bindingValue ^. #key :| []) + | bindingValue <- generated + ] + collisionErrors = + [ PrefixedNameCollision name targetKeys + | (name, targetKeys) <- Map.toAscList groupedByName, + NonEmpty.length targetKeys > 1 + ] + errors = invalidErrors <> duplicateKeyErrors <> collisionErrors <> overlapErrors keys + +-- | Attach a trusted Kubernetes object reference without querying a cluster. +fromKubernetesObject :: KubernetesRef -> EnvBinding -> EnvBinding +fromKubernetesObject reference bindingValue = + annotateBinding (kubernetesAnnotations reference) bindingValue + +bindingErrors :: [EnvBinding] -> [EnvError] +bindingErrors bindings = + [ InvalidEnvironmentName name + | bindingValue <- bindings, + let name = bindingValue ^. #name, + not (validEnvName name) + ] + <> fmap DuplicateEnvironmentName (duplicates (fmap (^. #name) bindings)) + <> fmap DuplicateTargetKey (duplicates (fmap (^. #key) bindings)) + <> overlapErrors (fmap (^. #key) bindings) + +overlapErrors :: [Key] -> [EnvError] +overlapErrors keys = + [ ConflictingTargetKeys lower higher + | (positionIndex, lower) <- zip [0 :: Int ..] keys, + higher <- drop (positionIndex + 1) keys, + lower /= higher, + isPrefixKey lower higher || isPrefixKey higher lower + ] + +duplicates :: (Ord a) => [a] -> [a] +duplicates values = + Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(value, 1) | value <- values])) + +validEnvName :: EnvName -> Bool +validEnvName (EnvName value) = + case Text.uncons value of + Nothing -> False + Just (firstCharacter, rest) -> + validInitial firstCharacter && Text.all validContinuation rest + where + validInitial character = asciiLetter character || character == '_' + validContinuation character = validInitial character || isDigit character + +asciiLetter :: Char -> Bool +asciiLetter character = isAsciiLower character || isAsciiUpper character + +prefixedName :: Text -> Key -> EnvName +prefixedName prefix key = + EnvName + ( Text.intercalate + "_" + (normalizeNamePart prefix : fmap normalizeNamePart (NonEmpty.toList (keySegments key))) + ) + +normalizeNamePart :: Text -> Text +normalizeNamePart = + Text.toUpper + . Text.map + (\character -> if asciiLetter character || isDigit character || character == '_' then character else '_') + +renderEnvName :: EnvName -> Text +renderEnvName (EnvName value) = value + +isPrefixKey :: Key -> Key -> Bool +isPrefixKey prefix candidateKey = + NonEmpty.toList (keySegments prefix) + `isListPrefixOf` NonEmpty.toList (keySegments candidateKey) + +isListPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isListPrefixOf [] _ = True +isListPrefixOf _ [] = False +isListPrefixOf (left : leftRest) (right : rightRest) = + left == right && isListPrefixOf leftRest rightRest + +insertRawValue :: Key -> RawValue -> RawValue -> RawValue +insertRawValue key value = go (NonEmpty.toList (keySegments key)) + where + go [] _ = value + go (segment : rest) (RawObject object) = + RawObject + ( object + & at segment + %~ Just + . go rest + . maybe (RawObject Map.empty) id + ) + go _ _ = error "validated environment keys cannot overlap" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Settei.EnvTest qualified +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain (testGroup "settei-env" [Settei.EnvTest.tests]) diff --git a/test/Settei/EnvTest.hs b/test/Settei/EnvTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/EnvTest.hs @@ -0,0 +1,127 @@ +module Settei.EnvTest (tests) where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Settei +import Settei.Env +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Env" + [ testCase "explicit binding records variable origin" $ do + input <- expectSource [binding (EnvName "HASKELL_ENV") runtimeEnvironment] [("HASKELL_ENV", "Production")] + case lookupSource runtimeEnvironment input of + Right (Just found) -> do + found ^. to candidateOrigin . #kind @?= EnvironmentSource + found ^. to candidateOrigin . #annotations . at "environment.variable" @?= Just "HASKELL_ENV" + _ -> fail "expected the environment candidate", + testCase "missing variables remain absent" $ do + input <- expectSource [binding (EnvName "OPTIONAL_VALUE") optionalValue] [] + case lookupSource optionalValue input of + Right Nothing -> pure () + _ -> fail "expected the optional variable to remain absent", + testCase "duplicate bindings are rejected" $ do + let sameName = + [ binding (EnvName "VALUE") runtimeEnvironment, + binding (EnvName "VALUE") optionalValue + ] + sameKey = + [ binding (EnvName "ONE") runtimeEnvironment, + binding (EnvName "TWO") runtimeEnvironment + ] + assertLeftContains isDuplicateName (envSource "environment" sameName (envSnapshot [])) + assertLeftContains isDuplicateKey (envSource "environment" sameKey (envSnapshot [])), + testCase "prefix collisions are rejected" $ do + let keys = [validKey "service.http-port", validKey "service.http_port"] + case prefixedBindings "MYAPP" keys of + Left errors -> + assertBool "expected a normalized-name collision" (any isPrefixCollision (NonEmpty.toList errors)) + Right _ -> fail "expected the prefix helper to reject a collision", + testCase "overlapping target keys are rejected" $ do + let bindings = + [ binding (EnvName "SERVICE") (validKey "service"), + binding (EnvName "PORT") (validKey "service.port") + ] + assertLeftContains isConflict (envSource "environment" bindings (envSnapshot [])), + testCase "Secret annotation remains redacted" $ do + let reference = kubernetesRef SecretObject (Just "payments") "payments-database" (Just "password") + passwordBinding = fromKubernetesObject reference (binding (EnvName "DATABASE_PASSWORD") databasePassword) + input <- expectSourceWith [passwordBinding] [("DATABASE_PASSWORD", secretSentinel)] + result <- expectResolution (resolve defaultResolveOptions [input] (required passwordSetting)) + let output = renderResolutionText (result ^. #report) + assertBool "secret value reached the report" (not (secretSentinel `Text.isInfixOf` output)) + assertBool "secret object metadata was omitted" ("payments-database" `Text.isInfixOf` output) + assertBool "secret key metadata was omitted" ("password" `Text.isInfixOf` output), + testCase "ConfigMap annotation retains public metadata" $ do + let reference = kubernetesRef ConfigMapObject Nothing "service-network" (Just "host") + hostBinding = fromKubernetesObject reference (binding (EnvName "SERVICE_HOST") serviceHost) + input <- expectSourceWith [hostBinding] [("SERVICE_HOST", "api.internal")] + result <- expectResolution (resolve defaultResolveOptions [input] (required hostSetting)) + let output = renderResolutionText (result ^. #report) + assertBool "ConfigMap metadata was omitted" ("service-network" `Text.isInfixOf` output) + assertBool "public value was omitted" ("api.internal" `Text.isInfixOf` output) + ] + +expectSource :: [EnvBinding] -> [(Text, Text)] -> IO Source +expectSource bindings values = expectSourceWith bindings values + +expectSourceWith :: [EnvBinding] -> [(Text, Text)] -> IO Source +expectSourceWith bindings values = + case envSource "environment" bindings (envSnapshot values) of + Left _ -> fail "expected a valid environment source" + Right value -> pure value + +expectResolution :: Either (NonEmpty ConfigError) a -> IO a +expectResolution = \case + Left _ -> fail "expected successful resolution" + Right value -> pure value + +assertLeftContains :: (EnvError -> Bool) -> Either (NonEmpty EnvError) a -> IO () +assertLeftContains predicate = \case + Left errors -> assertBool "expected matching validation error" (any predicate (NonEmpty.toList errors)) + Right _ -> fail "expected binding validation to fail" + +isDuplicateName :: EnvError -> Bool +isDuplicateName (DuplicateEnvironmentName _) = True +isDuplicateName _ = False + +isDuplicateKey :: EnvError -> Bool +isDuplicateKey (DuplicateTargetKey _) = True +isDuplicateKey _ = False + +isPrefixCollision :: EnvError -> Bool +isPrefixCollision (PrefixedNameCollision _ _) = True +isPrefixCollision _ = False + +isConflict :: EnvError -> Bool +isConflict (ConflictingTargetKeys _ _) = True +isConflict _ = False + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +hostSetting :: Setting Text +hostSetting = publicSetting serviceHost "Service host" textDecoder + +runtimeEnvironment :: Key +runtimeEnvironment = validKey "runtime.environment" + +optionalValue :: Key +optionalValue = validKey "optional.value" + +databasePassword :: Key +databasePassword = validKey "database.password" + +serviceHost :: Key +serviceHost = validKey "service.host" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +secretSentinel :: Text +secretSentinel = "never-render-this-secret"