hinagata-core (empty) → 0.1.0.0

raw patch · 15 files changed

+2034/−0 lines, 15 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, cryptohash-sha256, directory, filepath, hinagata-core, lens, settei, settei-env, temporary, text, time, transformers, unix, yaml

Files

• CHANGELOG.md +20/−0
• LICENSE +28/−0
• hinagata-core.cabal +81/−0
• src/Hinagata/Config.hs +308/−0
• src/Hinagata/Connection.hs +130/−0
• src/Hinagata/Error.hs +20/−0
• src/Hinagata/Fixture/Bundle.hs +403/−0
• src/Hinagata/Fixture/Graph.hs +63/−0
• src/Hinagata/Fixture/Manifest.hs +116/−0
• src/Hinagata/Fixture/SqlPolicy.hs +128/−0
• src/Hinagata/Fixture/Types.hs +53/−0
• src/Hinagata/Hook/Revision.hs +152/−0
• src/Hinagata/Prelude.hs +24/−0
• src/Hinagata/Types.hs +104/−0
• test/Main.hs +404/−0

@@ -0,0 +1,20 @@+# Changelog++## 0.1.0.0 - 2026-10-18++### New Features++- Compile ordered SQL and CSV fixtures with dependency resolution, manifest validation, path containment, and deterministic plan identities.+- Capture verified fixture bundles with SHA-256 digests, bounded streaming, and SQL size and transaction-policy checks.+- Expose validated identifiers, explicit connection descriptions, structured errors, and typed configuration declarations with secret redaction.+- Derive baseline hook revisions from declared executable bytes, files, and non-secret values.++### Bug Fixes++- Reject transaction-control statements using all PostgreSQL whitespace characters.+- Prevent ambient host-address settings from overriding explicit connection targets.+- Close interrupted capture resources and remove incomplete bundles on cancellation.++### Other Changes++- Include package changelog and repository metadata, and bound the test suite's dependency on hinagata-core to the shared release series.

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2026, Hinagata contributors++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.

@@ -0,0 +1,81 @@+cabal-version: 3.12+name: hinagata-core+version: 0.1.0.0+synopsis: Pure fixture plans and configuration for Hinagata+description: Deterministic fixture planning for PostgreSQL test databases.+category: Testing+license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: nadeem@gmail.com+homepage: https://github.com/shinzui/hinagata+bug-reports: https://github.com/shinzui/hinagata/issues+extra-doc-files: CHANGELOG.md+build-type: Simple++common common+  default-language: GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    OverloadedLabels+    OverloadedStrings++  ghc-options: -Wall++library+  import: common+  hs-source-dirs: src+  exposed-modules:+    Hinagata.Config+    Hinagata.Connection+    Hinagata.Error+    Hinagata.Fixture.Bundle+    Hinagata.Fixture.Graph+    Hinagata.Fixture.Manifest+    Hinagata.Fixture.SqlPolicy+    Hinagata.Fixture.Types+    Hinagata.Hook.Revision+    Hinagata.Prelude+    Hinagata.Types++  build-depends:+    aeson >=2.2 && <2.4,+    base >=4.21 && <5,+    bytestring >=0.12 && <0.14,+    containers >=0.7 && <0.9,+    cryptohash-sha256 >=0.11.102.1 && <0.12,+    directory >=1.3 && <1.5,+    filepath >=1.5 && <1.7,+    lens >=5.3 && <5.4,+    settei >=0.2 && <0.3,+    settei-env >=0.2 && <0.3,+    temporary >=1.3 && <1.4,+    text >=2.1 && <2.3,+    time >=1.14 && <1.16,+    transformers >=0.6 && <0.8,+    unix >=2.8 && <2.9,+    yaml >=0.11.11.2 && <0.12,++test-suite hinagata-core-test+  import: common+  ghc-options: -rtsopts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base >=4.21 && <5,+    bytestring >=0.12 && <0.14,+    directory >=1.3 && <1.5,+    filepath >=1.5 && <1.7,+    hinagata-core ^>=0.1.0.0,+    settei >=0.2 && <0.3,+    settei-env >=0.2 && <0.3,+    temporary >=1.3 && <1.4,+    text >=2.1 && <2.3,+    unix >=2.8 && <2.9,++source-repository head+  type: git+  location: https://github.com/shinzui/hinagata.git+  subdir: hinagata-core

@@ -0,0 +1,308 @@+-- | Pure, inspectable Settei declarations for Hinagata's shared settings.+-- Sources are supplied explicitly by the caller; this module performs no IO.+module Hinagata.Config+  ( HinagataConfig (..),+    EndpointConfig (..),+    AccessConfig (..),+    DatabaseGrant (..),+    SchemaPrivilege (..),+    SchemaGrant (..),+    RoleSetting (..),+    CloneStrategy (..),+    accessTarget,+    hinagataConfig,+    hinagataEnvironmentBindings,+  )+where++import Data.Text qualified as Text+import Hinagata.Connection+import Hinagata.Prelude+import Hinagata.Types+import Settei qualified+import Settei.Env qualified as Env+import System.FilePath (isAbsolute)++-- | Connection transport shared by the three independently declared roles.+data EndpointConfig = EndpointConfig+  { host :: !Host,+    port :: !Port+  }+  deriving stock (Eq, Show)++-- | One explicitly selected role and database. Passwords remain secret-safe.+data AccessConfig = AccessConfig+  { user :: !Text,+    database :: !DatabaseName,+    password :: !(Maybe Secret)+  }+  deriving stock (Eq)++instance Show AccessConfig where+  show AccessConfig {user, database} =+    "AccessConfig {user = " ++ show user ++ ", database = " ++ show database ++ ", password = <redacted>}"++-- | The only database-level privileges that the lifecycle layer may apply.+data DatabaseGrant = GrantConnect | GrantCreate | GrantTemporary+  deriving stock (Eq, Ord, Show)++data SchemaPrivilege = SchemaUsage | SchemaCreate+  deriving stock (Eq, Ord, Show)++data SchemaGrant = SchemaGrant+  { schema :: !SqlIdentifier,+    privilege :: !SchemaPrivilege+  }+  deriving stock (Eq, Show)++-- | A declared, non-secret database-level role setting. Its value is+-- configuration, never SQL text. Credential values belong in access targets.+data RoleSetting = RoleSetting+  { name :: !SqlIdentifier,+    value :: !Text+  }+  deriving stock (Eq, Show)++data CloneStrategy = WalLog | FileCopy+  deriving stock (Eq, Ord, Show)++-- | All limits are local to one suite-scoped manager.+data HinagataConfig = HinagataConfig+  { endpoint :: !EndpointConfig,+    project :: !ProjectId,+    fixtureRoot :: !FilePath,+    bundleRoot :: !FilePath,+    maintenanceDatabase :: !DatabaseName,+    maintenanceSchema :: !SqlIdentifier,+    administration :: !AccessConfig,+    setup :: !AccessConfig,+    application :: !AccessConfig,+    setupGrants :: ![DatabaseGrant],+    applicationGrants :: ![DatabaseGrant],+    setupSchemaGrants :: ![SchemaGrant],+    applicationSchemaGrants :: ![SchemaGrant],+    setupSettings :: ![RoleSetting],+    applicationSettings :: ![RoleSetting],+    cloneStrategy :: !CloneStrategy,+    acquisitionDeadlineMs :: !Positive,+    setupDeadlineMs :: !Positive,+    setupWorkers :: !Positive,+    activeLeases :: !Positive,+    pendingRequests :: !Positive,+    chunkSize :: !Positive,+    sqlSizeLimit :: !Positive+  }+  deriving stock (Eq, Show)++-- | Recheck the target invariant when turning a resolved access description into+-- a libpq target. The resolver's user decoder already guarantees this succeeds.+accessTarget :: EndpointConfig -> AccessConfig -> Either Text ConnectionTarget+accessTarget EndpointConfig {host, port} AccessConfig {user, database, password} =+  mkConnectionTarget host port user database password++hinagataConfig :: Settei.Config HinagataConfig+hinagataConfig =+  HinagataConfig+    <$> endpointConfig+    <*> required "project.id" "Project identity used in owned database names" projectDecoder+    <*> required "fixture.root" "Absolute fixture source directory" directoryDecoder+    <*> required "bundle.root" "Absolute private bundle cache directory" directoryDecoder+    <*> required "maintenance.database" "Existing maintenance database" databaseDecoder+    <*> defaulted "maintenance.schema" "Maintenance catalog schema" identifierDecoder "maintenance-schema" "Use a dedicated catalog schema" (knownIdentifier "hinagata")+    <*> accessConfig "administration"+    <*> accessConfig "setup"+    <*> accessConfig "application"+    <*> defaulted "setup.grants" "Database grants for setup role" grantsDecoder "setup-grants" "Allow setup migration and fixture creation" [GrantConnect, GrantCreate, GrantTemporary]+    <*> defaulted "application.grants" "Database grants for application role" grantsDecoder "application-grants" "Application connects without schema creation" [GrantConnect]+    <*> defaulted "setup.schema_grants" "Schema grants for setup role" schemaGrantsDecoder "setup-schema-grants" "Permit migrations in public" [SchemaGrant (knownIdentifier "public") SchemaUsage, SchemaGrant (knownIdentifier "public") SchemaCreate]+    <*> defaulted "application.schema_grants" "Schema grants for application role" schemaGrantsDecoder "application-schema-grants" "Permit application access to public" [SchemaGrant (knownIdentifier "public") SchemaUsage]+    <*> defaulted "setup.settings" "Database-level setup role settings" settingsDecoder "setup-settings" "No extra role settings" []+    <*> defaulted "application.settings" "Database-level application role settings" settingsDecoder "application-settings" "No extra role settings" []+    <*> defaulted "clone.strategy" "PostgreSQL clone strategy" (Settei.enumDecoder [("WAL_LOG", WalLog), ("FILE_COPY", FileCopy)]) "clone-strategy" "WAL_LOG is the portable default" WalLog+    <*> positiveDefault "limits.acquisition_deadline_ms" "Acquisition deadline in milliseconds" 30000+    <*> positiveDefault "limits.setup_deadline_ms" "Setup deadline in milliseconds" 300000+    <*> positiveDefault "limits.setup_workers" "Manager-local concurrent setup workers" 2+    <*> positiveDefault "limits.active_leases" "Manager-local active leases" 8+    <*> positiveDefault "limits.pending_requests" "Manager-local queued acquisition requests" 32+    <*> positiveDefault "limits.chunk_size" "CSV transfer chunk bytes" 65536+    <*> positiveDefault "limits.sql_size_limit" "Maximum SQL step bytes" 1048576++endpointConfig :: Settei.Config EndpointConfig+endpointConfig =+  EndpointConfig+    <$> required "endpoint.host" "Absolute socket directory or TCP hostname" hostDecoder+    <*> required "endpoint.port" "PostgreSQL listener port" portDecoder++accessConfig :: Text -> Settei.Config AccessConfig+accessConfig prefix =+  AccessConfig+    <$> required (prefix <> ".user") "Explicit database role" userDecoder+    <*> required (prefix <> ".database") "Explicit database for this role" databaseDecoder+    <*> Settei.optional (Settei.secretSetting (key (prefix <> ".password")) "Optional role password" secretDecoder)++-- | Explicit bindings only. Invalid static names or key collisions are returned+-- to the caller and can be forced in startup tests before reading the environment.+hinagataEnvironmentBindings :: Either (NonEmpty Env.EnvError) Env.Bindings+hinagataEnvironmentBindings =+  Env.bindings+    [ Env.binding (Env.EnvName ("HINAGATA_" <> Text.toUpper (Text.replace "." "_" name))) (key name)+    | name <- settingNames+    ]++settingNames :: [Text]+settingNames =+  [ "endpoint.host",+    "endpoint.port",+    "project.id",+    "fixture.root",+    "bundle.root",+    "maintenance.database",+    "maintenance.schema",+    "administration.user",+    "administration.database",+    "administration.password",+    "setup.user",+    "setup.database",+    "setup.password",+    "application.user",+    "application.database",+    "application.password",+    "setup.grants",+    "application.grants",+    "setup.schema_grants",+    "application.schema_grants",+    "setup.settings",+    "application.settings",+    "clone.strategy",+    "limits.acquisition_deadline_ms",+    "limits.setup_deadline_ms",+    "limits.setup_workers",+    "limits.active_leases",+    "limits.pending_requests",+    "limits.chunk_size",+    "limits.sql_size_limit"+  ]++required :: Text -> Text -> Settei.Decoder a -> Settei.Config a+required name description valueDecoder = Settei.required (Settei.publicSetting (key name) description valueDecoder)++defaulted :: (Show a) => Text -> Text -> Settei.Decoder a -> Text -> Text -> a -> Settei.Config a+defaulted name description valueDecoder rule explanation value =+  Settei.withDefault+    (Settei.publicShowSetting (key name) description valueDecoder)+    (Settei.constantDefault (Settei.RuleName rule) explanation value)++positiveDefault :: Text -> Text -> Int -> Settei.Config Positive+positiveDefault name description value =+  defaulted name description (positiveDecoder name) (name <> "-default") "Manager-local operational default" (knownPositive value)++key :: Text -> Settei.Key+key name = case Settei.parseKey name of+  Right result -> result+  Left problem -> error ("Invalid static Hinagata setting key: " ++ show problem)++knownPositive :: Int -> Positive+knownPositive value = case mkPositive "built-in limit" value of+  Right result -> result+  Left problem -> error (Text.unpack problem)++knownIdentifier :: Text -> SqlIdentifier+knownIdentifier value = case mkSqlIdentifier value of+  Right result -> result+  Left problem -> error (Text.unpack problem)++hostDecoder :: Settei.Decoder Host+hostDecoder = Settei.parsedDecoder "an absolute socket directory or TCP hostname" $ \value ->+  if Text.isPrefixOf "/" value then socketDirectory value else tcpHost value++portDecoder :: Settei.Decoder Port+portDecoder = Settei.decoder $ \settingKey raw -> do+  value <- Settei.runDecoder Settei.boundedIntegralDecoder settingKey raw+  either (const (Left (Settei.decodeFailure settingKey "port between 1 and 65535"))) Right (mkPort value)++projectDecoder :: Settei.Decoder ProjectId+projectDecoder = Settei.parsedDecoder "a lowercase project ID" mkProjectId++databaseDecoder :: Settei.Decoder DatabaseName+databaseDecoder = Settei.parsedDecoder "a PostgreSQL database name of at most 63 UTF-8 bytes" mkDatabaseName++identifierDecoder :: Settei.Decoder SqlIdentifier+identifierDecoder = Settei.parsedDecoder "a PostgreSQL identifier of at most 63 UTF-8 bytes" mkSqlIdentifier++directoryDecoder :: Settei.Decoder FilePath+directoryDecoder = Settei.parsedDecoder "an absolute directory path without NUL" $ \value ->+  if not (Text.null value) && not (Text.any (== '\0') value) && isAbsolute (Text.unpack value)+    then Right (Text.unpack value)+    else Left "invalid directory"++userDecoder :: Settei.Decoder Text+userDecoder = Settei.parsedDecoder "a nonempty database role without NUL" $ \value ->+  if Text.null value || Text.any (== '\0') value then Left "invalid user" else Right value++secretDecoder :: Settei.Decoder Secret+secretDecoder = Settei.parsedDecoder "a password without NUL" mkSecret++positiveDecoder :: Text -> Settei.Decoder Positive+positiveDecoder name = Settei.decoder $ \settingKey raw -> do+  value <- Settei.runDecoder Settei.boundedIntegralDecoder settingKey raw+  either (const (Left (Settei.decodeFailure settingKey "a positive integer"))) Right (mkPositive name value)++grantsDecoder :: Settei.Decoder [DatabaseGrant]+grantsDecoder = Settei.decoder $ \settingKey raw ->+  case scalarList raw of+    Nothing -> Left (Settei.decodeFailure settingKey "a comma-separated or array grant list")+    Just names -> traverse (parseGrant settingKey) names++parseGrant :: Settei.Key -> Text -> Either Settei.DecodeFailure DatabaseGrant+parseGrant settingKey value = case Text.toUpper (Text.strip value) of+  "CONNECT" -> Right GrantConnect+  "CREATE" -> Right GrantCreate+  "TEMPORARY" -> Right GrantTemporary+  _ -> Left (Settei.decodeFailure settingKey "CONNECT, CREATE, or TEMPORARY grants")++schemaGrantsDecoder :: Settei.Decoder [SchemaGrant]+schemaGrantsDecoder = Settei.decoder $ \settingKey raw ->+  case scalarList raw of+    Nothing -> Left (Settei.decodeFailure settingKey "a comma-separated or array schema grant list")+    Just values -> traverse (parseSchemaGrant settingKey) values++parseSchemaGrant :: Settei.Key -> Text -> Either Settei.DecodeFailure SchemaGrant+parseSchemaGrant settingKey value =+  case Text.breakOn ":" value of+    (schemaName, assigned)+      | not (Text.null assigned),+        Right schema <- mkSqlIdentifier (Text.strip schemaName) ->+          case Text.toUpper (Text.strip (Text.drop 1 assigned)) of+            "USAGE" -> Right SchemaGrant {schema, privilege = SchemaUsage}+            "CREATE" -> Right SchemaGrant {schema, privilege = SchemaCreate}+            _ -> invalid+    _ -> invalid+  where+    invalid = Left (Settei.decodeFailure settingKey "SCHEMA:USAGE or SCHEMA:CREATE grant")++settingsDecoder :: Settei.Decoder [RoleSetting]+settingsDecoder = Settei.decoder $ \settingKey raw ->+  case scalarList raw of+    Nothing -> Left (Settei.decodeFailure settingKey "a comma-separated or array setting list")+    Just values -> traverse (parseRoleSetting settingKey) values++parseRoleSetting :: Settei.Key -> Text -> Either Settei.DecodeFailure RoleSetting+parseRoleSetting settingKey value =+  case Text.breakOn "=" value of+    (settingName, assigned)+      | not (Text.null assigned),+        Right name <- mkSqlIdentifier (Text.strip settingName),+        let settingValue = Text.strip (Text.drop 1 assigned),+        not (Text.any (== '\0') settingValue) ->+          Right RoleSetting {name, value = settingValue}+    _ -> Left (Settei.decodeFailure settingKey "NAME=VALUE database setting")++scalarList :: Settei.RawValue -> Maybe [Text]+scalarList (Settei.RawText value)+  | Text.null (Text.strip value) = Just []+  | otherwise = Just (Text.splitOn "," value)+scalarList (Settei.RawArray values) = traverse textValue values+  where+    textValue (Settei.RawText value) = Just value+    textValue _ = Nothing+scalarList _ = Nothing

