diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for settei-yaml + +## 0.1.0.0 — 2026-07-18 + +- Initial experimental release. +- Add a strict YAML mapping with exact node locations, explicit unsupported-feature + errors, and mounted-file Kubernetes 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-yaml.cabal b/settei-yaml.cabal new file mode 100644 --- /dev/null +++ b/settei-yaml.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.8 +name: settei-yaml +version: 0.1.0.0 +synopsis: YAML sources for Settei +description: + Translate one strict YAML document into a provenance-aware Settei source + while preserving exact node locations and rejecting ambiguous features. + +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 +extra-source-files: test/fixtures/characterization/README.md +data-files: test/fixtures/characterization/*.yaml + +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.Yaml + build-depends: + , attoparsec >=0.14.4 && <0.15 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , conduit >=1.3.6 && <1.4 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , libyaml >=0.1.4 && <0.2 + , scientific >=0.3.7 && <0.4 + , settei ==0.1.0.0 + , text >=2.1 && <2.2 + +test-suite settei-yaml-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Paths_settei_yaml + Settei.YamlCharacterizationTest + Settei.YamlTest + + autogen-modules: Paths_settei_yaml + build-depends: + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , settei ==0.1.0.0 + , settei-yaml ==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/Yaml.hs b/src/Settei/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Yaml.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Yaml +-- Description: Strict, location-preserving YAML sources for Settei. +module Settei.Yaml + ( YamlErrorCategory (..), + YamlSourceError, + YamlSourceOptions, + annotateYamlSourceOptions, + decodeYamlSource, + fromKubernetesMountedFile, + readYamlSource, + withYamlSourcePath, + yamlErrorCategory, + yamlErrorColumn, + yamlErrorContext, + yamlErrorLine, + yamlErrorMessage, + yamlErrorName, + yamlErrorPath, + yamlSourceAnnotations, + yamlSourceName, + yamlSourceOptions, + yamlSourcePath, + ) +where + +import Control.Applicative ((<|>)) +import Control.Exception (IOException, displayException, try) +import Control.Monad (when) +import Data.Attoparsec.Text qualified as Attoparsec +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Char (ord) +import Data.Conduit (runConduitRes, (.|)) +import Data.Conduit.List qualified as ConduitList +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Ratio qualified as Ratio +import Data.Scientific (Scientific) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Settei +import Settei.Prelude +import System.IO.Unsafe (unsafePerformIO) +import Text.Libyaml qualified as Libyaml + +-- | Stable classes of adapter failure. No constructor retains a raw YAML value. +data YamlErrorCategory + = YamlSyntaxError + | YamlIoError + | YamlMultipleDocuments + | YamlDuplicateKey + | YamlNonStringKey + | YamlDottedKey + | YamlUnsupportedFeature + | YamlInvalidScalar + | YamlTopLevelType + deriving stock (Generic, Eq, Ord, Show) + +-- | A secret-safe YAML input failure. +data YamlSourceError = YamlSourceError + { category :: !YamlErrorCategory, + name :: !Text, + path :: !(Maybe FilePath), + line :: !(Maybe Int), + column :: !(Maybe Int), + context :: !Text, + message :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | How one YAML document should be named and annotated in provenance. +data YamlSourceOptions = YamlSourceOptions + { name :: !Text, + path :: !(Maybe FilePath), + annotations :: !(Map Text Text) + } + deriving stock (Generic, Eq) + +data PathPiece = MappingKey !Text | SequenceIndex !Int + deriving stock (Generic, Eq, Ord) + +type LocationMap = Map [Text] SourceLocation + +-- | Start options for an in-memory YAML document. +yamlSourceOptions :: Text -> YamlSourceOptions +yamlSourceOptions name = YamlSourceOptions {name, path = Nothing, annotations = Map.empty} + +-- | Attach a real or logical file path to an in-memory document. +withYamlSourcePath :: FilePath -> YamlSourceOptions -> YamlSourceOptions +withYamlSourcePath path options = options & #path .~ Just path + +-- | Add trusted, secret-safe origin metadata. +annotateYamlSourceOptions :: Map Text Text -> YamlSourceOptions -> YamlSourceOptions +annotateYamlSourceOptions annotations options = options & #annotations %~ (annotations <>) + +-- | Attach a trusted Kubernetes reference for a mounted YAML file. +-- +-- This performs no cluster lookup. Setting sensitivity remains the sole redaction policy. +fromKubernetesMountedFile :: KubernetesRef -> YamlSourceOptions -> YamlSourceOptions +fromKubernetesMountedFile reference = + annotateYamlSourceOptions (kubernetesAnnotations reference) + +-- | Return the stable source name. +yamlSourceName :: YamlSourceOptions -> Text +yamlSourceName options = options ^. #name + +-- | Return the optional file path. +yamlSourcePath :: YamlSourceOptions -> Maybe FilePath +yamlSourcePath options = options ^. #path + +-- | Return caller-supplied, secret-safe annotations. +yamlSourceAnnotations :: YamlSourceOptions -> Map Text Text +yamlSourceAnnotations options = options ^. #annotations + +-- | Return an error's stable category. +yamlErrorCategory :: YamlSourceError -> YamlErrorCategory +yamlErrorCategory problem = problem ^. #category + +-- | Return the source name associated with an error. +yamlErrorName :: YamlSourceError -> Text +yamlErrorName problem = problem ^. #name + +-- | Return the file path associated with an error, when known. +yamlErrorPath :: YamlSourceError -> Maybe FilePath +yamlErrorPath problem = problem ^. #path + +-- | Return the one-based line associated with an error, when known. +yamlErrorLine :: YamlSourceError -> Maybe Int +yamlErrorLine problem = problem ^. #line + +-- | Return the one-based column associated with an error, when known. +yamlErrorColumn :: YamlSourceError -> Maybe Int +yamlErrorColumn problem = problem ^. #column + +-- | Return a structural path such as @$.service.ports[0]@. +yamlErrorContext :: YamlSourceError -> Text +yamlErrorContext problem = problem ^. #context + +-- | Return a concise message that never includes a raw scalar or source excerpt. +yamlErrorMessage :: YamlSourceError -> Text +yamlErrorMessage problem = problem ^. #message + +-- | Decode exactly one YAML mapping into a Settei file source. +-- +-- Duplicate keys, non-string keys, dotted keys, aliases, anchors, merge keys, custom +-- tags, special floating values, and multiple documents fail explicitly. +decodeYamlSource :: YamlSourceOptions -> ByteString -> Either (NonEmpty YamlSourceError) Source +decodeYamlSource options bytes = + first NonEmpty.singleton $ do + events <- decodeMarkedEvents options bytes + (root, locations) <- parseDocument options events + pure + ( locateSource + (locationFor locations) + ( annotateSource + (options ^. #annotations) + (source (options ^. #name) (FileSource "YAML") root) + ) + ) + +-- | Read one file and pass it through the same strict pure translator. +-- +-- The supplied file path replaces any path already present in the options. +readYamlSource :: YamlSourceOptions -> FilePath -> IO (Either (NonEmpty YamlSourceError) Source) +readYamlSource options filePath = do + let fileOptions = withYamlSourcePath filePath options + contents <- try @IOException (ByteString.readFile filePath) + pure $ case contents of + Left exception -> + Left + ( NonEmpty.singleton + ( yamlError + fileOptions + YamlIoError + Nothing + [] + (Text.pack (displayException exception)) + ) + ) + Right bytes -> decodeYamlSource fileOptions bytes + +decodeMarkedEvents :: YamlSourceOptions -> ByteString -> Either YamlSourceError [Libyaml.MarkedEvent] +decodeMarkedEvents options bytes = unsafePerformIO $ do + decoded <- + try @Libyaml.YamlException + (runConduitRes (Libyaml.decodeMarked bytes .| ConduitList.consume)) + pure $ first (syntaxError options) decoded +{-# NOINLINE decodeMarkedEvents #-} + +syntaxError :: YamlSourceOptions -> Libyaml.YamlException -> YamlSourceError +syntaxError options = \case + Libyaml.YamlParseException problem parserContext mark -> + yamlError + options + YamlSyntaxError + (Just mark) + [] + ( Text.intercalate + ": " + (filter (not . Text.null) (fmap Text.pack [parserContext, problem])) + ) + Libyaml.YamlException message -> + yamlError options YamlSyntaxError Nothing [] (Text.pack message) + +parseDocument :: YamlSourceOptions -> [Libyaml.MarkedEvent] -> Either YamlSourceError (RawValue, LocationMap) +parseDocument options events = case events of + firstEvent : rest + | eventOf firstEvent == Libyaml.EventStreamStart -> parseStream rest + _ -> Left (unexpectedStructure options Nothing []) + where + parseStream = \case + finalEvent : [] + | eventOf finalEvent == Libyaml.EventStreamEnd -> + Right (RawObject Map.empty, Map.empty) + documentStart : rest + | eventOf documentStart == Libyaml.EventDocumentStart -> do + (root, locations, remaining) <- case rest of + documentEnd : trailing + | eventOf documentEnd == Libyaml.EventDocumentEnd -> + Right (RawObject Map.empty, Map.empty, trailing) + _ -> do + (value, foundLocations, afterValue) <- parseNode options [] (Just []) rest + afterEnd <- requireEvent options Libyaml.EventDocumentEnd afterValue + Right (value, foundLocations, afterEnd) + case remaining of + next : _ + | eventOf next == Libyaml.EventDocumentStart -> + Left (yamlError options YamlMultipleDocuments (Just (startMark next)) [] "multiple YAML documents are not supported") + streamEnd : [] + | eventOf streamEnd == Libyaml.EventStreamEnd -> + case root of + RawObject _ -> Right (root, locations) + RawNull -> Right (RawObject Map.empty, Map.empty) + _ -> Left (yamlError options YamlTopLevelType Nothing [] "the top-level YAML value must be a mapping") + _ -> Left (unexpectedStructure options Nothing []) + _ -> Left (unexpectedStructure options Nothing []) + +parseNode :: + YamlSourceOptions -> + [PathPiece] -> + Maybe [Text] -> + [Libyaml.MarkedEvent] -> + Either YamlSourceError (RawValue, LocationMap, [Libyaml.MarkedEvent]) +parseNode options context keyPath = \case + [] -> Left (unexpectedStructure options Nothing context) + marked : rest -> case eventOf marked of + Libyaml.EventScalar bytes tag style anchor -> do + rejectAnchor options context marked anchor + value <- scalarValue options context marked bytes tag style + Right (value, locationMap options keyPath marked, rest) + Libyaml.EventSequenceStart tag _ anchor -> do + rejectAnchor options context marked anchor + rejectCollectionTag options context marked Libyaml.SeqTag tag + (values, remaining) <- parseSequence options context 0 rest + Right (RawArray values, locationMap options keyPath marked, remaining) + Libyaml.EventMappingStart tag _ anchor -> do + rejectAnchor options context marked anchor + rejectCollectionTag options context marked Libyaml.MapTag tag + (object, childLocations, remaining) <- parseMapping options context keyPath Map.empty Map.empty rest + Right + ( RawObject object, + locationMap options keyPath marked <> childLocations, + remaining + ) + Libyaml.EventAlias _ -> + Left (yamlError options YamlUnsupportedFeature (Just (startMark marked)) context "YAML aliases are not supported") + _ -> Left (unexpectedStructure options (Just (startMark marked)) context) + +parseSequence :: + YamlSourceOptions -> + [PathPiece] -> + Int -> + [Libyaml.MarkedEvent] -> + Either YamlSourceError ([RawValue], [Libyaml.MarkedEvent]) +parseSequence options context position = \case + [] -> Left (unexpectedStructure options Nothing context) + marked : rest + | eventOf marked == Libyaml.EventSequenceEnd -> Right ([], rest) + | otherwise -> do + (value, _, remaining) <- parseNode options (context <> [SequenceIndex position]) Nothing (marked : rest) + (values, finalEvents) <- parseSequence options context (position + 1) remaining + Right (value : values, finalEvents) + +parseMapping :: + YamlSourceOptions -> + [PathPiece] -> + Maybe [Text] -> + Map Text RawValue -> + LocationMap -> + [Libyaml.MarkedEvent] -> + Either YamlSourceError (Map Text RawValue, LocationMap, [Libyaml.MarkedEvent]) +parseMapping options context keyPath object locations = \case + [] -> Left (unexpectedStructure options Nothing context) + marked : rest + | eventOf marked == Libyaml.EventMappingEnd -> Right (object, locations, rest) + | otherwise -> do + key <- mappingKey options context marked + let keyContext = context <> [MappingKey key] + when (key == "<<") $ + Left (yamlError options YamlUnsupportedFeature (Just (startMark marked)) keyContext "YAML merge keys are not supported") + when (Text.any (== '.') key) $ + Left (yamlError options YamlDottedKey (Just (startMark marked)) keyContext "mapping keys containing dots are not supported; use nested mappings") + when (Map.member key object) $ + Left (yamlError options YamlDuplicateKey (Just (startMark marked)) keyContext "duplicate mapping key") + let childKeyPath = fmap (<> [key]) keyPath + (value, childLocations, remaining) <- parseNode options keyContext childKeyPath rest + parseMapping + options + context + keyPath + (Map.insert key value object) + (locations <> childLocations) + remaining + +mappingKey :: YamlSourceOptions -> [PathPiece] -> Libyaml.MarkedEvent -> Either YamlSourceError Text +mappingKey options context marked = case eventOf marked of + Libyaml.EventScalar bytes tag style anchor -> do + rejectAnchor options context marked anchor + value <- scalarValue options context marked bytes tag style + case value of + RawText key -> Right key + _ -> Left (yamlError options YamlNonStringKey (Just (startMark marked)) context "mapping keys must be strings") + _ -> Left (yamlError options YamlNonStringKey (Just (startMark marked)) context "mapping keys must be scalar strings") + +scalarValue :: + YamlSourceOptions -> + [PathPiece] -> + Libyaml.MarkedEvent -> + ByteString -> + Libyaml.Tag -> + Libyaml.Style -> + Either YamlSourceError RawValue +scalarValue options context marked bytes tag style = do + value <- + first + (const (yamlError options YamlInvalidScalar (Just (startMark marked)) context "scalar is not valid UTF-8")) + (TextEncoding.decodeUtf8' bytes) + case tag of + Libyaml.StrTag -> Right (RawText value) + Libyaml.NullTag -> Right RawNull + Libyaml.BoolTag -> parseBoolean options context marked value + Libyaml.IntTag -> parseTaggedInteger options context marked value + Libyaml.FloatTag -> RawNumber . toRational <$> parseNumber options context marked value + Libyaml.NoTag + | style `elem` [Libyaml.SingleQuoted, Libyaml.DoubleQuoted, Libyaml.Literal, Libyaml.Folded] -> + Right (RawText value) + | isNull value -> Right RawNull + | Just boolean <- yamlBoolean value -> Right (RawBool boolean) + | Right number <- parseYamlNumber value -> Right (RawNumber (toRational number)) + | otherwise -> Right (RawText value) + _ -> Left (yamlError options YamlUnsupportedFeature (Just (startMark marked)) context "this YAML scalar tag is not supported") + +parseBoolean :: YamlSourceOptions -> [PathPiece] -> Libyaml.MarkedEvent -> Text -> Either YamlSourceError RawValue +parseBoolean options context marked value = + maybe + (Left (yamlError options YamlInvalidScalar (Just (startMark marked)) context "invalid boolean scalar")) + (Right . RawBool) + (yamlBoolean value) + +parseTaggedInteger :: YamlSourceOptions -> [PathPiece] -> Libyaml.MarkedEvent -> Text -> Either YamlSourceError RawValue +parseTaggedInteger options context marked value = do + number <- parseNumber options context marked value + let rational = toRational number + if Ratio.denominator rational == 1 + then Right (RawNumber rational) + else Left (yamlError options YamlInvalidScalar (Just (startMark marked)) context "integer tag requires a whole number") + +parseNumber :: YamlSourceOptions -> [PathPiece] -> Libyaml.MarkedEvent -> Text -> Either YamlSourceError Scientific +parseNumber options context marked value = + first + (const (yamlError options YamlInvalidScalar (Just (startMark marked)) context "invalid or non-finite numeric scalar")) + (parseYamlNumber value) + +parseYamlNumber :: Text -> Either String Scientific +parseYamlNumber = Attoparsec.parseOnly (yamlNumberParser <* Attoparsec.endOfInput) + +yamlNumberParser :: Attoparsec.Parser Scientific +yamlNumberParser = + (fromInteger <$> ("0x" *> Attoparsec.hexadecimal)) + <|> (fromInteger <$> ("0o" *> octal)) + <|> Attoparsec.scientific + where + octal = Text.foldl' step 0 <$> Attoparsec.takeWhile1 isOctalDigit + isOctalDigit character = character >= '0' && character <= '7' + step accumulator character = accumulator * 8 + fromIntegral (ord character - ord '0') + +yamlBoolean :: Text -> Maybe Bool +yamlBoolean value = case Text.toCaseFold value of + "y" -> Just True + "yes" -> Just True + "on" -> Just True + "true" -> Just True + "n" -> Just False + "no" -> Just False + "off" -> Just False + "false" -> Just False + _ -> Nothing + +isNull :: Text -> Bool +isNull value = Text.toCaseFold value == "null" || value == "~" || Text.null value + +rejectAnchor :: YamlSourceOptions -> [PathPiece] -> Libyaml.MarkedEvent -> Libyaml.Anchor -> Either YamlSourceError () +rejectAnchor options context marked = \case + Nothing -> Right () + Just _ -> Left (yamlError options YamlUnsupportedFeature (Just (startMark marked)) context "YAML anchors are not supported") + +rejectCollectionTag :: + YamlSourceOptions -> + [PathPiece] -> + Libyaml.MarkedEvent -> + Libyaml.Tag -> + Libyaml.Tag -> + Either YamlSourceError () +rejectCollectionTag options context marked expected actual + | actual == Libyaml.NoTag || actual == expected = Right () + | otherwise = Left (yamlError options YamlUnsupportedFeature (Just (startMark marked)) context "this YAML collection tag is not supported") + +requireEvent :: + YamlSourceOptions -> + Libyaml.Event -> + [Libyaml.MarkedEvent] -> + Either YamlSourceError [Libyaml.MarkedEvent] +requireEvent options expected = \case + marked : rest + | eventOf marked == expected -> Right rest + | otherwise -> Left (unexpectedStructure options (Just (startMark marked)) []) + [] -> Left (unexpectedStructure options Nothing []) + +locationMap :: YamlSourceOptions -> Maybe [Text] -> Libyaml.MarkedEvent -> LocationMap +locationMap options keyPath marked = case keyPath of + Just segments@(_ : _) -> Map.singleton segments (sourceLocation options (startMark marked)) + _ -> Map.empty + +locationFor :: LocationMap -> Key -> Maybe SourceLocation +locationFor locations key = Map.lookup (NonEmpty.toList (keySegments key)) locations + +sourceLocation :: YamlSourceOptions -> Libyaml.YamlMark -> SourceLocation +sourceLocation options (Libyaml.YamlMark _ zeroBasedLine zeroBasedColumn) = + SourceLocation + { path = maybe (options ^. #name) Text.pack (options ^. #path), + line = Just (zeroBasedLine + 1), + column = Just (zeroBasedColumn + 1) + } + +yamlError :: + YamlSourceOptions -> + YamlErrorCategory -> + Maybe Libyaml.YamlMark -> + [PathPiece] -> + Text -> + YamlSourceError +yamlError options category mark context message = + YamlSourceError + { category, + name = options ^. #name, + path = options ^. #path, + line = oneBasedLine <$> mark, + column = oneBasedColumn <$> mark, + context = renderContext context, + message + } + +unexpectedStructure :: YamlSourceOptions -> Maybe Libyaml.YamlMark -> [PathPiece] -> YamlSourceError +unexpectedStructure options mark context = + yamlError options YamlSyntaxError mark context "unexpected YAML event sequence" + +renderContext :: [PathPiece] -> Text +renderContext = foldl renderPiece "$" + where + renderPiece rendered (MappingKey key) = rendered <> "." <> key + renderPiece rendered (SequenceIndex position) = rendered <> "[" <> Text.pack (show position) <> "]" + +eventOf :: Libyaml.MarkedEvent -> Libyaml.Event +eventOf (Libyaml.MarkedEvent event _ _) = event + +startMark :: Libyaml.MarkedEvent -> Libyaml.YamlMark +startMark (Libyaml.MarkedEvent _ mark _) = mark + +oneBasedLine :: Libyaml.YamlMark -> Int +oneBasedLine (Libyaml.YamlMark _ line _) = line + 1 + +oneBasedColumn :: Libyaml.YamlMark -> Int +oneBasedColumn (Libyaml.YamlMark _ _ column) = column + 1 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Settei.YamlCharacterizationTest qualified as CharacterizationTest +import Settei.YamlTest qualified as YamlTest +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain (testGroup "settei-yaml" [CharacterizationTest.tests, YamlTest.tests]) diff --git a/test/Settei/YamlCharacterizationTest.hs b/test/Settei/YamlCharacterizationTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/YamlCharacterizationTest.hs @@ -0,0 +1,53 @@ +module Settei.YamlCharacterizationTest (tests) where + +import Data.ByteString.Char8 qualified as ByteString8 +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Settei.Yaml +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Yaml.Characterization" + [ testCase "duplicate block mapping keys fail at the second key" $ do + problem <- expectError "service:\n port: 8000\n port: 9000\n" + yamlErrorCategory problem @?= YamlDuplicateKey + yamlErrorLine problem @?= Just 3 + yamlErrorContext problem @?= "$.service.port", + testCase "duplicate flow mapping keys fail at the second key" $ do + problem <- expectError "service: {port: 8000, port: 9000}\n" + yamlErrorCategory problem @?= YamlDuplicateKey + yamlErrorLine problem @?= Just 1, + testCase "multiple documents fail instead of dropping a document" $ do + problem <- expectError "---\nservice: one\n---\nservice: two\n" + yamlErrorCategory problem @?= YamlMultipleDocuments + yamlErrorLine problem @?= Just 3, + testCase "aliases and anchors fail explicitly" $ do + anchorProblem <- expectError "shared: &shared\n port: 8000\n" + yamlErrorCategory anchorProblem @?= YamlUnsupportedFeature + aliasProblem <- expectError "service: *shared\n" + yamlErrorCategory aliasProblem @?= YamlUnsupportedFeature, + testCase "merge keys fail explicitly" $ do + problem <- expectError "service:\n <<: {port: 8000}\n" + yamlErrorCategory problem @?= YamlUnsupportedFeature + yamlErrorContext problem @?= "$.service.<<", + testCase "custom tags fail explicitly" $ do + problem <- expectError "service: !custom value\n" + yamlErrorCategory problem @?= YamlUnsupportedFeature, + testCase "non-string mapping keys fail" $ do + problem <- expectError "1: value\n" + yamlErrorCategory problem @?= YamlNonStringKey, + testCase "syntax failures retain one-based parser marks" $ do + problem <- expectError "service: [one, two\n" + yamlErrorCategory problem @?= YamlSyntaxError + assertBool "syntax error omitted its line" (maybe False (> 0) (yamlErrorLine problem)) + assertBool "syntax error omitted its column" (maybe False (> 0) (yamlErrorColumn problem)) + ] + +expectError :: String -> IO YamlSourceError +expectError input = + case decodeYamlSource (withYamlSourcePath "characterization.yaml" (yamlSourceOptions "characterization")) (ByteString8.pack input) of + Left errors -> pure (NonEmpty.head errors) + Right _ -> fail "expected strict YAML characterization to fail" diff --git a/test/Settei/YamlTest.hs b/test/Settei/YamlTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/YamlTest.hs @@ -0,0 +1,194 @@ +module Settei.YamlTest (tests) where + +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString8 +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Ratio ((%)) +import Data.Text qualified as Text +import Paths_settei_yaml qualified as Paths +import Settei +import Settei.Prelude +import Settei.Yaml +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Yaml" + [ testCase "nested mappings become segmented keys with exact locations" $ do + input <- expectSource "service:\n http:\n host: api.internal\n port: 8080\n" + host <- expectCandidate serviceHttpHost input + assertBool "host did not remain text" (candidateValue host == RawText "api.internal") + host ^. to candidateOrigin . #name @?= "application" + host ^? to candidateOrigin . #location . _Just . #path @?= Just "application.yaml" + host ^? to candidateOrigin . #location . _Just . #line @?= Just (Just 3) + host ^? to candidateOrigin . #location . _Just . #column @?= Just (Just 11) + port <- expectCandidate serviceHttpPort input + assertBool "port did not remain numeric" (candidateValue port == RawNumber 8080), + testCase "explicit null remains a present candidate" $ do + input <- expectSource "service:\n optional: null\n" + found <- expectCandidate serviceOptional input + assertBool "explicit null became absence" (candidateValue found == RawNull), + testCase "large integers, decimals, booleans, and arrays retain portable meaning" $ do + input <- + expectSource + "limits:\n huge: 123456789012345678901234567890\n ratio: 1.25\nfeature:\n enabled: true\n names: [one, two]\n" + huge <- expectCandidate hugeNumber input + assertBool + "large integer lost precision" + (candidateValue huge == RawNumber 123456789012345678901234567890) + ratio <- expectCandidate ratioNumber input + assertBool "decimal lost precision" (candidateValue ratio == RawNumber (5 % 4)) + enabled <- expectCandidate featureEnabled input + assertBool "boolean was not typed" (candidateValue enabled == RawBool True) + names <- expectCandidate featureNames input + assertBool + "array shape changed" + (candidateValue names == RawArray [RawText "one", RawText "two"]), + testCase "higher YAML overrides leaves and replaces arrays wholesale" $ do + low <- expectNamedSource "low" "service:\n host: old.internal\n port: 7000\n names: [one, two]\n" + high <- expectNamedSource "high" "service:\n port: 9000\n names: [three]\n" + result <- + expectResolution + ( resolve + defaultResolveOptions + [low, high] + ((,,) <$> required hostSetting <*> required portSetting <*> required namesSetting) + ) + result ^. #value @?= ("old.internal", 9000, ["three"]) + case result ^. #report . #nodes . at servicePort of + Just node -> do + node ^. #origin . _Just . #name @?= "high" + fmap (^. #name) (node ^. #shadowed) @?= ["low"] + Nothing -> fail "expected resolved YAML port provenance", + testCase "dotted keys fail instead of becoming implicit nesting" $ do + problem <- expectError "service.port: 8080\n" + yamlErrorCategory problem @?= YamlDottedKey + yamlErrorContext problem @?= "$.service.port", + testCase "special floating values fail instead of becoming text" $ do + problem <- expectError "service:\n ratio: !!float .inf\n" + yamlErrorCategory problem @?= YamlInvalidScalar, + testCase "invalid UTF-8 fails without retaining source bytes" $ do + let invalid = ByteString.pack [115, 101, 114, 118, 105, 99, 101, 58, 32, 255] + case decodeYamlSource sourceOptions invalid of + Left errors -> do + let problem = NonEmpty.head errors + assertBool + "unexpected invalid UTF-8 category" + (yamlErrorCategory problem `elem` [YamlSyntaxError, YamlInvalidScalar]) + Right _ -> fail "expected invalid UTF-8 to fail", + testCase "mounted Secret metadata remains visible while its setting is redacted" $ do + let reference = kubernetesRef SecretObject (Just "production") "database-config" (Just "config.yaml") + options = fromKubernetesMountedFile reference sourceOptions + input <- expectSourceWith options ("database:\n password: " <> Text.unpack secretSentinel <> "\n") + result <- expectResolution (resolve defaultResolveOptions [input] (required passwordSetting)) + let textOutput = renderResolutionText (result ^. #report) + jsonOutput = renderResolutionJson (result ^. #report) + assertBool "secret reached text output" (not (secretSentinel `Text.isInfixOf` textOutput)) + assertBool "secret reached JSON output" (not (secretSentinel `Text.isInfixOf` jsonOutput)) + assertBool "Secret metadata was omitted" ("database-config" `Text.isInfixOf` textOutput), + testCase "readYamlSource reports IO failures with the requested path" $ do + result <- readYamlSource (yamlSourceOptions "missing") "test/fixtures/does-not-exist.yaml" + case result of + Left errors -> do + let problem = NonEmpty.head errors + yamlErrorCategory problem @?= YamlIoError + yamlErrorPath problem @?= Just "test/fixtures/does-not-exist.yaml" + Right _ -> fail "expected missing YAML file to fail", + testCase "readYamlSource loads a fixture and records its actual path" $ do + fixturePath <- Paths.getDataFileName "test/fixtures/characterization/nested.yaml" + result <- readYamlSource (yamlSourceOptions "fixture") fixturePath + input <- case result of + Left errors -> fail (show errors) + Right sourceValue -> pure sourceValue + host <- expectCandidate serviceHttpHost input + host ^? to candidateOrigin . #location . _Just . #path @?= Just (Text.pack fixturePath), + testCase "syntax errors never echo an earlier secret scalar" $ do + let input = + "database:\n password: " + <> Text.unpack secretSentinel + <> "\nbroken: [one, two\n" + case decodeYamlSource sourceOptions (ByteString8.pack input) of + Left errors -> + assertBool + "secret reached structured YAML errors" + (not (secretSentinel `Text.isInfixOf` Text.pack (show errors))) + Right _ -> fail "expected malformed YAML to fail", + testCase "top-level sequences fail because configuration keys require a mapping" $ do + problem <- expectError "[one, two]\n" + yamlErrorCategory problem @?= YamlTopLevelType + ] + +sourceOptions :: YamlSourceOptions +sourceOptions = withYamlSourcePath "application.yaml" (yamlSourceOptions "application") + +expectSource :: String -> IO Source +expectSource = expectSourceWith sourceOptions + +expectNamedSource :: Text -> String -> IO Source +expectNamedSource name = + expectSourceWith (withYamlSourcePath (Text.unpack name <> ".yaml") (yamlSourceOptions name)) + +expectSourceWith :: YamlSourceOptions -> String -> IO Source +expectSourceWith options input = + case decodeYamlSource options (ByteString8.pack input) of + Left errors -> fail (show errors) + Right value -> pure value + +expectError :: String -> IO YamlSourceError +expectError input = case decodeYamlSource sourceOptions (ByteString8.pack input) of + Left errors -> pure (NonEmpty.head errors) + Right _ -> fail "expected YAML decoding to fail" + +expectCandidate :: Key -> Source -> IO Candidate +expectCandidate key input = case lookupSource key input of + Right (Just found) -> pure found + _ -> fail "expected YAML candidate" + +expectResolution :: Either (NonEmpty ConfigError) a -> IO a +expectResolution = \case + Left _ -> fail "expected YAML resolution to succeed" + Right value -> pure value + +hostSetting :: Setting Text +hostSetting = publicSetting serviceHost "Service host" textDecoder + +portSetting :: Setting Int +portSetting = publicSetting servicePort "Service port" boundedIntegralDecoder + +namesSetting :: Setting [Text] +namesSetting = publicSetting serviceNames "Service names" textListDecoder + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +textListDecoder :: Decoder [Text] +textListDecoder = decoder $ \key -> \case + RawArray values -> traverse (textElement key) values + _ -> Left (decodeFailure key "an array of text") + +textElement :: Key -> RawValue -> Either DecodeFailure Text +textElement key = \case + RawText value -> Right value + _ -> Left (decodeFailure key "an array of text") + +serviceHttpHost, serviceHttpPort, serviceHost, servicePort, serviceNames, serviceOptional, hugeNumber, ratioNumber, featureEnabled, featureNames, databasePassword :: Key +serviceHttpHost = validKey "service.http.host" +serviceHttpPort = validKey "service.http.port" +serviceHost = validKey "service.host" +servicePort = validKey "service.port" +serviceNames = validKey "service.names" +serviceOptional = validKey "service.optional" +hugeNumber = validKey "limits.huge" +ratioNumber = validKey "limits.ratio" +featureEnabled = validKey "feature.enabled" +featureNames = validKey "feature.names" +databasePassword = validKey "database.password" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +secretSentinel :: Text +secretSentinel = "never-render-this-yaml-secret" diff --git a/test/fixtures/characterization/README.md b/test/fixtures/characterization/README.md new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/README.md @@ -0,0 +1,20 @@ +# libyaml 0.1.4 characterization + +Settei uses `Text.Libyaml.decodeMarked` from `libyaml` 0.1.4 rather than converting +through `Data.Aeson.Value`. Direct inspection of `yaml` 0.11.11.2 showed that its common +`decodeEither'` entry point discards duplicate-key warnings, while `decodeMarked` retains +every mapping pair and one zero-based start and end mark per parser event. + +The `Settei.Yaml.Characterization` tests prove the supported boundary. Block and flow +duplicates fail at the second key. Syntax errors and successful values retain marks, which +the public adapter reports as one-based positions. Multiple documents, anchors, aliases, +merge keys, custom tags, and non-string keys fail explicitly. Scalars support null, +booleans, exact finite numbers, strings, arrays, and ordinary string-keyed mappings. + +These fixtures are small review artifacts matching the inline executable cases: + +- `duplicate-block.yaml` and `duplicate-flow.yaml` contain ambiguous mappings. +- `multiple-documents.yaml` contains two documents that must not be collapsed. +- `alias.yaml`, `merge-key.yaml`, and `custom-tag.yaml` exercise deliberately unsupported + YAML graph and extension features. +- `nested.yaml` is the supported location and translation baseline. diff --git a/test/fixtures/characterization/alias.yaml b/test/fixtures/characterization/alias.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/alias.yaml @@ -0,0 +1,3 @@ +shared: &shared + port: 8000 +service: *shared diff --git a/test/fixtures/characterization/custom-tag.yaml b/test/fixtures/characterization/custom-tag.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/custom-tag.yaml @@ -0,0 +1,1 @@ +service: !custom value diff --git a/test/fixtures/characterization/duplicate-block.yaml b/test/fixtures/characterization/duplicate-block.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/duplicate-block.yaml @@ -0,0 +1,3 @@ +service: + port: 8000 + port: 9000 diff --git a/test/fixtures/characterization/duplicate-flow.yaml b/test/fixtures/characterization/duplicate-flow.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/duplicate-flow.yaml @@ -0,0 +1,1 @@ +service: {port: 8000, port: 9000} diff --git a/test/fixtures/characterization/merge-key.yaml b/test/fixtures/characterization/merge-key.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/merge-key.yaml @@ -0,0 +1,2 @@ +service: + <<: {port: 8000} diff --git a/test/fixtures/characterization/multiple-documents.yaml b/test/fixtures/characterization/multiple-documents.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/multiple-documents.yaml @@ -0,0 +1,4 @@ +--- +service: one +--- +service: two diff --git a/test/fixtures/characterization/nested.yaml b/test/fixtures/characterization/nested.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/nested.yaml @@ -0,0 +1,4 @@ +service: + http: + host: api.internal + port: 8080