diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for settei-kdl + +## 0.1.0.0 — 2026-07-18 + +- Initial experimental release. +- Add the canonical KDL v2 mapping with exact spans, deterministic cardinality, explicit + ambiguity 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-kdl.cabal b/settei-kdl.cabal new file mode 100644 --- /dev/null +++ b/settei-kdl.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.8 +name: settei-kdl +version: 0.1.0.0 +synopsis: KDL v2 sources for Settei +description: + Translate a canonical KDL v2 document into a provenance-aware Settei + source while preserving node spans and rejecting ambiguous shapes. + +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/*.kdl + +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.Kdl + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , kdl-hs >=1.1.1 && <1.2 + , settei ==0.1.0.0 + , text >=2.1 && <2.2 + +test-suite settei-kdl-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Paths_settei_kdl + Settei.KdlCharacterizationTest + Settei.KdlTest + + autogen-modules: Paths_settei_kdl + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , settei ==0.1.0.0 + , settei-kdl ==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/Kdl.hs b/src/Settei/Kdl.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Kdl.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Kdl +-- Description: Canonical, span-preserving KDL v2 sources for Settei. +module Settei.Kdl + ( KdlErrorCategory (..), + KdlSourceError, + KdlSourceOptions, + KdlSpan, + annotateKdlSourceOptions, + decodeKdlSource, + fromKubernetesMountedFile, + kdlErrorCategory, + kdlErrorContext, + kdlErrorMessage, + kdlErrorName, + kdlErrorPath, + kdlErrorRelatedSpan, + kdlErrorSpan, + kdlSourceAnnotations, + kdlSourceName, + kdlSourceOptions, + kdlSourcePath, + kdlSpanColumn, + kdlSpanEndColumn, + kdlSpanEndLine, + kdlSpanLine, + readKdlSource, + withKdlSourcePath, + ) +where + +import Control.Exception (IOException, displayException, try) +import Control.Monad (foldM, when) +import Data.Bifunctor (first) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.Text.Read qualified as TextRead +import KDL.Parser qualified as KDLParser +import KDL.Types qualified as KDL +import Settei +import Settei.Prelude + +-- | Stable classes of adapter failure. No constructor retains a raw KDL value. +data KdlErrorCategory + = KdlSyntaxError + | KdlIoError + | KdlDuplicateProperty + | KdlInvalidName + | KdlUnsupportedAnnotation + | KdlUnsupportedValue + | KdlMixedNodeShape + | KdlPropertyChildCollision + deriving stock (Generic, Eq, Ord, Show) + +-- | A complete one-based KDL source span. +data KdlSpan = KdlSpan + { line :: !Int, + column :: !Int, + endLine :: !Int, + endColumn :: !Int + } + deriving stock (Generic, Eq, Ord, Show) + +-- | A secret-safe KDL input failure. +data KdlSourceError = KdlSourceError + { category :: !KdlErrorCategory, + name :: !Text, + path :: !(Maybe FilePath), + location :: !(Maybe KdlSpan), + relatedLocation :: !(Maybe KdlSpan), + context :: !Text, + message :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | How one KDL v2 document should be named and annotated in provenance. +data KdlSourceOptions = KdlSourceOptions + { name :: !Text, + path :: !(Maybe FilePath), + annotations :: !(Map Text Text) + } + deriving stock (Generic, Eq) + +type LocationMap = Map [Text] KdlSpan + +-- | Start options for an in-memory KDL document. +kdlSourceOptions :: Text -> KdlSourceOptions +kdlSourceOptions name = KdlSourceOptions {name, path = Nothing, annotations = Map.empty} + +-- | Attach a real or logical path to an in-memory KDL document. +withKdlSourcePath :: FilePath -> KdlSourceOptions -> KdlSourceOptions +withKdlSourcePath path options = options & #path .~ Just path + +-- | Add trusted, secret-safe origin metadata. +annotateKdlSourceOptions :: Map Text Text -> KdlSourceOptions -> KdlSourceOptions +annotateKdlSourceOptions annotations options = options & #annotations %~ (annotations <>) + +-- | Attach a trusted Kubernetes reference for a mounted KDL file. +-- +-- This performs no cluster lookup. Setting sensitivity remains the sole redaction policy. +fromKubernetesMountedFile :: KubernetesRef -> KdlSourceOptions -> KdlSourceOptions +fromKubernetesMountedFile reference = + annotateKdlSourceOptions (kubernetesAnnotations reference) + +-- | Return the stable source name. +kdlSourceName :: KdlSourceOptions -> Text +kdlSourceName options = options ^. #name + +-- | Return the optional file path. +kdlSourcePath :: KdlSourceOptions -> Maybe FilePath +kdlSourcePath options = options ^. #path + +-- | Return caller-supplied, secret-safe annotations. +kdlSourceAnnotations :: KdlSourceOptions -> Map Text Text +kdlSourceAnnotations options = options ^. #annotations + +-- | Return an error's stable category. +kdlErrorCategory :: KdlSourceError -> KdlErrorCategory +kdlErrorCategory problem = problem ^. #category + +-- | Return the source name associated with an error. +kdlErrorName :: KdlSourceError -> Text +kdlErrorName problem = problem ^. #name + +-- | Return the file path associated with an error, when known. +kdlErrorPath :: KdlSourceError -> Maybe FilePath +kdlErrorPath problem = problem ^. #path + +-- | Return the smallest trustworthy primary span for an error. +kdlErrorSpan :: KdlSourceError -> Maybe KdlSpan +kdlErrorSpan problem = problem ^. #location + +-- | Return a second trustworthy span for a collision, when available. +kdlErrorRelatedSpan :: KdlSourceError -> Maybe KdlSpan +kdlErrorRelatedSpan problem = problem ^. #relatedLocation + +-- | Return the structural path associated with an error. +kdlErrorContext :: KdlSourceError -> Text +kdlErrorContext problem = problem ^. #context + +-- | Return a concise message that never includes a raw scalar or source excerpt. +kdlErrorMessage :: KdlSourceError -> Text +kdlErrorMessage problem = problem ^. #message + +-- | Return a span's one-based start line. +kdlSpanLine :: KdlSpan -> Int +kdlSpanLine value = value ^. #line + +-- | Return a span's one-based start column. +kdlSpanColumn :: KdlSpan -> Int +kdlSpanColumn value = value ^. #column + +-- | Return a span's one-based inclusive end line. +kdlSpanEndLine :: KdlSpan -> Int +kdlSpanEndLine value = value ^. #endLine + +-- | Return a span's one-based inclusive end column. +kdlSpanEndColumn :: KdlSpan -> Int +kdlSpanEndColumn value = value ^. #endColumn + +-- | Decode one KDL v2 document into a Settei file source. +-- +-- Type annotations, non-finite numbers, duplicate properties, invalid key segments, and +-- ambiguous mixtures fail explicitly. The parser's rendered source excerpt is discarded +-- on syntax failure so structured errors remain safe before setting sensitivity is known. +decodeKdlSource :: KdlSourceOptions -> Text -> Either (NonEmpty KdlSourceError) Source +decodeKdlSource options input = + first NonEmpty.singleton $ do + document <- first (syntaxError options) (KDLParser.parseWith (parseConfig options) input) + (root, locations) <- translateDocument options document + pure + ( annotateSourceAt + (spanAnnotationsFor locations) + ( locateSource + (sourceLocationFor options locations) + ( annotateSource + (Map.singleton "kdl.version" "2" <> options ^. #annotations) + (source (options ^. #name) (FileSource "KDL v2") 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. +readKdlSource :: KdlSourceOptions -> FilePath -> IO (Either (NonEmpty KdlSourceError) Source) +readKdlSource options filePath = do + let fileOptions = withKdlSourcePath filePath options + contents <- try @IOException (TextIO.readFile filePath) + pure $ case contents of + Left exception -> + Left + ( NonEmpty.singleton + ( kdlError + fileOptions + KdlIoError + Nothing + Nothing + [] + (Text.pack (displayException exception)) + ) + ) + Right input -> decodeKdlSource fileOptions input + +parseConfig :: KdlSourceOptions -> KDLParser.ParseConfig +parseConfig options = + KDLParser.ParseConfig + { KDLParser.filepath = maybe "" id (options ^. #path), + KDLParser.includeSpans = True + } + +syntaxError :: KdlSourceOptions -> Text -> KdlSourceError +syntaxError options rendered = + kdlError + options + KdlSyntaxError + (parseErrorLocation rendered) + Nothing + [] + "invalid KDL v2 syntax" + +parseErrorLocation :: Text -> Maybe KdlSpan +parseErrorLocation rendered = do + header <- listToMaybe (Text.lines rendered) + case reverse (filter (not . Text.null) (Text.splitOn ":" header)) of + columnText : lineText : _ -> do + line <- parsePositiveInt lineText + column <- parsePositiveInt columnText + pure KdlSpan {line, column, endLine = line, endColumn = column} + _ -> Nothing + +parsePositiveInt :: Text -> Maybe Int +parsePositiveInt value = case TextRead.decimal value of + Right (number, rest) + | number > 0 && Text.null rest -> Just number + _ -> Nothing + +translateDocument :: KdlSourceOptions -> KDL.Document -> Either KdlSourceError (RawValue, LocationMap) +translateDocument options document = + translateNodeList options [] (nodeListNodes document) + +translateNodeList :: + KdlSourceOptions -> + [Text] -> + [KDL.Node] -> + Either KdlSourceError (RawValue, LocationMap) +translateNodeList options prefix nodes = do + groups <- groupNodes options prefix nodes + translated <- traverse (translateGroup options prefix) (Map.toAscList groups) + pure + ( RawObject (Map.fromList [(name, value) | (name, value, _) <- translated]), + mconcat [locations | (_, _, locations) <- translated] + ) + +groupNodes :: + KdlSourceOptions -> + [Text] -> + [KDL.Node] -> + Either KdlSourceError (Map Text [KDL.Node]) +groupNodes options prefix = foldM addNode Map.empty + where + addNode groups node = do + name <- validateIdentifier options prefix (nodeName node) + pure + ( groups + & at name + %~ \existing -> Just (maybe [node] (<> [node]) existing) + ) + +translateGroup :: + KdlSourceOptions -> + [Text] -> + (Text, [KDL.Node]) -> + Either KdlSourceError (Text, RawValue, LocationMap) +translateGroup options prefix (name, nodes) = case nodes of + [] -> pure (name, RawNull, Map.empty) + [node] -> do + (value, locations) <- translateNode options (prefix <> [name]) node + pure (name, value, locations) + firstNode : remainingNodes -> do + values <- traverse (fmap fst . translateNode options (prefix <> [name])) (firstNode : remainingNodes) + let groupSpan = coverSpans (nodeLocation firstNode :| fmap nodeLocation remainingNodes) + pure + ( name, + RawArray values, + Map.singleton (prefix <> [name]) groupSpan + ) + +translateNode :: + KdlSourceOptions -> + [Text] -> + KDL.Node -> + Either KdlSourceError (RawValue, LocationMap) +translateNode options path node = do + rejectNodeAnnotation options path node + properties <- validateProperties options path (nodeEntries node) + let arguments = [entryValue entry | entry <- nodeEntries node, entryName entry == Nothing] + childNodes = nodeChildren node + when (not (null arguments) && (not (Map.null properties) || not (null childNodes))) $ + Left + ( kdlError + options + KdlMixedNodeShape + (Just (nodeLocation node)) + Nothing + path + "positional arguments cannot be combined with properties or children" + ) + case arguments of + firstArgument : remainingArguments -> do + values <- traverse (translateValue options path) (firstArgument : remainingArguments) + let value = case values of + [single] -> single + many -> RawArray many + location = coverSpans (valueLocation firstArgument :| fmap valueLocation remainingArguments) + pure (value, Map.singleton path location) + [] + | Map.null properties && null childNodes -> + pure (RawNull, Map.singleton path (nodeLocation node)) + | otherwise -> translateObjectNode options path node properties childNodes + +translateObjectNode :: + KdlSourceOptions -> + [Text] -> + KDL.Node -> + Map Text KDL.Entry -> + [KDL.Node] -> + Either KdlSourceError (RawValue, LocationMap) +translateObjectNode options path node properties childNodes = do + childGroups <- groupNodes options path childNodes + case firstCollision properties childGroups of + Just (name, property, child) -> + Left + ( kdlError + options + KdlPropertyChildCollision + (entryNameLocation property) + (Just (identifierLocation (nodeName child))) + (path <> [name]) + "a property and child use the same field name" + ) + Nothing -> pure () + (propertyObject, propertyLocations) <- translateProperties options path properties + (childValue, childLocations) <- translateNodeList options path childNodes + let childObject = case childValue of + RawObject object -> object + _ -> Map.empty + pure + ( RawObject (propertyObject <> childObject), + Map.singleton path (nodeLocation node) <> propertyLocations <> childLocations + ) + +translateProperties :: + KdlSourceOptions -> + [Text] -> + Map Text KDL.Entry -> + Either KdlSourceError (Map Text RawValue, LocationMap) +translateProperties options path properties = do + translated <- + traverse + ( \(name, entry) -> do + value <- translateValue options (path <> [name]) (entryValue entry) + pure (name, value, Map.singleton (path <> [name]) (valueLocation (entryValue entry))) + ) + (Map.toAscList properties) + pure + ( Map.fromList [(name, value) | (name, value, _) <- translated], + mconcat [locations | (_, _, locations) <- translated] + ) + +validateProperties :: + KdlSourceOptions -> + [Text] -> + [KDL.Entry] -> + Either KdlSourceError (Map Text KDL.Entry) +validateProperties options path = foldM addProperty Map.empty + where + addProperty properties entry = case entryName entry of + Nothing -> pure properties + Just identifier -> do + name <- validateIdentifier options path identifier + case properties ^. at name of + Just earlier -> + Left + ( kdlError + options + KdlDuplicateProperty + (Just (identifierLocation identifier)) + (entryNameLocation earlier) + (path <> [name]) + "duplicate property" + ) + Nothing -> pure (properties & at name ?~ entry) + +firstCollision :: Map Text KDL.Entry -> Map Text [KDL.Node] -> Maybe (Text, KDL.Entry, KDL.Node) +firstCollision properties childGroups = + listToMaybe + [ (name, property, child) + | name <- Map.keys properties, + Just property <- [properties ^. at name], + Just (child : _) <- [childGroups ^. at name] + ] + +translateValue :: KdlSourceOptions -> [Text] -> KDL.Value -> Either KdlSourceError RawValue +translateValue options path value = do + rejectValueAnnotation options path value + case valueData value of + KDL.String text -> Right (RawText text) + KDL.Number number -> Right (RawNumber (toRational number)) + KDL.Bool boolean -> Right (RawBool boolean) + KDL.Null -> Right RawNull + KDL.Inf -> unsupported + KDL.NegInf -> unsupported + KDL.NaN -> unsupported + where + unsupported = + Left + ( kdlError + options + KdlUnsupportedValue + (Just (valueLocation value)) + Nothing + path + "non-finite KDL numbers are not supported" + ) + +rejectNodeAnnotation :: KdlSourceOptions -> [Text] -> KDL.Node -> Either KdlSourceError () +rejectNodeAnnotation options path node = case nodeAnnotation node of + Nothing -> Right () + Just annotation -> + Left + ( kdlError + options + KdlUnsupportedAnnotation + (Just (annotationLocation annotation)) + Nothing + path + "KDL node type annotations are not supported" + ) + +rejectValueAnnotation :: KdlSourceOptions -> [Text] -> KDL.Value -> Either KdlSourceError () +rejectValueAnnotation options path value = case valueAnnotation value of + Nothing -> Right () + Just annotation -> + Left + ( kdlError + options + KdlUnsupportedAnnotation + (Just (annotationLocation annotation)) + Nothing + path + "KDL value type annotations are not supported" + ) + +validateIdentifier :: + KdlSourceOptions -> + [Text] -> + KDL.Identifier -> + Either KdlSourceError Text +validateIdentifier options prefix identifier = + case mkKey (NonEmpty.singleton name) of + Right _ -> Right name + Left _ -> + Left + ( kdlError + options + KdlInvalidName + (Just (identifierLocation identifier)) + Nothing + (prefix <> [name]) + "KDL names must be non-empty Settei key segments without dots" + ) + where + name = identifierText identifier + +kdlError :: + KdlSourceOptions -> + KdlErrorCategory -> + Maybe KdlSpan -> + Maybe KdlSpan -> + [Text] -> + Text -> + KdlSourceError +kdlError options category location relatedLocation context message = + KdlSourceError + { category, + name = options ^. #name, + path = options ^. #path, + location, + relatedLocation, + context = renderContext context, + message + } + +renderContext :: [Text] -> Text +renderContext = foldl (\rendered segment -> rendered <> "." <> segment) "$" + +sourceLocationFor :: KdlSourceOptions -> LocationMap -> Key -> Maybe SourceLocation +sourceLocationFor options locations key = do + found <- locations ^. at (NonEmpty.toList (keySegments key)) + pure + SourceLocation + { path = maybe (options ^. #name) Text.pack (options ^. #path), + line = Just (found ^. #line), + column = Just (found ^. #column) + } + +spanAnnotationsFor :: LocationMap -> Key -> Map Text Text +spanAnnotationsFor locations key = case locations ^. at (NonEmpty.toList (keySegments key)) of + Nothing -> Map.empty + Just found -> + Map.fromList + [ ("kdl.span.start-line", renderInt (found ^. #line)), + ("kdl.span.start-column", renderInt (found ^. #column)), + ("kdl.span.end-line", renderInt (found ^. #endLine)), + ("kdl.span.end-column", renderInt (found ^. #endColumn)) + ] + +renderInt :: Int -> Text +renderInt = Text.pack . show + +coverSpans :: NonEmpty KdlSpan -> KdlSpan +coverSpans (firstSpan :| remaining) = foldl cover firstSpan remaining + where + cover start finish = + KdlSpan + { line = start ^. #line, + column = start ^. #column, + endLine = finish ^. #endLine, + endColumn = finish ^. #endColumn + } + +nodeListNodes :: KDL.NodeList -> [KDL.Node] +nodeListNodes KDL.NodeList {KDL.nodes = nodes} = nodes + +nodeAnnotation :: KDL.Node -> Maybe KDL.Ann +nodeAnnotation KDL.Node {KDL.ann = annotation} = annotation + +nodeName :: KDL.Node -> KDL.Identifier +nodeName KDL.Node {KDL.name = name} = name + +nodeEntries :: KDL.Node -> [KDL.Entry] +nodeEntries KDL.Node {KDL.entries = entries} = entries + +nodeChildren :: KDL.Node -> [KDL.Node] +nodeChildren KDL.Node {KDL.children = childList} = maybe [] nodeListNodes childList + +nodeLocation :: KDL.Node -> KdlSpan +nodeLocation KDL.Node {KDL.ext = KDL.NodeExtension {KDL.span = location}} = fromKdlSpan location + +entryName :: KDL.Entry -> Maybe KDL.Identifier +entryName KDL.Entry {KDL.name = name} = name + +entryNameLocation :: KDL.Entry -> Maybe KdlSpan +entryNameLocation entry = identifierLocation <$> entryName entry + +entryValue :: KDL.Entry -> KDL.Value +entryValue KDL.Entry {KDL.value = value} = value + +valueAnnotation :: KDL.Value -> Maybe KDL.Ann +valueAnnotation KDL.Value {KDL.ann = annotation} = annotation + +valueData :: KDL.Value -> KDL.ValueData +valueData KDL.Value {KDL.data_ = value} = value + +valueLocation :: KDL.Value -> KdlSpan +valueLocation KDL.Value {KDL.ext = KDL.ValueExtension {KDL.span = location}} = fromKdlSpan location + +annotationLocation :: KDL.Ann -> KdlSpan +annotationLocation KDL.Ann {KDL.ext = KDL.AnnExtension {KDL.span = location}} = fromKdlSpan location + +identifierText :: KDL.Identifier -> Text +identifierText KDL.Identifier {KDL.value = value} = value + +identifierLocation :: KDL.Identifier -> KdlSpan +identifierLocation KDL.Identifier {KDL.ext = KDL.IdentifierExtension {KDL.span = location}} = fromKdlSpan location + +fromKdlSpan :: KDL.Span -> KdlSpan +fromKdlSpan + KDL.Span + { KDL.startLine = line, + KDL.startCol = column, + KDL.endLine = endLine, + KDL.endCol = endColumn + } = KdlSpan {line, column, endLine, endColumn} 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.KdlCharacterizationTest qualified as CharacterizationTest +import Settei.KdlTest qualified as KdlTest +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain (testGroup "settei-kdl" [CharacterizationTest.tests, KdlTest.tests]) diff --git a/test/Settei/KdlCharacterizationTest.hs b/test/Settei/KdlCharacterizationTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/KdlCharacterizationTest.hs @@ -0,0 +1,81 @@ +module Settei.KdlCharacterizationTest (tests) where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Ratio ((%)) +import Data.Text qualified as Text +import Settei +import Settei.Kdl +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Kdl.Characterization" + [ testCase "KDL v2 strings, booleans, null, and exact numbers remain typed" $ do + input <- expectSource "text \"hello\"\nraw #\"raw text\"#\nflag #true\nempty #null\ninteger 12345678901234567890\ndecimal 1.25\n" + expectValue "text" input (RawText "hello") + expectValue "raw" input (RawText "raw text") + expectValue "flag" input (RawBool True) + expectValue "empty" input RawNull + expectValue "integer" input (RawNumber 12345678901234567890) + expectValue "decimal" input (RawNumber (5 % 4)), + testCase "duplicate properties remain visible and fail at the second span" $ do + problem <- expectError "service port=8000 port=9000\n" + kdlErrorCategory problem @?= KdlDuplicateProperty + fmap kdlSpanColumn (kdlErrorSpan problem) @?= Just 19 + fmap kdlSpanColumn (kdlErrorRelatedSpan problem) @?= Just 9, + testCase "node and value type annotations fail explicitly" $ do + nodeProblem <- expectError "(record)service { port 8080 }\n" + kdlErrorCategory nodeProblem @?= KdlUnsupportedAnnotation + valueProblem <- expectError "service (port)8080\n" + kdlErrorCategory valueProblem @?= KdlUnsupportedAnnotation, + testCase "non-finite KDL numbers fail instead of being coerced" $ do + problem <- expectError "ratio #inf\n" + kdlErrorCategory problem @?= KdlUnsupportedValue, + testCase "comments and slash-dash remove values before translation" $ do + input <- expectSource "// comment\nfoo 1 /- 2 3\n/- omitted 4\nbar 5\n" + expectValue "foo" input (RawArray [RawNumber 1, RawNumber 3]) + expectValue "bar" input (RawNumber 5) + assertBool + "slash-dashed node remained in the document" + (case lookupSource (validKey "omitted") input of Right Nothing -> True; _ -> False), + testCase "quoted empty and dotted names reach explicit Settei validation" $ do + emptyProblem <- expectError "\"\" 1\n" + kdlErrorCategory emptyProblem @?= KdlInvalidName + dottedProblem <- expectError "\"service.port\" 8080\n" + kdlErrorCategory dottedProblem @?= KdlInvalidName, + testCase "syntax failures keep only a one-based header location" $ do + let sentinel = "never-retain-this-kdl-secret" + input = "password \"" <> sentinel <> "\"\nservice { broken [\n" + problem <- expectError input + kdlErrorCategory problem @?= KdlSyntaxError + assertBool "syntax error omitted its line" (maybe False ((> 0) . kdlSpanLine) (kdlErrorSpan problem)) + assertBool "syntax error omitted its column" (maybe False ((> 0) . kdlSpanColumn) (kdlErrorSpan problem)) + assertBool + "syntax error retained the source excerpt" + (not (sentinel `Text.isInfixOf` Text.pack (show problem))) + ] + +sourceOptions :: KdlSourceOptions +sourceOptions = withKdlSourcePath "characterization.kdl" (kdlSourceOptions "characterization") + +expectSource :: Text -> IO Source +expectSource input = case decodeKdlSource sourceOptions input of + Left errors -> fail (show errors) + Right sourceValue -> pure sourceValue + +expectError :: Text -> IO KdlSourceError +expectError input = case decodeKdlSource sourceOptions input of + Left errors -> pure (NonEmpty.head errors) + Right _ -> fail "expected KDL decoding to fail" + +expectValue :: Text -> Source -> RawValue -> IO () +expectValue keyText input expected = case lookupSource (validKey keyText) input of + Right (Just found) -> assertBool "unexpected KDL raw value" (candidateValue found == expected) + _ -> fail "expected KDL candidate" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/Settei/KdlTest.hs b/test/Settei/KdlTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/KdlTest.hs @@ -0,0 +1,181 @@ +module Settei.KdlTest (tests) where + +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 Paths_settei_kdl qualified as Paths +import Settei +import Settei.Kdl +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Kdl" + [ testCase "nested nodes become segmented keys with exact spans" $ do + input <- expectSource "runtime {\n environment \"production\"\n}\nservice {\n http {\n host \"0.0.0.0\"\n port 8080\n }\n}\n" + host <- expectCandidate serviceHttpHost input + assertBool "host did not remain text" (candidateValue host == RawText "0.0.0.0") + host ^? to candidateOrigin . #location . _Just . #path @?= Just "application.kdl" + host ^? to candidateOrigin . #location . _Just . #line @?= Just (Just 6) + host ^? to candidateOrigin . #location . _Just . #column @?= Just (Just 10) + host ^. to candidateOrigin . #annotations . at "kdl.span.end-column" @?= Just "18" + host ^. to candidateOrigin . #annotations . at "kdl.version" @?= Just "2", + testCase "positional arguments become scalars or arrays and empty nodes become null" $ do + input <- expectSource "tag \"api\"\ntags \"api\" \"public\"\noptional\n" + expectRaw tagKey input (RawText "api") + expectRaw tagsKey input (RawArray [RawText "api", RawText "public"]) + expectRaw optionalKey input RawNull, + testCase "properties and non-colliding children form one object" $ do + input <- expectSource "service host=\"api.internal\" {\n port 8080\n}\n" + expectRaw serviceHost input (RawText "api.internal") + expectRaw servicePort input (RawNumber 8080), + testCase "repeated siblings preserve document order as an array" $ do + input <- + expectSource + "backend {\n host \"one.internal\"\n port 8080\n}\nbackend {\n host \"two.internal\"\n port 8081\n}\n" + expectRaw + backendKey + input + ( RawArray + [ RawObject (Map.fromList [("host", RawText "one.internal"), ("port", RawNumber 8080)]), + RawObject (Map.fromList [("host", RawText "two.internal"), ("port", RawNumber 8081)]) + ] + ) + backend <- expectCandidate backendKey input + backend ^? to candidateOrigin . #location . _Just . #line @?= Just (Just 1) + backend ^. to candidateOrigin . #annotations . at "kdl.span.end-line" @?= Just "8", + testCase "arguments mixed with children fail at the node span" $ do + problem <- expectError "service \"api\" { port 8080 }\n" + kdlErrorCategory problem @?= KdlMixedNodeShape + fmap kdlSpanColumn (kdlErrorSpan problem) @?= Just 1, + testCase "arguments mixed with properties fail at the node span" $ do + problem <- expectError "service \"api\" port=8080\n" + kdlErrorCategory problem @?= KdlMixedNodeShape + fmap kdlSpanColumn (kdlErrorSpan problem) @?= Just 1, + testCase "property-child collisions report both available locations" $ do + problem <- expectError "service port=7000 {\n port 8000\n}\n" + kdlErrorCategory problem @?= KdlPropertyChildCollision + kdlErrorContext problem @?= "$.service.port" + fmap kdlSpanLine (kdlErrorSpan problem) @?= Just 1 + fmap kdlSpanLine (kdlErrorRelatedSpan problem) @?= Just 2, + testCase "higher KDL overrides leaves and replaces arrays through core" $ do + low <- expectNamedSource "low" "service { host \"old.internal\"; port 7000; names \"one\" \"two\"; }\n" + high <- expectNamedSource "high" "service { port 9000; names \"three\" \"four\"; }\n" + result <- + expectResolution + ( resolve + defaultResolveOptions + [low, high] + ((,,) <$> required hostSetting <*> required portSetting <*> required namesSetting) + ) + result ^. #value @?= ("old.internal", 9000, ["three", "four"]) + case result ^. #report . #nodes . at servicePort of + Just node -> do + node ^. #origin . _Just . #name @?= "high" + fmap (^. #name) (node ^. #shadowed) @?= ["low"] + Nothing -> fail "expected resolved KDL port provenance", + testCase "mounted Secret metadata remains visible while its value is redacted" $ do + let reference = kubernetesRef SecretObject (Just "production") "database-config" (Just "config.kdl") + options = fromKubernetesMountedFile reference sourceOptions + input <- expectSourceWith options ("database { password \"" <> 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 "readKdlSource reports IO failures with the requested path" $ do + result <- readKdlSource (kdlSourceOptions "missing") "test/fixtures/does-not-exist.kdl" + case result of + Left errors -> do + let problem = NonEmpty.head errors + kdlErrorCategory problem @?= KdlIoError + kdlErrorPath problem @?= Just "test/fixtures/does-not-exist.kdl" + Right _ -> fail "expected missing KDL file to fail", + testCase "readKdlSource loads a fixture and records its actual path" $ do + fixturePath <- Paths.getDataFileName "test/fixtures/characterization/nested.kdl" + result <- readKdlSource (kdlSourceOptions "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) + ] + +sourceOptions :: KdlSourceOptions +sourceOptions = withKdlSourcePath "application.kdl" (kdlSourceOptions "application") + +expectSource :: Text -> IO Source +expectSource = expectSourceWith sourceOptions + +expectNamedSource :: Text -> Text -> IO Source +expectNamedSource name = + expectSourceWith (withKdlSourcePath (Text.unpack name <> ".kdl") (kdlSourceOptions name)) + +expectSourceWith :: KdlSourceOptions -> Text -> IO Source +expectSourceWith options input = case decodeKdlSource options input of + Left errors -> fail (show errors) + Right sourceValue -> pure sourceValue + +expectError :: Text -> IO KdlSourceError +expectError input = case decodeKdlSource sourceOptions input of + Left errors -> pure (NonEmpty.head errors) + Right _ -> fail "expected KDL decoding to fail" + +expectCandidate :: Key -> Source -> IO Candidate +expectCandidate key input = case lookupSource key input of + Right (Just found) -> pure found + _ -> fail "expected KDL candidate" + +expectRaw :: Key -> Source -> RawValue -> IO () +expectRaw key input expected = do + found <- expectCandidate key input + assertBool "unexpected KDL raw value" (candidateValue found == expected) + +expectResolution :: Either (NonEmpty ConfigError) a -> IO a +expectResolution = \case + Left errors -> fail (Text.unpack (renderErrorsText errors)) + 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, tagKey, tagsKey, optionalKey, serviceHost, servicePort, serviceNames, backendKey, databasePassword :: Key +serviceHttpHost = validKey "service.http.host" +tagKey = validKey "tag" +tagsKey = validKey "tags" +optionalKey = validKey "optional" +serviceHost = validKey "service.host" +servicePort = validKey "service.port" +serviceNames = validKey "service.names" +backendKey = validKey "backend" +databasePassword = validKey "database.password" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +secretSentinel :: Text +secretSentinel = "never-render-this-kdl-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,7 @@ +# KDL characterization fixtures + +These fixtures exercise the canonical KDL v2 subset accepted by `settei-kdl`. They are +package data so file-loading tests do not depend on the developer's working directory. + +`nested.kdl` is the successful nested-object fixture used to prove package-local file +loading and source-path provenance. diff --git a/test/fixtures/characterization/nested.kdl b/test/fixtures/characterization/nested.kdl new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/nested.kdl @@ -0,0 +1,6 @@ +service { + http { + host "fixture.internal" + port 8080 + } +}