@@ -0,0 +1,130 @@+module Hinagata.Connection+  ( Host,+    socketDirectory,+    tcpHost,+    hostText,+    Secret,+    secretText,+    mkSecret,+    ConnectionTarget,+    mkConnectionTarget,+    connectionHost,+    connectionPort,+    connectionUser,+    connectionDatabase,+    connectionPassword,+    ConnectionString,+    connectionStringText,+    renderConnectionString,+  )+where++import Data.Text qualified as Text+import Hinagata.Prelude+import Hinagata.Types+import System.FilePath (isAbsolute)++data Host = SocketDirectory !Text | TcpHost !Text+  deriving stock (Eq, Show)++hostText :: Host -> Text+hostText (SocketDirectory value) = value+hostText (TcpHost value) = value++socketDirectory :: Text -> Either Text Host+socketDirectory value+  | Text.null value = Left "socket directory is empty"+  | Text.any (== '\0') value = Left "socket directory contains NUL"+  | not (isAbsolute (Text.unpack value)) = Left "socket directory must be absolute"+  | otherwise = Right (SocketDirectory value)++tcpHost :: Text -> Either Text Host+tcpHost value+  | Text.null value = Left "TCP host is empty"+  | Text.any (== '\0') value = Left "TCP host contains NUL"+  | Text.any (== '/') value = Left "TCP host contains '/'"+  | otherwise = Right (TcpHost value)++newtype Secret = Secret Text+  deriving stock (Eq)++instance Show Secret where+  show _ = "<redacted>"++mkSecret :: Text -> Either Text Secret+mkSecret value+  | Text.any (== '\0') value = Left "credential contains NUL"+  | otherwise = Right (Secret value)++secretText :: Secret -> Text+secretText (Secret value) = value++data ConnectionTarget = ConnectionTarget+  { host :: !Host,+    port :: !Port,+    user :: !Text,+    database :: !DatabaseName,+    password :: !(Maybe Secret)+  }+  deriving stock (Eq)++instance Show ConnectionTarget where+  show ConnectionTarget {host, port, user, database} =+    "ConnectionTarget {host = "+      ++ show host+      ++ ", port = "+      ++ show port+      ++ ", user = "+      ++ show user+      ++ ", database = "+      ++ show database+      ++ ", password = <redacted>}"++mkConnectionTarget :: Host -> Port -> Text -> DatabaseName -> Maybe Secret -> Either Text ConnectionTarget+mkConnectionTarget host port user database password+  | Text.null user = Left "database user is empty"+  | Text.any (== '\0') user = Left "database user contains NUL"+  | otherwise = Right ConnectionTarget {host, port, user, database, password}++connectionHost :: ConnectionTarget -> Host+connectionHost ConnectionTarget {host} = host++connectionPort :: ConnectionTarget -> Port+connectionPort ConnectionTarget {port} = port++connectionUser :: ConnectionTarget -> Text+connectionUser ConnectionTarget {user} = user++connectionDatabase :: ConnectionTarget -> DatabaseName+connectionDatabase ConnectionTarget {database} = database++connectionPassword :: ConnectionTarget -> Maybe Secret+connectionPassword ConnectionTarget {password} = password++newtype ConnectionString = ConnectionString Text+  deriving stock (Eq)++instance Show ConnectionString where+  show _ = "<redacted connection string>"++connectionStringText :: ConnectionString -> Text+connectionStringText (ConnectionString value) = value++-- | Render explicit endpoint fields, clearing ambient hostaddr overrides.+-- Other libpq defaults (including authentication and TLS) remain available.+renderConnectionString :: ConnectionTarget -> ConnectionString+renderConnectionString ConnectionTarget {host, port, user, database, password} =+  ConnectionString $+    Text.intercalate " " $+      [ field "host" (hostText host),+        field "hostaddr" "",+        field "port" (Text.pack (show (portNumber port))),+        field "user" user,+        field "dbname" (databaseNameText database)+      ]+        ++ maybe [] (\credential -> [field "password" (secretText credential)]) password+  where+    field key value = key <> "='" <> Text.concatMap escape value <> "'"+    escape '\'' = "\\'"+    escape '\\' = "\\\\"+    escape character = Text.singleton character

@@ -0,0 +1,20 @@+-- | Shared location and operation context for typed diagnostics.+-- Backend and command-line errors remain in their owning packages.+module Hinagata.Error+  ( DiagnosticContext (..),+    diagnosticContext,+  )+where++import Hinagata.Fixture.Types (FixtureName)+import Hinagata.Prelude++data DiagnosticContext = DiagnosticContext+  { operation :: !Text,+    fixture :: !(Maybe FixtureName),+    sourcePath :: !(Maybe FilePath)+  }+  deriving stock (Eq, Show)++diagnosticContext :: Text -> DiagnosticContext+diagnosticContext operation = DiagnosticContext {operation, fixture = Nothing, sourcePath = Nothing}

