diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog for settei-dhall + +## 0.1.0.0 — 2026-07-18 + +- Initial experimental release. +- Add typed Dhall-to-Settei translation with NoImports and LocalImportsWithin policies. +- Retain root and transitive import-closure provenance without claiming unavailable + leaf-level import attribution. 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-dhall.cabal b/settei-dhall.cabal new file mode 100644 --- /dev/null +++ b/settei-dhall.cabal @@ -0,0 +1,99 @@ +cabal-version: 3.8 +name: settei-dhall +version: 0.1.0.0 +synopsis: Dhall sources for Settei +description: + Evaluate typed Dhall expressions into provenance-aware Settei sources with + explicit, enforceable import policies. + +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/*.dhall + test/fixtures/characterization/local/*.dhall + +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.Dhall + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , dhall >=1.42.3 && <1.43 + , dhall-json ==1.7.12 + , directory >=1.3.8 && <1.4 + , filepath >=1.5.4 && <1.6 + , generic-lens >=2.2 && <2.4 + , scientific >=0.3.7 && <0.4 + , settei ==0.1.0.0 + , text >=2.1 && <2.2 + , transformers >=0.6.1 && <0.7 + +test-suite settei-dhall-prototype-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Settei.DhallPrototypeTest + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , dhall >=1.42.3 && <1.43 + , directory >=1.3.8 && <1.4 + , filepath >=1.5.4 && <1.6 + , microlens >=0.4.14 && <0.6 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10.2 && <0.11 + , temporary >=1.3 && <1.4 + , text >=2.1 && <2.2 + , transformers >=0.6.1 && <0.7 + +test-suite settei-dhall-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: ProductionMain.hs + other-modules: + Paths_settei_dhall + Settei.DhallTest + + autogen-modules: Paths_settei_dhall + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , dhall >=1.42.3 && <1.43 + , directory >=1.3.8 && <1.4 + , filepath >=1.5.4 && <1.6 + , generic-lens >=2.2 && <2.4 + , microlens >=0.4.14 && <0.6 + , settei ==0.1.0.0 + , settei-dhall ==0.1.0.0 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10.2 && <0.11 + , temporary >=1.3 && <1.4 + , text >=2.1 && <2.2 + , transformers >=0.6.1 && <0.7 diff --git a/src/Settei/Dhall.hs b/src/Settei/Dhall.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Dhall.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Dhall +-- Description: Typed Dhall sources with enforceable import policies. +module Settei.Dhall + ( DhallErrorCategory (..), + DhallImport, + DhallImportMode (..), + DhallImportPolicy (..), + DhallLoadedSource, + DhallRoot (..), + DhallSourceError, + DhallSourceOptions, + annotateDhallSourceOptions, + dhallErrorCategory, + dhallErrorMessage, + dhallErrorName, + dhallErrorPath, + dhallExpression, + dhallImportMode, + dhallImportPath, + dhallImportSemanticHash, + dhallLoadedImports, + dhallLoadedSource, + dhallSourceAnnotations, + dhallSourceImportPolicy, + dhallSourceName, + dhallSourceOptions, + loadDhallSource, + loadDhallSourceDetailed, + ) +where + +import Control.Exception (AsyncException, IOException, SomeException, fromException, throwIO, try) +import Control.Monad (foldM, unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.State.Strict qualified as State +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as AesonKey +import Data.Aeson.KeyMap qualified as AesonKeyMap +import Data.Bifunctor (first) +import Data.Foldable qualified as Foldable +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.Void (Void) +import Dhall.Core qualified as Dhall +import Dhall.Import qualified as UpstreamImport +import Dhall.JSON qualified as DhallJSON +import Dhall.Parser qualified as DhallParser +import Dhall.TypeCheck qualified as DhallTypeCheck +import Settei +import Settei.Prelude +import System.Directory qualified as Directory +import System.FilePath qualified as FilePath + +-- | Import capabilities available to version-one callers. +-- +-- 'NoImports' rejects every embedded import. 'LocalImportsWithin' accepts only +-- canonical local paths contained by the named directory. Environment, remote, +-- missing, and alternative imports are rejected before upstream evaluation. +data DhallImportPolicy + = NoImports + | LocalImportsWithin !FilePath + deriving stock (Generic, Eq, Show) + +-- | A Dhall root supplied as labeled expression text or a file path. +-- +-- No 'Show' instance is provided because expression text can contain secrets. +data DhallRoot + = DhallExpression + { name :: !Text, + text :: !Text + } + | DhallFile !FilePath + deriving stock (Generic, Eq) + +-- | Construct a labeled in-memory expression without exposing its text through 'Show'. +dhallExpression :: Text -> Text -> DhallRoot +dhallExpression name text = DhallExpression {name, text} + +-- | Source naming, policy, and trusted secret-safe annotations. +data DhallSourceOptions = DhallSourceOptions + { name :: !Text, + importPolicy :: !DhallImportPolicy, + annotations :: !(Map Text Text) + } + deriving stock (Generic, Eq) + +-- | How a local import is interpreted by Dhall. +data DhallImportMode + = DhallCodeImport + | DhallRawTextImport + | DhallRawBytesImport + | DhallLocationImport + deriving stock (Generic, Eq, Ord, Show) + +-- | One substantiated local import in a cache-independent transitive closure. +data DhallImport = DhallImport + { path :: !FilePath, + mode :: !DhallImportMode, + semanticHash :: !(Maybe Text) + } + deriving stock (Generic, Eq, Ord, Show) + +-- | A translated source together with its structured import closure. +data DhallLoadedSource = DhallLoadedSource + { value :: !Source, + imports :: ![DhallImport] + } + deriving stock (Generic) + +-- | Stable phases of Dhall adapter failure. +data DhallErrorCategory + = DhallIoError + | DhallParseError + | DhallImportPolicyError + | DhallImportError + | DhallTypeError + | DhallConversionError + | DhallInvalidKey + | DhallTopLevelType + deriving stock (Generic, Eq, Ord, Show) + +-- | A secret-safe Dhall input failure. +-- +-- The error retains only a stable category, source name, optional safe path, +-- and fixed message. It never retains source text or an upstream exception. +data DhallSourceError = DhallSourceError + { category :: !DhallErrorCategory, + name :: !Text, + path :: !(Maybe FilePath), + message :: !Text + } + deriving stock (Generic, Eq, Show) + +data PreparedRoot = PreparedRoot + { label :: !Text, + baseDirectory :: !FilePath, + filePath :: !(Maybe FilePath), + input :: !Text + } + deriving stock (Generic) + +data PreflightFailure = PreflightFailure + { category :: !DhallErrorCategory, + path :: !(Maybe FilePath), + message :: !Text + } + deriving stock (Generic) + +-- | Construct source options with no annotations. +dhallSourceOptions :: Text -> DhallImportPolicy -> DhallSourceOptions +dhallSourceOptions name importPolicy = + DhallSourceOptions {name, importPolicy, annotations = Map.empty} + +-- | Add trusted, secret-safe annotations. Dhall's reserved provenance keys win collisions. +annotateDhallSourceOptions :: Map Text Text -> DhallSourceOptions -> DhallSourceOptions +annotateDhallSourceOptions annotations options = options & #annotations %~ (annotations <>) + +-- | Return the source's report name. +dhallSourceName :: DhallSourceOptions -> Text +dhallSourceName options = options ^. #name + +-- | Return the enforced import policy. +dhallSourceImportPolicy :: DhallSourceOptions -> DhallImportPolicy +dhallSourceImportPolicy options = options ^. #importPolicy + +-- | Return caller-supplied annotations. +dhallSourceAnnotations :: DhallSourceOptions -> Map Text Text +dhallSourceAnnotations options = options ^. #annotations + +-- | Return a stable error category. +dhallErrorCategory :: DhallSourceError -> DhallErrorCategory +dhallErrorCategory problem = problem ^. #category + +-- | Return the source name associated with an error. +dhallErrorName :: DhallSourceError -> Text +dhallErrorName problem = problem ^. #name + +-- | Return a safe relevant path when one is known. +dhallErrorPath :: DhallSourceError -> Maybe FilePath +dhallErrorPath problem = problem ^. #path + +-- | Return a fixed secret-safe error message. +dhallErrorMessage :: DhallSourceError -> Text +dhallErrorMessage problem = problem ^. #message + +-- | Return a local import's canonical path. +dhallImportPath :: DhallImport -> FilePath +dhallImportPath imported = imported ^. #path + +-- | Return how a local import was interpreted. +dhallImportMode :: DhallImport -> DhallImportMode +dhallImportMode imported = imported ^. #mode + +-- | Return the import's optional semantic integrity hash. +dhallImportSemanticHash :: DhallImport -> Maybe Text +dhallImportSemanticHash imported = imported ^. #semanticHash + +-- | Extract the Settei source from a detailed load result. +dhallLoadedSource :: DhallLoadedSource -> Source +dhallLoadedSource loaded = loaded ^. #value + +-- | Return the sorted, de-duplicated transitive local import closure. +dhallLoadedImports :: DhallLoadedSource -> [DhallImport] +dhallLoadedImports loaded = loaded ^. #imports + +-- | Evaluate one Dhall root into a Settei source. +loadDhallSource :: + DhallSourceOptions -> + DhallRoot -> + IO (Either (NonEmpty DhallSourceError) Source) +loadDhallSource options root = + fmap (fmap dhallLoadedSource) (loadDhallSourceDetailed options root) + +-- | Evaluate one Dhall root and retain its structured local import closure. +-- +-- Evaluation follows the registered @dhall-json@ path: parse, resolve imports, +-- type-check, normalize, convert JSON-compatible values, and translate directly +-- to 'RawValue'. Rendered Dhall or JSON text is never used as an intermediate. +loadDhallSourceDetailed :: + DhallSourceOptions -> + DhallRoot -> + IO (Either (NonEmpty DhallSourceError) DhallLoadedSource) +loadDhallSourceDetailed options root = do + preparedResult <- prepareRoot options root + case preparedResult of + Left problem -> pure (Left (NonEmpty.singleton problem)) + Right prepared -> + case DhallParser.exprFromText (Text.unpack (prepared ^. #label)) (prepared ^. #input) of + Left _ -> pure (failure options DhallParseError (prepared ^. #filePath) "invalid Dhall syntax") + Right expression -> do + resolvedResult <- resolveExpression options prepared expression + pure $ do + (resolved, imports) <- resolvedResult + case DhallTypeCheck.typeOf resolved of + Left _ -> failure options DhallTypeError (prepared ^. #filePath) "Dhall expression does not type-check" + Right _ -> pure () + jsonValue <- firstOne options (prepared ^. #filePath) (convertExpression resolved) + rawValue <- firstOne options (prepared ^. #filePath) (translateRoot jsonValue) + let provenance = provenanceAnnotations options prepared imports + sourceValue = + locateSource + (const (Just (SourceLocation (prepared ^. #label) Nothing Nothing))) + ( annotateSource + (provenance <> options ^. #annotations) + (source (options ^. #name) (FileSource "Dhall") rawValue) + ) + pure DhallLoadedSource {value = sourceValue, imports} + +prepareRoot :: DhallSourceOptions -> DhallRoot -> IO (Either DhallSourceError PreparedRoot) +prepareRoot options = \case + DhallExpression name text -> do + baseResult <- policyBaseDirectory options + pure + ( fmap + (\baseDirectory -> PreparedRoot {label = name, baseDirectory, filePath = Nothing, input = text}) + baseResult + ) + DhallFile requestedPath -> do + absoluteResult <- try @IOException (Directory.makeAbsolute requestedPath >>= Directory.canonicalizePath) + case absoluteResult of + Left _ -> pure (Left (singleError options DhallIoError (Just requestedPath) "cannot resolve Dhall root path")) + Right canonicalPath -> do + permitted <- rootPermitted options canonicalPath + if not permitted + then pure (Left (singleError options DhallImportPolicyError (Just canonicalPath) "Dhall root is outside the allowed directory")) + else do + inputResult <- try @IOException (TextIO.readFile canonicalPath) + pure $ case inputResult of + Left _ -> Left (singleError options DhallIoError (Just canonicalPath) "cannot read Dhall root file") + Right input -> + Right + PreparedRoot + { label = Text.pack canonicalPath, + baseDirectory = FilePath.takeDirectory canonicalPath, + filePath = Just canonicalPath, + input + } + +policyBaseDirectory :: DhallSourceOptions -> IO (Either DhallSourceError FilePath) +policyBaseDirectory options = case options ^. #importPolicy of + NoImports -> Right <$> Directory.getCurrentDirectory + LocalImportsWithin requestedRoot -> do + result <- try @IOException (Directory.makeAbsolute requestedRoot >>= Directory.canonicalizePath) + pure $ case result of + Left _ -> Left (singleError options DhallImportPolicyError (Just requestedRoot) "cannot resolve allowed import directory") + Right canonicalRoot -> Right canonicalRoot + +rootPermitted :: DhallSourceOptions -> FilePath -> IO Bool +rootPermitted options canonicalPath = case options ^. #importPolicy of + NoImports -> pure True + LocalImportsWithin requestedRoot -> do + rootResult <- try @IOException (Directory.makeAbsolute requestedRoot >>= Directory.canonicalizePath) + pure (either (const False) (`isWithin` canonicalPath) rootResult) + +resolveExpression :: + DhallSourceOptions -> + PreparedRoot -> + Dhall.Expr DhallParser.Src Dhall.Import -> + IO (Either (NonEmpty DhallSourceError) (Dhall.Expr DhallParser.Src Void, [DhallImport])) +resolveExpression options prepared expression = case options ^. #importPolicy of + NoImports -> do + result <- try @UpstreamImport.ImportResolutionDisabled (UpstreamImport.assertNoImports expression) + pure $ case result of + Left _ -> failure options DhallImportPolicyError (prepared ^. #filePath) "imports are disabled" + Right resolved -> Right (resolved, []) + LocalImportsWithin requestedRoot -> do + canonicalRootResult <- try @IOException (Directory.makeAbsolute requestedRoot >>= Directory.canonicalizePath) + case canonicalRootResult of + Left _ -> pure (failure options DhallImportPolicyError (Just requestedRoot) "cannot resolve allowed import directory") + Right canonicalRoot -> do + preflightResult <- preflightLocal canonicalRoot (prepared ^. #baseDirectory) expression + case preflightResult of + Left problem -> + pure + ( failure + options + (problem ^. #category) + (problem ^. #path) + (problem ^. #message) + ) + Right imports -> do + let status = + (UpstreamImport.emptyStatus (prepared ^. #baseDirectory)) + { UpstreamImport._semanticCacheMode = UpstreamImport.IgnoreSemanticCache + } + loaded <- try @SomeException (State.runStateT (UpstreamImport.loadWith expression) status) + case loaded of + Left exception -> case fromException exception :: Maybe AsyncException of + Just asynchronous -> throwIO asynchronous + Nothing -> pure (failure options DhallImportError (prepared ^. #filePath) "Dhall import resolution failed") + Right (resolved, _) -> pure (Right (resolved, imports)) + +preflightLocal :: + FilePath -> + FilePath -> + Dhall.Expr DhallParser.Src Dhall.Import -> + IO (Either PreflightFailure [DhallImport]) +preflightLocal canonicalRoot baseDirectory expression = + fmap + (fmap (Set.toAscList . snd)) + (runExceptT (visitExpression canonicalRoot Set.empty Set.empty baseDirectory expression)) + +visitExpression :: + FilePath -> + Set FilePath -> + Set DhallImport -> + FilePath -> + Dhall.Expr DhallParser.Src Dhall.Import -> + ExceptT PreflightFailure IO (Set FilePath, Set DhallImport) +visitExpression allowedRoot visited observed baseDirectory expression = do + when (hasImportAlternative expression) (throwPreflight DhallImportPolicyError Nothing "import alternatives are not allowed") + foldM + (visitImport allowedRoot baseDirectory) + (visited, observed) + (Foldable.toList expression) + +visitImport :: + FilePath -> + FilePath -> + (Set FilePath, Set DhallImport) -> + Dhall.Import -> + ExceptT PreflightFailure IO (Set FilePath, Set DhallImport) +visitImport allowedRoot baseDirectory (visited, observed) importValue = + case Dhall.importType (Dhall.importHashed importValue) of + Dhall.Local {} -> do + requestedResult <- liftIO (try @IOException (resolveLocalPath baseDirectory importValue)) + requestedPath <- case requestedResult of + Left _ -> throwPreflight DhallImportError Nothing "cannot resolve local import path" + Right value -> pure value + exists <- liftIO (Directory.doesFileExist requestedPath) + unless exists (throwPreflight DhallImportError (Just requestedPath) "local import does not exist") + canonicalResult <- liftIO (try @IOException (Directory.canonicalizePath requestedPath)) + canonical <- case canonicalResult of + Left _ -> throwPreflight DhallImportError (Just requestedPath) "cannot canonicalize local import" + Right value -> pure value + unless (isWithin allowedRoot canonical) (throwPreflight DhallImportPolicyError (Just canonical) "local import is outside the allowed directory") + let descriptor = + DhallImport + { path = canonical, + mode = importMode (Dhall.importMode importValue), + semanticHash = fmap (Text.pack . show) (Dhall.hash (Dhall.importHashed importValue)) + } + observedWithImport = Set.insert descriptor observed + if Dhall.importMode importValue /= Dhall.Code || Set.member canonical visited + then pure (visited, observedWithImport) + else do + inputResult <- liftIO (try @IOException (TextIO.readFile canonical)) + input <- case inputResult of + Left _ -> throwPreflight DhallImportError (Just canonical) "cannot read local import" + Right value -> pure value + imported <- case DhallParser.exprFromText canonical input of + Left _ -> throwPreflight DhallParseError (Just canonical) "invalid syntax in local import" + Right value -> pure value + visitExpression + allowedRoot + (Set.insert canonical visited) + observedWithImport + (FilePath.takeDirectory canonical) + imported + Dhall.Env _ -> throwPreflight DhallImportPolicyError Nothing "environment imports are not allowed" + Dhall.Remote _ -> throwPreflight DhallImportPolicyError Nothing "remote imports are not allowed" + Dhall.Missing -> throwPreflight DhallImportPolicyError Nothing "missing imports are not allowed" + +resolveLocalPath :: FilePath -> Dhall.Import -> IO FilePath +resolveLocalPath baseDirectory importValue = do + canonicalBase <- Directory.canonicalizePath baseDirectory + let status = UpstreamImport.emptyStatus canonicalBase + parent = NonEmpty.head (UpstreamImport._stack status) + chained <- State.evalStateT (UpstreamImport.chainImport parent importValue) status + case Dhall.importType (Dhall.importHashed (UpstreamImport.chainedImport chained)) of + Dhall.Local prefix file -> UpstreamImport.localToPath prefix file + _ -> error "local import did not remain local after chaining" + +hasImportAlternative :: Dhall.Expr s a -> Bool +hasImportAlternative Dhall.ImportAlt {} = True +hasImportAlternative expression = anyOf Dhall.subExpressions hasImportAlternative expression + +importMode :: Dhall.ImportMode -> DhallImportMode +importMode = \case + Dhall.Code -> DhallCodeImport + Dhall.RawText -> DhallRawTextImport + Dhall.RawBytes -> DhallRawBytesImport + Dhall.Location -> DhallLocationImport + +convertExpression :: Dhall.Expr s Void -> Either (DhallErrorCategory, Text) Aeson.Value +convertExpression resolved = do + finite <- + first + (const (DhallConversionError, "Dhall value contains a non-finite Double")) + ( DhallJSON.handleSpecialDoubles + DhallJSON.ForbidWithinJSON + (DhallJSON.convertToHomogeneousMaps DhallJSON.NoConversion resolved) + ) + first + (const (DhallConversionError, "Dhall value is not JSON-compatible")) + (DhallJSON.dhallToJSON finite) + +translateRoot :: Aeson.Value -> Either (DhallErrorCategory, Text) RawValue +translateRoot value = case value of + Aeson.Object _ -> translateValue [] value + _ -> Left (DhallTopLevelType, "top-level Dhall value must be a record") + +translateValue :: [Text] -> Aeson.Value -> Either (DhallErrorCategory, Text) RawValue +translateValue path = \case + Aeson.Null -> Right RawNull + Aeson.String value -> Right (RawText value) + Aeson.Bool value -> Right (RawBool value) + Aeson.Number value -> Right (RawNumber (toRational value)) + Aeson.Array values -> RawArray <$> traverse (translateValue path) (Foldable.toList values) + Aeson.Object object -> do + fields <- traverse translateField (AesonKeyMap.toAscList object) + Right (RawObject (Map.fromAscList fields)) + where + translateField (rawKey, value) = do + let key = AesonKey.toText rawKey + case mkKey (key NonEmpty.:| []) of + Left _ -> Left (DhallInvalidKey, "Dhall record field is not a valid Settei key segment") + Right _ -> pure () + translated <- translateValue (path <> [key]) value + pure (key, translated) + +provenanceAnnotations :: DhallSourceOptions -> PreparedRoot -> [DhallImport] -> Map Text Text +provenanceAnnotations options prepared imports = + Map.fromList + [ ("dhall.root", prepared ^. #label), + ("dhall.import-policy", policyName (options ^. #importPolicy)), + ("dhall.import-count", Text.pack (show (length imports))), + ("dhall.provenance-precision", "root-and-import-closure; leaf-level import attribution unavailable after normalization") + ] + <> Map.fromList (concatMap importAnnotations (zip [0 :: Int ..] imports)) + +importAnnotations :: (Int, DhallImport) -> [(Text, Text)] +importAnnotations (position, imported) = + let prefix = "dhall.import." <> Text.pack (show position) <> "." + in [ (prefix <> "kind", "local"), + (prefix <> "path", Text.pack (imported ^. #path)), + (prefix <> "mode", importModeName (imported ^. #mode)) + ] + <> maybe [] (pure . (prefix <> "semantic-hash",)) (imported ^. #semanticHash) + +policyName :: DhallImportPolicy -> Text +policyName NoImports = "no-imports" +policyName (LocalImportsWithin _) = "local-imports-within" + +importModeName :: DhallImportMode -> Text +importModeName DhallCodeImport = "code" +importModeName DhallRawTextImport = "raw-text" +importModeName DhallRawBytesImport = "raw-bytes" +importModeName DhallLocationImport = "location" + +throwPreflight :: DhallErrorCategory -> Maybe FilePath -> Text -> ExceptT PreflightFailure IO a +throwPreflight category path message = throwE PreflightFailure {category, path, message} + +isWithin :: FilePath -> FilePath -> Bool +isWithin root pathCandidate = + let relative = FilePath.makeRelative root pathCandidate + in not (FilePath.isAbsolute relative) + && case FilePath.splitDirectories relative of + ".." : _ -> False + _ -> True + +failure :: DhallSourceOptions -> DhallErrorCategory -> Maybe FilePath -> Text -> Either (NonEmpty DhallSourceError) a +failure options category path message = Left (NonEmpty.singleton (singleError options category path message)) + +singleError :: DhallSourceOptions -> DhallErrorCategory -> Maybe FilePath -> Text -> DhallSourceError +singleError options category path message = + DhallSourceError {category, name = options ^. #name, path, message} + +firstOne :: + DhallSourceOptions -> + Maybe FilePath -> + Either (DhallErrorCategory, Text) a -> + Either (NonEmpty DhallSourceError) a +firstOne options path = first (\(category, message) -> NonEmpty.singleton (singleError options category path message)) 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.DhallPrototypeTest qualified as DhallPrototypeTest +import Test.Tasty (defaultMain) + +main :: IO () +main = defaultMain DhallPrototypeTest.tests diff --git a/test/ProductionMain.hs b/test/ProductionMain.hs new file mode 100644 --- /dev/null +++ b/test/ProductionMain.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Control.Exception (bracket_) +import Settei.DhallTest qualified as DhallTest +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (defaultMain) + +main :: IO () +main = + withSystemTempDirectory "settei-dhall-cache" $ \cacheDirectory -> do + previous <- lookupEnv "XDG_CACHE_HOME" + bracket_ + (setEnv "XDG_CACHE_HOME" cacheDirectory) + (maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") previous) + (defaultMain DhallTest.tests) diff --git a/test/Settei/DhallPrototypeTest.hs b/test/Settei/DhallPrototypeTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/DhallPrototypeTest.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.DhallPrototypeTest (tests) where + +import Control.Exception (SomeException, try) +import Control.Monad (foldM, unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.State.Strict qualified as State +import Data.Foldable qualified as Foldable +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Dhall.Core qualified as Dhall +import Dhall.Import qualified as DhallImport +import Dhall.Parser qualified as DhallParser +import Lens.Micro qualified as Lens +import System.Directory qualified as Directory +import System.FilePath qualified as FilePath +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +data PrototypeFailure + = ImportAlternative + | DisallowedImport + | OutsideRoot + | MissingLocalFile + | InvalidImportedFile + deriving stock (Eq, Show) + +data ObservedLocalImport = ObservedLocalImport + { path :: !FilePath, + mode :: !Dhall.ImportMode, + semanticHash :: !(Maybe Text) + } + deriving stock (Eq, Ord, Show) + +tests :: TestTree +tests = + testGroup + "Dhall import-policy prototype" + [ testCase "NoImports rejects before loading" $ do + expression <- parse "no-imports" "./not-created.dhall" + rejected <- try @SomeException (DhallImport.assertNoImports expression) + assertBool "assertNoImports unexpectedly accepted an import" (either (const True) (const False) rejected), + testCase "local-only records a transitive import closure" $ + withSystemTempDirectory "settei-dhall-prototype" $ \root -> do + let first = root FilePath. "first.dhall" + second = root FilePath. "second.dhall" + TextIO.writeFile first "./second.dhall" + TextIO.writeFile second "{ service = { port = 8080 } }" + expression <- parse "root" "./first.dhall" + result <- preflightLocal root root expression + case result of + Left problem -> assertFailure (show problem) + Right imports -> fmap FilePath.takeFileName imports @?= ["first.dhall", "second.dhall"], + testCase "local-only rejects a parent escape" $ + withSystemTempDirectory "settei-dhall-prototype" $ \workspace -> do + let allowed = workspace FilePath. "allowed" + outside = workspace FilePath. "outside.dhall" + Directory.createDirectory allowed + TextIO.writeFile outside "{ escaped = True }" + expression <- parse "root" "../outside.dhall" + result <- preflightLocal allowed allowed expression + result @?= Left OutsideRoot, + testCase "local-only rejects a symlink escape" $ + withSystemTempDirectory "settei-dhall-prototype" $ \workspace -> do + let allowed = workspace FilePath. "allowed" + outside = workspace FilePath. "outside.dhall" + link = allowed FilePath. "linked.dhall" + Directory.createDirectory allowed + TextIO.writeFile outside "{ escaped = True }" + Directory.createFileLink outside link + expression <- parse "root" "./linked.dhall" + result <- preflightLocal allowed allowed expression + result @?= Left OutsideRoot, + testCase "local-only rejects environment and remote capabilities without using them" $ do + environment <- parse "environment" "env:SETTEI_DHALL_PROTOTYPE_SECRET" + remote <- parse "remote" "https://example.com/config.dhall" + withSystemTempDirectory "settei-dhall-prototype" $ \root -> do + preflightLocal root root environment >>= (@?= Left DisallowedImport) + preflightLocal root root remote >>= (@?= Left DisallowedImport), + testCase "local-only rejects missing and alternative imports" $ + withSystemTempDirectory "settei-dhall-prototype" $ \root -> do + missing <- parse "missing" "missing" + alternative <- parse "alternative" "./one.dhall ? ./two.dhall" + preflightLocal root root missing >>= (@?= Left DisallowedImport) + preflightLocal root root alternative >>= (@?= Left ImportAlternative), + testCase "local-only retains a semantic integrity hash structurally" $ + withSystemTempDirectory "settei-dhall-prototype" $ \root -> do + let imported = root FilePath. "hashed.dhall" + TextIO.writeFile imported "{ value = True }" + expression <- + parse + "hashed" + "./hashed.dhall sha256:0000000000000000000000000000000000000000000000000000000000000000" + result <- preflightLocalDetailed root root expression + case result of + Left problem -> assertFailure (show problem) + Right [observed] -> assertBool "semantic hash was discarded" (semanticHash observed /= Nothing) + Right observed -> assertFailure ("unexpected import closure: " <> show observed) + ] + +parse :: FilePath -> Text -> IO (Dhall.Expr DhallParser.Src Dhall.Import) +parse label input = case DhallParser.exprFromText label input of + Left problem -> assertFailure (show problem) >> error "unreachable" + Right expression -> pure expression + +preflightLocal :: FilePath -> FilePath -> Dhall.Expr DhallParser.Src Dhall.Import -> IO (Either PrototypeFailure [FilePath]) +preflightLocal allowedRoot baseDirectory expression = + fmap (fmap (fmap path)) (preflightLocalDetailed allowedRoot baseDirectory expression) + +preflightLocalDetailed :: + FilePath -> + FilePath -> + Dhall.Expr DhallParser.Src Dhall.Import -> + IO (Either PrototypeFailure [ObservedLocalImport]) +preflightLocalDetailed allowedRoot baseDirectory expression = do + canonicalRoot <- Directory.canonicalizePath allowedRoot + fmap + (fmap (Set.toAscList . snd)) + (runExceptT (visitExpression canonicalRoot Set.empty Set.empty baseDirectory expression)) + +visitExpression :: + FilePath -> + Set FilePath -> + Set ObservedLocalImport -> + FilePath -> + Dhall.Expr DhallParser.Src Dhall.Import -> + ExceptT PrototypeFailure IO (Set FilePath, Set ObservedLocalImport) +visitExpression allowedRoot visited observed baseDirectory expression = do + when (hasImportAlternative expression) (throwE ImportAlternative) + foldM + (visitImport allowedRoot baseDirectory) + (visited, observed) + (Foldable.toList expression) + +visitImport :: + FilePath -> + FilePath -> + (Set FilePath, Set ObservedLocalImport) -> + Dhall.Import -> + ExceptT PrototypeFailure IO (Set FilePath, Set ObservedLocalImport) +visitImport allowedRoot baseDirectory (visited, observed) importValue = + case Dhall.importType (Dhall.importHashed importValue) of + Dhall.Local {} -> do + candidate <- liftIO (resolveLocalPath baseDirectory importValue) + exists <- liftIO (Directory.doesFileExist candidate) + unless exists (throwE MissingLocalFile) + canonical <- liftIO (Directory.canonicalizePath candidate) + unless (isWithin allowedRoot canonical) (throwE OutsideRoot) + let descriptor = + ObservedLocalImport + { path = canonical, + mode = Dhall.importMode importValue, + semanticHash = fmap (Text.pack . show) (Dhall.hash (Dhall.importHashed importValue)) + } + observedWithImport = Set.insert descriptor observed + if Dhall.importMode importValue /= Dhall.Code || Set.member canonical visited + then pure (visited, observedWithImport) + else do + input <- liftIO (TextIO.readFile canonical) + imported <- case DhallParser.exprFromText canonical input of + Left _ -> throwE InvalidImportedFile + Right value -> pure value + visitExpression + allowedRoot + (Set.insert canonical visited) + observedWithImport + (FilePath.takeDirectory canonical) + imported + _ -> throwE DisallowedImport + +resolveLocalPath :: FilePath -> Dhall.Import -> IO FilePath +resolveLocalPath baseDirectory importValue = do + canonicalBase <- Directory.canonicalizePath baseDirectory + let status = DhallImport.emptyStatus canonicalBase + parent = NonEmpty.head (DhallImport._stack status) + chained <- State.evalStateT (DhallImport.chainImport parent importValue) status + case Dhall.importType (Dhall.importHashed (DhallImport.chainedImport chained)) of + Dhall.Local prefix file -> DhallImport.localToPath prefix file + _ -> error "local import did not remain local after chaining" + +hasImportAlternative :: Dhall.Expr s a -> Bool +hasImportAlternative Dhall.ImportAlt {} = True +hasImportAlternative expression = Lens.anyOf Dhall.subExpressions hasImportAlternative expression + +isWithin :: FilePath -> FilePath -> Bool +isWithin root candidate = + let relative = FilePath.makeRelative root candidate + in not (FilePath.isAbsolute relative) + && case FilePath.splitDirectories relative of + ".." : _ -> False + _ -> True diff --git a/test/Settei/DhallTest.hs b/test/Settei/DhallTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/DhallTest.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.DhallTest (tests) where + +import Data.Foldable (traverse_) +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 Data.Text.IO qualified as TextIO +import Dhall.Core qualified as DhallCore +import Dhall.Import qualified as DhallImport +import Dhall.Parser qualified as DhallParser +import Paths_settei_dhall qualified as Paths +import Settei +import Settei.Dhall +import Settei.Prelude +import System.Directory qualified as Directory +import System.FilePath qualified as FilePath +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Dhall" + [ testCase "a typed record becomes a nested source" $ do + loaded <- + expectDetailed + noImportOptions + ( dhallExpression + "direct record" + "{ service = { host = \"api.internal\", port = 8080, enabled = True, tags = [ \"api\", \"public\" ] } }" + ) + dhallLoadedImports loaded @?= [] + host <- expectCandidate serviceHost (dhallLoadedSource loaded) + assertRaw (RawText "api.internal") (candidateValue host) + port <- expectCandidate servicePort (dhallLoadedSource loaded) + assertRaw (RawNumber 8080) (candidateValue port) + enabled <- expectCandidate serviceEnabled (dhallLoadedSource loaded) + assertRaw (RawBool True) (candidateValue enabled) + tags <- expectCandidate serviceTags (dhallLoadedSource loaded) + assertRaw (RawArray [RawText "api", RawText "public"]) (candidateValue tags), + testCase "optional values, unions, and association lists retain the official JSON shape" $ do + input <- + expectSource + noImportOptions + ( dhallExpression + "conversion shapes" + ( Text.unlines + [ "{ present = Some \"yes\"", + ", absent = None Text", + ", choice = < Left : Text | Right : Natural >.Left \"selected\"", + ", entries = [ { mapKey = \"one\", mapValue = 1 }, { mapKey = \"two\", mapValue = 2 } ]", + "}" + ] + ) + ) + candidateValue <$> expectCandidate presentKey input >>= assertRaw (RawText "yes") + candidateValue <$> expectCandidate absentKey input >>= assertRaw RawNull + candidateValue <$> expectCandidate choiceKey input >>= assertRaw (RawText "selected") + entries <- candidateValue <$> expectCandidate entriesKey input + assertBool "association list was silently collapsed into an object" (isTwoEntryArray entries), + testCase "a constructor applies schema defaults before conversion" $ do + input <- + expectSource + noImportOptions + ( dhallExpression + "schema evolution" + ( Text.unlines + [ "let Input = { name : Text }", + "let Output = { name : Text, description : Optional Text, tags : List Text }", + "let default : { description : Optional Text, tags : List Text } =", + " { description = None Text, tags = [] : List Text }", + "let make = \\(input : Input) -> default // input", + "let value : Output = make { name = \"my-service\" }", + "in { service = value }" + ] + ) + ) + candidateValue <$> expectCandidate serviceName input >>= assertRaw (RawText "my-service") + candidateValue <$> expectCandidate serviceDescription input >>= assertRaw RawNull + candidateValue <$> expectCandidate serviceTags input >>= assertRaw (RawArray []), + testCase "NoImports rejects before opening a missing import" $ do + problem <- expectError noImportOptions (dhallExpression "disabled import" "./never-opened.dhall") + dhallErrorCategory problem @?= DhallImportPolicyError + dhallErrorMessage problem @?= "imports are disabled", + testCase "local-only records a transitive closure and honest provenance" $ + withSystemTempDirectory "settei-dhall-local" $ \root -> do + let application = root FilePath. "application.dhall" + service = root FilePath. "service.dhall" + database = root FilePath. "database.dhall" + TextIO.writeFile application "let Service = ./service.dhall in { service = Service }" + TextIO.writeFile service "let Database = ./database.dhall in { host = \"api.internal\", port = 8080, database = Database }" + TextIO.writeFile database "{ host = \"db.internal\" }" + loaded <- expectDetailed (localOptions root) (DhallFile application) + fmap (FilePath.takeFileName . dhallImportPath) (dhallLoadedImports loaded) + @?= ["database.dhall", "service.dhall"] + let input = dhallLoadedSource loaded + port <- expectCandidate servicePort input + port ^? to candidateOrigin . #location . _Just . #path + @?= Just (Text.pack application) + let annotations = port ^. to candidateOrigin . #annotations + annotations ^. at "dhall.import-count" @?= Just "2" + annotations ^. at "dhall.provenance-precision" + @?= Just "root-and-import-closure; leaf-level import attribution unavailable after normalization" + result <- expectResolution (resolve defaultResolveOptions [input] (required portSetting)) + let rendered = renderResolutionText (result ^. #report) + assertBool "text report omitted Dhall root" (Text.pack application `Text.isInfixOf` rendered) + assertBool + "text report fabricated leaf attribution" + ("leaf-level import attribution unavailable after normalization" `Text.isInfixOf` rendered), + testCase "the packaged local-import fixture survives source distribution" $ do + application <- Paths.getDataFileName "test/fixtures/characterization/local/application.dhall" + loaded <- expectDetailed (localOptions (FilePath.takeDirectory application)) (DhallFile application) + fmap (FilePath.takeFileName . dhallImportPath) (dhallLoadedImports loaded) + @?= ["database.dhall", "service.dhall"], + testCase "local-only rejects parent and symlink escapes" $ + withSystemTempDirectory "settei-dhall-escape" $ \workspace -> do + let allowed = workspace FilePath. "allowed" + externalFile = workspace FilePath. "outside.dhall" + link = allowed FilePath. "linked.dhall" + Directory.createDirectory allowed + TextIO.writeFile externalFile "{ escaped = True }" + parentProblem <- expectError (localOptions allowed) (dhallExpression "parent escape" "../outside.dhall") + dhallErrorCategory parentProblem @?= DhallImportPolicyError + Directory.createFileLink externalFile link + symlinkProblem <- expectError (localOptions allowed) (dhallExpression "symlink escape" "./linked.dhall") + dhallErrorCategory symlinkProblem @?= DhallImportPolicyError, + testCase "local-only rejects environment, remote, missing, and alternative imports" $ + withSystemTempDirectory "settei-dhall-capabilities" $ \root -> do + let options = localOptions root + environment <- expectError options (dhallExpression "environment" "env:SETTEI_DHALL_TEST_SECRET") + remote <- expectError options (dhallExpression "remote" "https://example.com/config.dhall") + missing <- expectError options (dhallExpression "missing" "missing") + alternative <- expectError options (dhallExpression "alternative" "./one.dhall ? ./two.dhall") + fmap dhallErrorCategory [environment, remote, missing, alternative] + @?= replicate 4 DhallImportPolicyError, + testCase "local-only reports an import cycle without recursing forever" $ + withSystemTempDirectory "settei-dhall-cycle" $ \root -> do + TextIO.writeFile (root FilePath. "a.dhall") "./b.dhall" + TextIO.writeFile (root FilePath. "b.dhall") "./a.dhall" + problem <- expectError (localOptions root) (dhallExpression "cycle" "./a.dhall") + dhallErrorCategory problem @?= DhallImportError, + testCase "semantic hashes and raw-text modes remain structural provenance" $ + withSystemTempDirectory "settei-dhall-hash" $ \root -> do + let hashed = root FilePath. "hashed.dhall" + message = root FilePath. "message.txt" + hashedExpression = "{ value = True }" + TextIO.writeFile hashed hashedExpression + TextIO.writeFile message "hello from raw text" + semanticHash <- hashExpression hashedExpression + loaded <- + expectDetailed + (localOptions root) + ( dhallExpression + "hashed and raw text" + ( "{ hashed = ./hashed.dhall " + <> semanticHash + <> ", message = ./message.txt as Text }" + ) + ) + let imports = dhallLoadedImports loaded + length imports @?= 2 + assertBool "semantic hash was discarded" (any ((/= Nothing) . dhallImportSemanticHash) imports) + assertBool "raw-text mode was discarded" (any ((== DhallRawTextImport) . dhallImportMode) imports) + candidateValue <$> expectCandidate messageKey (dhallLoadedSource loaded) + >>= assertRaw (RawText "hello from raw text"), + testCase "a changed local import is not hidden by upstream cache state" $ + withSystemTempDirectory "settei-dhall-cache" $ \root -> do + let imported = root FilePath. "value.dhall" + rootExpression = dhallExpression "cache repeat" "{ service = ./value.dhall }" + options = localOptions root + TextIO.writeFile imported "{ port = 8000 }" + firstSource <- expectSource options rootExpression + candidateValue <$> expectCandidate servicePort firstSource >>= assertRaw (RawNumber 8000) + TextIO.writeFile imported "{ port = 9000 }" + secondSource <- expectSource options rootExpression + candidateValue <$> expectCandidate servicePort secondSource >>= assertRaw (RawNumber 9000), + testCase "higher Dhall sources override leaves through the core resolver" $ do + low <- expectSource (dhallSourceOptions "low" NoImports) (dhallExpression "low" "{ service = { host = \"old.internal\", port = 7000 } }") + high <- expectSource (dhallSourceOptions "high" NoImports) (dhallExpression "high" "{ service = { port = 9000 } }") + result <- + expectResolution + ( resolve + defaultResolveOptions + [low, high] + ((,) <$> required hostSetting <*> required portSetting) + ) + result ^. #value @?= ("old.internal", 9000), + testCase "stable error phases and Show output never retain source secrets" $ do + let cases = + [ (dhallExpression "parse" ("{ password = \"" <> secretSentinel <> "\", broken ="), DhallParseError), + (dhallExpression "type" ("{ password = \"" <> secretSentinel <> "\", broken = if True then True else 1 }"), DhallTypeError), + (dhallExpression "conversion" ("{ password = \"" <> secretSentinel <> "\", bytes = 0x\"00\" }"), DhallConversionError), + (dhallExpression "key" ("{ `service.port` = 8080, password = \"" <> secretSentinel <> "\" }"), DhallInvalidKey), + (dhallExpression "top-level" "[ 1, 2 ]", DhallTopLevelType) + ] + traverse_ + ( \(root, expectedCategory) -> do + problem <- expectError noImportOptions root + dhallErrorCategory problem @?= expectedCategory + assertBool + "secret reached structured Dhall error" + (not (secretSentinel `Text.isInfixOf` Text.pack (show problem))) + ) + cases, + testCase "resolved secret values are redacted while Dhall provenance remains" $ do + input <- + expectSource + noImportOptions + (dhallExpression "secret root" ("{ database = { password = \"" <> secretSentinel <> "\" } }")) + result <- expectResolution (resolve defaultResolveOptions [input] (required passwordSetting)) + result ^. #value @?= secretSentinel + let textOutput = renderResolutionText (result ^. #report) + jsonOutput = renderResolutionJson (result ^. #report) + assertBool "secret reached text report" (not (secretSentinel `Text.isInfixOf` textOutput)) + assertBool "secret reached JSON report" (not (secretSentinel `Text.isInfixOf` jsonOutput)) + assertBool "Dhall provenance was redacted with the value" ("secret root" `Text.isInfixOf` textOutput) + ] + +noImportOptions :: DhallSourceOptions +noImportOptions = dhallSourceOptions "application Dhall" NoImports + +localOptions :: FilePath -> DhallSourceOptions +localOptions root = dhallSourceOptions "application Dhall" (LocalImportsWithin root) + +expectDetailed :: DhallSourceOptions -> DhallRoot -> IO DhallLoadedSource +expectDetailed options root = do + result <- loadDhallSourceDetailed options root + case result of + Left problems -> assertFailure (show problems) >> error "unreachable" + Right value -> pure value + +expectSource :: DhallSourceOptions -> DhallRoot -> IO Source +expectSource options root = dhallLoadedSource <$> expectDetailed options root + +expectError :: DhallSourceOptions -> DhallRoot -> IO DhallSourceError +expectError options root = do + result <- loadDhallSource options root + case result of + Left problems -> pure (NonEmpty.head problems) + Right _ -> assertFailure "expected Dhall loading to fail" >> error "unreachable" + +expectCandidate :: Key -> Source -> IO Candidate +expectCandidate key input = case lookupSource key input of + Right (Just found) -> pure found + _ -> assertFailure "expected Dhall candidate" >> error "unreachable" + +expectResolution :: Either (NonEmpty ConfigError) a -> IO a +expectResolution = \case + Left _ -> assertFailure "expected Dhall resolution to succeed" >> error "unreachable" + Right value -> pure value + +hashExpression :: Text -> IO Text +hashExpression input = case DhallParser.exprFromText "hash fixture" input of + Left problem -> assertFailure (show problem) >> error "unreachable" + Right parsed -> do + resolved <- DhallImport.assertNoImports parsed + pure (DhallImport.hashExpressionToCode (DhallCore.normalize (DhallCore.denote resolved))) + +isTwoEntryArray :: RawValue -> Bool +isTwoEntryArray = \case + RawArray [RawObject firstEntry, RawObject secondEntry] -> + Map.lookup "mapKey" firstEntry == Just (RawText "one") + && Map.lookup "mapValue" firstEntry == Just (RawNumber 1) + && Map.lookup "mapKey" secondEntry == Just (RawText "two") + && Map.lookup "mapValue" secondEntry == Just (RawNumber 2) + _ -> False + +assertRaw :: RawValue -> RawValue -> IO () +assertRaw expected actual = assertBool "raw Dhall value did not match" (actual == expected) + +hostSetting :: Setting Text +hostSetting = publicSetting serviceHost "Service host" textDecoder + +portSetting :: Setting Int +portSetting = publicSetting servicePort "Service port" boundedIntegralDecoder + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +serviceHost, servicePort, serviceEnabled, serviceTags, serviceName, serviceDescription, presentKey, absentKey, choiceKey, entriesKey, messageKey, databasePassword :: Key +serviceHost = validKey "service.host" +servicePort = validKey "service.port" +serviceEnabled = validKey "service.enabled" +serviceTags = validKey "service.tags" +serviceName = validKey "service.name" +serviceDescription = validKey "service.description" +presentKey = validKey "present" +absentKey = validKey "absent" +choiceKey = validKey "choice" +entriesKey = validKey "entries" +messageKey = validKey "message" +databasePassword = validKey "database.password" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +secretSentinel :: Text +secretSentinel = "never-render-this-dhall-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,8 @@ +# Dhall characterization fixtures + +These files preserve the input boundaries tested by `Settei.DhallTest` and shipped in the +`settei-dhall` source distribution. `direct.dhall`, `nested.dhall`, `list.dhall`, +`optional.dhall`, and `schema-default.dhall` cover JSON-compatible normalized values. +`parse-error.dhall`, `type-error.dhall`, and `unsupported-bytes.dhall` cover stable error +phases. The `local/` chain proves transitive import collection; path, symlink, cycle, and +cache cases use temporary directories because they require filesystem topology. diff --git a/test/fixtures/characterization/direct.dhall b/test/fixtures/characterization/direct.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/direct.dhall @@ -0,0 +1,1 @@ +{ host = "api.internal", port = 8080, enabled = True } diff --git a/test/fixtures/characterization/list.dhall b/test/fixtures/characterization/list.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/list.dhall @@ -0,0 +1,1 @@ +{ tags = [ "api", "public" ] } diff --git a/test/fixtures/characterization/local/application.dhall b/test/fixtures/characterization/local/application.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/local/application.dhall @@ -0,0 +1,3 @@ +let Service = ./service.dhall + +in { service = Service } diff --git a/test/fixtures/characterization/local/database.dhall b/test/fixtures/characterization/local/database.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/local/database.dhall @@ -0,0 +1,1 @@ +{ host = "db.internal" } diff --git a/test/fixtures/characterization/local/service.dhall b/test/fixtures/characterization/local/service.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/local/service.dhall @@ -0,0 +1,3 @@ +let Database = ./database.dhall + +in { host = "api.internal", port = 8080, database = Database } diff --git a/test/fixtures/characterization/nested.dhall b/test/fixtures/characterization/nested.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/nested.dhall @@ -0,0 +1,1 @@ +{ service = { http = { host = "api.internal", port = 8080 } } } diff --git a/test/fixtures/characterization/optional.dhall b/test/fixtures/characterization/optional.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/optional.dhall @@ -0,0 +1,1 @@ +{ present = Some "configured", absent = None Text } diff --git a/test/fixtures/characterization/parse-error.dhall b/test/fixtures/characterization/parse-error.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/parse-error.dhall @@ -0,0 +1,1 @@ +{ service = { port = diff --git a/test/fixtures/characterization/schema-default.dhall b/test/fixtures/characterization/schema-default.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/schema-default.dhall @@ -0,0 +1,12 @@ +let Input = { name : Text } + +let Output = { name : Text, description : Optional Text, tags : List Text } + +let default : { description : Optional Text, tags : List Text } = + { description = None Text, tags = [] : List Text } + +let make = \(input : Input) -> default // input + +let value : Output = make { name = "my-service" } + +in { service = value } diff --git a/test/fixtures/characterization/type-error.dhall b/test/fixtures/characterization/type-error.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/type-error.dhall @@ -0,0 +1,1 @@ +{ service = { port = if True then True else 8080 } } diff --git a/test/fixtures/characterization/unsupported-bytes.dhall b/test/fixtures/characterization/unsupported-bytes.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/characterization/unsupported-bytes.dhall @@ -0,0 +1,1 @@ +{ bytes = 0x"00" }