Compare commits
7 Commits
9d0e9ebbe5
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
| e995844bc5 | |||
| 469527f03c | |||
| b6622c0a01 | |||
| dfc231604b | |||
| b9d43a63bd | |||
| 42b45a1c20 | |||
| 652fb32539 |
@@ -0,0 +1,41 @@
|
||||
name: Build and Test
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [main]
|
||||
pull_request:
|
||||
branches: [main]
|
||||
|
||||
jobs:
|
||||
build-and-test:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- name: Checkout
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
submodules: true
|
||||
|
||||
- name: Install system dependencies
|
||||
run: |
|
||||
sudo apt-get update -qq
|
||||
sudo apt-get install -y -qq libsqlite3-dev
|
||||
|
||||
- name: Install Stack
|
||||
run: |
|
||||
curl -sSL https://get.haskellstack.org/ | sh
|
||||
|
||||
- name: Cache Stack artifacts
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: |
|
||||
~/.stack
|
||||
.stack-work
|
||||
key: stack-${{ runner.os }}-${{ hashFiles('stack.yaml', 'orville-sqlite.cabal') }}
|
||||
restore-keys: |
|
||||
stack-${{ runner.os }}-
|
||||
|
||||
- name: Build
|
||||
run: stack build --pedantic
|
||||
|
||||
- name: Test
|
||||
run: stack test
|
||||
@@ -1,61 +1,154 @@
|
||||
# orville-sqlite
|
||||
|
||||
This library is intended to be a SQLite Haskell API similar in spirit to https://github.com/flipstone/orville/
|
||||
A type-safe SQLite API for Haskell, modeled after the [Flipstone Orville](https://github.com/flipstone/orville/) PostgreSQL library.
|
||||
|
||||
The goal of this library is to provide a type safe approach to mapping Haskell types to SQLite data. We aim for type-safe queries and migrations.
|
||||
Maps Haskell data types to SQLite tables with compile-time schema guarantees.
|
||||
|
||||
The Flipstone orville library is robust and deep. This library aspires to the same but realizes it's unlikely to get there anytime soon.
|
||||
## Status — MVP
|
||||
|
||||
## Goal
|
||||
The MVP provides the core pipeline: define columns and record marshallers, auto-migrate schemas, and execute basic CRUD queries.
|
||||
|
||||
This library intends to provide a similar API for describing the database schema and executing queries as the Flipstone Orville library.
|
||||
|
||||
We will not port the PostgreSQL implementation directly but instead target a similar API.
|
||||
|
||||
The APIs that concern us the most are:
|
||||
|
||||
- Orville.PostgreSQL.Marshall.SqlMarshaller
|
||||
- Orville.PostgreSQL.AutoMigration as AutoMigration
|
||||
- Orville.PostgreSQL.Execution
|
||||
|
||||
and even for those, we only what's strictly necessary to define a way to take a Haskell data type like
|
||||
## Usage
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
data Person =
|
||||
import Orville.SQLite
|
||||
|
||||
data Person = Person
|
||||
{ personId :: Int64
|
||||
, firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Column definitions (type-safe, parameterized by nullability)
|
||||
personIdField :: FieldDefinition 'NotNull Int64
|
||||
personIdField = integerField "id"
|
||||
|
||||
firstNameField :: FieldDefinition 'NotNull Text
|
||||
firstNameField = textField "first_name"
|
||||
|
||||
lastNameField :: FieldDefinition 'NotNull Text
|
||||
lastNameField = textField "last_name"
|
||||
|
||||
ageField :: FieldDefinition 'NotNull Int64
|
||||
ageField = integerField "age"
|
||||
|
||||
-- SqlMarshaller: maps the record to/from SQL columns
|
||||
personMarshaller :: SqlMarshaller Person Person
|
||||
personMarshaller =
|
||||
Person
|
||||
{ firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int
|
||||
}
|
||||
<$> marshallReadOnlyField personIdField -- auto-increment PK
|
||||
<*> marshallField firstName firstNameField
|
||||
<*> marshallField lastName lastNameField
|
||||
<*> marshallField age ageField
|
||||
|
||||
-- TableDefinition ties a table name, primary key, and marshaller together
|
||||
personTable :: TableDefinition Int64 Person Person
|
||||
personTable =
|
||||
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
db <- openConnection "people.db"
|
||||
withConnection db $ do
|
||||
-- Auto-migrate: creates the table if it doesn't exist
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
|
||||
-- Insert
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
insertEntity personTable (Person 0 "Bob" "Jones" 25)
|
||||
|
||||
-- Query by primary key
|
||||
mAlice <- findEntity personTable 1
|
||||
-- mAlice = Just (Person 1 "Alice" "Smith" 30)
|
||||
|
||||
-- Find all
|
||||
all <- findAll personTable
|
||||
-- all = [Person 1 "Alice" "Smith" 30, Person 2 "Bob" "Jones" 25]
|
||||
|
||||
-- Update
|
||||
updateEntity personTable (Person 1 "Alice" "Jones" 31)
|
||||
|
||||
-- Delete
|
||||
deleteEntity personTable 2
|
||||
|
||||
pure ()
|
||||
closeConnection db
|
||||
```
|
||||
|
||||
and map it to a table of schema
|
||||
The above creates this table:
|
||||
|
||||
```sql
|
||||
CREATE TABLE person (
|
||||
first_name VARCHAR(100) NOT NULL,
|
||||
last_name VARCHAR(100) NOT NULL,
|
||||
age INT
|
||||
CREATE TABLE IF NOT EXISTS person (
|
||||
age INTEGER NOT NULL,
|
||||
last_name TEXT NOT NULL,
|
||||
first_name TEXT NOT NULL,
|
||||
id INTEGER PRIMARY KEY
|
||||
);
|
||||
```
|
||||
|
||||
and then give us an API for marshalling that Haskell type to that table definition
|
||||
## Modules
|
||||
|
||||
then using that marshaller we should have APIs that can;
|
||||
| Module | Purpose |
|
||||
|--------|---------|
|
||||
| `Orville.SQLite` | Top-level re-exports |
|
||||
| `Orville.SQLite.Monad` | `OrvilleM` reader monad and connection management |
|
||||
| `Orville.SQLite.SqlType` | Type encoding/decoding for SQLite storage classes |
|
||||
| `Orville.SQLite.FieldDefinition` | GADT column definitions with `NotNull`/`Nullable` |
|
||||
| `Orville.SQLite.SqlMarshaller` | GADT record-to-table mapping (applicative syntax) |
|
||||
| `Orville.SQLite.TableDefinition` | `PrimaryKey` and `mkTableDefinition` |
|
||||
| `Orville.SQLite.AutoMigration` | Schema introspection via `PRAGMA table_info`, DDL generation |
|
||||
| `Orville.SQLite.Execution` | `insertEntity`, `findEntity`, `findAll`, `updateEntity`, `deleteEntity` |
|
||||
|
||||
- create the table if it does not exist
|
||||
- alter the table to match the schema if the table does exist but its columns don't match
|
||||
- query the table and retrieve Person values
|
||||
- insert Person values into the table
|
||||
- update the table from Person values.
|
||||
## Feature Coverage
|
||||
|
||||
## Development environment
|
||||
### Included (MVP)
|
||||
|
||||
The development environment should be entirely inside of Docker - no local
|
||||
tools should be installed on the machine directly. use the `hs` wrapper script
|
||||
to execute Haskell tooling inside of Docker.
|
||||
- `FieldDefinition` with `NotNull`/`Nullable` type parameters
|
||||
- `SqlMarshaller` GADT with `marshallField`, `marshallReadOnlyField`, `marshallMaybe`
|
||||
- `TableDefinition` with single-column primary keys
|
||||
- `AutoMigration`: create tables, add nullable columns, drop columns (explicit opt-in), dry-run
|
||||
- `Execution`: insert, find-by-PK, find-all, update, delete
|
||||
- In-memory databases (`:memory:`) and file-based databases
|
||||
|
||||
## Base SQLite library
|
||||
### Not yet implemented
|
||||
|
||||
Our base library for interacting with SQLite should be direct-sqlite - https://github.com/IreneKnapp/direct-sqlite
|
||||
- Foreign keys and composite primary keys
|
||||
- Table indexes
|
||||
- Plans (N+1 query prevention via `Plan`)
|
||||
- Batch operations
|
||||
- Upsert (`upsertEntity`)
|
||||
- `findEntitiesBy` (filtering on non-PK columns)
|
||||
- `updateFields` (partial update)
|
||||
- Raw SQL execution (`executeAndDecode`)
|
||||
- Nested record marshalling and `prefixMarshaller`
|
||||
- `AnnotatedSqlMarshaller`
|
||||
- `SyntheticField`
|
||||
- Connection pooling
|
||||
|
||||
## Development
|
||||
|
||||
All tooling runs inside Docker via the `./hs` wrapper. No local Haskell installation needed.
|
||||
|
||||
```bash
|
||||
./hs stack build # build
|
||||
./hs stack test # run tests (53 tests)
|
||||
./hs stack ghci # REPL
|
||||
./hs fourmolu -i src/ # format
|
||||
```
|
||||
|
||||
Or use the convenience scripts:
|
||||
|
||||
```bash
|
||||
./scripts/build # build with pedantic
|
||||
./scripts/test # run tests
|
||||
```
|
||||
|
||||
### Dependencies
|
||||
|
||||
- GHC 9.10.3
|
||||
- [direct-sqlite](https://github.com/IreneKnapp/direct-sqlite) — low-level FFI binding to SQLite
|
||||
- `text`, `bytestring`, `mtl`
|
||||
|
||||
+13
-1
@@ -19,7 +19,9 @@ library
|
||||
Orville.SQLite.AutoMigration
|
||||
Orville.SQLite.Execution
|
||||
Orville.SQLite.FieldDefinition
|
||||
Orville.SQLite.Internal
|
||||
Orville.SQLite.Monad
|
||||
Orville.SQLite.Raw
|
||||
Orville.SQLite.RawSql
|
||||
Orville.SQLite.SqlMarshaller
|
||||
Orville.SQLite.SqlType
|
||||
@@ -32,16 +34,26 @@ library
|
||||
, text
|
||||
, bytestring
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall -Werror
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Test.Setup
|
||||
Test.AutoMigration
|
||||
Test.EntityOperations
|
||||
Test.FieldDefinition
|
||||
Test.Raw
|
||||
Test.SqlMarshaller
|
||||
hs-source-dirs: test
|
||||
build-depends:
|
||||
base >=4.17 && <5
|
||||
, bytestring
|
||||
, direct-sqlite
|
||||
, mtl
|
||||
, orville-sqlite
|
||||
, hspec
|
||||
, text
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Werror
|
||||
|
||||
Executable
+8
@@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
|
||||
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
PROJECT_DIR="$(dirname "$SCRIPT_DIR")"
|
||||
|
||||
cd "$PROJECT_DIR"
|
||||
./hs stack build "$@"
|
||||
Executable
+8
@@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
|
||||
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
PROJECT_DIR="$(dirname "$SCRIPT_DIR")"
|
||||
|
||||
cd "$PROJECT_DIR"
|
||||
./hs stack test "$@"
|
||||
@@ -13,12 +13,15 @@ module Orville.SQLite
|
||||
, module Orville.SQLite.AutoMigration
|
||||
-- * Execution
|
||||
, module Orville.SQLite.Execution
|
||||
-- * Raw
|
||||
, module Orville.SQLite.Raw
|
||||
) where
|
||||
|
||||
import Orville.SQLite.AutoMigration
|
||||
import Orville.SQLite.Execution
|
||||
import Orville.SQLite.FieldDefinition
|
||||
import Orville.SQLite.Monad
|
||||
import Orville.SQLite.Raw
|
||||
import Orville.SQLite.SqlMarshaller
|
||||
import Orville.SQLite.SqlType
|
||||
import Orville.SQLite.TableDefinition
|
||||
|
||||
@@ -15,8 +15,8 @@ import Control.Monad.Reader (ask)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Database.SQLite3.Direct (columnCount)
|
||||
import Orville.SQLite.FieldDefinition (fieldColumnName, fieldToSqlValue)
|
||||
import Orville.SQLite.Internal (getRowData)
|
||||
import Orville.SQLite.Monad (OrvilleM)
|
||||
import Orville.SQLite.SqlMarshaller (
|
||||
marshallerDecodeRow,
|
||||
@@ -148,22 +148,4 @@ deleteEntity tableDef key = do
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
getRowData ::
|
||||
SQLite3.Statement ->
|
||||
[String] ->
|
||||
IO [(String, SQLite3.SQLData)]
|
||||
getRowData stmt cols = do
|
||||
colCount <- columnCount stmt
|
||||
let count :: Int = fromIntegral colCount
|
||||
indexes = take count [0 :: SQLite3.ColumnIndex ..]
|
||||
mapM
|
||||
( \i -> do
|
||||
let idx :: Int = fromIntegral i
|
||||
colName =
|
||||
if idx < length cols
|
||||
then cols !! idx
|
||||
else ""
|
||||
sqlVal <- SQLite3.column stmt i
|
||||
pure (colName, sqlVal)
|
||||
)
|
||||
indexes
|
||||
|
||||
|
||||
@@ -0,0 +1,28 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.Internal (
|
||||
getRowData,
|
||||
) where
|
||||
|
||||
import Control.Monad (forM)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Database.SQLite3.Direct (columnCount)
|
||||
|
||||
getRowData ::
|
||||
SQLite3.Statement ->
|
||||
[String] ->
|
||||
IO [(String, SQLite3.SQLData)]
|
||||
getRowData stmt cols = do
|
||||
colCount <- columnCount stmt
|
||||
let count :: Int = fromIntegral colCount
|
||||
indexes = take count [0 :: SQLite3.ColumnIndex ..]
|
||||
forM indexes $ \i -> do
|
||||
let idx :: Int = fromIntegral i
|
||||
-- Try column name from statement metadata first, then fall back to provided names, then empty
|
||||
mName <- SQLite3.columnName stmt i
|
||||
let colName = case mName of
|
||||
Just n | not (T.null n) -> T.unpack n
|
||||
_ -> if idx < length cols then cols !! idx else ""
|
||||
sqlVal <- SQLite3.column stmt i
|
||||
pure (colName, sqlVal)
|
||||
@@ -0,0 +1,71 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Orville.SQLite.Raw (
|
||||
execute,
|
||||
executeWith,
|
||||
query_,
|
||||
queryWith,
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Reader (ask)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
|
||||
import Orville.SQLite.Internal (getRowData)
|
||||
import Orville.SQLite.Monad (OrvilleM)
|
||||
|
||||
-- | Execute a raw SQL statement with no parameters.
|
||||
execute :: T.Text -> OrvilleM ()
|
||||
execute sql = do
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
-- | Execute a raw SQL statement with bound parameters.
|
||||
executeWith :: T.Text -> [SQLite3.SQLData] -> OrvilleM ()
|
||||
executeWith sql params = do
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt params
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
-- | Execute a raw SQL query with no parameters and collect all rows.
|
||||
query_ :: T.Text -> OrvilleM [[(String, SQLite3.SQLData)]]
|
||||
query_ sql = do
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
let loop acc = do
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure (reverse acc)
|
||||
SQLite3.Row -> do
|
||||
rowData <- getRowData stmt []
|
||||
loop (rowData : acc)
|
||||
loop []
|
||||
|
||||
-- | Execute a raw SQL query with bound parameters and collect all rows.
|
||||
queryWith :: T.Text -> [SQLite3.SQLData] -> OrvilleM [[(String, SQLite3.SQLData)]]
|
||||
queryWith sql params = do
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt params
|
||||
let loop acc = do
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure (reverse acc)
|
||||
SQLite3.Row -> do
|
||||
rowData <- getRowData stmt []
|
||||
loop (rowData : acc)
|
||||
loop []
|
||||
+10
-83
@@ -1,92 +1,19 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Orville.SQLite
|
||||
import Test.Hspec
|
||||
|
||||
data Person = Person
|
||||
{ personId :: Int64
|
||||
, firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
personIdField :: FieldDefinition 'NotNull Int64
|
||||
personIdField = integerField "id"
|
||||
|
||||
firstNameField :: FieldDefinition 'NotNull Text
|
||||
firstNameField = textField "first_name"
|
||||
|
||||
lastNameField :: FieldDefinition 'NotNull Text
|
||||
lastNameField = textField "last_name"
|
||||
|
||||
ageField :: FieldDefinition 'NotNull Int64
|
||||
ageField = integerField "age"
|
||||
|
||||
personMarshaller :: SqlMarshaller Person Person
|
||||
personMarshaller =
|
||||
Person
|
||||
<$> marshallReadOnlyField personIdField
|
||||
<*> marshallField firstName firstNameField
|
||||
<*> marshallField lastName lastNameField
|
||||
<*> marshallField age ageField
|
||||
|
||||
personTable :: TableDefinition Int64 Person Person
|
||||
personTable =
|
||||
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
|
||||
import qualified Test.AutoMigration as AutoMigration
|
||||
import qualified Test.EntityOperations as EntityOperations
|
||||
import qualified Test.FieldDefinition as FieldDefinition
|
||||
import qualified Test.Raw as Raw
|
||||
import qualified Test.SqlMarshaller as SqlMarshaller
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
describe "Orville.SQLite" $ do
|
||||
it "creates a table and inserts a row" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
mAlice <- findEntity personTable 1
|
||||
liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30)
|
||||
closeConnection db
|
||||
|
||||
it "finds all rows" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
insertEntity personTable (Person 0 "Bob" "Jones" 25)
|
||||
results <- findAll personTable
|
||||
liftIO $ length results `shouldBe` 2
|
||||
closeConnection db
|
||||
|
||||
it "updates a row" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
updateEntity personTable (Person 1 "Alice" "Jones" 31)
|
||||
mAlice <- findEntity personTable 1
|
||||
liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Jones" 31)
|
||||
closeConnection db
|
||||
|
||||
it "deletes a row" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
deleteEntity personTable 1
|
||||
mAlice <- findEntity personTable 1
|
||||
liftIO $ mAlice `shouldBe` Nothing
|
||||
closeConnection db
|
||||
|
||||
it "returns Nothing for missing row" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
mAlice <- findEntity personTable 999
|
||||
liftIO $ mAlice `shouldBe` Nothing
|
||||
closeConnection db
|
||||
describe "FieldDefinition" FieldDefinition.fieldDefinitionTests
|
||||
describe "SqlMarshaller" SqlMarshaller.sqlMarshallerTests
|
||||
describe "EntityOperations" EntityOperations.entityOperationsTests
|
||||
describe "AutoMigration" AutoMigration.autoMigrationTests
|
||||
describe "Raw" Raw.rawTests
|
||||
|
||||
@@ -0,0 +1,93 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Test.AutoMigration where
|
||||
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Test.Hspec
|
||||
|
||||
import Orville.SQLite
|
||||
import Test.Setup
|
||||
|
||||
autoMigrationTests :: Spec
|
||||
autoMigrationTests = do
|
||||
describe "autoMigrateSchema" $ do
|
||||
it "creates a table that does not exist" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
pure ()
|
||||
closeConnection db
|
||||
|
||||
it "is idempotent -- running twice does not error" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
pure ()
|
||||
closeConnection db
|
||||
|
||||
it "creates multiple tables at once" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema
|
||||
defaultOptions
|
||||
[ schemaTable personTable []
|
||||
, schemaTable widgetTable []
|
||||
]
|
||||
pure ()
|
||||
closeConnection db
|
||||
|
||||
it "adds a new nullable column via ALTER TABLE" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [existingTableSchema]
|
||||
insertEntity widgetTable (Widget 1 "Test")
|
||||
autoMigrateSchema defaultOptions [schemaTable widgetTable []]
|
||||
mWidget <- findEntity widgetTable 1
|
||||
liftIO $ mWidget `shouldBe` Just (Widget 1 "Test")
|
||||
closeConnection db
|
||||
|
||||
it "attempting to use old marshaller after column drop fails" $ do
|
||||
db <- openConnection ":memory:"
|
||||
result <- liftIO $ try $ withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable []]
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
autoMigrateSchema defaultOptions [schemaTable personTable ["age"]]
|
||||
-- This will fail because the marshaller still references the age column
|
||||
findEntity personTable 1
|
||||
closeConnection db
|
||||
liftIO $
|
||||
result `shouldSatisfy` \case
|
||||
Left (_ :: SomeException) -> True
|
||||
Right _ -> False
|
||||
|
||||
it "dry run does not create tables" $ do
|
||||
db <- openConnection ":memory:"
|
||||
withConnection db $ do
|
||||
autoMigrateSchema
|
||||
defaultOptions{runSchemaChanges = False}
|
||||
[schemaTable personTable []]
|
||||
-- Migration is skipped; table should not exist
|
||||
result <-
|
||||
liftIO $
|
||||
try $
|
||||
withConnection db $
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
liftIO $
|
||||
result `shouldSatisfy` \case
|
||||
Left (_ :: SomeException) -> True
|
||||
Right _ -> False
|
||||
closeConnection db
|
||||
|
||||
-- | Schema that only has widget_id (no label), representing an older version.
|
||||
existingTableSchema :: SchemaItem
|
||||
existingTableSchema =
|
||||
let
|
||||
marshaller = Widget <$> marshallField widgetId widgetIdField <*> marshallReadOnlyField widgetLabelField
|
||||
tableDef = mkTableDefinition "widget" (primaryKey widgetId widgetIdField) marshaller
|
||||
in
|
||||
schemaTable tableDef []
|
||||
@@ -0,0 +1,130 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Test.EntityOperations where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Test.Hspec
|
||||
|
||||
import Orville.SQLite
|
||||
import Test.Setup
|
||||
|
||||
entityOperationsTests :: Spec
|
||||
entityOperationsTests = do
|
||||
describe "insertEntity" $ do
|
||||
it "inserts a row and returns via findEntity" $ do
|
||||
let p = Person 0 "Alice" "Smith" 30
|
||||
mAlice <- withFreshDb personTable $ do
|
||||
insertEntity personTable p
|
||||
findEntity personTable 1
|
||||
liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30)
|
||||
|
||||
it "assigns auto-increment ids sequentially" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "A" "One" 20)
|
||||
insertEntity personTable (Person 0 "B" "Two" 25)
|
||||
insertEntity personTable (Person 0 "C" "Three" 30)
|
||||
findAll personTable
|
||||
liftIO $ map personId results `shouldBe` [1, 2, 3]
|
||||
|
||||
it "inserts an entity with explicit PK (non-auto-increment)" $ do
|
||||
let w = Widget 42 "TestWidget"
|
||||
mWidget <- withFreshDb widgetTable $ do
|
||||
insertEntity widgetTable w
|
||||
findEntity widgetTable 42
|
||||
liftIO $ mWidget `shouldBe` Just w
|
||||
|
||||
it "inserts an entity with a nullable field set to Just" $ do
|
||||
let t = Task 0 "Buy groceries" (Just 15)
|
||||
mTask <- withFreshDb taskTable $ do
|
||||
insertEntity taskTable t
|
||||
findEntity taskTable 1
|
||||
liftIO $ mTask `shouldBe` Just (Task 1 "Buy groceries" (Just 15))
|
||||
|
||||
it "inserts an entity with a nullable field set to Nothing" $ do
|
||||
let t = Task 0 "No due date" Nothing
|
||||
mTask <- withFreshDb taskTable $ do
|
||||
insertEntity taskTable t
|
||||
findEntity taskTable 1
|
||||
liftIO $ mTask `shouldBe` Just (Task 1 "No due date" Nothing)
|
||||
|
||||
describe "findEntity" $ do
|
||||
it "returns Nothing for a non-existent key" $ do
|
||||
result <-
|
||||
withFreshDb personTable $
|
||||
findEntity personTable 999
|
||||
liftIO $ result `shouldBe` Nothing
|
||||
|
||||
it "returns Nothing on an empty table" $ do
|
||||
result <-
|
||||
withFreshDb personTable $
|
||||
findEntity personTable 1
|
||||
liftIO $ result `shouldBe` Nothing
|
||||
|
||||
describe "findAll" $ do
|
||||
it "returns all inserted rows" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
insertEntity personTable (Person 0 "Bob" "Jones" 25)
|
||||
findAll personTable
|
||||
liftIO $ length results `shouldBe` 2
|
||||
|
||||
it "returns empty list on empty table" $ do
|
||||
results <-
|
||||
withFreshDb personTable $
|
||||
findAll personTable
|
||||
liftIO $ results `shouldBe` []
|
||||
|
||||
it "returns rows in insertion order" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "First" "One" 10)
|
||||
insertEntity personTable (Person 0 "Second" "Two" 20)
|
||||
insertEntity personTable (Person 0 "Third" "Three" 30)
|
||||
findAll personTable
|
||||
liftIO $ map firstName results `shouldBe` ["First", "Second", "Third"]
|
||||
|
||||
describe "updateEntity" $ do
|
||||
it "updates a row and returns via findEntity" $ do
|
||||
result <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
updateEntity personTable (Person 1 "Alice" "Jones" 31)
|
||||
findEntity personTable 1
|
||||
liftIO $ result `shouldBe` Just (Person 1 "Alice" "Jones" 31)
|
||||
|
||||
it "updates a widget with explicit PK" $ do
|
||||
result <- withFreshDb widgetTable $ do
|
||||
insertEntity widgetTable (Widget 10 "OldLabel")
|
||||
updateEntity widgetTable (Widget 10 "NewLabel")
|
||||
findEntity widgetTable 10
|
||||
liftIO $ result `shouldBe` Just (Widget 10 "NewLabel")
|
||||
|
||||
it "does not affect other rows" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
insertEntity personTable (Person 0 "Bob" "Jones" 25)
|
||||
updateEntity personTable (Person 1 "Alice" "Updated" 99)
|
||||
findAll personTable
|
||||
liftIO $ map firstName results `shouldBe` ["Alice", "Bob"]
|
||||
|
||||
describe "deleteEntity" $ do
|
||||
it "deletes a row" $ do
|
||||
result <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
deleteEntity personTable 1
|
||||
findEntity personTable 1
|
||||
liftIO $ result `shouldBe` Nothing
|
||||
|
||||
it "does not delete other rows" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
insertEntity personTable (Person 0 "Bob" "Jones" 25)
|
||||
deleteEntity personTable 1
|
||||
findAll personTable
|
||||
liftIO $ map firstName results `shouldBe` ["Bob"]
|
||||
|
||||
it "deleting non-existent key does nothing" $ do
|
||||
results <- withFreshDb personTable $ do
|
||||
insertEntity personTable (Person 0 "Alice" "Smith" 30)
|
||||
deleteEntity personTable 999
|
||||
findAll personTable
|
||||
liftIO $ length results `shouldBe` 1
|
||||
@@ -0,0 +1,95 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Test.FieldDefinition where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Text as T
|
||||
import Test.Hspec
|
||||
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Orville.SQLite
|
||||
|
||||
fieldDefinitionTests :: Spec
|
||||
fieldDefinitionTests = do
|
||||
describe "integerField" $ do
|
||||
it "roundtrips encode/decode" $ do
|
||||
let fd = integerField "count"
|
||||
let val = 42 :: Int64
|
||||
fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val
|
||||
|
||||
it "encodes to SQLInteger" $ do
|
||||
let fd = integerField "count"
|
||||
fieldToSqlValue 99 fd `shouldBe` SQLite3.SQLInteger 99
|
||||
|
||||
it "decodes from SQLInteger" $ do
|
||||
let fd = integerField "count"
|
||||
fieldFromSqlValue (SQLite3.SQLInteger 99) fd `shouldBe` Right 99
|
||||
|
||||
describe "textField" $ do
|
||||
it "roundtrips encode/decode" $ do
|
||||
let fd = textField "name"
|
||||
let val = "Hello" :: T.Text
|
||||
fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val
|
||||
|
||||
it "encodes to SQLText" $ do
|
||||
let fd = textField "name"
|
||||
fieldToSqlValue "test" fd `shouldBe` SQLite3.SQLText "test"
|
||||
|
||||
it "decodes from SQLText" $ do
|
||||
let fd = textField "name"
|
||||
fieldFromSqlValue (SQLite3.SQLText "decoded") fd `shouldBe` Right ("decoded" :: T.Text)
|
||||
|
||||
describe "realField" $ do
|
||||
it "roundtrips encode/decode" $ do
|
||||
let fd = realField "price"
|
||||
let val = 3.14 :: Double
|
||||
fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val
|
||||
|
||||
it "encodes to SQLFloat" $ do
|
||||
let fd = realField "price"
|
||||
fieldToSqlValue 2.718 fd `shouldBe` SQLite3.SQLFloat 2.718
|
||||
|
||||
describe "blobField" $ do
|
||||
it "roundtrips encode/decode" $ do
|
||||
let fd = blobField "data"
|
||||
let val = "binary\0stuff" :: BS.ByteString
|
||||
fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val
|
||||
|
||||
describe "nullableField" $ do
|
||||
it "is marked as nullable" $ do
|
||||
let fd = nullableField (integerField "opt")
|
||||
fieldIsNullable fd `shouldBe` True
|
||||
|
||||
it "retains the column name" $ do
|
||||
let fd = nullableField (textField "notes")
|
||||
fieldColumnName fd `shouldBe` "notes"
|
||||
|
||||
describe "convertField" $ do
|
||||
it "converts between types" $ do
|
||||
let fd = integerField "count"
|
||||
let converted = convertField show (read @Int64) fd :: FieldDefinition 'NotNull String
|
||||
fieldFromSqlValue (SQLite3.SQLInteger 123) converted `shouldBe` Right "123"
|
||||
|
||||
describe "fieldColumnName" $ do
|
||||
it "returns the column name for non-null field" $ do
|
||||
fieldColumnName (integerField "my_col") `shouldBe` "my_col"
|
||||
|
||||
it "returns the column name for nullable field" $ do
|
||||
fieldColumnName (nullableField (textField "opt_col")) `shouldBe` "opt_col"
|
||||
|
||||
describe "fieldSqlTypeName" $ do
|
||||
it "returns INTEGER for integerField" $ do
|
||||
fieldSqlTypeName (integerField "x") `shouldBe` "INTEGER"
|
||||
|
||||
it "returns TEXT for textField" $ do
|
||||
fieldSqlTypeName (textField "x") `shouldBe` "TEXT"
|
||||
|
||||
it "returns REAL for realField" $ do
|
||||
fieldSqlTypeName (realField "x") `shouldBe` "REAL"
|
||||
|
||||
it "returns BLOB for blobField" $ do
|
||||
fieldSqlTypeName (blobField "x") `shouldBe` "BLOB"
|
||||
@@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Test.Raw where
|
||||
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Test.Hspec
|
||||
|
||||
import Orville.SQLite
|
||||
|
||||
rawTests :: Spec
|
||||
rawTests = do
|
||||
describe "execute" $ do
|
||||
it "runs a CREATE TABLE and INSERT statement" $ do
|
||||
db <- openConnection ":memory:"
|
||||
runOrvilleM db $ execute "CREATE TABLE raw_test (id INTEGER, name TEXT)"
|
||||
runOrvilleM db $ execute "INSERT INTO raw_test VALUES (1, 'hello')"
|
||||
rows <- runOrvilleM db $ query_ "SELECT * FROM raw_test"
|
||||
length rows `shouldBe` 1
|
||||
closeConnection db
|
||||
|
||||
describe "executeWith" $ do
|
||||
it "runs parameterized INSERT" $ do
|
||||
db <- openConnection ":memory:"
|
||||
runOrvilleM db $ execute "CREATE TABLE raw_test2 (id INTEGER, name TEXT)"
|
||||
runOrvilleM db $ executeWith "INSERT INTO raw_test2 VALUES (?, ?)" [SQLite3.SQLInteger 42, SQLite3.SQLText "world"]
|
||||
rows <- runOrvilleM db $ query_ "SELECT * FROM raw_test2"
|
||||
length rows `shouldBe` 1
|
||||
closeConnection db
|
||||
|
||||
describe "query_" $ do
|
||||
it "returns rows from a SELECT" $ do
|
||||
db <- openConnection ":memory:"
|
||||
runOrvilleM db $ execute "CREATE TABLE raw_test3 (a INTEGER)"
|
||||
runOrvilleM db $ execute "INSERT INTO raw_test3 VALUES (1)"
|
||||
runOrvilleM db $ execute "INSERT INTO raw_test3 VALUES (2)"
|
||||
rows <- runOrvilleM db $ query_ "SELECT * FROM raw_test3 ORDER BY a"
|
||||
length rows `shouldBe` 2
|
||||
closeConnection db
|
||||
|
||||
describe "queryWith" $ do
|
||||
it "returns rows matching parameters" $ do
|
||||
db <- openConnection ":memory:"
|
||||
runOrvilleM db $ execute "CREATE TABLE raw_test4 (name TEXT)"
|
||||
runOrvilleM db $ executeWith "INSERT INTO raw_test4 VALUES (?)" [SQLite3.SQLText "alpha"]
|
||||
runOrvilleM db $ executeWith "INSERT INTO raw_test4 VALUES (?)" [SQLite3.SQLText "beta"]
|
||||
rows <- runOrvilleM db $ queryWith "SELECT * FROM raw_test4 WHERE name = ?" [SQLite3.SQLText "beta"]
|
||||
length rows `shouldBe` 1
|
||||
closeConnection db
|
||||
@@ -0,0 +1,106 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Test.Setup where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
|
||||
import Orville.SQLite
|
||||
|
||||
{- | A simple entity for testing, with an auto-increment primary key.
|
||||
The PK (personId) is read-only — SQLite populates it via INTEGER PRIMARY KEY.
|
||||
-}
|
||||
data Person = Person
|
||||
{ personId :: Int64
|
||||
, firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
personIdField :: FieldDefinition 'NotNull Int64
|
||||
personIdField = integerField "id"
|
||||
|
||||
firstNameField :: FieldDefinition 'NotNull Text
|
||||
firstNameField = textField "first_name"
|
||||
|
||||
lastNameField :: FieldDefinition 'NotNull Text
|
||||
lastNameField = textField "last_name"
|
||||
|
||||
ageField :: FieldDefinition 'NotNull Int64
|
||||
ageField = integerField "age"
|
||||
|
||||
personMarshaller :: SqlMarshaller Person Person
|
||||
personMarshaller =
|
||||
Person
|
||||
<$> marshallReadOnlyField personIdField
|
||||
<*> marshallField firstName firstNameField
|
||||
<*> marshallField lastName lastNameField
|
||||
<*> marshallField age ageField
|
||||
|
||||
personTable :: TableDefinition Int64 Person Person
|
||||
personTable =
|
||||
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
|
||||
|
||||
-- | An entity where the PK is part of the write entity (not auto-increment).
|
||||
data Widget = Widget
|
||||
{ widgetId :: Int64
|
||||
, widgetLabel :: Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
widgetIdField :: FieldDefinition 'NotNull Int64
|
||||
widgetIdField = integerField "widget_id"
|
||||
|
||||
widgetLabelField :: FieldDefinition 'NotNull Text
|
||||
widgetLabelField = textField "label"
|
||||
|
||||
widgetMarshaller :: SqlMarshaller Widget Widget
|
||||
widgetMarshaller =
|
||||
Widget
|
||||
<$> marshallField widgetId widgetIdField
|
||||
<*> marshallField widgetLabel widgetLabelField
|
||||
|
||||
widgetTable :: TableDefinition Int64 Widget Widget
|
||||
widgetTable =
|
||||
mkTableDefinition "widget" (primaryKey widgetId widgetIdField) widgetMarshaller
|
||||
|
||||
-- | An entity with a nullable field.
|
||||
data Task = Task
|
||||
{ taskId :: Int64
|
||||
, taskDescription :: Text
|
||||
, taskDueDay :: Maybe Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
taskIdField :: FieldDefinition 'NotNull Int64
|
||||
taskIdField = integerField "task_id"
|
||||
|
||||
taskDescriptionField :: FieldDefinition 'NotNull Text
|
||||
taskDescriptionField = textField "description"
|
||||
|
||||
taskDueDayField :: FieldDefinition 'Nullable Int64
|
||||
taskDueDayField = nullableField (integerField "due_day")
|
||||
|
||||
taskMarshaller :: SqlMarshaller Task Task
|
||||
taskMarshaller =
|
||||
Task
|
||||
<$> marshallReadOnlyField taskIdField
|
||||
<*> marshallField taskDescription taskDescriptionField
|
||||
<*> marshallMaybe taskDueDay taskDueDayField
|
||||
|
||||
taskTable :: TableDefinition Int64 Task Task
|
||||
taskTable =
|
||||
mkTableDefinition "task" (primaryKey taskId taskIdField) taskMarshaller
|
||||
|
||||
{- | Run an OrvilleM action against a fresh in-memory database,
|
||||
with the given table created via auto-migration.
|
||||
-}
|
||||
withFreshDb :: TableDefinition key w r -> OrvilleM a -> IO a
|
||||
withFreshDb tableDef action = do
|
||||
db <- openConnection ":memory:"
|
||||
result <- withConnection db $ do
|
||||
autoMigrateSchema defaultOptions [schemaTable tableDef []]
|
||||
action
|
||||
closeConnection db
|
||||
pure result
|
||||
@@ -0,0 +1,108 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Test.SqlMarshaller where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Test.Hspec
|
||||
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Orville.SQLite
|
||||
import Test.Setup
|
||||
|
||||
sqlMarshallerTests :: Spec
|
||||
sqlMarshallerTests = do
|
||||
describe "marshallerFieldInfo" $ do
|
||||
it "enumerates all fields including read-only" $ do
|
||||
let info = marshallerFieldInfo personMarshaller
|
||||
map fieldInfoName info `shouldBe` ["age", "last_name", "first_name", "id"]
|
||||
|
||||
it "reports correct types" $ do
|
||||
let info = marshallerFieldInfo personMarshaller
|
||||
let types = [(fieldInfoName i, fieldInfoType i) | i <- info]
|
||||
lookup "id" types `shouldBe` Just "INTEGER"
|
||||
lookup "first_name" types `shouldBe` Just "TEXT"
|
||||
lookup "last_name" types `shouldBe` Just "TEXT"
|
||||
lookup "age" types `shouldBe` Just "INTEGER"
|
||||
|
||||
describe "marshallerDerivedColumns" $ do
|
||||
it "lists all column names" $ do
|
||||
let cols = marshallerDerivedColumns personMarshaller
|
||||
length cols `shouldBe` 4
|
||||
|
||||
describe "marshallerEncodeWrite" $ do
|
||||
it "excludes read-only fields" $ do
|
||||
let p = Person 0 "Alice" "Smith" 30
|
||||
let pairs = marshallerEncodeWrite personMarshaller p
|
||||
let names = map fst pairs
|
||||
names `shouldNotContain` ["id"]
|
||||
|
||||
it "includes all write fields" $ do
|
||||
let p = Person 0 "Alice" "Smith" 30
|
||||
let pairs = marshallerEncodeWrite personMarshaller p
|
||||
let names = map fst pairs
|
||||
names `shouldBe` ["age", "last_name", "first_name"]
|
||||
|
||||
it "encodes correct values" $ do
|
||||
let p = Person 0 "Alice" "Smith" 30
|
||||
let pairs = marshallerEncodeWrite personMarshaller p
|
||||
lookup "first_name" pairs `shouldBe` Just (SQLite3.SQLText "Alice")
|
||||
lookup "last_name" pairs `shouldBe` Just (SQLite3.SQLText "Smith")
|
||||
lookup "age" pairs `shouldBe` Just (SQLite3.SQLInteger 30)
|
||||
|
||||
it "encodes nullable field as SQLNull when Nothing" $ do
|
||||
let t = Task 0 "No due" Nothing
|
||||
let pairs = marshallerEncodeWrite taskMarshaller t
|
||||
lookup "due_day" pairs `shouldBe` Just SQLite3.SQLNull
|
||||
|
||||
it "encodes nullable field as SQLInteger when Just" $ do
|
||||
let t = Task 0 "Has due" (Just 10)
|
||||
let pairs = marshallerEncodeWrite taskMarshaller t
|
||||
lookup "due_day" pairs `shouldBe` Just (SQLite3.SQLInteger 10)
|
||||
|
||||
describe "marshallerDecodeRow" $ do
|
||||
it "decodes a complete row" $ do
|
||||
let row =
|
||||
[ ("id", SQLite3.SQLInteger 1)
|
||||
, ("first_name", SQLite3.SQLText "Alice")
|
||||
, ("last_name", SQLite3.SQLText "Smith")
|
||||
, ("age", SQLite3.SQLInteger 30)
|
||||
]
|
||||
marshallerDecodeRow personMarshaller row `shouldBe` Right (Person 1 "Alice" "Smith" 30)
|
||||
|
||||
it "reports missing column" $ do
|
||||
let row =
|
||||
[ ("first_name", SQLite3.SQLText "Alice")
|
||||
, ("last_name", SQLite3.SQLText "Smith")
|
||||
, ("age", SQLite3.SQLInteger 30)
|
||||
]
|
||||
marshallerDecodeRow personMarshaller row `shouldSatisfy` \case
|
||||
Left e -> "id" `T.isInfixOf` T.pack e
|
||||
Right _ -> False
|
||||
|
||||
describe "marshallReadOnlyField" $ do
|
||||
it "is included in decode but excluded from encode" $ do
|
||||
let p = Person 0 "Alice" "Smith" 30
|
||||
let pairs = marshallerEncodeWrite personMarshaller p
|
||||
let colNames = marshallerDerivedColumns personMarshaller
|
||||
colNames `shouldContain` ["id"] -- id appears in SELECT
|
||||
map fst pairs `shouldNotContain` ["id"] -- id not in INSERT values
|
||||
describe "marshallMaybe" $ do
|
||||
it "decodes SQLNull as Nothing" $ do
|
||||
let row =
|
||||
[ ("task_id", SQLite3.SQLInteger 1)
|
||||
, ("description", SQLite3.SQLText "Test")
|
||||
, ("due_day", SQLite3.SQLNull)
|
||||
]
|
||||
marshallerDecodeRow taskMarshaller row
|
||||
`shouldBe` Right (Task 1 "Test" Nothing)
|
||||
|
||||
it "decodes SQLInteger as Just" $ do
|
||||
let row =
|
||||
[ ("task_id", SQLite3.SQLInteger 1)
|
||||
, ("description", SQLite3.SQLText "Test")
|
||||
, ("due_day", SQLite3.SQLInteger 25)
|
||||
]
|
||||
marshallerDecodeRow taskMarshaller row
|
||||
`shouldBe` Right (Task 1 "Test" (Just 25))
|
||||
Reference in New Issue
Block a user