@@ -0,0 +1,403 @@+module Hinagata.Fixture.Bundle+  ( BundleConfig (..),+    BundleError (..),+    CapturedStep (..),+    CapturedFixture (..),+    FixturePlan,+    planDigest,+    planDirectory,+    planFixtures,+    verifyPlan,+    verifyComposedRemainder,+    compileFixtures,+    CompositionError (..),+    CapturedFixtureRef (..),+    ComposedPlan (..),+    composePlans,+  )+where++import Control.Exception (IOException, try)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)+import Crypto.Hash.SHA256 qualified as SHA256+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.ByteString.Builder (Builder, byteString, toLazyByteString, word64BE, word8)+import Data.ByteString.Lazy qualified as Lazy+import Data.List (isPrefixOf)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Encoding+import Data.Word (Word64)+import Hinagata.Fixture.Graph (GraphError, resolveFixtures)+import Hinagata.Fixture.Manifest+import Hinagata.Fixture.SqlPolicy+import Hinagata.Fixture.Types+import Hinagata.Prelude+import Hinagata.Types+import Numeric (showHex)+import System.Directory+  ( canonicalizePath,+    createDirectoryIfMissing,+    doesDirectoryExist,+    doesFileExist,+    getFileSize,+    getModificationTime,+    pathIsSymbolicLink,+    renameDirectory,+  )+import System.FilePath (isAbsolute, makeRelative, takeFileName, (</>))+import System.IO (Handle, IOMode (..), withBinaryFile)+import System.IO.Error (isDoesNotExistError)+import System.IO.Temp (withTempDirectory)++data BundleConfig = BundleConfig+  { fixtureRoot :: !FilePath,+    bundleRoot :: !FilePath,+    sqlSizeLimit :: !Positive,+    chunkSize :: !Positive+  }+  deriving stock (Eq, Show)++data BundleError+  = BundleIo !Text+  | MissingFixture !FixtureName+  | UnsafePath !FilePath+  | InvalidFixtureManifest !FixtureName !ManifestError+  | InvalidFixtureGraph !GraphError+  | SourceChanged !FilePath+  | SqlStepTooLarge !FilePath+  | InvalidSql !FilePath !SqlPolicyError+  deriving stock (Eq, Show)++data CapturedStep+  = CapturedSql+      { relativePath :: !FilePath,+        contentDigest :: !Text,+        byteLength :: !Word64+      }+  | CapturedCopy+      { copySpec :: !CopySpec,+        relativePath :: !FilePath,+        contentDigest :: !Text,+        byteLength :: !Word64+      }+  deriving stock (Eq, Show)++data CapturedFixture = CapturedFixture+  { name :: !FixtureName,+    includes :: ![FixtureName],+    steps :: ![CapturedStep],+    identity :: !Text+  }+  deriving stock (Eq, Show)++data FixturePlan = FixturePlan+  { directory :: !FilePath,+    digest :: !Text,+    fixtures :: ![CapturedFixture]+  }+  deriving stock (Eq, Show)++planDigest :: FixturePlan -> Text+planDigest FixturePlan {digest} = digest++planDirectory :: FixturePlan -> FilePath+planDirectory FixturePlan {directory} = directory++planFixtures :: FixturePlan -> [CapturedFixture]+planFixtures FixturePlan {fixtures} = fixtures++-- | Recheck a frozen bundle before a database load uses it. A cached plan is+-- reusable in process, but on-disk bundle bytes may have changed meanwhile.+verifyPlan :: FixturePlan -> IO Bool+verifyPlan FixturePlan {directory, digest, fixtures} =+  verifyBundle directory (strictBuilder (manifestEncoding digest fixtures)) fixtures++-- | Verify the bundle manifest and only the scenario fixtures that a clone+-- will load. A shared base prefix was verified when its template was sealed.+verifyComposedRemainder :: FixturePlan -> ComposedPlan -> IO Bool+verifyComposedRemainder FixturePlan {directory, digest, fixtures} ComposedPlan {scenarioRemainder} =+  verifyBundle directory (strictBuilder (manifestEncoding digest fixtures)) (map fixture scenarioRemainder)++data CompositionError = ConflictingFixture !FixtureName+  deriving stock (Eq, Show)++data CapturedFixtureRef = CapturedFixtureRef+  { directory :: !FilePath,+    fixture :: !CapturedFixture+  }+  deriving stock (Eq, Show)++data ComposedPlan = ComposedPlan+  { basePrefix :: ![CapturedFixtureRef],+    scenarioRemainder :: ![CapturedFixtureRef]+  }+  deriving stock (Eq, Show)++-- | Purely compare frozen fixture identities and remove a verified-equal+-- overlap from the scenario. Only the lifecycle manager can authorize skipping+-- the base prefix on a clone of its sealed baseline.+composePlans :: FixturePlan -> FixturePlan -> Either CompositionError ComposedPlan+composePlans base scenario = do+  remainder <- traverse select (planFixtures scenario)+  pure+    ComposedPlan+      { basePrefix = map (CapturedFixtureRef (planDirectory base)) (planFixtures base),+        scenarioRemainder = [reference | Just reference <- remainder]+      }+  where+    baseIdentities = Map.fromList [(fixtureName, fixtureIdentity) | CapturedFixture {name = fixtureName, identity = fixtureIdentity} <- planFixtures base]+    select fixture@CapturedFixture {name = fixtureName, identity = fixtureIdentity} =+      case Map.lookup fixtureName baseIdentities of+        Nothing -> Right (Just (CapturedFixtureRef (planDirectory scenario) fixture))+        Just baseIdentity+          | baseIdentity == fixtureIdentity -> Right Nothing+          | otherwise -> Left (ConflictingFixture fixtureName)++compileFixtures :: BundleConfig -> [FixtureName] -> IO (Either BundleError FixturePlan)+compileFixtures config roots = do+  outcome <- try @IOException $ do+    root <- canonicalizePath (fixtureRoot config)+    validRoot <- doesDirectoryExist root+    if not validRoot+      then pure (Left (BundleIo "fixture root is not a directory"))+      else do+        createDirectoryIfMissing True (bundleRoot config)+        withTempDirectory (bundleRoot config) "hinagata-capture-" $ \staging ->+          runExceptT $ do+            definitions <- discover root roots+            ordered <- either (throwE . InvalidFixtureGraph) pure (resolveFixtures definitions roots)+            captured <- captureAll config root staging ordered+            let digest = hashBuilder (planEncoding captured)+                manifest = strictBuilder (manifestEncoding digest captured)+            lift (ByteString.writeFile (staging </> "manifest.bin") manifest)+            published <- lift (publish (bundleRoot config) staging digest manifest captured)+            pure FixturePlan {directory = published, digest, fixtures = captured}+  pure $ either (Left . BundleIo . Text.pack . show) id outcome++discover :: FilePath -> [FixtureName] -> ExceptT BundleError IO [FixtureDefinition]+discover root = go Set.empty []+  where+    go _ found [] = pure (reverse found)+    go seen found (next : rest)+      | Set.member next seen = go seen found rest+      | otherwise = do+          definition <- loadDefinition root next+          let FixtureDefinition {includes = dependencies} = definition+          go (Set.insert next seen) (definition : found) (dependencies ++ rest)++loadDefinition :: FilePath -> FixtureName -> ExceptT BundleError IO FixtureDefinition+loadDefinition root fixtureName = do+  let directory = root </> Text.unpack (fixtureNameText fixtureName)+  exists <- lift (doesDirectoryExist directory)+  unless exists (throwE (MissingFixture fixtureName))+  canonicalDirectory <- lift (canonicalizePath directory)+  unless (within root canonicalDirectory) (throwE (UnsafePath directory))+  let manifestPath = canonicalDirectory </> "fixture.yaml"+  hasManifest <- lift (doesFileExist manifestPath)+  manifestIsLink <- lift $ do+    linkResult <- try @IOException (pathIsSymbolicLink manifestPath)+    case linkResult of+      Right linked -> pure linked+      Left failure | isDoesNotExistError failure -> pure False+      Left failure -> ioError failure+  if hasManifest || manifestIsLink+    then do+      canonicalManifest <- lift (canonicalizePath manifestPath)+      unless (within root canonicalManifest) (throwE (UnsafePath manifestPath))+      validManifest <- lift (doesFileExist canonicalManifest)+      unless validManifest (throwE (UnsafePath manifestPath))+      bytes <- lift (ByteString.readFile canonicalManifest)+      either (throwE . InvalidFixtureManifest fixtureName) (pure . manifestDefinition) (decodeManifest fixtureName bytes)+    else pure (implicitDefinition fixtureName)++captureAll :: BundleConfig -> FilePath -> FilePath -> [FixtureDefinition] -> ExceptT BundleError IO [CapturedFixture]+captureAll config root staging = go 0+  where+    go :: Int -> [FixtureDefinition] -> ExceptT BundleError IO [CapturedFixture]+    go _ [] = pure []+    go nextIndex (definition@FixtureDefinition {name, includes, steps} : rest) = do+      (capturedSteps, afterIndex) <- captureSteps nextIndex definition steps+      let identity = hashBuilder (fixtureEncoding name includes capturedSteps)+          captured = CapturedFixture {name, includes, steps = capturedSteps, identity}+      (captured :) <$> go afterIndex rest++    captureSteps :: Int -> FixtureDefinition -> [FixtureStep] -> ExceptT BundleError IO ([CapturedStep], Int)+    captureSteps nextIndex _ [] = pure ([], nextIndex)+    captureSteps nextIndex FixtureDefinition {name} (step : rest) = do+      let sourceDirectory = root </> Text.unpack (fixtureNameText name)+          relativePath = "step-" ++ show nextIndex+          output = staging </> relativePath+          input =+            sourceDirectory </> case step of+              SqlFile path -> path+              CopyCsv CopySpec {file} -> file+      source <- lift (canonicalizePath input)+      exists <- lift (doesFileExist source)+      unless (exists && within root source) (throwE (UnsafePath input))+      (byteCount, contentDigest) <- copyAndHash config source output (case step of SqlFile {} -> True; CopyCsv {} -> False)+      capturedStep <- case step of+        SqlFile {} -> do+          sql <- lift (ByteString.readFile output)+          either (throwE . InvalidSql input) (const (pure ())) (checkSqlPolicy sql)+          pure CapturedSql {relativePath, contentDigest, byteLength = byteCount}+        CopyCsv spec -> pure CapturedCopy {copySpec = spec, relativePath, contentDigest, byteLength = byteCount}+      (remaining, afterIndex) <- captureSteps (nextIndex + 1) FixtureDefinition {name, includes = [], steps = []} rest+      pure (capturedStep : remaining, afterIndex)++copyAndHash :: BundleConfig -> FilePath -> FilePath -> Bool -> ExceptT BundleError IO (Word64, Text)+copyAndHash config source output isSql = do+  sizeBefore <- lift (getFileSize source)+  modifiedBefore <- lift (getModificationTime source)+  result <- lift $ withBinaryFile source ReadMode $ \input ->+    withBinaryFile output WriteMode $ \destination -> loop input destination 0 SHA256.init+  (byteCount, hashContext) <- either throwE pure result+  sizeAfter <- lift (getFileSize source)+  modifiedAfter <- lift (getModificationTime source)+  when (sizeBefore /= sizeAfter || modifiedBefore /= modifiedAfter) (throwE (SourceChanged source))+  pure (byteCount, hex (SHA256.finalize hashContext))+  where+    limit = fromIntegral (positiveValue (sqlSizeLimit config)) :: Word64+    chunk = min 1048576 (positiveValue (chunkSize config))+    loop :: Handle -> Handle -> Word64 -> SHA256.Ctx -> IO (Either BundleError (Word64, SHA256.Ctx))+    loop input destination byteCount context = do+      bytes <- ByteString.hGet input chunk+      if ByteString.null bytes+        then pure (Right (byteCount, context))+        else do+          let newLength = byteCount + fromIntegral (ByteString.length bytes)+          if isSql && newLength > limit+            then pure (Left (SqlStepTooLarge source))+            else do+              ByteString.hPut destination bytes+              let nextContext = SHA256.update context bytes+              nextContext `seq` loop input destination newLength nextContext++publish :: FilePath -> FilePath -> Text -> ByteString -> [CapturedFixture] -> IO FilePath+publish bundleRoot staging digest manifest captured = do+  let preferred = bundleRoot </> ("v1-" ++ Text.unpack digest)+      unique = preferred ++ "-" ++ takeFileName staging+  exists <- doesDirectoryExist preferred+  if exists+    then do+      valid <- verifyBundle preferred manifest captured+      if valid then pure preferred else renameDirectory staging unique >> pure unique+    else do+      result <- try @IOException (renameDirectory staging preferred)+      case result of+        Right () -> pure preferred+        Left _ -> do+          valid <- verifyBundle preferred manifest captured+          if valid then pure preferred else renameDirectory staging unique >> pure unique++verifyBundle :: FilePath -> ByteString -> [CapturedFixture] -> IO Bool+verifyBundle directory manifest captured = do+  result <- try @IOException $ do+    directoryIsLink <- pathIsSymbolicLink directory+    if directoryIsLink+      then pure False+      else do+        manifestIsLink <- pathIsSymbolicLink (directory </> "manifest.bin")+        if manifestIsLink+          then pure False+          else do+            stored <- ByteString.readFile (directory </> "manifest.bin")+            if stored /= manifest+              then pure False+              else and <$> traverse verifyStep [step | CapturedFixture {steps = capturedSteps} <- captured, step <- capturedSteps]+  pure (either (const False) id result)+  where+    verifyStep step = do+      let path = directory </> relativePath step+      exists <- doesFileExist path+      if not exists+        then pure False+        else do+          isLink <- pathIsSymbolicLink path+          if isLink+            then pure False+            else do+              size <- getFileSize path+              digest <- hashFile path+              pure (size == fromIntegral (byteLength step) && digest == contentDigest step)++hashFile :: FilePath -> IO Text+hashFile path = withBinaryFile path ReadMode (go SHA256.init)+  where+    go context handle = do+      bytes <- ByteString.hGet handle 65536+      if ByteString.null bytes+        then pure (hex (SHA256.finalize context))+        else do+          let nextContext = SHA256.update context bytes+          nextContext `seq` go nextContext handle++within :: FilePath -> FilePath -> Bool+within root candidate =+  let relative = makeRelative root candidate+   in not (isAbsolute relative) && relative /= ".." && not ("../" `isPrefixOf` relative)++planEncoding :: [CapturedFixture] -> Builder+planEncoding fixtures = field "hinagata-plan-v1" <> count fixtures <> foldMap (field . identity) fixtures++manifestEncoding :: Text -> [CapturedFixture] -> Builder+manifestEncoding digest fixtures =+  field "hinagata-bundle-v1" <> field digest <> count fixtures <> foldMap encodeFixture fixtures+  where+    encodeFixture CapturedFixture {name, includes, steps, identity} =+      field (fixtureNameText name)+        <> field identity+        <> count includes+        <> foldMap (field . fixtureNameText) includes+        <> count steps+        <> foldMap encodeStepManifest steps++fixtureEncoding :: FixtureName -> [FixtureName] -> [CapturedStep] -> Builder+fixtureEncoding name includes steps =+  field "hinagata-fixture-v1"+    <> field (fixtureNameText name)+    <> count includes+    <> foldMap (field . fixtureNameText) includes+    <> count steps+    <> foldMap encodeStepContent steps++encodeStepManifest :: CapturedStep -> Builder+encodeStepManifest step = field (Text.pack (relativePath step)) <> encodeStepContent step++encodeStepContent :: CapturedStep -> Builder+encodeStepContent CapturedSql {contentDigest, byteLength} =+  word8 1 <> field contentDigest <> word64BE byteLength+encodeStepContent CapturedCopy {copySpec = CopySpec {schema, table, columns, file, header}, contentDigest, byteLength} =+  word8 2+    <> field (Text.pack file)+    <> field (sqlIdentifierText schema)+    <> field (sqlIdentifierText table)+    <> count columns+    <> foldMap (field . sqlIdentifierText) columns+    <> word8 (if header then 1 else 0)+    <> field contentDigest+    <> word64BE byteLength++field :: Text -> Builder+field value =+  let bytes = Encoding.encodeUtf8 value+   in word64BE (fromIntegral (ByteString.length bytes)) <> byteString bytes++count :: [a] -> Builder+count = word64BE . fromIntegral . length++strictBuilder :: Builder -> ByteString+strictBuilder = Lazy.toStrict . toLazyByteString++hashBuilder :: Builder -> Text+hashBuilder = hex . SHA256.hash . strictBuilder++hex :: ByteString -> Text+hex = Text.pack . concatMap twoDigits . ByteString.unpack+  where+    twoDigits byte = case showHex byte "" of+      [digit] -> ['0', digit]+      digits -> digits

