diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,74 @@ +# Changelog + +All notable changes to the valiant project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [0.1.0.0] - 2026-04-25 + +Initial release. The project ships four primary packages plus eight adapter +libraries. + +### Packages + +- **pg-wire** 0.1.0.0: pure-Haskell PostgreSQL v3 wire-protocol driver. No + libpq, no C dependencies. Includes a connection pool with idle reaping, + health checks, jittered max-life, queue mode (LIFO/FIFO), recycling + modes, lifecycle hooks, and `nothunks`-checked invariants. +- **valiant** 0.1.0.0: runtime library. Binary codecs for all common + PostgreSQL types (numerics, text, time, UUID, JSON/JSONB, hstore, inet, + macaddr, point, ranges, arrays, composites, enums), a `Statement` type, + query execution, server-side cursor streaming, pipelined execution, + COPY in/out, large objects, LISTEN/NOTIFY, advisory locks, transactions, + and re-exports from `pg-wire`. +- **valiant-cli** 0.1.0.0: `valiant` CLI with `prepare`, `check`, + `types`, `generate`, and `watch` commands. +- **valiant-plugin** 0.1.0.0: GHC source plugin that validates SQL files + against the `.valiant/` cache at compile time. + +### Adapters + +Eight first-party adapters for popular effect systems and streaming +libraries: `valiant-bluefin`, `valiant-conduit`, `valiant-effectful`, +`valiant-fused-effects`, `valiant-mtl`, `valiant-pipes`, +`valiant-streaming`, `valiant-streamly`. + +### Highlights + +- **Compile-time SQL safety.** Raw `.sql` files are validated against a + live PostgreSQL database via `valiant prepare` and a `.valiant/` cache. + The GHC source plugin checks parameter and result types at compile + time. No Template Haskell. +- **Performance.** Roughly 5x faster than hasql on multi-row reads and + 10x faster on pipelined batch writes in our comparative benchmarks + (`bench-compare`). Competitive with asyncpg (Python) on throughput. +- **Wire protocol features.** Extended query protocol with binary + format, statement caching, prepared statements, server-side cursors, + pipelining, COPY in/out (including CSV), large objects, + LISTEN/NOTIFY, query cancellation, cleartext, MD5, and SCRAM-SHA-256 + authentication. +- **Strict by default.** `StrictData`, `-funbox-strict-fields`, and + `-fspecialise-aggressively` across all libraries. `-fno-full-laziness` + on streaming-sensitive modules. `nothunks` invariants on the pool. +- **Tested.** 267 unit tests in `pg-wire`, 282 in `valiant`, 101 + integration tests against a real Postgres, plus property tests with + hedgehog and a state-machine test for the connection pool. + +### Added (post-tag) + +- `refine` and `refineWith` combinators in `Valiant.Binary.Decode` for + validating decoded values against extra invariants without writing a + full `PgDecode` instance. +- `fetchAllUnboxed`: an unboxed-vector variant of `fetchAllVec` for + fixed-size primitive result columns. Eliminates per-element pointer + indirection for `Int32`/`Int64`/`Double`/`Bool` and tuples of those. + +### Documentation + +- Tutorial, performance notes, asyncpg comparison, async architecture, + and gap analysis under `docs/`. +- Per-package READMEs for `pg-wire`, `valiant`, `valiant-cli`, + `valiant-plugin`, and each adapter. + +[0.1.0.0]: https://github.com/joshburgess/valiant/releases/tag/v0.1.0.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2026 Josh Burgess + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,410 @@ +# valiant + +**Compile-time checked SQL for Haskell.** + +Inspired by Rust's [sqlx](https://github.com/launchbadge/sqlx), built from scratch for Haskell. No Template Haskell. No `libpq`. No C dependencies. Raw `.sql` files validated against a live Postgres database at prepare time, with a GHC source plugin that enforces type safety at compile time. The fastest Haskell PostgreSQL library: 5x faster than hasql on multi-row reads, 10x faster on pipelined batch writes, competitive with asyncpg (Python) on throughput. + +## How it works + +``` + .sql files ──> valiant prepare ──> .valiant/ cache ──> GHC plugin ──> type-safe Haskell + (live DB) (committed) (compile time) +``` + +1. Write SQL in standalone `.sql` files with full editor support +2. Run `valiant prepare` to validate queries against your database and cache type metadata +3. The GHC source plugin reads the cache at compile time and verifies your Haskell types match +4. At runtime, a custom Postgres wire protocol driver executes queries with binary format encoding + +## Quick start + +```haskell +-- sql/users/find_by_id.sql: +-- SELECT id, name, email FROM users WHERE id = $1 + +{-# OPTIONS_GHC -fplugin=Valiant.Plugin + -fplugin-opt=Valiant.Plugin:sql-dir=sql #-} + +module MyApp.Queries.Users where + +import Valiant + +findById :: Statement Int32 (Maybe (Int32, Text, Maybe Text)) +findById = queryFile "users/find_by_id.sql" +``` + +The plugin verifies at compile time that: +- The `.sql` file exists +- `Int32` matches the `$1` parameter (Postgres `int4`) +- `(Int32, Text, Maybe Text)` matches the result columns +- `email` is correctly wrapped in `Maybe` (it's nullable) + +If anything is wrong, you get a clear compile error: + +``` +src/MyApp/Queries/Users.hs:12:1: error: [VALIANT-003] + + -- Result type mismatch + | + | Comparing column by column: + | + | Column Postgres type Your type Expected + | id int4 Int32 Int32 ok + | name text Text Text ok + | email text (nullable) Text Maybe Text MISMATCH + | + -- Fix: wrap the field in Maybe: Maybe Text +``` + +## Runtime usage + +```haskell +import Valiant +import MyApp.Queries.Users qualified as Q + +main :: IO () +main = do + pool <- newPool defaultPoolConfig + { poolConnString = "postgres://user:pass@localhost:5432/mydb" + , poolSize = 10 + } + + -- Fetch one row + mUser <- withResource pool $ \conn -> + fetchOne conn Q.findById 42 + + -- Fetch all rows + users <- withResource pool $ \conn -> + fetchAll conn Q.listAll () + + -- Execute a command + n <- withResource pool $ \conn -> + execute conn Q.insert ("Alice", Just "alice@example.com") + + -- Batch insert (pipelined, eliminates per-row round-trips) + withResource pool $ \conn -> + executeBatch conn Q.insert + [ ("Alice", Just "alice@example.com") + , ("Bob", Just "bob@example.com") + , ("Carol", Nothing) + ] + + -- Transactions + withTransaction pool $ \tx -> do + execute (txConn tx) Q.insert ("Dave", Just "dave@example.com") + execute (txConn tx) Q.insert ("Eve", Nothing) + + -- Constant-memory streaming (no cursor/transaction needed) + total <- withResource pool $ \conn -> + executeWithFold conn Q.listAll () (RowFold 0 (\n _ -> n + 1)) +``` + +## CLI tool + +```bash +# Validate all .sql files against your database +$ valiant prepare + [1/10] sql/users/find_by_id.sql ............ ok + [2/10] sql/users/find_by_email.sql ......... ok + ... + Wrote 10 cache files to .valiant/ + +# Check cache freshness (for CI, no database needed) +$ valiant check + +# Print inferred Haskell types +$ valiant types + sql/users/find_by_id.sql + Params: Int32 + Result: (Int32, Text, Maybe Text) + +# Auto-generate Haskell binding modules +$ valiant generate --module-prefix MyApp.Queries --output-dir src/MyApp/Queries/ + Generated src/MyApp/Queries/Users.hs (7 queries) + Generated src/MyApp/Queries/Posts.hs (3 queries) + +# Watch for changes and re-prepare +$ valiant watch +``` + +## Performance + +valiant is the fastest Haskell PostgreSQL library. It implements its own wire +protocol in pure Haskell with binary format encoding, direct byte writes, +pipelined execution, async sender/receiver split, and zero unnecessary copies. + +Benchmarks against [hasql](https://hackage.haskell.org/package/hasql) +(libpq FFI, binary) and [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple) +(libpq FFI, text). Single connection, native Postgres 16. + +**Reads** (Linux benchmark host, Postgres 16, Unix socket): + +| Rows | valiant | hasql | pg-simple | vs hasql | vs pg-simple | +|------|-------|-------|-----------|----------|--------------| +| 1 (by PK) | 138 μs | 89 μs | 179 μs | 1.6x slower | **23% faster** | +| 1,000 | **895 μs** | 4.76 ms | 3.57 ms | **5.3x faster** | **4.0x faster** | +| 5,000 | **4.66 ms** | 25.5 ms | 20.0 ms | **5.5x faster** | **4.3x faster** | +| 10,000 | **11.0 ms** | 54.4 ms | 38.3 ms | **5.0x faster** | **3.5x faster** | + +valiant is 1.6x slower on single-row lookups (the async sender/receiver +split has per-query coordination overhead that dominates when there's +nothing to pipeline) but **5x faster** once row decoding dominates. + +**Writes (pipelined):** + +| Rows | valiant (pipelined) | valiant (seq) | hasql | pg-simple | +|------|--------------------|------------|-------|-----------| +| 100 | **956 μs** | 15.2 ms | 9.46 ms | 15.9 ms | + +Pipelined batch inserts are **9.9x faster** than hasql and **16.6x faster** +than postgresql-simple. + +**vs asyncpg (Python)** (CI-verified on the same GitHub Actions runner, Postgres 16, Unix socket): + +| Benchmark | asyncpg | valiant | +|-----------|---------|-------| +| SELECT 1+1 throughput (10 conns) | 30,279/s | **31,056/s** | +| fetch 1000 rows throughput | 2,819/s | **3,091/s** | +| batch insert 1000 (pipelined) | N/A | **173.8/s** | + +See [docs/benchmark-results/asyncpg-comparison.md](docs/benchmark-results/asyncpg-comparison.md) +for the full head-to-head comparison. + +**Why it's fast:** + +- **Binary format decoding** -- direct from network buffer, no FFI boundary +- **Direct byte writes** -- `unsafeCreate` + `pokeByteOff`, 5-6x faster than Builder for fixed-size types (30ns per Int32) +- **Pipelined execution** -- `executeBatch` sends N Bind+Execute pairs with 1 Sync, 40-100x faster than sequential +- **Sender/receiver split** -- dedicated writer+reader threads per connection, automatic pipelining for concurrent workloads +- **Fused Builder encoding** -- all protocol messages in a batch fused into one Builder, one allocation, one `send()` +- **Direct-to-Vector parsing** -- DataRow parsed directly into mutable Vector, no intermediate list +- **Pre-computed message sizes** -- single-pass protocol encoding, no double-copy +- **Message coalescing + TCP_NODELAY** -- single syscall per message sequence +- **Fused row decoding** -- decode as rows arrive, no intermediate list +- **Pure Haskell** -- no `libpq`, no C toolchain, no system dependencies + +| | libpq (FFI) | valiant (pure Haskell) | +|---|---|---| +| Single-row latency | **89 μs** (hasql) | 138 μs (1.6x slower) | +| Multi-row throughput (10K) | 54.4 ms (hasql) | **11.0 ms (5.0x faster)** | +| Batch writes (100 inserts) | 9.46 ms (hasql) | **956 μs (9.9x faster)** | +| vs asyncpg (Python) | N/A | **Faster on row throughput** | +| Build requirements | Needs `libpq-dev` | No system dependencies | + +See [docs/PERFORMANCE.md](docs/PERFORMANCE.md) for the full deep-dive: +codec benchmarks, pool benchmarks, architecture comparison, optimization +techniques, and the complete optimization journey. Archived numbers with +CSV data (Apple Silicon / macOS / Docker Postgres) are in +[docs/benchmark-results/](docs/benchmark-results/README.md); the +[`bench-compare`](bench-compare/README.md) suite reproduces the read, +insert, and asyncpg comparisons locally or via the +[Benchmarks workflow](.github/workflows/benchmarks.yml). + +## Project structure + +valiant is a multi-package Cabal project: + +| Package | Description | +|---------|-------------| +| `pg-wire` | Pure Haskell PostgreSQL v3 wire protocol driver, connection pool, auth, TLS | +| `valiant` | Runtime library: binary codecs, query execution, transactions, streaming, COPY | +| `valiant-cli` | CLI tool (`valiant prepare`, `check`, `types`, `generate`, `watch`) | +| `valiant-plugin` | GHC source plugin for compile-time query validation | +| `valiant-conduit` | Conduit streaming adapter | +| `valiant-pipes` | Pipes streaming adapter | +| `valiant-streaming` | `streaming` library adapter | +| `valiant-streamly` | Streamly streaming adapter | +| `valiant-bluefin` | Bluefin effect system adapter | +| `valiant-effectful` | Effectful effect system adapter | +| `valiant-fused-effects` | Fused-effects effect system adapter | +| `valiant-mtl` | MTL monad transformer adapter | +| `valiant-example` | Example REST API using valiant + scotty | +| [`bench-compare`](bench-compare/README.md) | Comparative benchmarks against hasql, postgresql-simple, persistent, and asyncpg | + +``` +valiant/ +├── wire/ # pg-wire: wire protocol, connection, pool, auth, TLS +│ ├── src/PgWire/ # Protocol messages, builders, parsers, async I/O +│ └── test/ # Wire protocol unit tests +├── runtime/ # valiant: runtime library +│ ├── src/Valiant/ # Binary codecs, execute, batch, pipeline, fold, copy, streaming +│ ├── bench/ # Codec + concurrent benchmarks (criterion) +│ ├── integration/ # Integration tests (require Postgres) +│ └── test/ # Codec unit tests +├── src/ # valiant-cli source +│ └── Valiant/CLI/ # Commands, cache, type map, discovery, nullability +├── plugin/ # GHC source plugin +│ └── src/Valiant/Plugin/ # AST traversal, verification, error messages +├── adapters/ # Streaming and effect system adapters (8 packages) +│ ├── valiant-conduit/ # Conduit adapter +│ ├── valiant-pipes/ # Pipes adapter +│ ├── valiant-streaming/ # streaming library adapter +│ ├── valiant-streamly/ # Streamly adapter +│ ├── valiant-bluefin/ # Bluefin effect system adapter +│ ├── valiant-effectful/ # Effectful effect system adapter +│ ├── valiant-fused-effects/ # Fused-effects adapter +│ └── valiant-mtl/ # MTL monad transformer adapter +├── example/ # Example REST API (scotty) +├── bench-compare/ # Comparative benchmarks vs hasql, pg-simple +├── scripts/ # pg-setup.sh, pg-teardown.sh +├── docs/ # TUTORIAL.md, PERFORMANCE.md, ASYNC_ARCHITECTURE.md +└── .valiant/ # Cached query metadata (committed to VCS) +``` + +## Features + +### SQL authoring +- One SQL statement per `.sql` file with full editor support +- Optional metadata comments: `-- valiant:name`, `-- valiant:result`, `-- valiant:single` +- Directory structure maps to Haskell module structure + +### Compile-time validation +- 6 structured error codes (`VALIANT-001`..`006`) with column-by-column diagnostics +- Nullability inference from `pg_attribute` +- Did-you-mean suggestions for mistyped file paths (Levenshtein distance) +- Type inference (no signature required) or typed hole discovery +- `addDependentFile` tracking: GHC recompiles when `.sql` files change + +### Type mapping + +| Postgres | Haskell | Postgres | Haskell | +|----------|---------|----------|---------| +| `bool` | `Bool` | `float4` | `Float` | +| `int2` | `Int16` | `float8` | `Double` | +| `int4` | `Int32` | `numeric` | `Scientific` | +| `int8` | `Int64` | `uuid` | `UUID` | +| `text` | `Text` | `json`/`jsonb` | `Value` | +| `bytea` | `ByteString` | `date` | `Day` | +| `varchar` | `Text` | `time` | `TimeOfDay` | +| `timestamp` | `LocalTime` | `timestamptz` | `UTCTime` | +| `interval` | `PgInterval` | `inet`/`cidr` | `PgInet` | +| `int4[]`, etc. | `Vector Int32`, etc. | | | + +Nullable columns are wrapped in `Maybe`. Custom types are auto-discovered +from `pg_type` at prepare time: enums map to `Text`, domains unwrap to +their base type, ranges map to `PgRange BaseType`. Manual overrides via +`valiant-types.json`. + +### Runtime +- Custom PostgreSQL v3 wire protocol implementation (no FFI, no `libpq`) +- Async sender/receiver split: dedicated writer+reader threads per connection + with automatic pipelining for concurrent workloads (7.2x scaling at 32 threads) +- Binary format encoding/decoding for all supported types +- Extended query protocol (Parse/Bind/Execute/Sync) with prepared statement caching +- Cross-connection shared statement cache at the pool level +- Pipelined batch execution (`executeBatch`) for high-throughput writes +- Pipeline Applicative for combining independent queries into one round-trip +- Fused Builder encoding and direct-to-Vector DataRow parsing +- Constant-memory streaming via `RowFold` (no cursor/transaction needed) +- Server-side cursors for large result sets within transactions +- Connection pooling with idle reaping, max lifetime, health checking, and + pool-level type cache +- SCRAM-SHA-256 (with channel binding), MD5, and cleartext authentication +- TLS 1.2/1.3 via the `tls` library, client certificates, CA validation +- Multi-host failover with `target_session_attrs` and `load_balance_hosts` +- Transactions with configurable isolation levels and savepoints +- LISTEN/NOTIFY for async notifications (callback-based, no polling) +- COPY IN/OUT for bulk data transfer (text, CSV, and binary formats) +- Query cancellation with `cancelQuery` and `withQueryTimeout` +- Composite, range, array, interval, and Scientific binary codecs +- `PgEnum` type class for Haskell sum types mapping to PG enums +- Protocol tracing via `setTraceHandler` callback +- Logging hooks for query timing and connection events + +## Workflow + +### Development + +```bash +# 1. Write a query +echo "SELECT id, name FROM users WHERE active = true" > sql/users/list_active.sql + +# 2. Validate against your dev database +export DATABASE_URL="postgres://localhost:5432/mydb" +valiant prepare + +# 3. Write (or generate) the Haskell binding +# 4. Build (the plugin checks everything at compile time) +cabal build +``` + +### CI + +```yaml +steps: + - name: Verify query cache + run: valiant check # no database needed + + - name: Build + run: cabal build + env: + VALIANT_OFFLINE: "true" # plugin reads from .valiant/ only +``` + +### Running benchmarks + +```bash +# Start Postgres via docker-compose (tuned for benchmarks) +docker compose up -d --wait +export DATABASE_URL="postgres://valiant_test:valiant_test@localhost:5433/valiant_test" + +# Codec benchmarks (pure, no database needed) +cabal bench valiant-bench --benchmark-options='--match prefix codec' + +# Query benchmarks +cabal bench valiant-bench --benchmark-options='--match prefix query' + +# Concurrent benchmarks (the async split showcase) +cabal bench valiant-bench --benchmark-options='+RTS -N -RTS --match prefix concurrent' + +# Comparative benchmarks vs hasql and postgresql-simple +# (requires system libpq: `brew install libpq` on macOS, then add its bin to PATH) +cabal run --project-file=cabal.project.bench bench-compare + +# Teardown +docker compose down +``` + +## Building from source + +Requires GHC 9.10.3 and Cabal 3.0+. v0.1 ships against a single GHC +version; multi-GHC support (9.6, 9.8, and newer) is planned for 0.1.x +once the plugin's GHC AST shims are in place. + +```bash +git clone https://github.com/joshburgess/valiant.git +cd valiant +cabal build all +cabal test pg-wire-test valiant-test valiant-cli-test valiant-plugin-test +``` + +All packages compile with `-Werror`. + +## Design decisions + +**Why not Template Haskell?** TH has stage restrictions, cross-compilation issues, and makes it hard to produce good error messages. A GHC source plugin runs after typechecking, has access to the full AST, and can emit rich diagnostics with source locations and custom formatting. + +**Why a separate prepare step?** Connecting to Postgres from inside the compiler (as Rust's sqlx does) causes well-known compilation speed issues and complicates CI. A separate CLI step + JSON cache keeps compilation fast and enables fully offline builds. + +**Why a custom wire protocol driver?** Full control over binary format encoding, connection management, and protocol features (pipelining, async I/O, COPY, LISTEN/NOTIFY, cursors) without depending on `libpq` or any existing Haskell database library. No system C dependencies means simpler builds and cross-compilation. And as the benchmarks show, pure Haskell binary decoding is faster than FFI-based alternatives on multi-row reads. + +**Why sender/receiver split?** The same architecture behind asyncpg's 3x advantage over psycopg2. Dedicated writer+reader threads per connection allow multiple green threads to pipeline queries automatically on a single connection, achieving 7.2x throughput scaling at 32 threads. + +## Comparison with Rust's sqlx + +| Aspect | Rust sqlx | valiant | +|--------|-----------|-------| +| SQL authoring | String literals or `.sql` files | `.sql` files (primary) | +| Compile-time mechanism | Proc macro | GHC source plugin | +| DB at compile time | From proc macro | Separate `valiant prepare` step | +| Offline mode | `.sqlx/` JSON cache | `.valiant/` JSON cache | +| Code generation | No | `valiant generate` (optional) | +| Runtime driver | Custom async Rust driver | Custom async Haskell driver | +| Concurrent I/O | Tokio async/await | Sender/receiver green threads | +| Error messages | Generic Rust type errors | Column-by-column diagnostics with fixes | +| Pipelining | Via driver internals | Explicit `executeBatch` + automatic via async split | +| Custom types | Trait impls | Auto-discovery from `pg_type` + `PgEnum` type class | + +## License + +BSD-3-Clause diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Valiant.CLI.App (run) + +main :: IO () +main = run diff --git a/src/Valiant/CLI/App.hs b/src/Valiant/CLI/App.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/App.hs @@ -0,0 +1,145 @@ +module Valiant.CLI.App + ( run + ) where + +import Valiant.CLI.Command.Check (runCheck) +import Valiant.CLI.Command.Generate (GenerateOpts (..), runGenerate) +import Valiant.CLI.Command.Prepare (runPrepare) +import Valiant.CLI.Command.Types (runTypes) +import Valiant.CLI.Command.Watch (runWatch) +import Valiant.CLI.Config (AppEnv (..), resolveEnv) +import Options.Applicative +import System.Exit (ExitCode, exitWith) + +-- | Entry point for the @valiant@ CLI. +run :: IO () +run = do + opts <- execParser parserInfo + env <- resolveEnv (optSqlDir opts) (optCacheDir opts) (optDatabaseUrl opts) (optVerbose opts) + code <- dispatch env (optCommand opts) + exitWith code + +-- CLI option types -------------------------------------------------------- + +data Opts = Opts + { optSqlDir :: FilePath + , optCacheDir :: FilePath + , optDatabaseUrl :: Maybe String + , optVerbose :: Bool + , optCommand :: Command + } + +data PrepareOpts = PrepareOpts + { prepInlineDirs :: [FilePath] + -- ^ Directories to scan for inline @query "..."@ calls in @.hs@ files. + } + +data Command + = CmdPrepare PrepareOpts + | CmdCheck + | CmdTypes (Maybe FilePath) + | CmdGenerate GenerateOpts + | CmdWatch + +-- Dispatch ---------------------------------------------------------------- + +dispatch :: AppEnv -> Command -> IO ExitCode +dispatch env = \case + CmdPrepare opts -> runPrepare env (prepInlineDirs opts) + CmdCheck -> runCheck env + CmdTypes mFile -> runTypes env mFile + CmdGenerate opts -> runGenerate env opts + CmdWatch -> runWatch env + +-- Parsers ----------------------------------------------------------------- + +parserInfo :: ParserInfo Opts +parserInfo = + info + (optsParser <**> helper) + ( fullDesc + <> header "valiant — compile-time checked SQL for Haskell" + <> progDesc "Validate .sql files against a live Postgres database and cache type metadata." + ) + +optsParser :: Parser Opts +optsParser = + Opts + <$> strOption + ( long "sql-dir" + <> metavar "DIR" + <> value "sql" + <> showDefault + <> help "Directory containing .sql files" + ) + <*> strOption + ( long "cache-dir" + <> metavar "DIR" + <> value ".valiant" + <> showDefault + <> help "Directory for cached query metadata" + ) + <*> optional + ( strOption + ( long "database-url" + <> metavar "URL" + <> help "PostgreSQL connection URL (overrides DATABASE_URL env var)" + ) + ) + <*> switch + ( long "verbose" + <> short 'v' + <> help "Enable verbose output" + ) + <*> commandParser + +commandParser :: Parser Command +commandParser = + subparser + ( command "prepare" + ( info + ( CmdPrepare . PrepareOpts + <$> many + ( strOption + ( long "inline" + <> metavar "DIR" + <> help "Scan .hs files in DIR for inline query \"...\" calls" + ) + ) + ) + (progDesc "Prepare all .sql files (and inline queries) against the database") + ) + <> command "check" (info (pure CmdCheck) (progDesc "Check that all cache files are current")) + <> command + "types" + ( info + ( CmdTypes + <$> optional (argument str (metavar "FILE" <> help "Show types for a specific .sql file")) + ) + (progDesc "Print inferred Haskell types for queries") + ) + <> command + "generate" + ( info + ( CmdGenerate + <$> ( GenerateOpts + <$> strOption + ( long "module-prefix" + <> metavar "PREFIX" + <> value "Queries" + <> showDefault + <> help "Module name prefix for generated modules" + ) + <*> strOption + ( long "output-dir" + <> metavar "DIR" + <> value "src" + <> showDefault + <> help "Output directory for generated Haskell files" + ) + ) + ) + (progDesc "Generate Haskell binding modules from .sql files") + ) + <> command "watch" (info (pure CmdWatch) (progDesc "Watch .sql files for changes and re-prepare")) + ) diff --git a/src/Valiant/CLI/Cache.hs b/src/Valiant/CLI/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Cache.hs @@ -0,0 +1,246 @@ +module Valiant.CLI.Cache + ( CacheEntry (..) + , CacheParam (..) + , CacheColumn (..) + , StatementType (..) + , writeCacheEntry + , readCacheEntry + , findCacheFile + , cacheFileName + , statementTypeFromSql + , ensureCacheDir + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecodeStrict, object, withObject, withText, (.:), (.:?), (.=)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.List (find, isSuffixOf) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime) +import Data.Word (Word32) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, listDirectory, renameFile) +import System.FilePath (()) + +-- | The full cache entry written to a @.valiant/*.json@ file. +data CacheEntry = CacheEntry + { ceVersion :: Text + , ceFile :: FilePath + , ceSqlHash :: Text + , ceSql :: Text + , ceDbUrlHash :: Text + , cePreparedAt :: UTCTime + , ceStatementType :: StatementType + , ceParams :: [CacheParam] + , ceColumns :: [CacheColumn] + } + deriving stock (Show, Eq) + +data StatementType = Select | Insert | Update | Delete | Other + deriving stock (Show, Eq) + +data CacheParam = CacheParam + { cpIndex :: Int + , cpName :: Maybe Text + -- ^ Named parameter name from @:name@ syntax. 'Nothing' for positional @$N@. + , cpPgOid :: Word32 + , cpPgTypeName :: Text + , cpHaskellType :: Text + , cpHaskellModule :: Text + , cpPgTypeCategory :: Maybe Text + -- ^ @\"enum\"@, @\"domain\"@, @\"range\"@, etc. 'Nothing' for built-in types. + , cpPgEnumLabels :: Maybe [Text] + -- ^ Enum labels from @pg_enum@, if this is an enum type. + } + deriving stock (Show, Eq) + +data CacheColumn = CacheColumn + { ccName :: Text + , ccPgOid :: Word32 + , ccPgTypeName :: Text + , ccNullable :: Bool + , ccHaskellType :: Text + , ccHaskellModule :: Text + , ccSourceTableOid :: Maybe Word32 + , ccSourceColumnNum :: Maybe Int + , ccPgTypeCategory :: Maybe Text + -- ^ @\"enum\"@, @\"domain\"@, @\"range\"@, etc. 'Nothing' for built-in types. + , ccPgEnumLabels :: Maybe [Text] + -- ^ Enum labels from @pg_enum@, if this is an enum type. + } + deriving stock (Show, Eq) + +-- JSON instances ---------------------------------------------------------- + +instance ToJSON CacheEntry where + toJSON CacheEntry {..} = + object + [ "valiant_version" .= ceVersion + , "file" .= ceFile + , "sql_hash" .= ceSqlHash + , "sql" .= ceSql + , "database_url_hash" .= ceDbUrlHash + , "prepared_at" .= cePreparedAt + , "statement_type" .= ceStatementType + , "parameters" .= ceParams + , "columns" .= ceColumns + ] + +instance FromJSON CacheEntry where + parseJSON = withObject "CacheEntry" $ \o -> + CacheEntry + <$> o .: "valiant_version" + <*> o .: "file" + <*> o .: "sql_hash" + <*> o .: "sql" + <*> o .: "database_url_hash" + <*> o .: "prepared_at" + <*> o .: "statement_type" + <*> o .: "parameters" + <*> o .: "columns" + +instance ToJSON StatementType where + toJSON = \case + Select -> String "select" + Insert -> String "insert" + Update -> String "update" + Delete -> String "delete" + Other -> String "other" + +instance FromJSON StatementType where + parseJSON = withText "StatementType" $ \case + "select" -> pure Select + "insert" -> pure Insert + "update" -> pure Update + "delete" -> pure Delete + _ -> pure Other + +instance ToJSON CacheParam where + toJSON CacheParam {..} = + object + [ "index" .= cpIndex + , "name" .= cpName + , "pg_oid" .= cpPgOid + , "pg_type_name" .= cpPgTypeName + , "haskell_type" .= cpHaskellType + , "haskell_module" .= cpHaskellModule + , "pg_type_category" .= cpPgTypeCategory + , "pg_enum_labels" .= cpPgEnumLabels + ] + +instance FromJSON CacheParam where + parseJSON = withObject "CacheParam" $ \o -> + CacheParam + <$> o .: "index" + <*> o .:? "name" + <*> o .: "pg_oid" + <*> o .: "pg_type_name" + <*> o .: "haskell_type" + <*> o .: "haskell_module" + <*> o .:? "pg_type_category" + <*> o .:? "pg_enum_labels" + +instance ToJSON CacheColumn where + toJSON CacheColumn {..} = + object + [ "name" .= ccName + , "pg_oid" .= ccPgOid + , "pg_type_name" .= ccPgTypeName + , "nullable" .= ccNullable + , "haskell_type" .= ccHaskellType + , "haskell_module" .= ccHaskellModule + , "source_table_oid" .= ccSourceTableOid + , "source_column_number" .= ccSourceColumnNum + , "pg_type_category" .= ccPgTypeCategory + , "pg_enum_labels" .= ccPgEnumLabels + ] + +instance FromJSON CacheColumn where + parseJSON = withObject "CacheColumn" $ \o -> + CacheColumn + <$> o .: "name" + <*> o .: "pg_oid" + <*> o .: "pg_type_name" + <*> o .: "nullable" + <*> o .: "haskell_type" + <*> o .: "haskell_module" + <*> o .:? "source_table_oid" + <*> o .:? "source_column_number" + <*> o .:? "pg_type_category" + <*> o .:? "pg_enum_labels" + +-- File operations --------------------------------------------------------- + +-- | Ensure the cache directory exists. +ensureCacheDir :: FilePath -> IO () +ensureCacheDir = createDirectoryIfMissing True + +-- | Write a 'CacheEntry' to disk as pretty-printed JSON. +-- Uses write-to-temp-then-rename for atomicity: a crash mid-write +-- cannot leave a corrupted cache file. +writeCacheEntry :: FilePath -> CacheEntry -> IO () +writeCacheEntry cacheDir entry = do + ensureCacheDir cacheDir + let fileName = cacheFileName (ceFile entry) (T.take 12 (ceSqlHash entry)) + path = cacheDir fileName + tmpPath = path <> ".tmp" + LBS.writeFile tmpPath (encodePretty entry) + renameFile tmpPath path + +-- | Read a 'CacheEntry' from a JSON file. +readCacheEntry :: FilePath -> IO (Either String CacheEntry) +readCacheEntry path = do + -- Strict read: closes the handle before decoding, avoiding the + -- lazy-I/O handle leak when callers ignore the result on error. + bytes <- BS.readFile path + pure (eitherDecodeStrict bytes) + +-- | Find a cache file matching the given SQL file path and content hash. +findCacheFile :: FilePath -> FilePath -> Text -> IO (Maybe CacheEntry) +findCacheFile cacheDir sqlRelPath sqlHash = do + exists <- doesDirectoryExist cacheDir + if not exists + then pure Nothing + else do + files <- listDirectory cacheDir + let hashShort = T.take 12 sqlHash + expected = cacheFileName sqlRelPath hashShort + case find (== expected) files of + Nothing -> pure Nothing + Just f -> do + result <- readCacheEntry (cacheDir f) + pure $ case result of + Left _ -> Nothing + Right entry + | ceSqlHash entry == sqlHash -> Just entry + | otherwise -> Nothing + +-- | Generate a cache file name from an SQL relative path and truncated hash. +-- +-- >>> cacheFileName "users/find_by_id.sql" "a1b2c3d4e5f6" +-- "users-find_by_id-a1b2c3d4e5f6.json" +cacheFileName :: FilePath -> Text -> FilePath +cacheFileName sqlRelPath hashShort = + T.unpack (slug <> "-" <> hashShort) <> ".json" + where + slug = + T.replace "/" "-" . T.replace "\\" "-" . T.pack $ + dropSqlExt sqlRelPath + + dropSqlExt "" = "inline" + dropSqlExt p + | ".sql" `isSuffixOf` p = take (length p - 4) p + | otherwise = p + +-- | Infer the statement type from the SQL text. +statementTypeFromSql :: Text -> StatementType +statementTypeFromSql sql = + case T.words (T.toCaseFold (T.stripStart sql)) of + (w : _) + | w == "select" -> Select + | w == "insert" -> Insert + | w == "update" -> Update + | w == "delete" -> Delete + | w == "with" -> Select -- CTEs are usually selects + _ -> Other diff --git a/src/Valiant/CLI/Command/Check.hs b/src/Valiant/CLI/Command/Check.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Command/Check.hs @@ -0,0 +1,49 @@ +module Valiant.CLI.Command.Check + ( runCheck + ) where + +import Data.Text qualified as T +import Valiant.CLI.Cache (findCacheFile) +import Valiant.CLI.Config (AppEnv (..)) +import Valiant.CLI.Discover (SqlFile (..), discoverSqlFiles) +import Valiant.CLI.Error (ValiantCliError (..), dieWithError) +import Valiant.CLI.Output +import System.Exit (ExitCode (..)) + +runCheck :: AppEnv -> IO ExitCode +runCheck env = do + printHeader $ "Checking queries in " <> T.pack (appSqlDir env) <> " ..." + + files <- discoverSqlFiles (appSqlDir env) + case files of + [] -> dieWithError (ErrNoSqlFiles (appSqlDir env)) + _ -> pure () + + let total = length files + printLn $ " Checking " <> T.pack (show total) <> " queries..." + printLn "" + + results <- mapM (checkFile env total) (zip [1 ..] files) + let okCount = length (filter id results) + printSummary okCount total + + if okCount == total + then do + printLn " All cache files are current." + pure ExitSuccess + else do + printLn "" + printLn " Run `valiant prepare` to update stale or missing cache files." + pure (ExitFailure 1) + +checkFile :: AppEnv -> Int -> (Int, SqlFile) -> IO Bool +checkFile env total (idx, sqlFile) = do + printProgress idx total (sqlRelPath sqlFile) + mEntry <- findCacheFile (appCacheDir env) (sqlRelPath sqlFile) (sqlHash sqlFile) + case mEntry of + Just _ -> do + printOk + pure True + Nothing -> do + printStale + pure False diff --git a/src/Valiant/CLI/Command/Generate.hs b/src/Valiant/CLI/Command/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Command/Generate.hs @@ -0,0 +1,258 @@ +module Valiant.CLI.Command.Generate + ( runGenerate + , GenerateOpts (..) + ) where + +import Data.Char (toUpper) +import Data.List (intercalate, nub, sort) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Valiant.CLI.Cache (CacheColumn (..), CacheEntry (..), CacheParam (..), StatementType (..), findCacheFile) +import Valiant.CLI.Config (AppEnv (..)) +import Valiant.CLI.Discover (SqlFile (..), discoverSqlFiles) +import Valiant.CLI.Error (ValiantCliError (..), dieWithError) +import Valiant.CLI.Output +import Valiant.CLI.SqlMetadata (SqlMetadata (..), parseSqlMetadata) +import System.Directory (createDirectoryIfMissing, renameFile) +import System.Exit (ExitCode (..)) +import System.FilePath (takeBaseName, takeDirectory, ()) + +data GenerateOpts = GenerateOpts + { genModulePrefix :: String + , genOutputDir :: FilePath + } + deriving stock (Show) + +runGenerate :: AppEnv -> GenerateOpts -> IO ExitCode +runGenerate env opts = do + files <- discoverSqlFiles (appSqlDir env) + case files of + [] -> dieWithError (ErrNoSqlFiles (appSqlDir env)) + _ -> pure () + + -- Group SQL files by their parent directory → one module per directory + let grouped = groupByDirectory files + results <- mapM (generateModule env opts) (Map.toAscList grouped) + let okCount = length (filter id results) + total = length results + if okCount == total + then pure ExitSuccess + else pure (ExitFailure 1) + +-- | Group SQL files by their first directory component. +-- @users/find_by_id.sql@ → key @"users"@, @posts/insert.sql@ → key @"posts"@ +-- Files at the root go under key @""@. +groupByDirectory :: [SqlFile] -> Map String [SqlFile] +groupByDirectory = List.foldl' go Map.empty + where + go acc sf = + let dir = takeDirectory (sqlRelPath sf) + key = if dir == "." then "" else dir + in Map.insertWith (++) key [sf] acc + +-- | Generate a single Haskell module for a group of SQL files. +generateModule :: AppEnv -> GenerateOpts -> (String, [SqlFile]) -> IO Bool +generateModule env opts (dirKey, files) = do + -- Load cache entries for all files + entries <- mapM (loadEntry env) files + let pairs = [(sf, e) | (sf, Just e) <- zip files entries] + if null pairs + then do + printLn $ " Skipping " <> T.pack dirKey <> " (no cache entries)" + pure False + else do + let moduleName = buildModuleName (genModulePrefix opts) dirKey + modulePath = genOutputDir opts moduleNameToPath moduleName + content = renderModule env moduleName pairs + createDirectoryIfMissing True (takeDirectory modulePath) + let tmpPath = modulePath <> ".tmp" + writeFile tmpPath content + renameFile tmpPath modulePath + printLn $ + " Generated " + <> T.pack modulePath + <> " (" + <> T.pack (show (length pairs)) + <> " queries)" + pure True + +loadEntry :: AppEnv -> SqlFile -> IO (Maybe CacheEntry) +loadEntry env sf = findCacheFile (appCacheDir env) (sqlRelPath sf) (sqlHash sf) + +-- Module name construction ------------------------------------------------ + +buildModuleName :: String -> String -> String +buildModuleName prefix dirKey + | null dirKey = prefix + | otherwise = prefix <> "." <> toPascalCase dirKey + +toPascalCase :: String -> String +toPascalCase = concatMap capitalize . splitOn '/' + where + capitalize [] = [] + capitalize (c : cs) = toUpper c : cs + + splitOn _ [] = [] + splitOn sep s = + let (w, rest) = break (== sep) s + in w : case rest of + [] -> [] + (_ : rs) -> splitOn sep rs + +moduleNameToPath :: String -> FilePath +moduleNameToPath = (<> ".hs") . map (\c -> if c == '.' then '/' else c) + +-- Rendering --------------------------------------------------------------- + +renderModule :: AppEnv -> String -> [(SqlFile, CacheEntry)] -> String +renderModule env moduleName pairs = + unlines $ + [ "-- AUTO-GENERATED by valiant generate. Edit as needed." + , "-- Re-run: valiant generate --module-prefix " <> takeWhile (/= '.') moduleName <> " --output-dir ..." + , "{-# OPTIONS_GHC -fplugin=Valiant.Plugin" + , " -fplugin-opt=Valiant.Plugin:sql-dir=" <> appSqlDir env + , " -fplugin-opt=Valiant.Plugin:cache-dir=" <> appCacheDir env <> " #-}" + , "module " <> moduleName <> " where" + , "" + , "import Valiant" + ] + <> renderImports pairs + <> [""] + <> concatMap renderBinding pairs + +renderImports :: [(SqlFile, CacheEntry)] -> [String] +renderImports pairs = + let -- Group by module and collect types + grouped = Map.toAscList $ List.foldl' groupImport Map.empty (concatMap collectImports pairs) + in map renderImportLine grouped + +collectImports :: (SqlFile, CacheEntry) -> [(String, String)] +collectImports (_, entry) = + [(T.unpack (cpHaskellModule p), baseType (T.unpack (cpHaskellType p))) | p <- ceParams entry] + <> [(T.unpack (ccHaskellModule c), baseType (T.unpack (ccHaskellType c))) | c <- ceColumns entry] + +-- Strip "Maybe " prefix to get the base type for import +baseType :: String -> String +baseType ('M' : 'a' : 'y' : 'b' : 'e' : ' ' : rest) = rest +baseType t = t + +groupImport :: Map String [String] -> (String, String) -> Map String [String] +groupImport acc (modName, typeName) + | modName == "Prelude" = acc + | otherwise = Map.insertWith (\new old -> nub (old ++ new)) modName [typeName] acc + +renderImportLine :: (String, [String]) -> String +renderImportLine (modName, types) = + "import " <> modName <> " (" <> intercalate ", " (sort (nub types)) <> ")" + +renderBinding :: (SqlFile, CacheEntry) -> [String] +renderBinding (sf, entry) = + let meta = parseSqlMetadata (TE.decodeUtf8 (sqlContent sf)) + bindName = case smName meta of + Just name -> T.unpack name + Nothing -> sqlFileToBindingName (sqlRelPath sf) + paramType = formatParamType (ceParams entry) + resultType = case smResult meta of + Just typeName -> + let wrap = resultWrapper (sqlRelPath sf) (smSingle meta) (ceStatementType entry) (ceColumns entry) + in wrap (T.unpack typeName) + Nothing -> formatResultType (sqlRelPath sf) (smSingle meta) (ceStatementType entry) (ceColumns entry) + queryFn = case smResult meta of + Just typeName -> "queryFileAs @" <> T.unpack typeName + Nothing -> "queryFile" + sqlComment = T.unpack (T.takeWhile (/= '\n') (ceSql entry)) + in [ "" + , "-- " <> sqlRelPath sf + , "-- " <> sqlComment + , bindName <> " :: Statement " <> paramType <> " " <> resultType + , bindName <> " = " <> queryFn <> " " <> show (sqlRelPath sf) + ] + +-- | Convert @users/find_by_id.sql@ → @findById@ +sqlFileToBindingName :: FilePath -> String +sqlFileToBindingName path = snakeToCamel (takeBaseName path) + +snakeToCamel :: String -> String +snakeToCamel [] = [] +snakeToCamel s = + let (word, rest) = break (== '_') s + in word <> case rest of + [] -> [] + (_ : rs) -> capitalize rs + where + capitalize [] = [] + capitalize (c : cs) = + let (w, rest') = break (== '_') (c : cs) + in case w of + (x : xs) -> (toUpper x : xs) <> case rest' of + [] -> [] + (_ : rs) -> capitalize rs + [] -> case rest' of + [] -> [] + (_ : rs) -> capitalize rs + +formatParamType :: [CacheParam] -> String +formatParamType [] = "()" +formatParamType [p] = parensIfNeeded (T.unpack (cpHaskellType p)) +formatParamType ps = "(" <> intercalate ", " (map (T.unpack . cpHaskellType) ps) <> ")" + +formatResultType :: FilePath -> Bool -> StatementType -> [CacheColumn] -> String +formatResultType sqlPath single stmtType cols = case cols of + [] -> "()" + _ -> + let inner = case cols of + [c] -> parensIfNeeded (T.unpack (ccHaskellType c)) + cs -> "(" <> intercalate ", " (map (T.unpack . ccHaskellType) cs) <> ")" + in if single + then inner + else inferReturnWrapper sqlPath stmtType cols inner + +-- | Determine the wrapper for a named result type based on SQL conventions and metadata. +resultWrapper :: FilePath -> Bool -> StatementType -> [CacheColumn] -> String -> String +resultWrapper sqlPath single stmtType cols typeName + | single = typeName + | otherwise = inferReturnWrapper sqlPath stmtType cols typeName + +-- | Infer the return type wrapper from the SQL file name prefix. +-- The naming convention follows the roadmap: +-- +-- * @find_*@ → @Maybe r@ (zero or one row) +-- * @get_*@ → @r@ (exactly one row, no wrapper) +-- * @list_*@ → @[r]@ (multiple rows) +-- * @count_*@ → scalar type directly (no tuple, no wrapper) +-- * @exists_*@ → @Bool@ +-- * @insert*@/@update_*@/@delete_*@/@upsert_*@ → @()@ when no columns +-- * default → no wrapper (raw type) +inferReturnWrapper :: FilePath -> StatementType -> [CacheColumn] -> String -> String +inferReturnWrapper sqlPath _stmtType cols inner + | "find_" `isPrefixOfBase` base = "(Maybe " <> inner <> ")" + | "list_" `isPrefixOfBase` base = "[" <> inner <> "]" + | "count_" `isPrefixOfBase` base = case cols of + [c] -> parensIfNeeded (T.unpack (ccHaskellType c)) + _ -> inner + | "exists_" `isPrefixOfBase` base = "Bool" + | "get_" `isPrefixOfBase` base = inner + | isCommandPrefix base, null cols = "()" + | isCommandPrefix base = inner + | otherwise = inner + where + base = takeBaseName sqlPath + + isPrefixOfBase :: String -> String -> Bool + isPrefixOfBase prefix str = take (length prefix) str == prefix + + isCommandPrefix :: String -> Bool + isCommandPrefix b = + "insert" `isPrefixOfBase` b + || "update_" `isPrefixOfBase` b + || "delete_" `isPrefixOfBase` b + || "upsert_" `isPrefixOfBase` b + +-- | Wrap in parens if the type contains spaces (e.g. "Maybe Text" → "(Maybe Text)") +parensIfNeeded :: String -> String +parensIfNeeded s + | ' ' `elem` s = "(" <> s <> ")" + | otherwise = s diff --git a/src/Valiant/CLI/Command/Prepare.hs b/src/Valiant/CLI/Command/Prepare.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Command/Prepare.hs @@ -0,0 +1,251 @@ +module Valiant.CLI.Command.Prepare + ( runPrepare + ) where + +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Word (Word32) +import PgWire.Connection (Connection) +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.Cache +import Valiant.CLI.Config (AppEnv (..)) +import Valiant.CLI.Describe (ColumnMeta (..), DescribeError (..), ParamMeta (..), QueryMeta (..), describeQuery, withPgConnection) +import Valiant.CLI.Discover (SqlFile (..), discoverSqlFiles, discoverInlineSql) +import System.FilePath.Glob qualified as Glob +import Valiant.CLI.Error (ValiantCliError (..), dieWithError) +import Valiant.CLI.Hash (sha256Hex) +import Valiant.CLI.Nullability (resolveNullability) +import Valiant.CLI.Output +import Valiant.CLI.CustomTypes (CustomTypeMap, customTypesFile, loadCustomTypes) +import Valiant.CLI.NamedParams (NamedParamMapping, preprocessNamedParams) +import Valiant.CLI.TypeMap (HaskellType (..), ResolvedType (..), oidToHaskellTypeWith, oidToTypeNameWith, resolveType, resolveUnknownOid) +import System.Exit (ExitCode (..)) + +runPrepare :: AppEnv -> [FilePath] -> IO ExitCode +runPrepare env inlineDirs = do + dbUrl <- case appDatabaseUrl env of + Nothing -> dieWithError ErrNoDatabaseUrl + Just url -> pure url + + printHeader $ "Using database " <> maskPassword (TE.decodeUtf8 dbUrl) + printHeader $ "Scanning " <> T.pack (appSqlDir env) <> " for .sql files..." + + sqlFiles <- discoverSqlFiles (appSqlDir env) + + -- Discover inline SQL from Haskell source if --inline dirs provided + inlineFiles <- case inlineDirs of + [] -> pure [] + dirs -> do + hsPaths <- concat <$> mapM discoverHsFiles dirs + inlines <- discoverInlineSql hsPaths + case inlines of + [] -> pure [] + _ -> do + printLn $ " Found " <> T.pack (show (length inlines)) <> " inline queries in .hs files" + pure inlines + + let files = sqlFiles <> inlineFiles + case files of + [] -> dieWithError (ErrNoSqlFiles (appSqlDir env)) + _ -> printLn $ " Found " <> T.pack (show (length files)) <> " queries total" + + printLn "" + + customs <- loadCustomTypes customTypesFile + let total = length files + + withPgConnection dbUrl $ \conn -> do + results <- mapM (processFile env customs conn total) (zip [1 ..] files) + let okCount = length (filter id results) + printSummary okCount total + printLn $ " Wrote " <> T.pack (show okCount) <> " cache files to " <> T.pack (appCacheDir env) <> "/" + pure $ + if okCount == total + then ExitSuccess + else ExitFailure 1 + +-- | Discover all .hs files in a directory tree. +discoverHsFiles :: FilePath -> IO [FilePath] +discoverHsFiles dir = do + let pat = Glob.compile "**/*.hs" + matched <- Glob.globDir [pat] dir + pure (concat matched) + +processFile :: AppEnv -> CustomTypeMap -> Connection -> Int -> (Int, SqlFile) -> IO Bool +processFile env customs conn total (idx, sqlFile) = do + printProgress idx total (sqlRelPath sqlFile) + + -- Check if cache is already current + existing <- findCacheFile (appCacheDir env) (sqlRelPath sqlFile) (sqlHash sqlFile) + case existing of + Just _ -> do + printOk + pure True + Nothing -> do + -- Preprocess :name → $N before sending to Postgres + let (rewrittenSql, nameMapping) = preprocessNamedParams (sqlContent sqlFile) + prepFile = sqlFile {sqlContent = rewrittenSql} + result <- describeQuery conn prepFile + case result of + Left err -> do + printFailed (deMessage err) + pure False + Right meta -> do + nullabilities <- resolveNullability conn (qmColumns meta) + now <- getCurrentTime + buildResult <- buildCacheEntry env customs conn sqlFile meta nullabilities nameMapping now + case buildResult of + Left errMsg -> do + printFailed errMsg + pure False + Right entry -> do + writeCacheEntry (appCacheDir env) entry + printOk + pure True + +buildCacheEntry + :: AppEnv + -> CustomTypeMap + -> Connection + -> SqlFile + -> QueryMeta + -> [Bool] + -> NamedParamMapping + -> UTCTime + -> IO (Either Text CacheEntry) +buildCacheEntry env customs conn sqlFile meta nullabilities nameMapping now = do + let nameMap = Map.fromList [(idx, name) | (name, idx) <- nameMapping] + eParams <- resolveParams customs conn nameMap (qmParams meta) + case eParams of + Left err -> pure (Left err) + Right params -> do + eColumns <- resolveColumns customs conn (zip (qmColumns meta) nullabilities) + case eColumns of + Left err -> pure (Left err) + Right columns -> do + let sqlText = TE.decodeUtf8 (sqlContent sqlFile) + pure . Right $ + CacheEntry + { ceVersion = "0.1.0" + , ceFile = sqlRelPath sqlFile + , ceSqlHash = sqlHash sqlFile + , ceSql = sqlText + , ceDbUrlHash = maybe "" sha256Hex (appDatabaseUrl env) + , cePreparedAt = now + , ceStatementType = statementTypeFromSql sqlText + , ceParams = params + , ceColumns = columns + } + +resolveParams :: CustomTypeMap -> Connection -> Map.Map Int Text -> [ParamMeta] -> IO (Either Text [CacheParam]) +resolveParams customs conn nameMap = go [] + where + go !acc [] = pure (Right (reverse acc)) + go !acc (pm : pms) = do + result <- resolveParam customs conn nameMap pm + case result of + Left err -> pure (Left err) + Right cp -> go (cp : acc) pms + +resolveParam :: CustomTypeMap -> Connection -> Map.Map Int Text -> ParamMeta -> IO (Either Text CacheParam) +resolveParam customs conn nameMap ParamMeta {..} = + let Oid oid = pmOid + paramName = Map.lookup pmIndex nameMap + paramLabel = case paramName of + Just n -> ":" <> n + Nothing -> "$" <> T.pack (show pmIndex) + in case oidToHaskellTypeWith customs pmOid of + Just ht -> + pure . Right $ + CacheParam + { cpIndex = pmIndex + , cpName = paramName + , cpPgOid = fromIntegral oid + , cpPgTypeName = fromMaybe "unknown" (oidToTypeNameWith mempty pmOid) + , cpHaskellType = htType ht + , cpHaskellModule = htModule ht + , cpPgTypeCategory = Nothing + , cpPgEnumLabels = Nothing + } + Nothing -> do + -- Auto-discover via pg_type + resolved <- resolveUnknownOid conn customs pmOid + case resolved of + Left err -> + pure . Left $ err <> " for parameter " <> paramLabel + Right rt -> + pure . Right $ + CacheParam + { cpIndex = pmIndex + , cpName = paramName + , cpPgOid = fromIntegral oid + , cpPgTypeName = rtPgTypeName rt + , cpHaskellType = htType (rtHaskellType rt) + , cpHaskellModule = htModule (rtHaskellType rt) + , cpPgTypeCategory = rtCategory rt + , cpPgEnumLabels = rtEnumLabels rt + } + +resolveColumns :: CustomTypeMap -> Connection -> [(ColumnMeta, Bool)] -> IO (Either Text [CacheColumn]) +resolveColumns customs conn = go [] + where + go !acc [] = pure (Right (reverse acc)) + go !acc ((cm, nullable) : rest) = do + result <- resolveColumn customs conn cm nullable + case result of + Left err -> pure (Left err) + Right cc -> go (cc : acc) rest + +resolveColumn :: CustomTypeMap -> Connection -> ColumnMeta -> Bool -> IO (Either Text CacheColumn) +resolveColumn customs conn ColumnMeta {..} nullable = + let Oid oid = cmOid + Oid tOid = cmTableOid + tOidW32 = fromIntegral tOid :: Word32 + mkColumn ht cat labels = + CacheColumn + { ccName = cmName + , ccPgOid = fromIntegral oid + , ccPgTypeName = fromMaybe "unknown" (oidToTypeNameWith mempty cmOid) + , ccNullable = nullable + , ccHaskellType = htType (resolveType nullable ht) + , ccHaskellModule = htModule ht + , ccSourceTableOid = if tOidW32 == 0 then Nothing else Just tOidW32 + , ccSourceColumnNum = if cmColumnNumber == 0 then Nothing else Just cmColumnNumber + , ccPgTypeCategory = cat + , ccPgEnumLabels = labels + } + in case oidToHaskellTypeWith customs cmOid of + Just baseHt -> + pure . Right $ mkColumn baseHt Nothing Nothing + Nothing -> do + resolved <- resolveUnknownOid conn customs cmOid + case resolved of + Left err -> + pure . Left $ err <> " for column \"" <> cmName <> "\"" + Right rt -> + pure . Right $ + (mkColumn (rtHaskellType rt) (rtCategory rt) (rtEnumLabels rt)) + { ccPgTypeName = rtPgTypeName rt + } + +-- | Mask the password in a connection URL for display. +maskPassword :: Text -> Text +maskPassword url = + case T.breakOn "://" url of + (scheme, rest) + | T.null rest -> url + | otherwise -> + let afterScheme = T.drop 3 rest + in case T.breakOn "@" afterScheme of + (_, hostPart) + | T.null hostPart -> url + | otherwise -> + case T.breakOn ":" afterScheme of + (user, passAndHost) + | T.null passAndHost -> url + | otherwise -> + scheme <> "://" <> user <> ":***" <> T.dropWhile (/= '@') passAndHost diff --git a/src/Valiant/CLI/Command/Types.hs b/src/Valiant/CLI/Command/Types.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Command/Types.hs @@ -0,0 +1,55 @@ +module Valiant.CLI.Command.Types + ( runTypes + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import Valiant.CLI.Cache (CacheColumn (..), CacheEntry (..), CacheParam (..), findCacheFile) +import Valiant.CLI.Config (AppEnv (..)) +import Valiant.CLI.Discover (SqlFile (..), discoverSqlFiles) +import Valiant.CLI.Error (ValiantCliError (..), dieWithError) +import Valiant.CLI.Output +import System.Exit (ExitCode (..)) + +runTypes :: AppEnv -> Maybe FilePath -> IO ExitCode +runTypes env mFilter = do + allFiles <- discoverSqlFiles (appSqlDir env) + let files = case mFilter of + Nothing -> allFiles + Just f -> filter (\sf -> f == sqlRelPath sf) allFiles + + case files of + [] -> dieWithError (ErrNoSqlFiles (appSqlDir env)) + _ -> pure () + + results <- mapM (showTypes env) files + pure $ + if and results + then ExitSuccess + else ExitFailure 1 + +showTypes :: AppEnv -> SqlFile -> IO Bool +showTypes env sqlFile = do + mEntry <- findCacheFile (appCacheDir env) (sqlRelPath sqlFile) (sqlHash sqlFile) + case mEntry of + Nothing -> do + printLn $ " " <> T.pack (sqlRelPath sqlFile) + printLn " (no cache — run `valiant prepare`)" + printLn "" + pure False + Just entry -> do + printLn $ " " <> T.pack (ceFile entry) + printLn $ " Params: " <> formatParamType (ceParams entry) + printLn $ " Result: " <> formatResultType (ceColumns entry) + printLn "" + pure True + +formatParamType :: [CacheParam] -> Text +formatParamType [] = "()" +formatParamType [p] = cpHaskellType p +formatParamType ps = "(" <> T.intercalate ", " (map cpHaskellType ps) <> ")" + +formatResultType :: [CacheColumn] -> Text +formatResultType [] = "()" +formatResultType [c] = ccHaskellType c +formatResultType cs = "(" <> T.intercalate ", " (map ccHaskellType cs) <> ")" diff --git a/src/Valiant/CLI/Command/Watch.hs b/src/Valiant/CLI/Command/Watch.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Command/Watch.hs @@ -0,0 +1,90 @@ +module Valiant.CLI.Command.Watch + ( runWatch + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forever, unless) +import Data.IORef +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Valiant.CLI.Command.Prepare (runPrepare) +import Valiant.CLI.Config (AppEnv (..)) +import Valiant.CLI.Discover (SqlFile (..), discoverSqlFiles) +import Valiant.CLI.Error (ValiantCliError (..), dieWithError) +import Valiant.CLI.Output +import System.Directory (doesDirectoryExist) +import System.Exit (ExitCode (..)) + +-- | Run prepare in a loop, watching for SQL file changes. +-- Polls every 2 seconds (fsnotify can be added later for efficiency). +-- Automatically re-prepares when changes are detected. +runWatch :: AppEnv -> IO ExitCode +runWatch env = do + _ <- case appDatabaseUrl env of + Nothing -> dieWithError ErrNoDatabaseUrl + Just _ -> pure () + + exists <- doesDirectoryExist (appSqlDir env) + unless exists $ dieWithError (ErrSqlDirNotFound (appSqlDir env)) + + printHeader $ "Watching " <> T.pack (appSqlDir env) <> " for changes..." + printLn "" + + -- Initial prepare + printLn " Running initial prepare..." + _ <- runPrepare env [] + printLn "" + + -- Track known file hashes + files <- discoverSqlFiles (appSqlDir env) + hashRef <- newIORef (Map.fromList [(sqlRelPath sf, sqlHash sf) | sf <- files]) + + -- Poll loop + _ <- forever $ do + threadDelay 2000000 -- 2 seconds + scanAndPrepare env hashRef + + -- unreachable, but needed for type + pure ExitSuccess + +-- | Scan all SQL files, detect changes, report, and re-prepare if needed. +scanAndPrepare :: AppEnv -> IORef (Map FilePath Text) -> IO () +scanAndPrepare env hashRef = do + files <- discoverSqlFiles (appSqlDir env) + oldHashes <- readIORef hashRef + + let newHashes = Map.fromList [(sqlRelPath sf, sqlHash sf) | sf <- files] + changes = detectChanges oldHashes newHashes + + unless (null changes) $ do + mapM_ reportChange changes + printLn " Re-preparing..." + exitCode <- runPrepare env [] + case exitCode of + ExitSuccess -> printLn "" + ExitFailure _ -> printLn " (Some queries failed. Fix the SQL and save again.)\n" + + -- Update stored hashes + writeIORef hashRef newHashes + +data FileChange + = FileAdded FilePath + | FileModified FilePath + | FileDeleted FilePath + +detectChanges :: Map FilePath Text -> Map FilePath Text -> [FileChange] +detectChanges old new = + let added = [FileAdded k | k <- Map.keys new, not (Map.member k old)] + modified = [FileModified k | (k, v) <- Map.toList new, Map.member k old, Map.lookup k old /= Just v] + deleted = [FileDeleted k | k <- Map.keys old, not (Map.member k new)] + in added ++ modified ++ deleted + +reportChange :: FileChange -> IO () +reportChange (FileAdded path) = + printLn $ " [+] " <> T.pack path <> " (new file)" +reportChange (FileModified path) = + printLn $ " [~] " <> T.pack path <> " (modified)" +reportChange (FileDeleted path) = + printLn $ " [-] " <> T.pack path <> " (deleted)" diff --git a/src/Valiant/CLI/Config.hs b/src/Valiant/CLI/Config.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Config.hs @@ -0,0 +1,44 @@ +module Valiant.CLI.Config + ( AppEnv (..) + , resolveEnv + ) where + +import Configuration.Dotenv (defaultConfig, loadFile) +import Control.Exception (SomeException, try) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import System.Environment (lookupEnv) + +-- | Resolved application environment for all commands. +data AppEnv = AppEnv + { appSqlDir :: FilePath + , appCacheDir :: FilePath + , appDatabaseUrl :: Maybe ByteString + , appVerbose :: Bool + } + deriving stock (Show) + +-- | Load @.env@, then resolve the final 'AppEnv' from CLI options + environment. +resolveEnv + :: FilePath + -- ^ SQL directory (from CLI flag) + -> FilePath + -- ^ Cache directory (from CLI flag) + -> Maybe String + -- ^ Explicit DATABASE_URL (from CLI flag, overrides env) + -> Bool + -- ^ Verbose + -> IO AppEnv +resolveEnv sqlDir cacheDir mDbUrl verbose = do + -- Best-effort .env loading; ignore errors (file may not exist). + _ <- try @SomeException $ loadFile defaultConfig + dbUrl <- case mDbUrl of + Just url -> pure (Just (BS8.pack url)) + Nothing -> fmap BS8.pack <$> lookupEnv "DATABASE_URL" + pure + AppEnv + { appSqlDir = sqlDir + , appCacheDir = cacheDir + , appDatabaseUrl = dbUrl + , appVerbose = verbose + } diff --git a/src/Valiant/CLI/CustomTypes.hs b/src/Valiant/CLI/CustomTypes.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/CustomTypes.hs @@ -0,0 +1,63 @@ +module Valiant.CLI.CustomTypes + ( CustomTypeMap + , loadCustomTypes + , customTypesFile + ) where + +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Word (Word32) +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.TypeMap (HaskellType (..)) +import System.Directory (doesFileExist) + +-- | User-defined OID → Haskell type mappings. +type CustomTypeMap = Map Oid HaskellType + +-- | Default file name for custom type mappings. +customTypesFile :: FilePath +customTypesFile = "valiant-types.json" + +-- | Load custom type mappings from a JSON file if it exists. +-- Returns an empty map if the file is absent. +-- +-- Expected format: +-- +-- > [ +-- > { "oid": 600, "pg_type_name": "point", "haskell_type": "MyPoint", "haskell_module": "MyApp.Types" }, +-- > { "oid": 16389, "pg_type_name": "mood", "haskell_type": "Text", "haskell_module": "Data.Text" } +-- > ] +loadCustomTypes :: FilePath -> IO CustomTypeMap +loadCustomTypes path = do + exists <- doesFileExist path + if not exists + then pure Map.empty + else do + bytes <- LBS.readFile path + case eitherDecode bytes of + Left _ -> pure Map.empty + Right entries -> pure (toMap entries) + +toMap :: [CustomTypeEntry] -> CustomTypeMap +toMap = Map.fromList . map toPair + where + toPair CustomTypeEntry {..} = + (Oid cteOid, HaskellType cteHaskellType cteHaskellModule) + +data CustomTypeEntry = CustomTypeEntry + { cteOid :: Word32 + , ctePgTypeName :: Text + , cteHaskellType :: Text + , cteHaskellModule :: Text + } + +instance FromJSON CustomTypeEntry where + parseJSON = withObject "CustomTypeEntry" $ \o -> + CustomTypeEntry + <$> o .: "oid" + <*> o .: "pg_type_name" + <*> o .: "haskell_type" + <*> o .: "haskell_module" diff --git a/src/Valiant/CLI/Describe.hs b/src/Valiant/CLI/Describe.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Describe.hs @@ -0,0 +1,244 @@ +module Valiant.CLI.Describe + ( QueryMeta (..) + , ParamMeta (..) + , ColumnMeta (..) + , DescribeError (..) + , PgTypeInfo (..) + , PgTypeCategory (..) + , describeQuery + , queryTypeInfo + , queryEnumLabels + , queryRangeSubtype + , withPgConnection + ) where + +import Control.Exception (bracket, try) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.IORef (IORef, writeIORef) +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Data.Vector qualified as V +import Data.Vector (Vector) +import Data.Word (Word32) +import PgWire.Async (submitExclusive) +import PgWire.Connection (Connection, close, connAsync, connectString, simpleQuery) +import PgWire.Error (PgWireError) +import PgWire.Protocol.Backend (BackendMsg (..), FieldInfo (..), PgError (..), TxStatus) +import PgWire.Protocol.Frontend (DescribeTarget (..), FrontendMsg (..)) +import PgWire.Protocol.Oid (Oid (..)) +import PgWire.Wire (WireConn, recvBackendMsg, sendFrontendMsg) +import Valiant.CLI.Discover (SqlFile (..)) + +-- | Raw metadata returned by Postgres for a described query. +data QueryMeta = QueryMeta + { qmParams :: [ParamMeta] + , qmColumns :: [ColumnMeta] + } + deriving stock (Show) + +-- | Metadata for a single query parameter. +data ParamMeta = ParamMeta + { pmIndex :: Int + , pmOid :: Oid + } + deriving stock (Show) + +-- | Metadata for a single result column. +data ColumnMeta = ColumnMeta + { cmName :: Text + , cmOid :: Oid + , cmTableOid :: Oid + , cmColumnNumber :: Int + } + deriving stock (Show) + +-- | An error that occurred while describing a query. +data DescribeError = DescribeError + { deMessage :: Text + , deDetail :: Maybe Text + , deHint :: Maybe Text + } + deriving stock (Show) + +-- | Connect to Postgres, run an action, and close the connection. +withPgConnection :: ByteString -> (Connection -> IO a) -> IO a +withPgConnection connStr action = do + result <- try @PgWireError (bracket (connectString connStr) close action) + case result of + Right a -> pure a + Left err -> error $ "valiant: connection failed: " <> show err + +-- | Prepare and describe a SQL query, returning structured metadata. +describeQuery :: Connection -> SqlFile -> IO (Either DescribeError QueryMeta) +describeQuery conn sqlFile = do + let stmtName = BS8.pack ("valiant_" <> sqlRelPath sqlFile) + sql = sqlContent sqlFile + result <- parseAndDescribe conn stmtName sql + pure $ case result of + Left err -> Left (pgErrorToDescribeError err) + Right (paramOids, fields) -> Right (buildMeta paramOids fields) + +-- | Send Parse + Describe + Sync in one round trip and collect the response. +-- Returns the parameter OIDs and column field info, or the server's error. +parseAndDescribe + :: Connection + -> ByteString + -- ^ statement name + -> ByteString + -- ^ SQL text + -> IO (Either PgError (Vector Word32, Vector FieldInfo)) +parseAndDescribe conn stmtName sql = + submitExclusive (connAsync conn) $ \wc txRef -> do + sendFrontendMsg wc (Parse stmtName sql V.empty) + sendFrontendMsg wc (Describe DescribeStatement stmtName) + sendFrontendMsg wc Sync + collectDescribeResponse wc txRef + +-- | Collect the response to a Parse + Describe + Sync sequence. +-- Expected message order on success: +-- ParseComplete, ParameterDescription, (RowDescription | NoData), ReadyForQuery. +-- On error: ErrorResponse, ReadyForQuery. +collectDescribeResponse + :: WireConn + -> IORef TxStatus + -> IO (Either PgError (Vector Word32, Vector FieldInfo)) +collectDescribeResponse wc txRef = loop Nothing V.empty V.empty + where + loop !mErr !paramOids !fields = do + msg <- recvBackendMsg wc + case msg of + ParseComplete -> loop mErr paramOids fields + ParameterDescription oids -> loop mErr oids fields + RowDescription fs -> loop mErr paramOids fs + NoData -> loop mErr paramOids V.empty + ErrorResponse err -> loop (Just err) paramOids fields + ReadyForQuery status -> do + writeIORef txRef status + pure $ case mErr of + Just err -> Left err + Nothing -> Right (paramOids, fields) + _ -> loop mErr paramOids fields + +buildMeta :: Vector Word32 -> Vector FieldInfo -> QueryMeta +buildMeta paramOids fields = + QueryMeta + { qmParams = + [ ParamMeta {pmIndex = i + 1, pmOid = Oid oid} + | (i, oid) <- zip [0 ..] (V.toList paramOids) + ] + , qmColumns = map fieldToColumnMeta (V.toList fields) + } + +fieldToColumnMeta :: FieldInfo -> ColumnMeta +fieldToColumnMeta fi = + ColumnMeta + { cmName = TE.decodeUtf8 (fiName fi) + , cmOid = Oid (fiTypeOid fi) + , cmTableOid = Oid (fiTableOid fi) + , cmColumnNumber = fromIntegral (fiColumnNum fi) + } + +pgErrorToDescribeError :: PgError -> DescribeError +pgErrorToDescribeError err = + DescribeError + { deMessage = TE.decodeUtf8 (pgMessage err) + , deDetail = TE.decodeUtf8 <$> pgDetail err + , deHint = TE.decodeUtf8 <$> pgHint err + } + +-- Type discovery ------------------------------------------------------------- + +-- | Category of a PG type discovered from @pg_type@. +data PgTypeCategory + = PgEnum + | PgComposite + | PgDomain + | PgRange + | PgBase + | PgPseudo + deriving stock (Show, Eq) + +-- | Metadata about a PG type, queried from @pg_type@. +data PgTypeInfo = PgTypeInfo + { ptiName :: Text + , ptiCategory :: PgTypeCategory + , ptiArrayOid :: Word32 + -- ^ OID of the array form of this type (0 if none). + , ptiBaseOid :: Word32 + -- ^ For domains: the underlying type OID. 0 otherwise. + , ptiElemOid :: Word32 + -- ^ For array types: the element type OID. 0 otherwise. + } + deriving stock (Show) + +-- | Query @pg_type@ for information about an unknown OID. +queryTypeInfo :: Connection -> Oid -> IO (Maybe PgTypeInfo) +queryTypeInfo conn (Oid rawOid) = do + let sql = + "SELECT typname, typtype, typarray, typbasetype, typelem FROM pg_type WHERE oid = " + <> BS8.pack (show rawOid) + result <- try @PgWireError (simpleQuery conn sql) + pure $ case result of + Left _ -> Nothing + Right (rows, _) -> case rows of + (row : _) -> Just (parsePgTypeRow row) + [] -> Nothing + +parsePgTypeRow :: [Maybe ByteString] -> PgTypeInfo +parsePgTypeRow row = + let (mName, mTyptype, mTyparray, mTypbase, mTypelem) = case row of + (a : b : c : d : e : _) -> (a, b, c, d, e) + _ -> (Nothing, Nothing, Nothing, Nothing, Nothing) + in PgTypeInfo + { ptiName = maybe "" TE.decodeUtf8 mName + , ptiCategory = parseTyptype mTyptype + , ptiArrayOid = parseOidField mTyparray + , ptiBaseOid = parseOidField mTypbase + , ptiElemOid = parseOidField mTypelem + } + +parseTyptype :: Maybe ByteString -> PgTypeCategory +parseTyptype (Just "e") = PgEnum +parseTyptype (Just "c") = PgComposite +parseTyptype (Just "d") = PgDomain +parseTyptype (Just "r") = PgRange +parseTyptype (Just "p") = PgPseudo +parseTyptype _ = PgBase + +parseOidField :: Maybe ByteString -> Word32 +parseOidField Nothing = 0 +parseOidField (Just bs) = + case BS8.readInt bs of + Just (n, _) -> fromIntegral n + Nothing -> 0 + +-- | Query @pg_enum@ for the labels of an enum type. +queryEnumLabels :: Connection -> Oid -> IO [Text] +queryEnumLabels conn (Oid rawOid) = do + let sql = + "SELECT enumlabel FROM pg_enum WHERE enumtypid = " + <> BS8.pack (show rawOid) + <> " ORDER BY enumsortorder" + result <- try @PgWireError (simpleQuery conn sql) + pure $ case result of + Left _ -> [] + Right (rows, _) -> map labelOf rows + where + labelOf (Just v : _) = TE.decodeUtf8 v + labelOf _ = "" + +-- | Query @pg_range@ for the subtype OID of a range type. +queryRangeSubtype :: Connection -> Oid -> IO (Maybe Oid) +queryRangeSubtype conn (Oid rawOid) = do + let sql = + "SELECT rngsubtype FROM pg_range WHERE rngtypid = " + <> BS8.pack (show rawOid) + result <- try @PgWireError (simpleQuery conn sql) + pure $ case result of + Left _ -> Nothing + Right (rows, _) -> case rows of + ((Just v : _) : _) -> case BS8.readInt v of + Just (n, _) -> Just (Oid (fromIntegral n)) + Nothing -> Nothing + _ -> Nothing diff --git a/src/Valiant/CLI/Discover.hs b/src/Valiant/CLI/Discover.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Discover.hs @@ -0,0 +1,107 @@ +module Valiant.CLI.Discover + ( SqlFile (..) + , discoverSqlFiles + , discoverInlineSql + ) where + +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.List (nub, sort) +import Data.Text (Text) +import Valiant.CLI.Hash (sha256Hex, sha256HexTruncated) +import System.Directory (doesDirectoryExist, makeAbsolute) +import System.FilePath (makeRelative) +import System.FilePath.Glob qualified as Glob + +-- | A discovered SQL file with its content and hash. +data SqlFile = SqlFile + { sqlRelPath :: FilePath + -- ^ Relative path from the SQL root, e.g. @"users/find_by_id.sql"@. + , sqlAbsPath :: FilePath + -- ^ Absolute path on disk. + , sqlContent :: BS.ByteString + -- ^ Raw file contents. + , sqlHash :: Text + -- ^ Full SHA-256 hex digest of the content. + , sqlHashShort :: Text + -- ^ Truncated (12-char) SHA-256 hex digest. + } + deriving stock (Show) + +-- | Recursively discover all @.sql@ files under the given directory. +-- Returns files sorted by relative path. +discoverSqlFiles :: FilePath -> IO [SqlFile] +discoverSqlFiles sqlDir = do + absDir <- makeAbsolute sqlDir + exists <- doesDirectoryExist absDir + if not exists + then pure [] + else do + let pat = Glob.compile "**/*.sql" + matched <- Glob.globDir [pat] absDir + let paths = sort (concat matched) + mapM (mkSqlFile absDir) paths + +-- | Scan Haskell source files for @query "..."@ calls and extract the +-- SQL text as synthetic 'SqlFile' entries. Deduplicates by SQL content. +discoverInlineSql :: [FilePath] -> IO [SqlFile] +discoverInlineSql hsPaths = do + allSqls <- concat <$> mapM extractFromHsFile hsPaths + -- Deduplicate by content (same SQL text from different files = one cache entry) + let unique = nub allSqls + pure (sort unique) + +extractFromHsFile :: FilePath -> IO [SqlFile] +extractFromHsFile hsPath = do + content <- BS.readFile hsPath + let ls = BS8.lines content + sqls = concatMap extractQueryCalls ls + pure [mkInlineSqlFile sql | sql <- sqls] + +-- | Simple extraction of query "..." string literals from a line. +-- Looks for: query "..." (handles basic cases, not full Haskell parsing). +extractQueryCalls :: BS.ByteString -> [BS.ByteString] +extractQueryCalls line = + case BS8.breakSubstring "query \"" line of + (_, rest) + | BS.null rest -> [] + | otherwise -> + let afterQuery = BS.drop 7 rest -- skip 'query "' + in case BS8.elemIndex '"' afterQuery of + Nothing -> [] + Just endIdx -> + let sqlText = BS.take endIdx afterQuery + in sqlText : extractQueryCalls (BS.drop (endIdx + 1) afterQuery) + +mkInlineSqlFile :: BS.ByteString -> SqlFile +mkInlineSqlFile sqlBs = + let hash = sha256Hex sqlBs + hashShort = sha256HexTruncated 12 sqlBs + in SqlFile + { sqlRelPath = "" + , sqlAbsPath = "" + , sqlContent = sqlBs + , sqlHash = hash + , sqlHashShort = hashShort + } + +instance Eq SqlFile where + a == b = sqlContent a == sqlContent b + +instance Ord SqlFile where + compare a b = compare (sqlContent a) (sqlContent b) + +mkSqlFile :: FilePath -> FilePath -> IO SqlFile +mkSqlFile baseDir absPath = do + content <- BS.readFile absPath + let relPath = makeRelative baseDir absPath + hash = sha256Hex content + hashShort = sha256HexTruncated 12 content + pure + SqlFile + { sqlRelPath = relPath + , sqlAbsPath = absPath + , sqlContent = content + , sqlHash = hash + , sqlHashShort = hashShort + } diff --git a/src/Valiant/CLI/Error.hs b/src/Valiant/CLI/Error.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Error.hs @@ -0,0 +1,87 @@ +module Valiant.CLI.Error + ( ValiantCliError (..) + , PgErrorDetail (..) + , dieWithError + , renderError + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import PgWire.Protocol.Oid (Oid (..)) +import System.Exit (exitFailure) +import System.IO (stderr) + +-- | Structured error from Postgres. +data PgErrorDetail = PgErrorDetail + { pgMessage :: Text + , pgDetail :: Maybe Text + , pgHint :: Maybe Text + , pgPosition :: Maybe Int + } + deriving stock (Show) + +-- | All CLI failure modes. +data ValiantCliError + = ErrNoDatabaseUrl + | ErrConnectionFailed Text + | ErrSqlDirNotFound FilePath + | ErrNoSqlFiles FilePath + | ErrDescribeFailed FilePath PgErrorDetail + | ErrUnknownOid FilePath Text Oid + | ErrCacheReadFailed FilePath String + | ErrStaleCacheFile FilePath Text Text + | ErrMissingCacheFile FilePath + deriving stock (Show) + +-- | Render an error to human-readable text. +renderError :: ValiantCliError -> Text +renderError = \case + ErrNoDatabaseUrl -> + T.unlines + [ "valiant: DATABASE_URL is not set." + , "" + , " Set it in your environment or in a .env file:" + , " DATABASE_URL=postgres://user:pass@localhost:5432/mydb" + ] + ErrConnectionFailed msg -> + "valiant: Failed to connect to database: " <> msg + ErrSqlDirNotFound dir -> + "valiant: SQL directory not found: " <> T.pack dir + ErrNoSqlFiles dir -> + "valiant: No .sql files found in " <> T.pack dir + ErrDescribeFailed path detail -> + T.unlines $ + [ "valiant: " <> T.pack path <> ": FAILED" + , " ERROR: " <> pgMessage detail + ] + <> maybe [] (\d -> [" DETAIL: " <> d]) (pgDetail detail) + <> maybe [] (\h -> [" HINT: " <> h]) (pgHint detail) + ErrUnknownOid path col (Oid oid) -> + T.unlines + [ "valiant: " <> T.pack path <> ": unknown Postgres type" + , " Column \"" <> col <> "\" has OID " <> T.pack (show oid) + , " which valiant doesn't know how to map to a Haskell type." + , "" + , " Cast the column in SQL or register a custom type mapping." + ] + ErrCacheReadFailed path msg -> + "valiant: Failed to read cache file " <> T.pack path <> ": " <> T.pack msg + ErrStaleCacheFile path cached current -> + T.unlines + [ "valiant: " <> T.pack path <> ": STALE" + , " SQL content has changed since last prepare." + , " Cache hash: " <> cached + , " Current hash: " <> current + ] + ErrMissingCacheFile path -> + T.unlines + [ "valiant: " <> T.pack path <> ": MISSING" + , " No cached metadata found. Run `valiant prepare`." + ] + +-- | Print an error to stderr and exit with failure. +dieWithError :: ValiantCliError -> IO a +dieWithError err = do + TIO.hPutStrLn stderr (renderError err) + exitFailure diff --git a/src/Valiant/CLI/Hash.hs b/src/Valiant/CLI/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Hash.hs @@ -0,0 +1,25 @@ +module Valiant.CLI.Hash + ( sha256Hex + , sha256HexTruncated + ) where + +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word8) +import Numeric (showHex) + +-- | Full SHA-256 hex digest of a 'ByteString'. +sha256Hex :: ByteString -> Text +sha256Hex = T.pack . concatMap toHex . BS.unpack . SHA256.hash + +-- | SHA-256 hex digest truncated to @n@ characters. +sha256HexTruncated :: Int -> ByteString -> Text +sha256HexTruncated n = T.take n . sha256Hex + +toHex :: Word8 -> String +toHex w + | w < 16 = '0' : showHex w "" + | otherwise = showHex w "" diff --git a/src/Valiant/CLI/NamedParams.hs b/src/Valiant/CLI/NamedParams.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/NamedParams.hs @@ -0,0 +1,140 @@ +-- | Preprocessing for named parameters in SQL files. +-- +-- Converts @:name@ syntax to positional @$N@ parameters: +-- +-- @ +-- SELECT id, name FROM users WHERE org_id = :orgId AND role = :role +-- @ +-- +-- becomes: +-- +-- @ +-- SELECT id, name FROM users WHERE org_id = $1 AND role = $2 +-- @ +-- +-- The name-to-position mapping is returned for storage in the cache. +-- A name that appears multiple times maps to the same @$N@. +-- +-- Rules: +-- +-- * @::@ (Postgres type cast) is not treated as a named parameter +-- * String literals (@\'...\'@), quoted identifiers (@\"...\"@), +-- line comments (@-- ...@), and block comments (@\/\* ... \*\/@) +-- are skipped +-- * A named parameter is @:@ followed by @[a-zA-Z_][a-zA-Z0-9_]*@ +module Valiant.CLI.NamedParams + ( NamedParamMapping + , preprocessNamedParams + ) where + +import Data.ByteString (ByteString) +import Data.Char (isAlpha, isAlphaNum) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +-- | Mapping from parameter name to its positional index (1-based). +type NamedParamMapping = [(Text, Int)] + +-- | Preprocess a SQL bytestring, replacing @:name@ with @$N@. +-- Returns the rewritten SQL and the name-to-position mapping. +-- If the SQL contains no named parameters, returns the original +-- SQL unchanged with an empty mapping. +preprocessNamedParams :: ByteString -> (ByteString, NamedParamMapping) +preprocessNamedParams sqlBs = + let sql = TE.decodeUtf8 sqlBs + (rewritten, mapping) = rewrite sql + in if Map.null mapping + then (sqlBs, []) + else (TE.encodeUtf8 rewritten, Map.toAscList mapping) + +-- | Rewrite SQL text, replacing :name tokens with $N. +rewrite :: Text -> (Text, Map Text Int) +rewrite = go mempty Map.empty 1 + where + go !acc !seen !nextIdx txt + | T.null txt = (acc, seen) + | otherwise = case T.uncons txt of + Nothing -> (acc, seen) + Just (c, rest) + -- String literal: skip to closing quote + | c == '\'' -> + let (lit, after) = spanStringLit rest + in go (acc <> T.singleton c <> lit) seen nextIdx after + -- Quoted identifier: skip to closing double-quote + | c == '"' -> + let (qid, after) = spanQuotedId rest + in go (acc <> T.singleton c <> qid) seen nextIdx after + -- Line comment: skip to end of line + | c == '-', Just ('-', _) <- T.uncons rest -> + let (comment, after) = T.break (== '\n') rest + in go (acc <> T.singleton c <> comment) seen nextIdx after + -- Block comment: skip to */ + | c == '/', Just ('*', rest2) <- T.uncons rest -> + let (comment, after) = spanBlockComment rest2 + in go (acc <> "/*" <> comment) seen nextIdx after + -- Postgres cast (::) — not a named param + | c == ':', Just (':', _) <- T.uncons rest -> + go (acc <> "::") seen nextIdx (T.drop 1 rest) + -- Named parameter + | c == ':', Just (h, _) <- T.uncons rest, isParamStart h -> + let (name, after) = T.span isParamChar rest + in case Map.lookup name seen of + Just idx -> + go (acc <> "$" <> T.pack (show idx)) seen nextIdx after + Nothing -> + go (acc <> "$" <> T.pack (show nextIdx)) (Map.insert name nextIdx seen) (nextIdx + 1) after + -- Anything else: pass through + | otherwise -> + go (acc <> T.singleton c) seen nextIdx rest + + isParamStart c = isAlpha c || c == '_' + isParamChar c = isAlphaNum c || c == '_' + +-- | Consume a single-quoted string literal (handling '' escapes). +spanStringLit :: Text -> (Text, Text) +spanStringLit = go mempty + where + go !acc txt + | T.null txt = (acc, txt) + | otherwise = case T.uncons txt of + Just ('\'', rest) + | Just ('\'', rest2) <- T.uncons rest -> + go (acc <> "''") rest2 + | otherwise -> + (acc <> "'", rest) + Just (c, rest) -> + go (acc <> T.singleton c) rest + Nothing -> (acc, txt) + +-- | Consume a double-quoted identifier (handling "" escapes). +spanQuotedId :: Text -> (Text, Text) +spanQuotedId = go mempty + where + go !acc txt + | T.null txt = (acc, txt) + | otherwise = case T.uncons txt of + Just ('"', rest) + | Just ('"', rest2) <- T.uncons rest -> + go (acc <> "\"\"") rest2 + | otherwise -> + (acc <> "\"", rest) + Just (c, rest) -> + go (acc <> T.singleton c) rest + Nothing -> (acc, txt) + +-- | Consume a block comment up to and including the closing @*/@. +spanBlockComment :: Text -> (Text, Text) +spanBlockComment = go mempty + where + go !acc txt + | T.null txt = (acc, txt) + | otherwise = case T.uncons txt of + Just ('*', rest) + | Just ('/', rest2) <- T.uncons rest -> + (acc <> "*/", rest2) + Just (c, rest) -> + go (acc <> T.singleton c) rest + Nothing -> (acc, txt) diff --git a/src/Valiant/CLI/Nullability.hs b/src/Valiant/CLI/Nullability.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Nullability.hs @@ -0,0 +1,36 @@ +module Valiant.CLI.Nullability + ( resolveNullability + ) where + +import Control.Exception (try) +import Data.ByteString.Char8 qualified as BS8 +import PgWire.Connection (Connection, simpleQuery) +import PgWire.Error (PgWireError) +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.Describe (ColumnMeta (..)) + +-- | For each column, determine whether it is nullable by querying +-- @pg_attribute@. Columns without a source table (computed columns) +-- are assumed nullable. +resolveNullability :: Connection -> [ColumnMeta] -> IO [Bool] +resolveNullability conn = mapM (isNullable conn) + +-- | Returns @True@ if the column is nullable. +isNullable :: Connection -> ColumnMeta -> IO Bool +isNullable conn col + | cmTableOid col == Oid 0 = pure True -- computed / expression column + | cmColumnNumber col == 0 = pure True -- no source column info + | otherwise = do + let Oid tableOid = cmTableOid col + sql = + "SELECT NOT attnotnull FROM pg_attribute WHERE attrelid = " + <> BS8.pack (show tableOid) + <> " AND attnum = " + <> BS8.pack (show (cmColumnNumber col)) + result <- try @PgWireError (simpleQuery conn sql) + pure $ case result of + Left _ -> True -- assume nullable on error + Right (rows, _) -> case rows of + ((Just "t" : _) : _) -> True + ((Just "f" : _) : _) -> False + _ -> True -- no info or unexpected value: default to nullable diff --git a/src/Valiant/CLI/Output.hs b/src/Valiant/CLI/Output.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/Output.hs @@ -0,0 +1,93 @@ +module Valiant.CLI.Output + ( printHeader + , printProgress + , printOk + , printFailed + , printStale + , printMissing + , printSummary + , printLn + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import System.Console.ANSI + ( Color (..) + , ColorIntensity (..) + , ConsoleLayer (..) + , SGR (..) + , hSupportsANSIColor + , setSGRCode + ) +import System.IO (stdout) + +-- | Print a section header. +printHeader :: Text -> IO () +printHeader hdr = TIO.putStrLn $ "valiant: " <> hdr + +-- | Print progress line without trailing newline. +-- +-- @printProgress 3 10 "sql/users/find_by_id.sql"@ produces: +-- +-- > [3/10] sql/users/find_by_id.sql ... +printProgress :: Int -> Int -> FilePath -> IO () +printProgress n total path = do + let pad = length (show total) + idx = leftPad pad (show n) + putStr $ " [" <> idx <> "/" <> show total <> "] " <> path <> " ... " + +-- | Print green "ok" with newline. +printOk :: IO () +printOk = withColor Green $ TIO.putStrLn "ok" + +-- | Print red "FAILED" with detail on the next line. +printFailed :: Text -> IO () +printFailed detail = do + withColor Red $ TIO.putStrLn "FAILED" + TIO.putStrLn $ " " <> detail + +-- | Print yellow "STALE" with newline. +printStale :: IO () +printStale = withColor Yellow $ TIO.putStrLn "STALE" + +-- | Print yellow "MISSING" with newline. +printMissing :: IO () +printMissing = withColor Yellow $ TIO.putStrLn "MISSING" + +-- | Print a summary line. +printSummary :: Int -> Int -> IO () +printSummary ok total + | ok == total = do + printLn "" + withColor Green . TIO.putStrLn $ + " All " <> T.pack (show total) <> " queries valid." + | otherwise = do + printLn "" + withColor Red . TIO.putStrLn $ + " " + <> T.pack (show ok) + <> " of " + <> T.pack (show total) + <> " queries valid. " + <> T.pack (show (total - ok)) + <> " failed." + +-- | Print a line of text. +printLn :: Text -> IO () +printLn = TIO.putStrLn + +-- Helpers ----------------------------------------------------------------- + +leftPad :: Int -> String -> String +leftPad n s = replicate (n - length s) ' ' <> s + +withColor :: Color -> IO () -> IO () +withColor color action = do + supportsColor <- hSupportsANSIColor stdout + if supportsColor + then do + putStr (setSGRCode [SetColor Foreground Vivid color]) + action + putStr (setSGRCode [Reset]) + else action diff --git a/src/Valiant/CLI/SqlMetadata.hs b/src/Valiant/CLI/SqlMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/SqlMetadata.hs @@ -0,0 +1,62 @@ +module Valiant.CLI.SqlMetadata + ( SqlMetadata (..) + , parseSqlMetadata + , defaultMetadata + ) where + +import Data.List qualified as List +import Data.Text (Text) +import Data.Text qualified as T + +-- | Optional metadata parsed from @-- valiant:@ comments in SQL files. +data SqlMetadata = SqlMetadata + { smName :: Maybe Text + -- ^ Override the generated binding name (@-- valiant:name getUserById@). + , smResult :: Maybe Text + -- ^ Use a named result type (@-- valiant:result User@). + , smSingle :: Bool + -- ^ Expect exactly one row (@-- valiant:single@). If set, the generated + -- binding returns @r@ instead of @Maybe r@ or @[r]@. + } + deriving stock (Show, Eq) + +defaultMetadata :: SqlMetadata +defaultMetadata = + SqlMetadata + { smName = Nothing + , smResult = Nothing + , smSingle = False + } + +-- | Parse @-- valiant:@ directives from SQL file content. +-- Only lines starting with @-- valiant:@ (with optional leading whitespace) +-- are recognised. The directives must appear before the first SQL keyword. +parseSqlMetadata :: Text -> SqlMetadata +parseSqlMetadata = List.foldl' applyDirective defaultMetadata . extractDirectives + +extractDirectives :: Text -> [(Text, Text)] +extractDirectives sql = + [ parseDirective line + | line <- T.lines sql + , isDirective line + ] + +isDirective :: Text -> Bool +isDirective line = + let stripped = T.stripStart line + in T.isPrefixOf "-- valiant:" stripped + +parseDirective :: Text -> (Text, Text) +parseDirective line = + let stripped = T.stripStart line + -- Remove "-- valiant:" prefix + afterPrefix = T.drop 11 stripped -- length "-- valiant:" == 11 + (key, rest) = T.break (== ' ') (T.strip afterPrefix) + in (T.toLower key, T.strip rest) + +applyDirective :: SqlMetadata -> (Text, Text) -> SqlMetadata +applyDirective meta (key, value) = case key of + "name" | not (T.null value) -> meta {smName = Just value} + "result" | not (T.null value) -> meta {smResult = Just value} + "single" -> meta {smSingle = True} + _ -> meta diff --git a/src/Valiant/CLI/TypeMap.hs b/src/Valiant/CLI/TypeMap.hs new file mode 100644 --- /dev/null +++ b/src/Valiant/CLI/TypeMap.hs @@ -0,0 +1,276 @@ +module Valiant.CLI.TypeMap + ( HaskellType (..) + , ResolvedType (..) + , oidToHaskellType + , oidToTypeName + , resolveType + , oidToHaskellTypeWith + , oidToTypeNameWith + , resolveUnknownOid + , isArrayOid + , arrayElementOid + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import PgWire.Connection (Connection) +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.Describe (PgTypeCategory (..), PgTypeInfo (..), queryEnumLabels, queryRangeSubtype, queryTypeInfo) + +-- | A Haskell type with its originating module. +data HaskellType = HaskellType + { htType :: Text + , htModule :: Text + } + deriving stock (Show, Eq) + +-- | Wrap a type in @Maybe@ if nullable. +resolveType :: Bool -> HaskellType -> HaskellType +resolveType nullable ht + | nullable = ht {htType = "Maybe " <> htType ht} + | otherwise = ht + +-- | Look up the Haskell type for a Postgres OID (built-in types only). +oidToHaskellType :: Oid -> Maybe HaskellType +oidToHaskellType oid = Map.lookup oid oidMap + +-- | Look up the Haskell type for a Postgres OID, falling back to a custom map. +oidToHaskellTypeWith :: Map Oid HaskellType -> Oid -> Maybe HaskellType +oidToHaskellTypeWith customs oid = + -- Custom types take priority over built-in mappings + case Map.lookup oid customs of + Just ht -> Just ht + Nothing -> case Map.lookup oid oidMap of + Just ht -> Just ht + Nothing -> arrayHaskellType oid customs + +-- | Look up the Postgres type name for an OID. +oidToTypeName :: Oid -> Maybe Text +oidToTypeName oid = Map.lookup oid oidNameMap + +-- | Look up the Postgres type name for an OID, falling back to a custom map. +oidToTypeNameWith :: Map Oid Text -> Oid -> Maybe Text +oidToTypeNameWith customs oid = + Map.lookup oid oidNameMap <> Map.lookup oid customs + +-- Array support ------------------------------------------------------------- + +-- | Check whether an OID is a known array type. +isArrayOid :: Oid -> Bool +isArrayOid oid = Map.member oid arrayOidToElement + +-- | For an array OID, return the element OID. +arrayElementOid :: Oid -> Maybe Oid +arrayElementOid oid = Map.lookup oid arrayOidToElement + +-- | Derive the Haskell type for an array OID: @Vector @. +arrayHaskellType :: Oid -> Map Oid HaskellType -> Maybe HaskellType +arrayHaskellType oid customs = do + elemOid <- arrayElementOid oid + elemHt <- case Map.lookup elemOid oidMap of + Just ht -> Just ht + Nothing -> Map.lookup elemOid customs + pure + HaskellType + { htType = "Vector " <> htType elemHt + , htModule = "Data.Vector" + } + +-- Automatic type discovery ------------------------------------------------ + +-- | Result of resolving an unknown OID via @pg_type@ introspection. +data ResolvedType = ResolvedType + { rtHaskellType :: HaskellType + , rtPgTypeName :: Text + , rtCategory :: Maybe Text + -- ^ @\"enum\"@, @\"domain\"@, @\"range\"@ — stored in the cache JSON. + , rtEnumLabels :: Maybe [Text] + -- ^ Enum labels, if this is an enum type. + } + deriving stock (Show) + +-- | Attempt to resolve an unknown OID by querying @pg_type@. +-- Handles enums (→ 'Text'), domains (→ unwrap to base type), +-- ranges (→ @PgRange BaseType@), and composites (→ error). +resolveUnknownOid + :: Connection + -> Map Oid HaskellType + -- ^ Custom type overrides + -> Oid + -> IO (Either Text ResolvedType) +resolveUnknownOid conn customs oid = do + mInfo <- queryTypeInfo conn oid + case mInfo of + Nothing -> + let Oid raw = oid + in pure . Left $ "Unknown OID " <> T.pack (show raw) <> " (not found in pg_type)" + Just info -> case ptiCategory info of + PgEnum -> do + labels <- queryEnumLabels conn oid + pure . Right $ + ResolvedType + { rtHaskellType = HaskellType "Text" "Data.Text" + , rtPgTypeName = ptiName info + , rtCategory = Just "enum" + , rtEnumLabels = Just labels + } + PgDomain -> do + -- Follow typbasetype to the underlying type + let baseOid = Oid (ptiBaseOid info) + case oidToHaskellTypeWith customs baseOid of + Just ht -> + pure . Right $ + ResolvedType + { rtHaskellType = ht + , rtPgTypeName = ptiName info + , rtCategory = Just "domain" + , rtEnumLabels = Nothing + } + Nothing -> do + -- Recursively resolve the base type (domain over domain, etc.) + nested <- resolveUnknownOid conn customs baseOid + case nested of + Left err -> pure . Left $ "Domain " <> ptiName info <> " -> " <> err + Right rt -> + pure . Right $ + rt + { rtPgTypeName = ptiName info + , rtCategory = Just "domain" + } + PgRange -> do + mSubOid <- queryRangeSubtype conn oid + case mSubOid of + Nothing -> + pure . Left $ "Range type " <> ptiName info <> ": could not determine subtype" + Just subOid -> do + mSubHt <- case oidToHaskellTypeWith customs subOid of + Just ht -> pure (Right ht) + Nothing -> do + nested <- resolveUnknownOid conn customs subOid + pure (rtHaskellType <$> nested) + case mSubHt of + Left err -> pure . Left $ "Range type " <> ptiName info <> " subtype: " <> err + Right subHt -> + pure . Right $ + ResolvedType + { rtHaskellType = + HaskellType ("PgRange " <> htType subHt) "Valiant" + , rtPgTypeName = ptiName info + , rtCategory = Just "range" + , rtEnumLabels = Nothing + } + PgComposite -> + pure . Left $ + "Composite type " + <> ptiName info + <> " (OID " + <> T.pack (show (let Oid raw = oid in raw)) + <> ") cannot be auto-mapped. Register it in valiant-types.json or cast in SQL." + _ -> + pure . Left $ + "Unknown type " + <> ptiName info + <> " (OID " + <> T.pack (show (let Oid raw = oid in raw)) + <> "). Register it in valiant-types.json or cast in SQL." + +-- Internal mapping tables ------------------------------------------------ + +oidMap :: Map Oid HaskellType +oidMap = + Map.fromList + [ (Oid 16, HaskellType "Bool" "Prelude") + , (Oid 17, HaskellType "ByteString" "Data.ByteString") + , (Oid 20, HaskellType "Int64" "Data.Int") + , (Oid 21, HaskellType "Int16" "Data.Int") + , (Oid 23, HaskellType "Int32" "Data.Int") + , (Oid 25, HaskellType "Text" "Data.Text") + , (Oid 114, HaskellType "Value" "Data.Aeson") + , (Oid 700, HaskellType "Float" "Prelude") + , (Oid 701, HaskellType "Double" "Prelude") + , (Oid 1043, HaskellType "Text" "Data.Text") + , (Oid 1082, HaskellType "Day" "Data.Time") + , (Oid 1083, HaskellType "TimeOfDay" "Data.Time") + , (Oid 1266, HaskellType "(TimeOfDay, TimeZone)" "Data.Time") + , (Oid 1114, HaskellType "LocalTime" "Data.Time") + , (Oid 1184, HaskellType "UTCTime" "Data.Time") + , (Oid 1186, HaskellType "PgInterval" "Valiant") + , (Oid 1700, HaskellType "Scientific" "Data.Scientific") + , (Oid 869, HaskellType "PgInet" "Valiant") + , (Oid 650, HaskellType "PgInet" "Valiant") + , (Oid 829, HaskellType "PgMacAddr" "Valiant") + , (Oid 774, HaskellType "PgMacAddr" "Valiant") + , (Oid 600, HaskellType "PgPoint" "Valiant") + , (Oid 2950, HaskellType "UUID" "Data.UUID") + , (Oid 3802, HaskellType "Value" "Data.Aeson") + ] + +oidNameMap :: Map Oid Text +oidNameMap = + Map.fromList + [ (Oid 16, "bool") + , (Oid 17, "bytea") + , (Oid 20, "int8") + , (Oid 21, "int2") + , (Oid 23, "int4") + , (Oid 25, "text") + , (Oid 114, "json") + , (Oid 700, "float4") + , (Oid 701, "float8") + , (Oid 1043, "varchar") + , (Oid 1082, "date") + , (Oid 1083, "time") + , (Oid 1266, "timetz") + , (Oid 1114, "timestamp") + , (Oid 1184, "timestamptz") + , (Oid 1186, "interval") + , (Oid 1700, "numeric") + , (Oid 869, "inet") + , (Oid 650, "cidr") + , (Oid 829, "macaddr") + , (Oid 774, "macaddr8") + , (Oid 600, "point") + , (Oid 2950, "uuid") + , (Oid 3802, "jsonb") + -- Array types + , (Oid 1000, "_bool") + , (Oid 1001, "_bytea") + , (Oid 1005, "_int2") + , (Oid 1007, "_int4") + , (Oid 1009, "_text") + , (Oid 1015, "_varchar") + , (Oid 1016, "_int8") + , (Oid 1021, "_float4") + , (Oid 1022, "_float8") + , (Oid 1115, "_timestamp") + , (Oid 1182, "_date") + , (Oid 1183, "_time") + , (Oid 1185, "_timestamptz") + , (Oid 2951, "_uuid") + , (Oid 199, "_json") + , (Oid 3807, "_jsonb") + ] + +-- | Mapping from array OIDs to their element OIDs. +arrayOidToElement :: Map Oid Oid +arrayOidToElement = + Map.fromList + [ (Oid 1000, Oid 16) -- bool[] + , (Oid 1001, Oid 17) -- bytea[] + , (Oid 1005, Oid 21) -- int2[] + , (Oid 1007, Oid 23) -- int4[] + , (Oid 1009, Oid 25) -- text[] + , (Oid 1015, Oid 1043) -- varchar[] + , (Oid 1016, Oid 20) -- int8[] + , (Oid 1021, Oid 700) -- float4[] + , (Oid 1022, Oid 701) -- float8[] + , (Oid 1115, Oid 1114) -- timestamp[] + , (Oid 1182, Oid 1082) -- date[] + , (Oid 1183, Oid 1083) -- time[] + , (Oid 1185, Oid 1184) -- timestamptz[] + , (Oid 2951, Oid 2950) -- uuid[] + , (Oid 199, Oid 114) -- json[] + , (Oid 3807, Oid 3802) -- jsonb[] + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import Valiant.CLI.CacheSpec qualified as CacheSpec +import Valiant.CLI.CustomTypesSpec qualified as CustomTypesSpec +import Valiant.CLI.DiscoverSpec qualified as DiscoverSpec +import Valiant.CLI.ErrorSpec qualified as ErrorSpec +import Valiant.CLI.HashSpec qualified as HashSpec +import Valiant.CLI.NamedParamsSpec qualified as NamedParamsSpec +import Valiant.CLI.SqlMetadataSpec qualified as SqlMetadataSpec +import Valiant.CLI.TypeMapSpec qualified as TypeMapSpec +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "Valiant.CLI.Hash" HashSpec.spec + describe "Valiant.CLI.TypeMap" TypeMapSpec.spec + describe "Valiant.CLI.Cache" CacheSpec.spec + describe "Valiant.CLI.Discover" DiscoverSpec.spec + describe "Valiant.CLI.Error" ErrorSpec.spec + describe "Valiant.CLI.SqlMetadata" SqlMetadataSpec.spec + describe "Valiant.CLI.NamedParams" NamedParamsSpec.spec + describe "Valiant.CLI.CustomTypes" CustomTypesSpec.spec diff --git a/test/Valiant/CLI/CacheSpec.hs b/test/Valiant/CLI/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/CacheSpec.hs @@ -0,0 +1,102 @@ +module Valiant.CLI.CacheSpec (spec) where + +import Data.Aeson (eitherDecode, encode) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Valiant.CLI.Cache +import Test.Hspec + +spec :: Spec +spec = do + describe "StatementType JSON round-trip" $ do + it "round-trips Select" $ do + eitherDecode (encode Select) `shouldBe` Right Select + + it "round-trips Insert" $ do + eitherDecode (encode Insert) `shouldBe` Right Insert + + describe "CacheEntry JSON round-trip" $ do + it "round-trips a full cache entry" $ do + now <- getCurrentTime + let entry = sampleEntry now + eitherDecode (encode entry) `shouldBe` Right entry + + describe "cacheFileName" $ do + it "produces the expected format" $ do + cacheFileName "users/find_by_id.sql" "a1b2c3d4e5f6" + `shouldBe` "users-find_by_id-a1b2c3d4e5f6.json" + + it "handles nested paths" $ do + let name = cacheFileName "admin/reports/monthly.sql" "abcdef012345" + name `shouldBe` "admin-reports-monthly-abcdef012345.json" + + describe "statementTypeFromSql" $ do + it "detects SELECT" $ do + statementTypeFromSql "SELECT id FROM users" `shouldBe` Select + + it "detects INSERT" $ do + statementTypeFromSql "INSERT INTO users (name) VALUES ($1)" `shouldBe` Insert + + it "detects UPDATE" $ do + statementTypeFromSql "UPDATE users SET name = $1" `shouldBe` Update + + it "detects DELETE" $ do + statementTypeFromSql "DELETE FROM users WHERE id = $1" `shouldBe` Delete + + it "detects CTE as Select" $ do + statementTypeFromSql "WITH cte AS (SELECT 1) SELECT * FROM cte" `shouldBe` Select + + it "is case-insensitive" $ do + statementTypeFromSql "select id from users" `shouldBe` Select + + it "handles leading whitespace" $ do + statementTypeFromSql " \n SELECT id FROM users" `shouldBe` Select + +sampleEntry :: UTCTime -> CacheEntry +sampleEntry now = + CacheEntry + { ceVersion = "0.1.0" + , ceFile = "users/find_by_id.sql" + , ceSqlHash = "abcdef0123456789" + , ceSql = "SELECT id, name FROM users WHERE id = $1" + , ceDbUrlHash = "fedcba9876543210" + , cePreparedAt = now + , ceStatementType = Select + , ceParams = + [ CacheParam + { cpIndex = 1 + , cpName = Nothing + , cpPgOid = 23 + , cpPgTypeName = "int4" + , cpHaskellType = "Int32" + , cpHaskellModule = "Data.Int" + , cpPgTypeCategory = Nothing + , cpPgEnumLabels = Nothing + } + ] + , ceColumns = + [ CacheColumn + { ccName = "id" + , ccPgOid = 23 + , ccPgTypeName = "int4" + , ccNullable = False + , ccHaskellType = "Int32" + , ccHaskellModule = "Data.Int" + , ccSourceTableOid = Just 16385 + , ccSourceColumnNum = Just 1 + , ccPgTypeCategory = Nothing + , ccPgEnumLabels = Nothing + } + , CacheColumn + { ccName = "name" + , ccPgOid = 25 + , ccPgTypeName = "text" + , ccNullable = False + , ccHaskellType = "Text" + , ccHaskellModule = "Data.Text" + , ccSourceTableOid = Just 16385 + , ccSourceColumnNum = Just 2 + , ccPgTypeCategory = Nothing + , ccPgEnumLabels = Nothing + } + ] + } diff --git a/test/Valiant/CLI/CustomTypesSpec.hs b/test/Valiant/CLI/CustomTypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/CustomTypesSpec.hs @@ -0,0 +1,62 @@ +module Valiant.CLI.CustomTypesSpec (spec) where + +import Data.Aeson (encode, object, (.=)) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.CustomTypes (loadCustomTypes) +import Valiant.CLI.TypeMap (HaskellType (..)) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "loadCustomTypes" $ do + it "returns empty map when file does not exist" $ do + customs <- loadCustomTypes "/nonexistent/valiant-types.json" + customs `shouldBe` Map.empty + + it "loads custom type mappings from JSON file" $ do + withSystemTempDirectory "valiant-test" $ \dir -> do + let path = dir <> "/valiant-types.json" + content = + encode + [ object + [ "oid" .= (600 :: Int) + , "pg_type_name" .= ("point" :: String) + , "haskell_type" .= ("MyPoint" :: String) + , "haskell_module" .= ("MyApp.Types" :: String) + ] + ] + LBS.writeFile path content + customs <- loadCustomTypes path + Map.lookup (Oid 600) customs `shouldBe` Just (HaskellType "MyPoint" "MyApp.Types") + + it "returns empty map on invalid JSON" $ do + withSystemTempDirectory "valiant-test" $ \dir -> do + let path = dir <> "/valiant-types.json" + writeFile path "not valid json" + customs <- loadCustomTypes path + customs `shouldBe` Map.empty + + it "loads multiple entries" $ do + withSystemTempDirectory "valiant-test" $ \dir -> do + let path = dir <> "/valiant-types.json" + content = + encode + [ object + [ "oid" .= (600 :: Int) + , "pg_type_name" .= ("point" :: String) + , "haskell_type" .= ("MyPoint" :: String) + , "haskell_module" .= ("MyApp.Types" :: String) + ] + , object + [ "oid" .= (601 :: Int) + , "pg_type_name" .= ("lseg" :: String) + , "haskell_type" .= ("MySegment" :: String) + , "haskell_module" .= ("MyApp.Types" :: String) + ] + ] + LBS.writeFile path content + customs <- loadCustomTypes path + Map.size customs `shouldBe` 2 diff --git a/test/Valiant/CLI/DiscoverSpec.hs b/test/Valiant/CLI/DiscoverSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/DiscoverSpec.hs @@ -0,0 +1,124 @@ +module Valiant.CLI.DiscoverSpec (spec) where + +import Data.ByteString.Char8 qualified as BS8 +import Data.List (sort) +import Valiant.CLI.Discover +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "discoverSqlFiles" $ do + it "finds .sql files recursively" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "users") + BS8.writeFile (tmpDir "users" "find.sql") "SELECT 1" + BS8.writeFile (tmpDir "list.sql") "SELECT 2" + files <- discoverSqlFiles tmpDir + sort (map sqlRelPath files) `shouldBe` ["list.sql", "users/find.sql"] + + it "returns empty for non-existent directory" $ do + files <- discoverSqlFiles "/tmp/valiant-nonexistent-dir-12345" + map sqlRelPath files `shouldBe` [] + + it "ignores non-.sql files" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + BS8.writeFile (tmpDir "query.sql") "SELECT 1" + BS8.writeFile (tmpDir "notes.txt") "not sql" + BS8.writeFile (tmpDir "readme.md") "not sql" + files <- discoverSqlFiles tmpDir + map sqlRelPath files `shouldBe` ["query.sql"] + + it "reads file content correctly" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let content = "SELECT id FROM users WHERE id = $1" + BS8.writeFile (tmpDir "test.sql") content + files <- discoverSqlFiles tmpDir + case files of + [f] -> sqlContent f `shouldBe` content + _ -> expectationFailure "expected exactly one file" + + describe "discoverInlineSql" $ do + it "extracts query calls from Haskell source" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Queries.hs" + writeFile hsFile $ unlines + [ "module Queries where" + , "import Valiant" + , "findById = query \"SELECT id, name FROM users WHERE id = $1\"" + , "listAll = query \"SELECT id, name FROM users\"" + ] + files <- discoverInlineSql [hsFile] + length files `shouldBe` 2 + + it "extracts SQL content correctly" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile "q = query \"SELECT 1\"" + files <- discoverInlineSql [hsFile] + case files of + [f] -> sqlContent f `shouldBe` "SELECT 1" + _ -> expectationFailure $ "expected 1 file, got " <> show (length files) + + it "sets path to " $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile "q = query \"SELECT 1\"" + files <- discoverInlineSql [hsFile] + case files of + [f] -> sqlRelPath f `shouldBe` "" + _ -> expectationFailure "expected 1 file" + + it "deduplicates identical SQL across files" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let f1 = tmpDir "A.hs" + f2 = tmpDir "B.hs" + writeFile f1 "a = query \"SELECT 1\"" + writeFile f2 "b = query \"SELECT 1\"" + files <- discoverInlineSql [f1, f2] + length files `shouldBe` 1 + + it "handles multiple queries on separate lines" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile $ unlines + [ "a = query \"SELECT 1\"" + , "b = query \"SELECT 2\"" + , "c = query \"SELECT 3\"" + ] + files <- discoverInlineSql [hsFile] + length files `shouldBe` 3 + + it "ignores queryFile calls" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile "q = queryFile \"users/find.sql\"" + files <- discoverInlineSql [hsFile] + length files `shouldBe` 0 + + it "ignores lines without query calls" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile $ unlines + [ "module Q where" + , "import Valiant" + , "-- this is a comment with query in it" + , "x = 42" + ] + files <- discoverInlineSql [hsFile] + length files `shouldBe` 0 + + it "returns empty for no .hs files" $ do + files <- discoverInlineSql [] + length files `shouldBe` 0 + + it "extracts SQL with named params" $ do + withSystemTempDirectory "valiant-test" $ \tmpDir -> do + let hsFile = tmpDir "Q.hs" + writeFile hsFile "q = query \"SELECT id FROM users WHERE name = :name AND active = :active\"" + files <- discoverInlineSql [hsFile] + case files of + [f] -> sqlContent f `shouldBe` "SELECT id FROM users WHERE name = :name AND active = :active" + _ -> expectationFailure $ "expected 1 file, got " <> show (length files) diff --git a/test/Valiant/CLI/ErrorSpec.hs b/test/Valiant/CLI/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/ErrorSpec.hs @@ -0,0 +1,69 @@ +module Valiant.CLI.ErrorSpec (spec) where + +import Data.Text qualified as T +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.Error +import Test.Hspec + +spec :: Spec +spec = do + describe "renderError" $ do + it "produces non-empty text for ErrNoDatabaseUrl" $ + renderError ErrNoDatabaseUrl `shouldNotBe` "" + + it "produces non-empty text for ErrConnectionFailed" $ + renderError (ErrConnectionFailed "timeout") `shouldNotBe` "" + + it "produces non-empty text for ErrSqlDirNotFound" $ + renderError (ErrSqlDirNotFound "sql/") `shouldNotBe` "" + + it "produces non-empty text for ErrNoSqlFiles" $ + renderError (ErrNoSqlFiles "sql/") `shouldNotBe` "" + + it "produces non-empty text for ErrDescribeFailed" $ + renderError (ErrDescribeFailed "test.sql" pgErr) `shouldNotBe` "" + + it "produces non-empty text for ErrUnknownOid" $ + renderError (ErrUnknownOid "test.sql" "col" (Oid 600)) `shouldNotBe` "" + + it "produces non-empty text for ErrCacheReadFailed" $ + renderError (ErrCacheReadFailed "cache.json" "parse error") `shouldNotBe` "" + + it "produces non-empty text for ErrStaleCacheFile" $ + renderError (ErrStaleCacheFile "test.sql" "aaa" "bbb") `shouldNotBe` "" + + it "produces non-empty text for ErrMissingCacheFile" $ + renderError (ErrMissingCacheFile "test.sql") `shouldNotBe` "" + + it "ErrNoDatabaseUrl mentions DATABASE_URL" $ + renderError ErrNoDatabaseUrl `shouldSatisfy` T.isInfixOf "DATABASE_URL" + + it "ErrSqlDirNotFound includes the directory path" $ + renderError (ErrSqlDirNotFound "my/sql/dir") + `shouldSatisfy` T.isInfixOf "my/sql/dir" + + it "ErrNoSqlFiles includes the directory path" $ + renderError (ErrNoSqlFiles "some/dir") + `shouldSatisfy` T.isInfixOf "some/dir" + + it "ErrStaleCacheFile includes both hashes" $ do + let rendered = renderError (ErrStaleCacheFile "q.sql" "abc123" "def456") + rendered `shouldSatisfy` T.isInfixOf "abc123" + rendered `shouldSatisfy` T.isInfixOf "def456" + + it "ErrMissingCacheFile mentions valiant prepare" $ + renderError (ErrMissingCacheFile "q.sql") + `shouldSatisfy` T.isInfixOf "valiant prepare" + + it "ErrDescribeFailed includes the PG error message" $ + renderError (ErrDescribeFailed "q.sql" pgErr) + `shouldSatisfy` T.isInfixOf "column \"emal\" does not exist" + +pgErr :: PgErrorDetail +pgErr = + PgErrorDetail + { pgMessage = "column \"emal\" does not exist" + , pgDetail = Nothing + , pgHint = Just "Perhaps you meant \"email\"." + , pgPosition = Nothing + } diff --git a/test/Valiant/CLI/HashSpec.hs b/test/Valiant/CLI/HashSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/HashSpec.hs @@ -0,0 +1,30 @@ +module Valiant.CLI.HashSpec (spec) where + +import Data.Text qualified as T +import Valiant.CLI.Hash +import Test.Hspec + +spec :: Spec +spec = do + it "produces a 64-character hex string" $ do + let h = sha256Hex "hello" + T.length h `shouldBe` 64 + + it "is deterministic" $ do + sha256Hex "test" `shouldBe` sha256Hex "test" + + it "differs for different inputs" $ do + sha256Hex "a" `shouldNotBe` sha256Hex "b" + + it "truncates to the requested length" $ do + let h = sha256HexTruncated 12 "hello" + T.length h `shouldBe` 12 + + it "truncated hash is a prefix of the full hash" $ do + let full = sha256Hex "hello" + short = sha256HexTruncated 12 "hello" + T.take 12 full `shouldBe` short + + -- Known SHA-256 of empty string + it "hashes empty string correctly" $ do + sha256Hex "" `shouldBe` "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" diff --git a/test/Valiant/CLI/NamedParamsSpec.hs b/test/Valiant/CLI/NamedParamsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/NamedParamsSpec.hs @@ -0,0 +1,162 @@ +module Valiant.CLI.NamedParamsSpec (spec) where + +import Data.ByteString.Char8 qualified as BS8 +import Valiant.CLI.NamedParams +import Test.Hspec + +spec :: Spec +spec = do + describe "preprocessNamedParams" $ do + -- Basic functionality + it "replaces a single :name with $1" $ do + let (sql, mapping) = preprocessNamedParams "SELECT * FROM users WHERE id = :userId" + sql `shouldBe` "SELECT * FROM users WHERE id = $1" + mapping `shouldBe` [("userId", 1)] + + it "replaces multiple distinct :names" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM users WHERE org_id = :orgId AND role = :role AND active = :active" + sql `shouldBe` "SELECT * FROM users WHERE org_id = $1 AND role = $2 AND active = $3" + mapping `shouldBe` [("active", 3), ("orgId", 1), ("role", 2)] + + it "reuses the same $N for repeated :name" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE a = :x OR b = :x" + sql `shouldBe` "SELECT * FROM t WHERE a = $1 OR b = $1" + mapping `shouldBe` [("x", 1)] + + it "handles mixed repeated and distinct names" $ do + let (sql, _mapping) = preprocessNamedParams + "SELECT * FROM t WHERE a = :x AND b = :y AND c = :x" + sql `shouldBe` "SELECT * FROM t WHERE a = $1 AND b = $2 AND c = $1" + + -- No-op cases + it "returns original SQL unchanged when no named params" $ do + let input = "SELECT * FROM users WHERE id = $1" + let (sql, mapping) = preprocessNamedParams input + sql `shouldBe` input + mapping `shouldBe` [] + + it "returns empty mapping for parameterless queries" $ do + let (sql, mapping) = preprocessNamedParams "SELECT 1" + sql `shouldBe` "SELECT 1" + mapping `shouldBe` [] + + -- Postgres cast (::) handling + it "does not treat :: as a named parameter" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT :val::text FROM t WHERE id = :id" + sql `shouldBe` "SELECT $1::text FROM t WHERE id = $2" + mapping `shouldBe` [("id", 2), ("val", 1)] + + it "handles multiple casts" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT :a::int4, :b::text" + sql `shouldBe` "SELECT $1::int4, $2::text" + mapping `shouldBe` [("a", 1), ("b", 2)] + + it "handles cast without named param" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT $1::text" + sql `shouldBe` "SELECT $1::text" + mapping `shouldBe` [] + + -- String literal handling + it "does not substitute inside string literals" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE name = :name AND note = ':not_a_param'" + sql `shouldBe` "SELECT * FROM t WHERE name = $1 AND note = ':not_a_param'" + mapping `shouldBe` [("name", 1)] + + it "handles escaped single quotes in strings" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE name = 'it''s :not_a_param' AND id = :id" + sql `shouldBe` "SELECT * FROM t WHERE name = 'it''s :not_a_param' AND id = $1" + mapping `shouldBe` [("id", 1)] + + -- Quoted identifier handling + it "does not substitute inside quoted identifiers" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT \":notParam\" FROM t WHERE id = :id" + sql `shouldBe` "SELECT \":notParam\" FROM t WHERE id = $1" + mapping `shouldBe` [("id", 1)] + + -- Comment handling + it "does not substitute inside line comments" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t -- WHERE :name = 'foo'\nWHERE id = :id" + sql `shouldBe` "SELECT * FROM t -- WHERE :name = 'foo'\nWHERE id = $1" + mapping `shouldBe` [("id", 1)] + + it "does not substitute inside block comments" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * /* :notParam */ FROM t WHERE id = :id" + sql `shouldBe` "SELECT * /* :notParam */ FROM t WHERE id = $1" + mapping `shouldBe` [("id", 1)] + + -- Naming conventions + it "supports underscored parameter names" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE org_id = :org_id" + sql `shouldBe` "SELECT * FROM t WHERE org_id = $1" + mapping `shouldBe` [("org_id", 1)] + + it "supports names starting with underscore" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE id = :_internal" + sql `shouldBe` "SELECT * FROM t WHERE id = $1" + mapping `shouldBe` [("_internal", 1)] + + it "supports names with digits" $ do + let (sql, mapping) = preprocessNamedParams + "SELECT * FROM t WHERE id = :param1 AND val = :param2" + sql `shouldBe` "SELECT * FROM t WHERE id = $1 AND val = $2" + mapping `shouldBe` [("param1", 1), ("param2", 2)] + + -- Edge cases + it "handles :name at end of input" $ do + let (sql, mapping) = preprocessNamedParams "SELECT * FROM t WHERE id = :id" + sql `shouldBe` "SELECT * FROM t WHERE id = $1" + mapping `shouldBe` [("id", 1)] + + it "handles :name at start of input" $ do + let (sql, mapping) = preprocessNamedParams ":val" + sql `shouldBe` "$1" + mapping `shouldBe` [("val", 1)] + + it "handles adjacent :names" $ do + let (sql, _) = preprocessNamedParams "VALUES (:a,:b,:c)" + sql `shouldBe` "VALUES ($1,$2,$3)" + + it "does not treat bare colon as param" $ do + let (sql, mapping) = preprocessNamedParams "SELECT * FROM t WHERE time > '12:30:00'" + sql `shouldBe` "SELECT * FROM t WHERE time > '12:30:00'" + mapping `shouldBe` [] + + it "does not treat colon followed by digit as param" $ do + let (sql, mapping) = preprocessNamedParams "SELECT * FROM t WHERE x = :1bad" + -- :1 is not a valid param name (starts with digit) + sql `shouldBe` "SELECT * FROM t WHERE x = :1bad" + mapping `shouldBe` [] + + -- Realistic queries + it "handles a realistic INSERT" $ do + let (sql, mapping) = preprocessNamedParams + "INSERT INTO users (name, email, org_id) VALUES (:name, :email, :orgId)" + sql `shouldBe` "INSERT INTO users (name, email, org_id) VALUES ($1, $2, $3)" + length mapping `shouldBe` 3 + + it "handles a realistic UPDATE" $ do + let (sql, mapping) = preprocessNamedParams + "UPDATE users SET name = :name, email = :email WHERE id = :userId" + sql `shouldBe` "UPDATE users SET name = $1, email = $2 WHERE id = $3" + length mapping `shouldBe` 3 + + it "handles a CTE with named params" $ do + let (sql, _) = preprocessNamedParams + "WITH active AS (SELECT * FROM users WHERE active = :active)\n\ + \SELECT * FROM active WHERE org_id = :orgId" + BS8.isInfixOf "$1" sql `shouldBe` True + BS8.isInfixOf "$2" sql `shouldBe` True + BS8.isInfixOf ":active" sql `shouldBe` False + BS8.isInfixOf ":orgId" sql `shouldBe` False diff --git a/test/Valiant/CLI/SqlMetadataSpec.hs b/test/Valiant/CLI/SqlMetadataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/SqlMetadataSpec.hs @@ -0,0 +1,59 @@ +module Valiant.CLI.SqlMetadataSpec (spec) where + +import Valiant.CLI.SqlMetadata +import Test.Hspec + +spec :: Spec +spec = do + describe "parseSqlMetadata" $ do + it "parses empty SQL as default metadata" $ do + let meta = parseSqlMetadata "SELECT 1" + smName meta `shouldBe` Nothing + smResult meta `shouldBe` Nothing + smSingle meta `shouldBe` False + + it "parses -- valiant:name directive" $ do + let sql = "-- valiant:name getUserById\nSELECT id, name FROM users WHERE id = $1" + meta = parseSqlMetadata sql + smName meta `shouldBe` Just "getUserById" + + it "parses -- valiant:result directive" $ do + let sql = "-- valiant:result User\nSELECT id, name FROM users WHERE id = $1" + meta = parseSqlMetadata sql + smResult meta `shouldBe` Just "User" + + it "parses -- valiant:single directive" $ do + let sql = "-- valiant:single\nSELECT id, name FROM users WHERE id = $1" + meta = parseSqlMetadata sql + smSingle meta `shouldBe` True + + it "parses multiple directives" $ do + let sql = + "-- valiant:name getUserById\n\ + \-- valiant:result User\n\ + \-- valiant:single\n\ + \SELECT id, name FROM users WHERE id = $1" + meta = parseSqlMetadata sql + smName meta `shouldBe` Just "getUserById" + smResult meta `shouldBe` Just "User" + smSingle meta `shouldBe` True + + it "ignores regular SQL comments" $ do + let sql = "-- This is a regular comment\nSELECT 1" + meta = parseSqlMetadata sql + smName meta `shouldBe` Nothing + + it "handles leading whitespace on directive lines" $ do + let sql = " -- valiant:name myQuery\nSELECT 1" + meta = parseSqlMetadata sql + smName meta `shouldBe` Just "myQuery" + + it "ignores directives with empty values for name and result" $ do + let sql = "-- valiant:name\nSELECT 1" + meta = parseSqlMetadata sql + smName meta `shouldBe` Nothing + + it "ignores unknown directive keys" $ do + let sql = "-- valiant:foobar baz\nSELECT 1" + meta = parseSqlMetadata sql + meta `shouldBe` defaultMetadata diff --git a/test/Valiant/CLI/TypeMapSpec.hs b/test/Valiant/CLI/TypeMapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Valiant/CLI/TypeMapSpec.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Valiant.CLI.TypeMapSpec (spec) where + +import Data.Map.Strict qualified as Map +import PgWire.Protocol.Oid (Oid (..)) +import Valiant.CLI.TypeMap +import Test.Hspec + +spec :: Spec +spec = do + describe "oidToHaskellType" $ do + it "maps int4 (OID 23) to Int32" $ do + let Just ht = oidToHaskellType (Oid 23) + htType ht `shouldBe` "Int32" + htModule ht `shouldBe` "Data.Int" + + it "maps text (OID 25) to Text" $ do + let Just ht = oidToHaskellType (Oid 25) + htType ht `shouldBe` "Text" + + it "maps bool (OID 16) to Bool" $ do + let Just ht = oidToHaskellType (Oid 16) + htType ht `shouldBe` "Bool" + + it "maps timestamptz (OID 1184) to UTCTime" $ do + let Just ht = oidToHaskellType (Oid 1184) + htType ht `shouldBe` "UTCTime" + + it "returns Nothing for unknown OIDs" $ do + oidToHaskellType (Oid 99999) `shouldBe` Nothing + + describe "oidToTypeName" $ do + it "maps OID 23 to int4" $ do + oidToTypeName (Oid 23) `shouldBe` Just "int4" + + it "maps OID 25 to text" $ do + oidToTypeName (Oid 25) `shouldBe` Just "text" + + describe "resolveType" $ do + it "wraps in Maybe when nullable" $ do + let ht = HaskellType "Text" "Data.Text" + htType (resolveType True ht) `shouldBe` "Maybe Text" + + it "leaves unchanged when not nullable" $ do + let ht = HaskellType "Int32" "Data.Int" + htType (resolveType False ht) `shouldBe` "Int32" + + describe "isArrayOid" $ do + it "recognises int4[] (OID 1007)" $ do + isArrayOid (Oid 1007) `shouldBe` True + + it "recognises text[] (OID 1009)" $ do + isArrayOid (Oid 1009) `shouldBe` True + + it "rejects non-array OID 23" $ do + isArrayOid (Oid 23) `shouldBe` False + + it "rejects unknown OID" $ do + isArrayOid (Oid 99999) `shouldBe` False + + describe "arrayElementOid" $ do + it "maps int4[] to int4" $ do + arrayElementOid (Oid 1007) `shouldBe` Just (Oid 23) + + it "maps text[] to text" $ do + arrayElementOid (Oid 1009) `shouldBe` Just (Oid 25) + + it "maps timestamptz[] to timestamptz" $ do + arrayElementOid (Oid 1185) `shouldBe` Just (Oid 1184) + + it "returns Nothing for non-array OID" $ do + arrayElementOid (Oid 23) `shouldBe` Nothing + + describe "oidToHaskellTypeWith (array support)" $ do + it "maps int4[] to Vector Int32" $ do + let Just ht = oidToHaskellTypeWith Map.empty (Oid 1007) + htType ht `shouldBe` "Vector Int32" + htModule ht `shouldBe` "Data.Vector" + + it "maps text[] to Vector Text" $ do + let Just ht = oidToHaskellTypeWith Map.empty (Oid 1009) + htType ht `shouldBe` "Vector Text" + + it "maps bool[] to Vector Bool" $ do + let Just ht = oidToHaskellTypeWith Map.empty (Oid 1000) + htType ht `shouldBe` "Vector Bool" + + it "uses custom types for unknown OIDs" $ do + let customs = Map.singleton (Oid 600) (HaskellType "MyPoint" "MyApp.Types") + Just ht = oidToHaskellTypeWith customs (Oid 600) + htType ht `shouldBe` "MyPoint" + htModule ht `shouldBe` "MyApp.Types" + + it "custom types override built-in types" $ do + let customs = Map.singleton (Oid 23) (HaskellType "CustomInt" "Custom") + Just ht = oidToHaskellTypeWith customs (Oid 23) + htType ht `shouldBe` "CustomInt" + + describe "oidToTypeName (array names)" $ do + it "maps int4[] OID to _int4" $ do + oidToTypeName (Oid 1007) `shouldBe` Just "_int4" + + it "maps text[] OID to _text" $ do + oidToTypeName (Oid 1009) `shouldBe` Just "_text" diff --git a/valiant-cli.cabal b/valiant-cli.cabal new file mode 100644 --- /dev/null +++ b/valiant-cli.cabal @@ -0,0 +1,134 @@ +cabal-version: 3.0 +name: valiant-cli +version: 0.1.0.0 +synopsis: Compile-time checked SQL for Haskell: CLI tool +description: + The @valiant@ CLI tool connects to a live PostgreSQL database, + validates @.sql@ files via @PREPARE@ / @DESCRIBE@, and caches + type metadata for the GHC source plugin to consume at compile time. +license: BSD-3-Clause +license-file: LICENSE +author: Josh Burgess +maintainer: joshburgess.webdev@gmail.com +category: Database +homepage: https://github.com/joshburgess/valiant +bug-reports: https://github.com/joshburgess/valiant/issues +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md +tested-with: GHC ==9.10.3 + +source-repository head + type: git + location: https://github.com/joshburgess/valiant + +flag werror + description: Enable -Werror for development builds. + default: False + manual: True + +common warnings + ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors -funbox-strict-fields -fspecialise-aggressively + if flag(werror) + ghc-options: -Werror + +-- The valiant-cli package ships an executable (`valiant`). The CLI's +-- implementation modules live in a private sublibrary so they don't +-- pollute the Hackage public API surface; the executable and the test +-- suite both depend on it directly. +library cli-internal + import: warnings + visibility: private + hs-source-dirs: src + default-language: GHC2021 + default-extensions: + DeriveAnyClass + DerivingStrategies + LambdaCase + OverloadedStrings + RecordWildCards + StrictData + + exposed-modules: + Valiant.CLI.App + Valiant.CLI.Cache + Valiant.CLI.Command.Check + Valiant.CLI.Command.Generate + Valiant.CLI.Command.Prepare + Valiant.CLI.Command.Types + Valiant.CLI.Command.Watch + Valiant.CLI.Config + Valiant.CLI.CustomTypes + Valiant.CLI.Describe + Valiant.CLI.Discover + Valiant.CLI.Error + Valiant.CLI.Hash + Valiant.CLI.NamedParams + Valiant.CLI.Nullability + Valiant.CLI.Output + Valiant.CLI.SqlMetadata + Valiant.CLI.TypeMap + + build-depends: + , aeson >=2.1 && <2.3 + , aeson-pretty >=0.8 && <0.9 + , ansi-terminal >=1.0 && <1.2 + , base >=4.17 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , cryptohash-sha256 >=0.11 && <0.12 + , directory >=1.3 && <1.4 + , dotenv >=0.11 && <0.13 + , filepath >=1.4 && <1.6 + , Glob >=0.10 && <0.11 + , optparse-applicative >=0.18 && <0.19 + , pg-wire ==0.1.* + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , vector >=0.13 && <0.14 + +executable valiant + import: warnings + hs-source-dirs: app + main-is: Main.hs + default-language: GHC2021 + build-depends: + , base >=4.17 && <5 + , valiant-cli:cli-internal + ghc-options: -threaded -rtsopts + +test-suite valiant-cli-test + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + default-language: GHC2021 + default-extensions: + OverloadedStrings + + ghc-options: -rtsopts "-with-rtsopts=-K8K" + + other-modules: + Valiant.CLI.CacheSpec + Valiant.CLI.CustomTypesSpec + Valiant.CLI.DiscoverSpec + Valiant.CLI.ErrorSpec + Valiant.CLI.HashSpec + Valiant.CLI.NamedParamsSpec + Valiant.CLI.SqlMetadataSpec + Valiant.CLI.TypeMapSpec + + build-depends: + , aeson + , base >=4.17 && <5 + , bytestring + , containers + , directory + , filepath + , hspec >=2.11 && <2.13 + , pg-wire + , temporary >=1.3 && <1.4 + , text + , time + , valiant-cli:cli-internal