@@ -0,0 +1,63 @@+module Hinagata.Fixture.Graph+  ( GraphError (..),+    resolveFixtures,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Hinagata.Fixture.Types+import Hinagata.Prelude ()++data GraphError+  = DuplicateFixture !FixtureName+  | MissingFixture !FixtureName ![FixtureName]+  | FixtureCycle ![FixtureName]+  deriving stock (Eq, Show)++-- | Stable depth-first postorder: includes precede their consumer, each name+-- appears once, and requested roots keep caller order.+resolveFixtures :: [FixtureDefinition] -> [FixtureName] -> Either GraphError [FixtureDefinition]+resolveFixtures definitions roots = do+  definitionsByName <- buildIndex definitions+  (_, reverseOrder) <- visitMany definitionsByName [] Set.empty [] roots+  pure (reverse reverseOrder)++buildIndex :: [FixtureDefinition] -> Either GraphError (Map FixtureName FixtureDefinition)+buildIndex = foldl step (Right Map.empty)+  where+    step (Left failure) _ = Left failure+    step (Right definitionsByName) definition@FixtureDefinition {name} =+      if Map.member name definitionsByName+        then Left (DuplicateFixture name)+        else Right (Map.insert name definition definitionsByName)++visitMany ::+  Map FixtureName FixtureDefinition ->+  [FixtureName] ->+  Set FixtureName ->+  [FixtureDefinition] ->+  [FixtureName] ->+  Either GraphError (Set FixtureName, [FixtureDefinition])+visitMany _ _ visited output [] = Right (visited, output)+visitMany definitionsByName stack visited output (next : rest) = do+  (visited', output') <- visit definitionsByName stack visited output next+  visitMany definitionsByName stack visited' output' rest++visit ::+  Map FixtureName FixtureDefinition ->+  [FixtureName] ->+  Set FixtureName ->+  [FixtureDefinition] ->+  FixtureName ->+  Either GraphError (Set FixtureName, [FixtureDefinition])+visit definitionsByName stack visited output current+  | current `elem` stack = Left (FixtureCycle (dropWhile (/= current) (reverse stack) ++ [current]))+  | Set.member current visited = Right (visited, output)+  | otherwise = case Map.lookup current definitionsByName of+      Nothing -> Left (MissingFixture current (reverse stack ++ [current]))+      Just definition@FixtureDefinition {includes} -> do+        (visited', output') <- visitMany definitionsByName (current : stack) visited output includes+        pure (Set.insert current visited', definition : output')

@@ -0,0 +1,116 @@+module Hinagata.Fixture.Manifest+  ( ManifestError (..),+    FixtureManifest,+    decodeManifest,+    manifestDefinition,+    manifestDescription,+    implicitDefinition,+  )+where++import Data.Aeson (Value (..), (.:), (.:?))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, parseEither, withObject)+import Data.ByteString (ByteString)+import Data.Text qualified as Text+import Data.Yaml qualified as Yaml+import Hinagata.Fixture.Types+import Hinagata.Prelude+import Hinagata.Types+import System.FilePath (isAbsolute)++data ManifestError+  = InvalidYaml !Text+  | InvalidManifest !Text+  deriving stock (Eq, Show)++data FixtureManifest = FixtureManifest+  { name :: !FixtureName,+    description :: !(Maybe Text),+    includes :: ![FixtureName],+    steps :: ![FixtureStep]+  }+  deriving stock (Eq, Show, Generic)++-- | Decode an explicit fixture.yaml. Its name must match the directory name.+-- The caller still validates filesystem paths and captures bytes before use.+decodeManifest :: FixtureName -> ByteString -> Either ManifestError FixtureManifest+decodeManifest expected bytes = do+  value <- either (Left . InvalidYaml . Text.pack . show) Right (Yaml.decodeEither' bytes)+  parsed <- either (Left . InvalidManifest . Text.pack) Right (parseEither parseManifest value)+  let FixtureManifest {name = actualName} = parsed+  if actualName == expected+    then Right parsed+    else Left (InvalidManifest "manifest name does not match fixture directory")++manifestDefinition :: FixtureManifest -> FixtureDefinition+manifestDefinition FixtureManifest {name, includes, steps} = FixtureDefinition {name, includes, steps}++manifestDescription :: FixtureManifest -> Maybe Text+manifestDescription FixtureManifest {description} = description++-- | A directory without fixture.yaml has exactly one conventional SQL step.+implicitDefinition :: FixtureName -> FixtureDefinition+implicitDefinition name = FixtureDefinition {name, includes = [], steps = [SqlFile "fixture.sql"]}++parseManifest :: Value -> Parser FixtureManifest+parseManifest = withObject "fixture manifest" $ \object -> do+  rejectUnknown ["name", "description", "include", "steps"] object+  nameText <- object .: "name"+  name <- either (fail . Text.unpack) pure (mkFixtureName nameText)+  description <- object .:? "description"+  includeNames <- fromMaybe [] <$> object .:? "include"+  includes <- traverse (either (fail . Text.unpack) pure . mkFixtureName) includeNames+  rawSteps <- object .: "steps"+  steps <- case rawSteps of+    [] -> fail "steps must be non-empty"+    values -> traverse parseStep values+  pure FixtureManifest {name, description, includes, steps}++parseStep :: Value -> Parser FixtureStep+parseStep = withObject "fixture step" $ \object -> do+  rejectUnknown ["sql", "copy"] object+  case (KeyMap.lookup "sql" object, KeyMap.lookup "copy" object) of+    (Just (String path), Nothing) -> SqlFile <$> safePath path+    (Nothing, Just value) -> CopyCsv <$> parseCopy value+    _ -> fail "step must contain exactly one of sql or copy"++parseCopy :: Value -> Parser CopySpec+parseCopy = withObject "copy step" $ \object -> do+  rejectUnknown ["table", "columns", "file", "format", "header"] object+  tableValue <- object .: "table"+  (schema, table) <- parseTable tableValue+  columnNames <- object .: "columns"+  columns <- case columnNames of+    [] -> fail "COPY columns must be non-empty"+    values -> traverse identifier values+  fileText <- object .: "file"+  file <- safePath fileText+  format <- object .: "format"+  unless (format == ("csv" :: Text)) (fail "COPY format must be csv")+  header <- object .: "header"+  pure CopySpec {schema, table, columns, file, header}++parseTable :: Value -> Parser (SqlIdentifier, SqlIdentifier)+parseTable = withObject "COPY table" $ \object -> do+  rejectUnknown ["schema", "name"] object+  schema <- object .: "schema" >>= identifier+  table <- object .: "name" >>= identifier+  pure (schema, table)++identifier :: Text -> Parser SqlIdentifier+identifier = either (fail . Text.unpack) pure . mkSqlIdentifier++safePath :: Text -> Parser FilePath+safePath raw = do+  let path = Text.unpack raw+  when (Text.null raw || Text.any (== '\0') raw || isAbsolute path || any (`elem` [".", "..", ""]) (Text.splitOn "/" raw)) $+    fail "step path must be a non-empty relative path without . or .. components"+  pure path++rejectUnknown :: [Text] -> KeyMap.KeyMap Value -> Parser ()+rejectUnknown allowed object =+  case filter (`notElem` allowed) (map Key.toText (KeyMap.keys object)) of+    [] -> pure ()+    unknown -> fail ("unknown fields: " ++ Text.unpack (Text.intercalate ", " unknown))

@@ -0,0 +1,128 @@+module Hinagata.Fixture.SqlPolicy+  ( SqlPolicyError (..),+    checkSqlPolicy,+  )+where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as ByteString+import Data.Char (toLower)+import Data.List (isPrefixOf)+import Data.Text qualified as Text+import Hinagata.Prelude++data SqlPolicyError+  = ForbiddenStatement !Text+  | PsqlCommand+  | UnterminatedSqlLiteral !Text+  | SqlContainsNul+  deriving stock (Eq, Show)++data Prefix = AfterStart | AfterPrepare+  deriving stock (Eq, Show)++-- | A lexical policy check for trusted SQL, not a PostgreSQL parser. The+-- caller executes the original bytes unchanged after this preflight.+checkSqlPolicy :: ByteString -> Either SqlPolicyError ()+checkSqlPolicy bytes+  | ByteString.elem '\0' bytes = Left SqlContainsNul+  | otherwise = scan True True Nothing (ByteString.unpack bytes)++scan :: Bool -> Bool -> Maybe Prefix -> String -> Either SqlPolicyError ()+scan _ _ _ [] = Right ()+scan statementStart lineStart prefix input@(character : rest)+  | character == '\n' = scan statementStart True prefix rest+  | character `elem` [' ', '\t', '\r', '\f', '\v'] = scan statementStart lineStart prefix rest+  | "--" `isPrefixOf` input = scan statementStart True prefix (dropLine (drop 2 input))+  | "/*" `isPrefixOf` input = do+      (remaining, nextLineStart) <- dropBlock 1 lineStart (drop 2 input)+      scan statementStart nextLineStart prefix remaining+  | character == '\\' && lineStart = Left PsqlCommand+  | character == ';' = scan True False Nothing rest+  | character == '\'' = do+      remaining <- dropSingle False rest+      scan False False Nothing remaining+  | character == '"' = do+      remaining <- dropDouble rest+      scan False False Nothing remaining+  | character == '$',+    Just (delimiter, afterOpen) <- dollarOpen input = do+      remaining <- dropDollar delimiter afterOpen+      scan False False Nothing remaining+  | identifierStart character =+      let (word, remaining) = span identifierContinue input+       in case remaining of+            '\'' : afterOpen | map toLower word == "e" -> do+              afterClose <- dropSingle True afterOpen+              scan False False Nothing afterClose+            _ -> case classify statementStart prefix (map toLower word) of+              Left failure -> Left failure+              Right (nextStart, nextPrefix) -> scan nextStart False nextPrefix remaining+  | otherwise = scan False False Nothing rest++classify :: Bool -> Maybe Prefix -> String -> Either SqlPolicyError (Bool, Maybe Prefix)+classify _ (Just _) "transaction" = Left (ForbiddenStatement "TRANSACTION")+classify _ (Just _) _ = Right (False, Nothing)+classify False Nothing _ = Right (False, Nothing)+classify True Nothing word+  | word `elem` ["begin", "commit", "end", "rollback", "abort", "savepoint", "release", "copy"] =+      Left (ForbiddenStatement (Text.pack word))+  | word == "start" = Right (False, Just AfterStart)+  | word == "prepare" = Right (False, Just AfterPrepare)+  | otherwise = Right (False, Nothing)++identifierStart :: Char -> Bool+identifierStart character = asciiLetter character || character == '_'++identifierContinue :: Char -> Bool+identifierContinue character = identifierStart character || (character >= '0' && character <= '9') || character == '$'++asciiLetter :: Char -> Bool+asciiLetter character = (character >= 'a' && character <= 'z') || (character >= 'A' && character <= 'Z')++dropLine :: String -> String+dropLine [] = []+dropLine ('\n' : rest) = rest+dropLine (_ : rest) = dropLine rest++dropBlock :: Int -> Bool -> String -> Either SqlPolicyError (String, Bool)+dropBlock _ _ [] = Left (UnterminatedSqlLiteral "block comment")+dropBlock depth lineStart input+  | "/*" `isPrefixOf` input = dropBlock (depth + 1) lineStart (drop 2 input)+  | "*/" `isPrefixOf` input =+      if depth == 1+        then Right (drop 2 input, lineStart)+        else dropBlock (depth - 1) lineStart (drop 2 input)+  | otherwise = case input of+      '\n' : rest -> dropBlock depth True rest+      _ : rest -> dropBlock depth lineStart rest++dropSingle :: Bool -> String -> Either SqlPolicyError String+dropSingle _ [] = Left (UnterminatedSqlLiteral "single-quoted string")+dropSingle escaped ('\\' : _ : rest) | escaped = dropSingle escaped rest+dropSingle escaped ('\'' : '\'' : rest) = dropSingle escaped rest+dropSingle _ ('\'' : rest) = Right rest+dropSingle escaped (_ : rest) = dropSingle escaped rest++dropDouble :: String -> Either SqlPolicyError String+dropDouble [] = Left (UnterminatedSqlLiteral "quoted identifier")+dropDouble ('"' : '"' : rest) = dropDouble rest+dropDouble ('"' : rest) = Right rest+dropDouble (_ : rest) = dropDouble rest++dollarOpen :: String -> Maybe (String, String)+dollarOpen ('$' : rest) =+  let (tag, afterTag) = span (\character -> asciiLetter character || (character >= '0' && character <= '9') || character == '_') rest+      validTag = case tag of+        [] -> True+        first : _ -> identifierStart first+   in case afterTag of+        '$' : body | validTag -> Just ('$' : tag ++ "$", body)+        _ -> Nothing+dollarOpen _ = Nothing++dropDollar :: String -> String -> Either SqlPolicyError String+dropDollar _ [] = Left (UnterminatedSqlLiteral "dollar-quoted string")+dropDollar delimiter input+  | delimiter `isPrefixOf` input = Right (drop (length delimiter) input)+  | otherwise = dropDollar delimiter (drop 1 input)

@@ -0,0 +1,53 @@+module Hinagata.Fixture.Types+  ( FixtureName,+    fixtureNameText,+    mkFixtureName,+    FixtureDefinition (..),+    FixtureStep (..),+    CopySpec (..),+  )+where++import Data.Text qualified as Text+import Hinagata.Prelude+import Hinagata.Types (SqlIdentifier)++-- | A path component and stable fixture identity, not an arbitrary file path.+newtype FixtureName = FixtureName Text+  deriving stock (Eq, Ord, Show)++fixtureNameText :: FixtureName -> Text+fixtureNameText (FixtureName value) = value++mkFixtureName :: Text -> Either Text FixtureName+mkFixtureName value+  | Text.null value = Left "fixture name is empty"+  | Text.length value > 63 = Left "fixture name exceeds 63 characters"+  | Text.head value == '-' || Text.last value == '-' = Left "fixture name cannot start or end with '-':"+  | Text.all valid value = Right (FixtureName value)+  | otherwise = Left "fixture name must contain only lowercase ASCII letters, digits, and '-':"+  where+    valid character = (character >= 'a' && character <= 'z') || (character >= '0' && character <= '9') || character == '-'++-- | Steps retain declaration order. Paths are validated and captured by the+-- bundle compiler before a plan becomes executable.+data FixtureStep+  = SqlFile !FilePath+  | CopyCsv !CopySpec+  deriving stock (Eq, Show, Generic)++data CopySpec = CopySpec+  { schema :: !SqlIdentifier,+    table :: !SqlIdentifier,+    columns :: ![SqlIdentifier],+    file :: !FilePath,+    header :: !Bool+  }+  deriving stock (Eq, Show, Generic)++data FixtureDefinition = FixtureDefinition+  { name :: !FixtureName,+    includes :: ![FixtureName],+    steps :: ![FixtureStep]+  }+  deriving stock (Eq, Show, Generic)

@@ -0,0 +1,152 @@+-- | Explicit, versioned identities for service-owned hook inputs. Locations and+-- literal values deliberately have no diagnostic rendering.+module Hinagata.Hook.Revision+  ( InputName,+    mkInputName,+    inputNameText,+    RevisionInput (..),+    RevisionError (..),+    CapturedRevision,+    hookRevision,+    revisionInputLabels,+    validateRevisionInputs,+    deriveHookRevision,+    verifyHookRevisionInputs,+  )+where++import Control.Exception (IOException, bracket, bracketOnError, try)+import Control.Monad (unless)+import Crypto.Hash.SHA256 qualified as SHA256+import Data.ByteString qualified as Bytes+import Data.ByteString.Builder (Builder, byteString, toLazyByteString, word64BE, word8)+import Data.List (sortOn)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Encoding+import Data.Word (Word64)+import Numeric (showHex)+import System.Directory (makeAbsolute)+import System.IO (hClose)+import System.Posix.Files (getFdStatus, isRegularFile)+import System.Posix.IO (OpenFileFlags (..), OpenMode (ReadOnly), closeFd, defaultFileFlags, fdToHandle, openFd)++newtype InputName = InputName Text+  deriving stock (Eq, Ord, Show)++inputNameText :: InputName -> Text+inputNameText (InputName name) = name++mkInputName :: Text -> Either RevisionError InputName+mkInputName name+  | Just (first, _) <- Text.uncons name,+    lower first,+    Text.all allowed name,+    all (\part -> part /= "" && part /= "." && part /= "..") (Text.splitOn "/" name) =+      Right (InputName name)+  | otherwise = Left InvalidInputName+  where+    lower c = c >= 'a' && c <= 'z'+    allowed c = lower c || (c >= '0' && c <= '9') || c `elem` ("._-/" :: String)++data RevisionInput+  = FileInput !InputName !FilePath+  | ValueInput !InputName !Text++data RevisionError+  = InvalidInputName+  | EmptyInputs+  | DuplicateInput !InputName+  | InputUnreadable !InputName+  | InputsChanged !InputName+  deriving stock (Eq, Show)++data Evidence = FileEvidence !InputName !FilePath !Word64 !Bytes.ByteString | ValueEvidence !InputName !Text++data CapturedRevision = CapturedRevision !Text ![Evidence]++hookRevision :: CapturedRevision -> Text+hookRevision (CapturedRevision revision _) = revision++-- | Safe logical labels and kinds; never locations or selected values.+revisionInputLabels :: CapturedRevision -> [(InputName, Text)]+revisionInputLabels (CapturedRevision _ evidence) = map label evidence+  where+    label (FileEvidence name _ _ _) = (name, "file")+    label (ValueEvidence name _) = (name, "value")++inputName :: RevisionInput -> InputName+inputName (FileInput name _) = name+inputName (ValueInput name _) = name++validateRevisionInputs :: [RevisionInput] -> Either RevisionError ()+validateRevisionInputs [] = Left EmptyInputs+validateRevisionInputs inputs = go Set.empty inputs+  where+    go _ [] = Right ()+    go seen (input : rest)+      | Set.member name seen = Left (DuplicateInput name)+      | otherwise = go (Set.insert name seen) rest+      where+        name = inputName input++deriveHookRevision :: [RevisionInput] -> IO (Either RevisionError CapturedRevision)+deriveHookRevision inputs = case validateRevisionInputs inputs of+  Left failure -> pure (Left failure)+  Right () -> do+    captured <- traverse capture (sortOn (Encoding.encodeUtf8 . inputNameText . inputName) inputs)+    pure $ do+      evidence <- sequence captured+      let encoding = byteString "hinagata-hook-revision-v1\0" <> word64BE (fromIntegral (length evidence)) <> foldMap encode evidence+          digest = SHA256.hashlazy (toLazyByteString encoding)+          hex = Text.pack (concatMap (\byte -> let value = showHex byte "" in if length value == 1 then '0' : value else value) (Bytes.unpack digest))+      Right (CapturedRevision ("hinagata-hook-revision-v1:sha256:" <> hex) evidence)++capture :: RevisionInput -> IO (Either RevisionError Evidence)+capture (ValueInput name value) = pure (Right (ValueEvidence name value))+capture (FileInput name path) = do+  result <- try @IOException $ do+    unless (not (null path) && '\0' `notElem` path) (ioError (userError "invalid input location"))+    absolute <- makeAbsolute path+    (size, digest) <- hashFile absolute+    pure (FileEvidence name absolute size digest)+  pure (either (const (Left (InputUnreadable name))) Right result)++-- Open nonblocking, then inspect the opened descriptor, so a pipe (including a+-- symlink to one or a path replaced during open) cannot block preparation.+hashFile :: FilePath -> IO (Word64, Bytes.ByteString)+hashFile path = bracket acquire hClose (\handle -> loop handle 0 SHA256.init)+  where+    acquire = bracketOnError (openFd path ReadOnly defaultFileFlags {nonBlock = True}) closeFd $ \fd -> do+      status <- getFdStatus fd+      unless (isRegularFile status) (ioError (userError "input is not regular"))+      fdToHandle fd+    loop handle count context = do+      bytes <- Bytes.hGet handle 65536+      if Bytes.null bytes+        then pure (count, SHA256.finalize context)+        else do+          let next = SHA256.update context bytes+              total = count + fromIntegral (Bytes.length bytes)+          next `seq` total `seq` loop handle total next++encode :: Evidence -> Builder+encode (FileEvidence name _ size digest) = sized (Encoding.encodeUtf8 (inputNameText name)) <> word8 1 <> word64BE size <> byteString digest+encode (ValueEvidence name value) = sized (Encoding.encodeUtf8 (inputNameText name)) <> word8 2 <> sized (Encoding.encodeUtf8 value)++sized :: Bytes.ByteString -> Builder+sized bytes = word64BE (fromIntegral (Bytes.length bytes)) <> byteString bytes++-- | Re-resolve every selected file, including symlinks, and compare its bytes.+-- This checks boundaries; callers must keep inputs stable throughout execution.+verifyHookRevisionInputs :: CapturedRevision -> IO (Either RevisionError ())+verifyHookRevisionInputs (CapturedRevision _ evidence) = go evidence+  where+    go [] = pure (Right ())+    go (ValueEvidence {} : rest) = go rest+    go (FileEvidence name path size digest : rest) = do+      result <- try @IOException (hashFile path)+      case result of+        Right current | current == (size, digest) -> go rest+        _ -> pure (Left (InputsChanged name))

@@ -0,0 +1,24 @@+{-# LANGUAGE PackageImports #-}++module Hinagata.Prelude+  ( module X,+    module Control.Lens,+    wireOptions,+  )+where++import "aeson" Data.Aeson as X (FromJSON (..), Options, ToJSON (..), Value, defaultOptions)+import "aeson" Data.Aeson.Types as X (camelTo2)+import "base" Control.Applicative as X ((<|>))+import "base" Control.Monad as X (unless, void, when)+import "base" Data.List.NonEmpty as X (NonEmpty (..))+import "base" Data.Maybe as X (fromMaybe, isJust, isNothing)+import "base" GHC.Generics as X (Generic)+import "lens" Control.Lens+import "text" Data.Text as X (Text)+import "time" Data.Time as X (UTCTime)++-- | One wire-format policy for non-opaque records. Validated identifiers and+-- credential-bearing values receive hand-written instances instead.+wireOptions :: Options+wireOptions = defaultOptions

@@ -0,0 +1,104 @@+module Hinagata.Types+  ( DatabaseName,+    databaseNameText,+    mkDatabaseName,+    ProjectId,+    projectIdText,+    mkProjectId,+    RunId,+    runIdText,+    mkRunId,+    SqlIdentifier,+    sqlIdentifierText,+    mkSqlIdentifier,+    quoteSqlIdentifier,+    Port,+    portNumber,+    mkPort,+    Positive,+    positiveValue,+    mkPositive,+  )+where++import Data.ByteString qualified as ByteString+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Encoding+import Hinagata.Prelude++newtype DatabaseName = DatabaseName Text+  deriving stock (Eq, Ord, Show)++databaseNameText :: DatabaseName -> Text+databaseNameText (DatabaseName value) = value++mkDatabaseName :: Text -> Either Text DatabaseName+mkDatabaseName value = DatabaseName <$> validatePgIdentifier value++newtype SqlIdentifier = SqlIdentifier Text+  deriving stock (Eq, Ord, Show)++sqlIdentifierText :: SqlIdentifier -> Text+sqlIdentifierText (SqlIdentifier value) = value++mkSqlIdentifier :: Text -> Either Text SqlIdentifier+mkSqlIdentifier value = SqlIdentifier <$> validatePgIdentifier value++quoteSqlIdentifier :: SqlIdentifier -> Text+quoteSqlIdentifier (SqlIdentifier value) = "\"" <> Text.replace "\"" "\"\"" value <> "\""++validatePgIdentifier :: Text -> Either Text Text+validatePgIdentifier value+  | Text.null value = Left "PostgreSQL identifier is empty"+  | Text.any (== '\0') value = Left "PostgreSQL identifier contains NUL"+  | ByteString.length (Encoding.encodeUtf8 value) > 63 = Left "PostgreSQL identifier exceeds 63 UTF-8 bytes"+  | otherwise = Right value++newtype ProjectId = ProjectId Text+  deriving stock (Eq, Ord, Show)++projectIdText :: ProjectId -> Text+projectIdText (ProjectId value) = value++mkProjectId :: Text -> Either Text ProjectId+mkProjectId value = ProjectId <$> validateSlug "project ID" value++newtype RunId = RunId Text+  deriving stock (Eq, Ord, Show)++runIdText :: RunId -> Text+runIdText (RunId value) = value++mkRunId :: Text -> Either Text RunId+mkRunId value = RunId <$> validateSlug "run ID" value++validateSlug :: Text -> Text -> Either Text Text+validateSlug label value+  | Text.null value = Left (label <> " is empty")+  | Text.length value > 63 = Left (label <> " exceeds 63 characters")+  | Text.all valid value = Right value+  | otherwise = Left (label <> " must use lowercase ASCII letters, digits, '-' or '_'")+  where+    valid character = (character >= 'a' && character <= 'z') || (character >= '0' && character <= '9') || character == '-' || character == '_'++newtype Port = Port Int+  deriving stock (Eq, Ord, Show)++portNumber :: Port -> Int+portNumber (Port value) = value++mkPort :: Int -> Either Text Port+mkPort value+  | value >= 1 && value <= 65535 = Right (Port value)+  | otherwise = Left "port must be between 1 and 65535"++newtype Positive = Positive Int+  deriving stock (Eq, Ord, Show)++positiveValue :: Positive -> Int+positiveValue (Positive value) = value++mkPositive :: Text -> Int -> Either Text Positive+mkPositive label value+  | value > 0 = Right (Positive value)+  | otherwise = Left (label <> " must be positive")

@@ -0,0 +1,404 @@+module Main (main) where++import Control.Monad (replicateM_)+import Data.ByteString.Char8 qualified as ByteString+import Data.List (isInfixOf, sort)+import Data.Text qualified as Text+import Hinagata.Config (AccessConfig (..), CloneStrategy (..), HinagataConfig (..), SchemaGrant (..), SchemaPrivilege (..), hinagataConfig, hinagataEnvironmentBindings)+import Hinagata.Connection+import Hinagata.Fixture.Bundle qualified as Bundle+import Hinagata.Fixture.Graph+import Hinagata.Fixture.Manifest+import Hinagata.Fixture.SqlPolicy+import Hinagata.Fixture.Types+import Hinagata.Hook.Revision qualified as Revision+import Hinagata.Prelude+import Hinagata.Types+import Settei qualified+import Settei.Env qualified as Env+import System.Directory (createDirectoryIfMissing, createFileLink, getModificationTime, removeFile, setModificationTime)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.IO (IOMode (WriteMode), withBinaryFile)+import System.IO.Temp (withSystemTempDirectory)+import System.Posix.Files (createNamedPipe, setFileMode)+import System.Posix.User (getEffectiveUserID)++main :: IO ()+main = do+  args <- getArgs+  case args of+    ["--csv-memory-probe", size, workspace] -> csvMemoryProbe (read size) workspace+    _ -> regressionTests++regressionTests :: IO ()+regressionTests = do+  let a = fixture "a" ["b", "c"]+      b = fixture "b" ["d"]+      c = fixture "c" ["d"]+      d = fixture "d" []+  assert "diamond closure" (fmap (map name) (resolveFixtures [a, b, c, d] [fixtureName "a"]) == Right (map fixtureName ["d", "b", "c", "a"]))+  assert "stable root order" (fmap (map name) (resolveFixtures [a, b, c, d] (map fixtureName ["c", "a"])) == Right (map fixtureName ["d", "c", "b", "a"]))+  assert "cycle path" (resolveFixtures [fixture "a" ["b"], fixture "b" ["c"], fixture "c" ["a"]] [fixtureName "a"] == Left (FixtureCycle (map fixtureName ["a", "b", "c", "a"])))+  assert "missing dependency path" (resolveFixtures [fixture "a" ["b"]] [fixtureName "a"] == Left (MissingFixture (fixtureName "b") (map fixtureName ["a", "b"])))+  assert "duplicate definition" (resolveFixtures [a, a] [fixtureName "a"] == Left (DuplicateFixture (fixtureName "a")))+  assert "Unicode byte limit" (either (const True) (const False) (mkDatabaseName (Text.replicate 32 "é")))+  assert "quoted SQL identifier" (fmap quoteSqlIdentifier (mkSqlIdentifier "x\"y") == Right "\"x\"\"y\"")+  assert "zero port rejected" (either (const True) (const False) (mkPort 0))+  assert "socket must be absolute" (either (const True) (const False) (socketDirectory "relative"))+  let target = do+        host <- socketDirectory "/tmp/a b'c\\d"+        port <- mkPort 5432+        database <- mkDatabaseName "example"+        password <- mkSecret "p'\\secret"+        mkConnectionTarget host port "service" database (Just password)+  assert "keyword escaping" (fmap (connectionStringText . renderConnectionString) target == Right "host='/tmp/a b\\'c\\\\d' hostaddr='' port='5432' user='service' dbname='example' password='p\\'\\\\secret'")+  assert "connection display redacts password" (all (not . (`isInfixOf` show target)) ["p'", "secret"])+  let validManifest =+        ByteString.pack+          ( unlines+              [ "name: example",+                "include: [common]",+                "steps:",+                "  - sql: prepare.sql",+                "  - copy:",+                "      table: {schema: app, name: members}",+                "      columns: [id, email]",+                "      file: members.csv",+                "      format: csv",+                "      header: true"+              ]+          )+  assert+    "manifest ordering"+    ( fmap (steps . manifestDefinition) (decodeManifest (fixtureName "example") validManifest)+        == Right+          [ SqlFile "prepare.sql",+            CopyCsv+              CopySpec+                { schema = sqlIdentifier "app",+                  table = sqlIdentifier "members",+                  columns = map sqlIdentifier ["id", "email"],+                  file = "members.csv",+                  header = True+                }+          ]+    )+  assert "unknown manifest fields rejected" (isManifestError (decodeManifest (fixtureName "example") (ByteString.pack "name: example\nunknown: true\nsteps: [{sql: fixture.sql}]\n")))+  assert "empty explicit steps rejected" (isManifestError (decodeManifest (fixtureName "example") (ByteString.pack "name: example\nsteps: []\n")))+  assert "directory/name mismatch rejected" (isManifestError (decodeManifest (fixtureName "other") validManifest))+  assert "path traversal rejected" (isManifestError (decodeManifest (fixtureName "example") (ByteString.pack "name: example\nsteps: [{sql: ../outside.sql}]\n")))+  assert "transaction control rejected" (checkSqlPolicy (ByteString.pack "/* comment */ BEGIN; SELECT 1") == Left (ForbiddenStatement "begin"))+  assert "nested comment does not conceal command" (checkSqlPolicy (ByteString.pack "/* outer /* nested */ end */ COPY x FROM STDIN") == Left (ForbiddenStatement "copy"))+  assert "dollar function body is opaque" (checkSqlPolicy (ByteString.pack "CREATE FUNCTION f() RETURNS void AS $$ BEGIN; COPY x FROM STDIN; END; $$ LANGUAGE plpgsql;") == Right ())+  assert "escape string is opaque" (checkSqlPolicy (ByteString.pack "SELECT E'abc\\'; COPY x FROM STDIN';") == Right ())+  assert "psql command rejected" (checkSqlPolicy (ByteString.pack "  \\i fixture.sql") == Left PsqlCommand)+  assert "NUL SQL rejected before libpq truncation" (checkSqlPolicy (ByteString.pack "SELECT 1;\0DELETE FROM users") == Left SqlContainsNul)+  assert "PREPARE TRANSACTION rejected" (checkSqlPolicy (ByteString.pack "PREPARE TRANSACTION 'x'") == Left (ForbiddenStatement "TRANSACTION"))+  assert "SQL PREPARE remains allowed" (checkSqlPolicy (ByteString.pack "PREPARE q AS SELECT 1") == Right ())+  assert+    "all top-level transaction forms rejected"+    ( all+        (isSqlPolicyError . checkSqlPolicy . ByteString.pack)+        ["START TRANSACTION", "COMMIT", "END", "ROLLBACK", "ABORT", "SAVEPOINT x", "RELEASE SAVEPOINT x"]+    )+  assert "standard string and quoted identifier are opaque" (checkSqlPolicy (ByteString.pack "SELECT 'BEGIN; COPY', \"COMMIT;\" FROM x;") == Right ())+  let whitespace = [" ", "\t", "\n", "\r", "\f", "\v"]+      forbidden = ["BEGIN", "COMMIT", "END", "ROLLBACK", "ABORT", "SAVEPOINT x", "RELEASE SAVEPOINT x", "COPY x FROM STDIN"]+  assert+    "all PostgreSQL ASCII whitespace preserves statement starts"+    ( all+        (isSqlPolicyError . checkSqlPolicy . ByteString.pack)+        [prefix ++ gap ++ statement | gap <- whitespace, statement <- forbidden, prefix <- ["", "SELECT 1;", "/* comment */", "-- comment\n"]]+    )+  assert+    "all PostgreSQL whitespace preserves transaction prefixes"+    ( all+        (isSqlPolicyError . checkSqlPolicy . ByteString.pack)+        [prefix ++ gap ++ "TRANSACTION 'x'" | gap <- whitespace, prefix <- ["START", "PREPARE"]]+    )+  assert+    "whitespace before psql commands preserves line start"+    (all ((== Left PsqlCommand) . checkSqlPolicy . ByteString.pack . (++ "\\i fixture.sql")) whitespace)+  assert+    "whitespace and forbidden words remain opaque inside literals and comments"+    ( all+        ((== Right ()) . checkSqlPolicy . ByteString.pack)+        ["SELECT '" ++ gap ++ "COMMIT;'; SELECT E'" ++ gap ++ "ROLLBACK;'; SELECT \"" ++ gap ++ "COPY\"; SELECT $$" ++ gap ++ "BEGIN;$$; /*" ++ gap ++ "COMMIT;*/ SELECT 1; --ROLLBACK" ++ gap ++ "\n" | gap <- whitespace]+    )+  configTests+  bundleTests+  revisionTests++-- | Run this in a fresh process with +RTS -s. The fixture data is generated+-- and captured in fixed chunks so maximum live residency can be compared for+-- 1x and 10x CSV inputs without materializing the CSV in this test process.+csvMemoryProbe :: Int -> FilePath -> IO ()+csvMemoryProbe byteCount workspace = do+  let fixtureRoot = workspace </> "fixtures"+      fixtureDirectory = fixtureRoot </> "bulk"+      bundleRoot = workspace </> "bundles"+      chunk = ByteString.replicate 65536 'A'+  createDirectoryIfMissing True fixtureDirectory+  ByteString.writeFile (fixtureDirectory </> "fixture.yaml") "name: bulk\nsteps:\n  - copy:\n      table: {schema: public, name: bulk}\n      columns: [payload]\n      file: bulk.csv\n      format: csv\n      header: false\n"+  withBinaryFile (fixtureDirectory </> "bulk.csv") WriteMode $ \handle ->+    replicateM_ (byteCount `div` ByteString.length chunk) (ByteString.hPut handle chunk)+  let config = Bundle.BundleConfig fixtureRoot bundleRoot (positive 1024) (positive 65536)+  result <- Bundle.compileFixtures config [fixtureName "bulk"]+  case result of+    Right plan -> putStrLn (Text.unpack (Bundle.planDigest plan))+    Left problem -> fail (show problem)++configTests :: IO ()+configTests = do+  validated <- case hinagataEnvironmentBindings of+    Right result -> pure result+    Left errors -> fail (show errors)+  assert "explicit environment binding count" (length (Env.bindingsList validated) == 30)+  assert "every declared setting has an environment binding" (sort (map Settei.schemaSettingKey (Settei.schemaPossible (Settei.describe hinagataConfig))) == sort (map Env.bindingKey (Env.bindingsList validated)))+  let low =+        sourceOrFail+          "config"+          Settei.BuiltInSource+          [ ("endpoint.host", "/tmp/postgresql"),+            ("endpoint.port", "5432"),+            ("project.id", "example"),+            ("fixture.root", "/tmp/fixtures"),+            ("bundle.root", "/tmp/bundles"),+            ("maintenance.database", "postgres"),+            ("administration.user", "admin"),+            ("administration.database", "postgres"),+            ("setup.user", "migrator"),+            ("setup.database", "template"),+            ("application.user", "service"),+            ("application.database", "testdb")+          ]+      env =+        Env.environmentSource+          validated+          ( Env.envSnapshot+              [ ("HINAGATA_APPLICATION_USER", "app_override"),+                ("HINAGATA_APPLICATION_PASSWORD", "top-secret-credential"),+                ("HINAGATA_CLONE_STRATEGY", "FILE_COPY")+              ]+          )+      resolved = Settei.resolve Settei.defaultResolveOptions [low, env] hinagataConfig+  case Settei.answer resolved of+    Left errors -> fail (Text.unpack (Settei.renderErrorsText errors))+    Right config -> do+      assert "later Settei source wins" (user (application config) == "app_override")+      assert "clone strategy supplied explicitly" (cloneStrategy config == FileCopy)+      assert "admin and app roles stay separate" (user (administration config) == "admin")+      assert "setup has explicit public schema CREATE" (any (\grant -> privilege grant == SchemaCreate) (setupSchemaGrants config))+      assert "visible WAL_LOG default overridden" (Text.isInfixOf "FILE_COPY" (Settei.renderResolutionText (Settei.report resolved)))+      assert "secret redacted on success" (not (Text.isInfixOf "top-secret-credential" (Settei.renderResolutionText (Settei.report resolved))))+      assert "secret redacted in typed config" (not (isInfixOf "top-secret-credential" (show config)))+  let bad = Env.environmentSource validated (Env.envSnapshot [("HINAGATA_APPLICATION_PASSWORD", "bad\0password"), ("HINAGATA_ENDPOINT_PORT", "0")])+      failed = Settei.resolve Settei.defaultResolveOptions [low, bad] hinagataConfig+      errorText = either Settei.renderErrorsText (const "") (Settei.answer failed)+  assert "bad settings rejected" (either (const True) (const False) (Settei.answer failed))+  assert "secret redacted on failure" (not (Text.isInfixOf "bad\0password" (errorText <> Settei.renderResolutionText (Settei.report failed))))+  let defaults = Settei.resolve Settei.defaultResolveOptions [low] hinagataConfig+  assert "default strategy visible" (Text.isInfixOf "clone.strategy = WalLog" (Settei.renderResolutionText (Settei.report defaults)))+  assert "no database default permits mutation" (either (const True) (const False) (Settei.answer (Settei.resolve Settei.defaultResolveOptions [] hinagataConfig)))++sourceOrFail :: Text -> Settei.SourceKind -> [(Text, Text)] -> Settei.Source+sourceOrFail name kind values =+  case Settei.sourceFromPairs name kind [(settingKey, Settei.RawText value) | (rawKey, value) <- values, Right settingKey <- [Settei.parseKey rawKey]] of+    Right result -> result+    Left errors -> error (show errors)++bundleTests :: IO ()+bundleTests = withSystemTempDirectory "hinagata-core-test-" $ \workspace -> do+  let fixtureRoot = workspace </> "fixtures"+      bundleRoot = workspace </> "bundles"+      fixtureDirectory = fixtureRoot </> "example"+      sqlPath = fixtureDirectory </> "fixture.sql"+      config =+        Bundle.BundleConfig+          { Bundle.fixtureRoot = fixtureRoot,+            Bundle.bundleRoot = bundleRoot,+            Bundle.sqlSizeLimit = positive 1024,+            Bundle.chunkSize = positive 7+          }+  createDirectoryIfMissing True fixtureDirectory+  ByteString.writeFile sqlPath "SELECT 1;"+  first <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "example"]+  again <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "example"]+  assert "bundle digest deterministic" (Bundle.planDigest first == Bundle.planDigest again)+  assert "verified bundle reused" (Bundle.planDirectory first == Bundle.planDirectory again)+  let capturedPath = Bundle.planDirectory first </> "step-0"+  assert "bundle contains captured bytes" =<< ((== "SELECT 1;") <$> ByteString.readFile capturedPath)+  ByteString.writeFile capturedPath "corrupted"+  rebuilt <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "example"]+  assert "modified cache rebuilt" (Bundle.planDigest first == Bundle.planDigest rebuilt && Bundle.planDirectory first /= Bundle.planDirectory rebuilt)+  ByteString.writeFile sqlPath "SELECT 2;"+  changed <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "example"]+  assert "source bytes change digest" (Bundle.planDigest changed /= Bundle.planDigest first)+  assert "existing plan retains frozen bytes" =<< ((== "SELECT 1;") <$> ByteString.readFile (Bundle.planDirectory rebuilt </> "step-0"))+  ByteString.writeFile sqlPath "BEGIN;"+  invalidSql <- Bundle.compileFixtures config [fixtureName "example"]+  assert "invalid SQL rejected before plan publication" (case invalidSql of Left (Bundle.InvalidSql _ _) -> True; _ -> False)+  let outsideFile = workspace </> "outside.sql"+  ByteString.writeFile outsideFile "SELECT 3;"+  createFileLink outsideFile (fixtureDirectory </> "escape.sql")+  ByteString.writeFile (fixtureDirectory </> "fixture.yaml") "name: example\nsteps: [{sql: escape.sql}]\n"+  escaped <- Bundle.compileFixtures config [fixtureName "example"]+  assert "symlink escape rejected" (case escaped of Left (Bundle.UnsafePath _) -> True; _ -> False)+  let brokenDirectory = fixtureRoot </> "broken"+  createDirectoryIfMissing True brokenDirectory+  ByteString.writeFile (brokenDirectory </> "fixture.sql") "SELECT 1;"+  createFileLink (workspace </> "missing.yaml") (brokenDirectory </> "fixture.yaml")+  broken <- Bundle.compileFixtures config [fixtureName "broken"]+  assert "broken manifest symlink rejected" (case broken of Left (Bundle.UnsafePath _) -> True; _ -> False)+  let copyDirectory = fixtureRoot </> "members"+      copyManifest = copyDirectory </> "fixture.yaml"+      csvPath = copyDirectory </> "members.csv"+  createDirectoryIfMissing True copyDirectory+  ByteString.writeFile csvPath "id\n1\n"+  ByteString.writeFile copyManifest "name: members\nsteps:\n  - copy:\n      table: {schema: app, name: members}\n      columns: [id]\n      file: members.csv\n      format: csv\n      header: true\n"+  copyOne <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "members"]+  ByteString.writeFile copyManifest "name: members\nsteps:\n  - copy:\n      table: {schema: app, name: members}\n      columns: [id]\n      file: members.csv\n      format: csv\n      header: false\n"+  copyTwo <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "members"]+  assert "COPY option changes digest" (Bundle.planDigest copyOne /= Bundle.planDigest copyTwo)+  ByteString.writeFile csvPath "id\n2\n"+  copyThree <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "members"]+  assert "CSV bytes change digest" (Bundle.planDigest copyTwo /= Bundle.planDigest copyThree)+  let leftDirectory = fixtureRoot </> "left"+      rightDirectory = fixtureRoot </> "right"+      scenarioDirectory = fixtureRoot </> "scenario"+  mapM_ (createDirectoryIfMissing True) [leftDirectory, rightDirectory, scenarioDirectory]+  ByteString.writeFile (leftDirectory </> "fixture.sql") "SELECT 10;"+  ByteString.writeFile (rightDirectory </> "fixture.sql") "SELECT 20;"+  ByteString.writeFile (scenarioDirectory </> "fixture.sql") "SELECT 30;"+  ByteString.writeFile (scenarioDirectory </> "fixture.yaml") "name: scenario\ninclude: [left, right]\nsteps: [{sql: fixture.sql}]\n"+  orderOne <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "scenario"]+  ByteString.writeFile (scenarioDirectory </> "fixture.yaml") "name: scenario\ninclude: [right, left]\nsteps: [{sql: fixture.sql}]\n"+  orderTwo <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "scenario"]+  assert "include order changes digest" (Bundle.planDigest orderOne /= Bundle.planDigest orderTwo)+  base <- bundleOrFail =<< Bundle.compileFixtures config (map fixtureName ["members", "left", "right"])+  let composed = Bundle.composePlans base orderOne+  assert "base prefix retains unrelated fixtures" (case composed of Right result -> length (Bundle.basePrefix result) == 3 && length (Bundle.scenarioRemainder result) == 1; _ -> False)+  case composed of+    Left _ -> fail "expected composable plans"+    Right selected -> do+      assert "scenario remainder verifies" =<< Bundle.verifyComposedRemainder orderOne selected+      (sharedStep, suffixStep) <- case (Bundle.planFixtures orderOne, Bundle.scenarioRemainder selected) of+        (shared : _, suffix : _) -> case (Bundle.steps shared, Bundle.steps (Bundle.fixture suffix)) of+          (sharedStep : _, suffixStep : _) -> pure (sharedStep, suffixStep)+          _ -> fail "expected shared and suffix steps"+        _ -> fail "expected shared and suffix fixtures"+      let sharedPath = Bundle.planDirectory orderOne </> Bundle.relativePath sharedStep+          suffixPath = Bundle.planDirectory orderOne </> Bundle.relativePath suffixStep+      ByteString.writeFile sharedPath "corrupted shared bytes"+      assert "complete plan detects changed shared bytes" . not =<< Bundle.verifyPlan orderOne+      assert "clone skips already sealed shared bytes" =<< Bundle.verifyComposedRemainder orderOne selected+      ByteString.writeFile suffixPath "corrupted scenario bytes"+      assert "clone rejects changed scenario suffix" . not =<< Bundle.verifyComposedRemainder orderOne selected+  assert "COPY option conflict rejected" (Bundle.composePlans copyOne copyTwo == Left (Bundle.ConflictingFixture (fixtureName "members")))+  ByteString.writeFile (leftDirectory </> "fixture.sql") "SELECT 11;"+  changedShared <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "scenario"]+  assert "shared byte conflict rejected" (Bundle.composePlans base changedShared == Left (Bundle.ConflictingFixture (fixtureName "left")))+  ByteString.writeFile (leftDirectory </> "fixture.sql") "SELECT 10;"+  ByteString.writeFile (leftDirectory </> "fixture.yaml") "name: left\ninclude: [right]\nsteps: [{sql: fixture.sql}]\n"+  changedIncludes <- bundleOrFail =<< Bundle.compileFixtures config [fixtureName "scenario"]+  assert "shared dependency conflict rejected" (Bundle.composePlans base changedIncludes == Left (Bundle.ConflictingFixture (fixtureName "left")))++bundleOrFail :: Either Bundle.BundleError Bundle.FixturePlan -> IO Bundle.FixturePlan+bundleOrFail = either (fail . show) pure++positive :: Int -> Positive+positive value = either (error . show) id (mkPositive "test" value)++fixture :: Text -> [Text] -> FixtureDefinition+fixture fixtureNameValue includeNames =+  FixtureDefinition+    { name = fixtureName fixtureNameValue,+      includes = map fixtureName includeNames,+      steps = [SqlFile "fixture.sql"]+    }++fixtureName :: Text -> FixtureName+fixtureName value = either (error . show) id (mkFixtureName value)++assert :: String -> Bool -> IO ()+assert label success = unless success $ do+  putStrLn ("FAIL: " ++ label)+  exitFailure++sqlIdentifier :: Text -> SqlIdentifier+sqlIdentifier value = either (error . show) id (mkSqlIdentifier value)++isManifestError :: Either ManifestError a -> Bool+isManifestError (Left _) = True+isManifestError (Right _) = False++isSqlPolicyError :: Either SqlPolicyError () -> Bool+isSqlPolicyError (Left _) = True+isSqlPolicyError (Right ()) = False++-- Fixed vectors are independently calculated from the version-1 binary format.+revisionTests :: IO ()+revisionTests = withSystemTempDirectory "hook-revision" $ \root -> do+  let name = either (error . show) id . Revision.mkInputName+      file label path = Revision.FileInput (name label) path+      value label text = Revision.ValueInput (name label) text+      derive inputs = Revision.deriveHookRevision inputs >>= either (fail . show) pure+      digest inputs = Revision.hookRevision <$> derive inputs+      rejected label inputs = Revision.deriveHookRevision inputs >>= assert label . either (const True) (const False)+      a = root </> "a"+      b = root </> "b"+  createDirectoryIfMissing True a+  createDirectoryIfMissing True b+  ByteString.writeFile (a </> "sql") "abc"+  ByteString.writeFile (b </> "sql") "abc"+  captured <- derive [file "sql" (a </> "sql"), value "marker" "é=\n"]+  let original = Revision.hookRevision captured+  assert "revision known answer file and UTF8 value" (original == "hinagata-hook-revision-v1:sha256:a63a56ff32994b9b2808afb2ff6378008b60208554fa07208dce418c4e0d88af")+  emptyValue <- digest [value "value" ""]+  assert "revision known answer empty value" (emptyValue == "hinagata-hook-revision-v1:sha256:2c43685f19a86f7630b96a5899b145d85c55a6a2c00c285ddb45dcf107e7cea6")+  relocated <- digest [value "marker" "é=\n", file "sql" (b </> "sql")]+  assert "revision order and relocation independent" (original == relocated)+  before <- getModificationTime (a </> "sql")+  setModificationTime (a </> "sql") (read "2000-01-01 00:00:00 UTC")+  after <- getModificationTime (a </> "sql")+  same <- digest [file "sql" (a </> "sql"), value "marker" "é=\n"]+  assert "revision excludes timestamps" (before /= after && same == original)+  unchanged <- Revision.verifyHookRevisionInputs captured+  assert "revision verifies stable bytes" (unchanged == Right ())+  mapM_+    (\inputs -> digest inputs >>= assert "revision changes with identity" . (/= original))+    [ [file "renamed" (a </> "sql"), value "marker" "é=\n"],+      [file "sql" (a </> "sql"), value "marker" "é="],+      [value "sql" "abc", value "marker" "é=\n"]+    ]+  boundaryA <- digest [value "a" "b=c\nd"]+  boundaryB <- digest [value "a" "b=c", value "d" ""]+  assert "revision framing distinguishes delimiters" (boundaryA /= boundaryB)+  ByteString.writeFile (a </> "sql") "abd"+  changed <- digest [file "sql" (a </> "sql"), value "marker" "é=\n"]+  assert "revision hashes exact bytes" (changed /= original)+  Revision.verifyHookRevisionInputs captured >>= assert "revision detects changed content" . either (const True) (const False)+  rejected "revision requires inputs" []+  rejected "revision rejects duplicate kinds" [file "sql" (a </> "sql"), value "sql" "x"]+  rejected "revision rejects duplicate executable" [value "executable" "a", value "executable" "b"]+  mapM_+    (\label -> assert "revision invalid name" (Revision.mkInputName label == Left Revision.InvalidInputName))+    ["", "A", "a//b", "a/./b", "a/../b", "a/", "a=b", "a\nb", "é"]+  rejected "revision missing file" [file "missing" (root </> "private-missing-sentinel")]+  rejected "revision directory" [file "directory" a]+  createNamedPipe (root </> "pipe") 0o600+  rejected "revision refuses pipe without blocking" [file "pipe" (root </> "pipe")]+  createFileLink (a </> "sql") (root </> "link")+  linked <- derive [file "sql" (root </> "link")]+  ByteString.writeFile (a </> "sql") "abe"+  Revision.verifyHookRevisionInputs linked >>= assert "revision detects changed symlink target" . either (const True) (const False)+  removeFile (a </> "sql")+  Revision.verifyHookRevisionInputs linked >>= assert "revision detects deleted symlink target" . either (const True) (const False)+  rejected "revision dangling symlink" [file "sql" (root </> "link")]+  uid <- getEffectiveUserID+  assert "permission regression must run unprivileged" (uid /= 0)+  setFileMode (b </> "sql") 0o000+  rejected "revision unreadable file with real permission boundary" [file "sql" (b </> "sql")]+  setFileMode (b </> "sql") 0o600