Format code with fourmolu
This commit is contained in:
@@ -0,0 +1,76 @@
|
||||
# AGENTS.md
|
||||
|
||||
## Project Overview
|
||||
|
||||
`orville-sqlite` is a Haskell library providing a type-safe SQLite API modeled after the [Flipstone Orville](https://github.com/flipstone/orville/) PostgreSQL library. It maps Haskell data types to SQLite tables with compile-time schema guarantees.
|
||||
|
||||
## Development Environment
|
||||
|
||||
**All development happens inside Docker.** No local Haskell tools should be installed directly on the host machine.
|
||||
|
||||
Use the `./hs` wrapper script for all Haskell tooling:
|
||||
|
||||
```bash
|
||||
./hs stack build
|
||||
./hs stack test
|
||||
./hs stack ghci
|
||||
./hs fourmolu -i src/
|
||||
./hs hlint src/
|
||||
```
|
||||
|
||||
The script builds a Docker image based on `ghcr.io/flipstone/haskell-tools:debian-ghc-9.10.3-5d6640d` with `libsqlite3-dev` installed. A named Docker volume (`orville-sqlite-stack-root`) caches GHC and dependencies across worktrees.
|
||||
|
||||
## Build System
|
||||
|
||||
- **GHC**: 9.10.3
|
||||
- **Build tool**: Stack (via the `hs` wrapper)
|
||||
- **Formatter**: fourmolu
|
||||
- **Linter**: hlint
|
||||
|
||||
## Dependencies
|
||||
|
||||
- **Base SQLite library**: [direct-sqlite](https://github.com/IreneKnapp/direct-sqlite) — the low-level FFI binding to SQLite
|
||||
- This library builds type-safe marshalling, auto-migration, and query execution on top of `direct-sqlite`
|
||||
|
||||
## Target API
|
||||
|
||||
The library should provide APIs analogous to three key modules from `orville-postgresql`:
|
||||
|
||||
1. **`Orville.PostgreSQL.Marshall.SqlMarshaller`** — Type-safe mapping between Haskell records and SQL table columns
|
||||
2. **`Orville.PostgreSQL.AutoMigration`** — Schema migration: create tables if they don't exist, alter tables to match expected schema
|
||||
3. **`Orville.PostgreSQL.Execution`** — Query execution: SELECT, INSERT, UPDATE against typed tables
|
||||
|
||||
### Example Usage (Target API)
|
||||
|
||||
Given a Haskell type:
|
||||
|
||||
```haskell
|
||||
data Person = Person
|
||||
{ firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int
|
||||
}
|
||||
```
|
||||
|
||||
It should map to a table:
|
||||
|
||||
```sql
|
||||
CREATE TABLE person (
|
||||
first_name VARCHAR(100) NOT NULL,
|
||||
last_name VARCHAR(100) NOT NULL,
|
||||
age INT
|
||||
);
|
||||
```
|
||||
|
||||
And support:
|
||||
- Creating the table if it doesn't exist
|
||||
- Altering the table to match the schema when columns differ
|
||||
- Querying rows as `Person` values
|
||||
- Inserting `Person` values
|
||||
- Updating rows from `Person` values
|
||||
|
||||
## Design Principles
|
||||
|
||||
- Haskell types to SQLite schema — not a direct port of the PostgreSQL implementation
|
||||
- Follow the spirit and API shape of Orville, adapted to SQLite's type system and SQL dialect
|
||||
- Favor type safety and compile-time guarantees over runtime flexibility
|
||||
@@ -0,0 +1,61 @@
|
||||
# orville-sqlite
|
||||
|
||||
This library is intended to be a SQLite Haskell API similar in spirit to https://github.com/flipstone/orville/
|
||||
|
||||
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.
|
||||
|
||||
The Flipstone orville library is robust and deep. This library aspires to the same but realizes it's unlikely to get there anytime soon.
|
||||
|
||||
## Goal
|
||||
|
||||
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
|
||||
|
||||
```haskell
|
||||
|
||||
data Person =
|
||||
Person
|
||||
{ firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int
|
||||
}
|
||||
```
|
||||
|
||||
and map it to a table of schema
|
||||
|
||||
```sql
|
||||
CREATE TABLE person (
|
||||
first_name VARCHAR(100) NOT NULL,
|
||||
last_name VARCHAR(100) NOT NULL,
|
||||
age INT
|
||||
);
|
||||
```
|
||||
|
||||
and then give us an API for marshalling that Haskell type to that table definition
|
||||
|
||||
then using that marshaller we should have APIs that can;
|
||||
|
||||
- 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.
|
||||
|
||||
## Development environment
|
||||
|
||||
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.
|
||||
|
||||
## Base SQLite library
|
||||
|
||||
Our base library for interacting with SQLite should be direct-sqlite - https://github.com/IreneKnapp/direct-sqlite
|
||||
@@ -0,0 +1,35 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper to run Haskell tooling (stack, hpack, fourmolu, hlint, ...)
|
||||
# inside a Docker image with our system dependencies pre-installed.
|
||||
# Usage: ./hs <cmd> [args]
|
||||
set -euo pipefail
|
||||
|
||||
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
|
||||
# Build a custom image on top of flipstone/haskell-tools that includes
|
||||
# the C libraries our Haskell packages need (e.g. libsqlite3-dev).
|
||||
IMAGE="orville-sqlite-haskell-tools"
|
||||
|
||||
docker build \
|
||||
--quiet \
|
||||
-t "${IMAGE}" \
|
||||
-f - \
|
||||
"${PROJECT_DIR}" << DOCKERFILE
|
||||
FROM ghcr.io/flipstone/haskell-tools:debian-ghc-9.10.3-5d6640d
|
||||
RUN apt-get update -qq && apt-get install -y -qq libsqlite3-dev
|
||||
DOCKERFILE
|
||||
|
||||
# Named Docker volume shared across all worktrees so cached
|
||||
# GHC/dependencies don't need rebuilding per worktree.
|
||||
STACK_ROOT_VOLUME="orville-sqlite-stack-root"
|
||||
|
||||
docker volume inspect "${STACK_ROOT_VOLUME}" > /dev/null 2>&1 || \
|
||||
docker volume create "${STACK_ROOT_VOLUME}" > /dev/null
|
||||
|
||||
exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
|
||||
-v "${PROJECT_DIR}:/work" \
|
||||
-v "${STACK_ROOT_VOLUME}:/stack-root" \
|
||||
-e STACK_ROOT=/stack-root \
|
||||
-w /work/orville-sqlite \
|
||||
"${IMAGE}" \
|
||||
"$@"
|
||||
+148
-147
@@ -3,17 +3,17 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Orville.SQLite.AutoMigration
|
||||
( MigrationOptions (..)
|
||||
, defaultOptions
|
||||
, SchemaItem (..)
|
||||
, schemaTable
|
||||
, dropColumns
|
||||
, autoMigrateSchema
|
||||
, MigrationStep (..)
|
||||
, generateMigrationPlan
|
||||
, executeMigrationPlan
|
||||
) where
|
||||
module Orville.SQLite.AutoMigration (
|
||||
MigrationOptions (..),
|
||||
defaultOptions,
|
||||
SchemaItem (..),
|
||||
schemaTable,
|
||||
dropColumns,
|
||||
autoMigrateSchema,
|
||||
MigrationStep (..),
|
||||
generateMigrationPlan,
|
||||
executeMigrationPlan,
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
@@ -23,192 +23,193 @@ import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Orville.SQLite.FieldDefinition (fieldColumnName)
|
||||
import Orville.SQLite.Monad (OrvilleM)
|
||||
import Orville.SQLite.SqlMarshaller
|
||||
( FieldInfo (..)
|
||||
, SqlMarshaller
|
||||
, marshallerFieldInfo
|
||||
)
|
||||
import Orville.SQLite.TableDefinition (TableDefinition (..), PrimaryKey (..))
|
||||
import Orville.SQLite.SqlMarshaller (
|
||||
FieldInfo (..),
|
||||
SqlMarshaller,
|
||||
marshallerFieldInfo,
|
||||
)
|
||||
import Orville.SQLite.TableDefinition (PrimaryKey (..), TableDefinition (..))
|
||||
|
||||
data MigrationOptions = MigrationOptions
|
||||
{ runSchemaChanges :: Bool
|
||||
}
|
||||
{ runSchemaChanges :: Bool
|
||||
}
|
||||
|
||||
defaultOptions :: MigrationOptions
|
||||
defaultOptions = MigrationOptions{runSchemaChanges = True}
|
||||
|
||||
newtype SchemaItem = SchemaItem
|
||||
{ unSchemaItem :: SchemaItemRep
|
||||
}
|
||||
{ unSchemaItem :: SchemaItemRep
|
||||
}
|
||||
|
||||
data SchemaItemRep where
|
||||
SchemaTableItem ::
|
||||
{ schemaItemTableName :: String
|
||||
, schemaItemMarshaller :: SqlMarshaller w r
|
||||
, schemaItemPkName :: String
|
||||
, schemaItemDropColumns :: [String]
|
||||
} -> SchemaItemRep
|
||||
SchemaTableItem ::
|
||||
{ schemaItemTableName :: String
|
||||
, schemaItemMarshaller :: SqlMarshaller w r
|
||||
, schemaItemPkName :: String
|
||||
, schemaItemDropColumns :: [String]
|
||||
} ->
|
||||
SchemaItemRep
|
||||
|
||||
schemaTable ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
[String] ->
|
||||
SchemaItem
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
[String] ->
|
||||
SchemaItem
|
||||
schemaTable tableDef dropCols =
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
in SchemaItem
|
||||
SchemaTableItem
|
||||
{ schemaItemTableName = tableName tableDef
|
||||
, schemaItemMarshaller = tableMarshaller tableDef
|
||||
, schemaItemPkName = fieldColumnName pkFieldDef
|
||||
, schemaItemDropColumns = dropCols
|
||||
}
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
in SchemaItem
|
||||
SchemaTableItem
|
||||
{ schemaItemTableName = tableName tableDef
|
||||
, schemaItemMarshaller = tableMarshaller tableDef
|
||||
, schemaItemPkName = fieldColumnName pkFieldDef
|
||||
, schemaItemDropColumns = dropCols
|
||||
}
|
||||
|
||||
dropColumns :: [String] -> TableDefinition key w r -> [String]
|
||||
dropColumns = const
|
||||
|
||||
data MigrationStep
|
||||
= CreateTable String [(String, String, Bool)] String
|
||||
| AddColumn String String String
|
||||
| DropColumn String String
|
||||
deriving (Show, Eq)
|
||||
= CreateTable String [(String, String, Bool)] String
|
||||
| AddColumn String String String
|
||||
| DropColumn String String
|
||||
deriving (Show, Eq)
|
||||
|
||||
data ExistingColumn = ExistingColumn
|
||||
{ existingName :: String
|
||||
, existingType :: String
|
||||
, existingNotNull :: Bool
|
||||
, existingPk :: Bool
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
{ existingName :: String
|
||||
, existingType :: String
|
||||
, existingNotNull :: Bool
|
||||
, existingPk :: Bool
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
generateMigrationPlan :: [SchemaItem] -> OrvilleM [MigrationStep]
|
||||
generateMigrationPlan items = concat <$> mapM planItem items
|
||||
|
||||
planItem :: SchemaItem -> OrvilleM [MigrationStep]
|
||||
planItem (SchemaItem (SchemaTableItem tableName' marshaller pkName dropColsList)) = do
|
||||
existingCols <- getExistingColumns tableName'
|
||||
let expectedCols = marshallerExpectedColumns marshaller pkName
|
||||
pure $ planTableChanges tableName' expectedCols existingCols pkName dropColsList
|
||||
existingCols <- getExistingColumns tableName'
|
||||
let expectedCols = marshallerExpectedColumns marshaller pkName
|
||||
pure $ planTableChanges tableName' expectedCols existingCols pkName dropColsList
|
||||
|
||||
getExistingColumns :: String -> OrvilleM [ExistingColumn]
|
||||
getExistingColumns tableName' = do
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <-
|
||||
SQLite3.prepare db ("PRAGMA table_info(" <> T.pack tableName' <> ")")
|
||||
let loop acc = do
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Row -> do
|
||||
name <- SQLite3.columnText stmt 1
|
||||
colType <- SQLite3.columnText stmt 2
|
||||
notNullVal <- SQLite3.column stmt 3
|
||||
isPkVal <- SQLite3.column stmt 5
|
||||
let notNullFlag =
|
||||
case notNullVal of
|
||||
SQLite3.SQLInteger n -> n /= 0
|
||||
_ -> False
|
||||
let isPkFlag =
|
||||
case isPkVal of
|
||||
SQLite3.SQLInteger n -> n /= 0
|
||||
_ -> False
|
||||
loop
|
||||
( ExistingColumn
|
||||
(T.unpack name)
|
||||
(T.unpack colType)
|
||||
notNullFlag
|
||||
isPkFlag
|
||||
: acc
|
||||
)
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure (reverse acc)
|
||||
loop []
|
||||
db <- ask
|
||||
liftIO $ do
|
||||
stmt <-
|
||||
SQLite3.prepare db ("PRAGMA table_info(" <> T.pack tableName' <> ")")
|
||||
let loop acc = do
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Row -> do
|
||||
name <- SQLite3.columnText stmt 1
|
||||
colType <- SQLite3.columnText stmt 2
|
||||
notNullVal <- SQLite3.column stmt 3
|
||||
isPkVal <- SQLite3.column stmt 5
|
||||
let notNullFlag =
|
||||
case notNullVal of
|
||||
SQLite3.SQLInteger n -> n /= 0
|
||||
_ -> False
|
||||
let isPkFlag =
|
||||
case isPkVal of
|
||||
SQLite3.SQLInteger n -> n /= 0
|
||||
_ -> False
|
||||
loop
|
||||
( ExistingColumn
|
||||
(T.unpack name)
|
||||
(T.unpack colType)
|
||||
notNullFlag
|
||||
isPkFlag
|
||||
: acc
|
||||
)
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure (reverse acc)
|
||||
loop []
|
||||
|
||||
marshallerExpectedColumns ::
|
||||
SqlMarshaller w r ->
|
||||
String ->
|
||||
[(String, String, Bool)]
|
||||
SqlMarshaller w r ->
|
||||
String ->
|
||||
[(String, String, Bool)]
|
||||
marshallerExpectedColumns marshaller pkName =
|
||||
[ ( fieldInfoName f
|
||||
, fieldInfoType f
|
||||
, fieldInfoName f == pkName || not (fieldInfoIsNullable f)
|
||||
)
|
||||
| f <- marshallerFieldInfo marshaller
|
||||
]
|
||||
[ ( fieldInfoName f
|
||||
, fieldInfoType f
|
||||
, fieldInfoName f == pkName || not (fieldInfoIsNullable f)
|
||||
)
|
||||
| f <- marshallerFieldInfo marshaller
|
||||
]
|
||||
|
||||
planTableChanges ::
|
||||
String ->
|
||||
[(String, String, Bool)] ->
|
||||
[ExistingColumn] ->
|
||||
String ->
|
||||
[String] ->
|
||||
[MigrationStep]
|
||||
String ->
|
||||
[(String, String, Bool)] ->
|
||||
[ExistingColumn] ->
|
||||
String ->
|
||||
[String] ->
|
||||
[MigrationStep]
|
||||
planTableChanges tableName' expected existing pkName dropColsList
|
||||
| null existing = [CreateTable tableName' expected pkName]
|
||||
| otherwise = addColSteps ++ dropColSteps
|
||||
| null existing = [CreateTable tableName' expected pkName]
|
||||
| otherwise = addColSteps ++ dropColSteps
|
||||
where
|
||||
existingNames = map existingName existing
|
||||
|
||||
addColSteps =
|
||||
[ AddColumn tableName' name colType
|
||||
| (name, colType, _) <- expected
|
||||
, name `notElem` existingNames
|
||||
]
|
||||
[ AddColumn tableName' name colType
|
||||
| (name, colType, _) <- expected
|
||||
, name `notElem` existingNames
|
||||
]
|
||||
|
||||
dropColSteps =
|
||||
[ DropColumn tableName' name
|
||||
| name <- dropColsList
|
||||
, name `elem` existingNames
|
||||
]
|
||||
[ DropColumn tableName' name
|
||||
| name <- dropColsList
|
||||
, name `elem` existingNames
|
||||
]
|
||||
|
||||
autoMigrateSchema :: MigrationOptions -> [SchemaItem] -> OrvilleM ()
|
||||
autoMigrateSchema opts items = do
|
||||
plan <- generateMigrationPlan items
|
||||
when (runSchemaChanges opts) $
|
||||
executeMigrationPlan plan
|
||||
plan <- generateMigrationPlan items
|
||||
when (runSchemaChanges opts) $
|
||||
executeMigrationPlan plan
|
||||
|
||||
executeMigrationPlan :: [MigrationStep] -> OrvilleM ()
|
||||
executeMigrationPlan = mapM_ executeStep
|
||||
where
|
||||
executeStep step = do
|
||||
db <- ask
|
||||
case step of
|
||||
CreateTable name cols pkName ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
mkCreateTable name cols pkName
|
||||
AddColumn name colName colType ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
T.pack $
|
||||
"ALTER TABLE "
|
||||
<> name
|
||||
<> " ADD COLUMN "
|
||||
<> colName
|
||||
<> " "
|
||||
<> colType
|
||||
DropColumn name colName ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
T.pack $
|
||||
"ALTER TABLE "
|
||||
<> name
|
||||
<> " DROP COLUMN "
|
||||
<> colName
|
||||
db <- ask
|
||||
case step of
|
||||
CreateTable name cols pkName ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
mkCreateTable name cols pkName
|
||||
AddColumn name colName colType ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
T.pack $
|
||||
"ALTER TABLE "
|
||||
<> name
|
||||
<> " ADD COLUMN "
|
||||
<> colName
|
||||
<> " "
|
||||
<> colType
|
||||
DropColumn name colName ->
|
||||
liftIO $
|
||||
SQLite3.exec db $
|
||||
T.pack $
|
||||
"ALTER TABLE "
|
||||
<> name
|
||||
<> " DROP COLUMN "
|
||||
<> colName
|
||||
|
||||
mkCreateTable :: String -> [(String, String, Bool)] -> String -> T.Text
|
||||
mkCreateTable name cols pkName =
|
||||
T.pack $
|
||||
"CREATE TABLE IF NOT EXISTS "
|
||||
<> name
|
||||
<> " (\n "
|
||||
<> intercalate ",\n " (map mkColumnDef cols)
|
||||
<> "\n)"
|
||||
T.pack $
|
||||
"CREATE TABLE IF NOT EXISTS "
|
||||
<> name
|
||||
<> " (\n "
|
||||
<> intercalate ",\n " (map mkColumnDef cols)
|
||||
<> "\n)"
|
||||
where
|
||||
mkColumnDef (colName, colType, notNullFlag)
|
||||
| colName == pkName =
|
||||
colName <> " " <> colType <> " PRIMARY KEY"
|
||||
| notNullFlag =
|
||||
colName <> " " <> colType <> " NOT NULL"
|
||||
| otherwise =
|
||||
colName <> " " <> colType
|
||||
| colName == pkName =
|
||||
colName <> " " <> colType <> " PRIMARY KEY"
|
||||
| notNullFlag =
|
||||
colName <> " " <> colType <> " NOT NULL"
|
||||
| otherwise =
|
||||
colName <> " " <> colType
|
||||
|
||||
+138
-138
@@ -2,13 +2,13 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.Execution
|
||||
( insertEntity
|
||||
, findEntity
|
||||
, findAll
|
||||
, updateEntity
|
||||
, deleteEntity
|
||||
) where
|
||||
module Orville.SQLite.Execution (
|
||||
insertEntity,
|
||||
findEntity,
|
||||
findAll,
|
||||
updateEntity,
|
||||
deleteEntity,
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Reader (ask)
|
||||
@@ -18,152 +18,152 @@ import qualified Database.SQLite3 as SQLite3
|
||||
import Database.SQLite3.Direct (columnCount)
|
||||
import Orville.SQLite.FieldDefinition (fieldColumnName, fieldToSqlValue)
|
||||
import Orville.SQLite.Monad (OrvilleM)
|
||||
import Orville.SQLite.SqlMarshaller
|
||||
( marshallerDerivedColumns
|
||||
, marshallerEncodeWrite
|
||||
, marshallerDecodeRow
|
||||
)
|
||||
import Orville.SQLite.TableDefinition (TableDefinition (..), PrimaryKey (..))
|
||||
import Orville.SQLite.SqlMarshaller (
|
||||
marshallerDecodeRow,
|
||||
marshallerDerivedColumns,
|
||||
marshallerEncodeWrite,
|
||||
)
|
||||
import Orville.SQLite.TableDefinition (PrimaryKey (..), TableDefinition (..))
|
||||
|
||||
insertEntity ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
OrvilleM ()
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
OrvilleM ()
|
||||
insertEntity tableDef entity = do
|
||||
db <- ask
|
||||
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
|
||||
let colNames = map fst pairs
|
||||
let placeholders = map (const "?") colNames
|
||||
let sql =
|
||||
"INSERT INTO "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " ("
|
||||
<> T.pack (intercalate ", " colNames)
|
||||
<> ") VALUES ("
|
||||
<> T.pack (intercalate ", " placeholders)
|
||||
<> ")"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt (map snd pairs)
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
db <- ask
|
||||
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
|
||||
let colNames = map fst pairs
|
||||
let placeholders = map (const "?") colNames
|
||||
let sql =
|
||||
"INSERT INTO "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " ("
|
||||
<> T.pack (intercalate ", " colNames)
|
||||
<> ") VALUES ("
|
||||
<> T.pack (intercalate ", " placeholders)
|
||||
<> ")"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt (map snd pairs)
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
findEntity ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
key ->
|
||||
OrvilleM (Maybe readEntity)
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
key ->
|
||||
OrvilleM (Maybe readEntity)
|
||||
findEntity tableDef key = do
|
||||
db <- ask
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
let cols = marshallerDerivedColumns (tableMarshaller tableDef)
|
||||
let sql =
|
||||
"SELECT "
|
||||
<> T.pack (intercalate ", " cols)
|
||||
<> " FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure Nothing
|
||||
SQLite3.Row -> do
|
||||
rowData <- getRowData stmt cols
|
||||
SQLite3.finalize stmt
|
||||
case marshallerDecodeRow (tableMarshaller tableDef) rowData of
|
||||
Left err -> error $ "Decode error in findEntity: " <> err
|
||||
Right entity -> pure (Just entity)
|
||||
db <- ask
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
let cols = marshallerDerivedColumns (tableMarshaller tableDef)
|
||||
let sql =
|
||||
"SELECT "
|
||||
<> T.pack (intercalate ", " cols)
|
||||
<> " FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
|
||||
stepResult <- SQLite3.step stmt
|
||||
case stepResult of
|
||||
SQLite3.Done -> do
|
||||
SQLite3.finalize stmt
|
||||
pure Nothing
|
||||
SQLite3.Row -> do
|
||||
rowData <- getRowData stmt cols
|
||||
SQLite3.finalize stmt
|
||||
case marshallerDecodeRow (tableMarshaller tableDef) rowData of
|
||||
Left err -> error $ "Decode error in findEntity: " <> err
|
||||
Right entity -> pure (Just entity)
|
||||
|
||||
findAll ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
OrvilleM [readEntity]
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
OrvilleM [readEntity]
|
||||
findAll tableDef = do
|
||||
db <- ask
|
||||
let cols = marshallerDerivedColumns (tableMarshaller tableDef)
|
||||
let sql =
|
||||
"SELECT "
|
||||
<> T.pack (intercalate ", " cols)
|
||||
<> " FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
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 cols
|
||||
case marshallerDecodeRow (tableMarshaller tableDef) rowData of
|
||||
Left err -> error $ "Decode error in findAll: " <> err
|
||||
Right entity -> loop (entity : acc)
|
||||
loop []
|
||||
db <- ask
|
||||
let cols = marshallerDerivedColumns (tableMarshaller tableDef)
|
||||
let sql =
|
||||
"SELECT "
|
||||
<> T.pack (intercalate ", " cols)
|
||||
<> " FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
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 cols
|
||||
case marshallerDecodeRow (tableMarshaller tableDef) rowData of
|
||||
Left err -> error $ "Decode error in findAll: " <> err
|
||||
Right entity -> loop (entity : acc)
|
||||
loop []
|
||||
|
||||
updateEntity ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
OrvilleM ()
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
OrvilleM ()
|
||||
updateEntity tableDef entity = do
|
||||
db <- ask
|
||||
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
|
||||
let PrimaryKey pkAccessor pkFieldDef = tablePrimaryKey tableDef
|
||||
let pkValue = pkAccessor entity
|
||||
let setClauses = map (\(col, _) -> col <> " = ?") pairs
|
||||
let sql =
|
||||
"UPDATE "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " SET "
|
||||
<> T.pack (intercalate ", " setClauses)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt (map snd pairs ++ [fieldToSqlValue pkValue pkFieldDef])
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
db <- ask
|
||||
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
|
||||
let PrimaryKey pkAccessor pkFieldDef = tablePrimaryKey tableDef
|
||||
let pkValue = pkAccessor entity
|
||||
let setClauses = map (\(col, _) -> col <> " = ?") pairs
|
||||
let sql =
|
||||
"UPDATE "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " SET "
|
||||
<> T.pack (intercalate ", " setClauses)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt (map snd pairs ++ [fieldToSqlValue pkValue pkFieldDef])
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
deleteEntity ::
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
key ->
|
||||
OrvilleM ()
|
||||
TableDefinition key writeEntity readEntity ->
|
||||
key ->
|
||||
OrvilleM ()
|
||||
deleteEntity tableDef key = do
|
||||
db <- ask
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
let sql =
|
||||
"DELETE FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
db <- ask
|
||||
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
|
||||
let sql =
|
||||
"DELETE FROM "
|
||||
<> T.pack (tableName tableDef)
|
||||
<> " WHERE "
|
||||
<> T.pack (fieldColumnName pkFieldDef)
|
||||
<> " = ?"
|
||||
liftIO $ do
|
||||
stmt <- SQLite3.prepare db sql
|
||||
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
|
||||
_ <- SQLite3.step stmt
|
||||
SQLite3.finalize stmt
|
||||
|
||||
getRowData ::
|
||||
SQLite3.Statement ->
|
||||
[String] ->
|
||||
IO [(String, SQLite3.SQLData)]
|
||||
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
|
||||
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
|
||||
|
||||
@@ -3,75 +3,77 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Orville.SQLite.FieldDefinition
|
||||
( Nullability (..)
|
||||
, FieldDefinition (..)
|
||||
, integerField
|
||||
, textField
|
||||
, realField
|
||||
, blobField
|
||||
, nullableField
|
||||
, convertField
|
||||
, fieldToSqlValue
|
||||
, fieldFromSqlValue
|
||||
, fieldColumnName
|
||||
, fieldSqlTypeName
|
||||
, fieldIsNullable
|
||||
) where
|
||||
module Orville.SQLite.FieldDefinition (
|
||||
Nullability (..),
|
||||
FieldDefinition (..),
|
||||
integerField,
|
||||
textField,
|
||||
realField,
|
||||
blobField,
|
||||
nullableField,
|
||||
convertField,
|
||||
fieldToSqlValue,
|
||||
fieldFromSqlValue,
|
||||
fieldColumnName,
|
||||
fieldSqlTypeName,
|
||||
fieldIsNullable,
|
||||
) where
|
||||
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Orville.SQLite.SqlType
|
||||
( SqlType
|
||||
, convertSqlType
|
||||
, integerType
|
||||
, realType
|
||||
, blobType
|
||||
, sqlTypeFromSql
|
||||
, sqlTypeName
|
||||
, sqlTypeToSql
|
||||
, textType
|
||||
)
|
||||
import Orville.SQLite.SqlType (
|
||||
SqlType,
|
||||
blobType,
|
||||
convertSqlType,
|
||||
integerType,
|
||||
realType,
|
||||
sqlTypeFromSql,
|
||||
sqlTypeName,
|
||||
sqlTypeToSql,
|
||||
textType,
|
||||
)
|
||||
|
||||
data Nullability = NotNull | Nullable
|
||||
|
||||
data FieldDefinition (nullability :: Nullability) :: Type -> Type where
|
||||
NotNullField ::
|
||||
{ notNullFieldName :: String
|
||||
, notNullFieldSqlType :: SqlType a
|
||||
} -> FieldDefinition 'NotNull a
|
||||
NullableField ::
|
||||
{ nullableFieldName :: String
|
||||
, nullableFieldSqlType :: SqlType a
|
||||
} -> FieldDefinition 'Nullable a
|
||||
NotNullField ::
|
||||
{ notNullFieldName :: String
|
||||
, notNullFieldSqlType :: SqlType a
|
||||
} ->
|
||||
FieldDefinition 'NotNull a
|
||||
NullableField ::
|
||||
{ nullableFieldName :: String
|
||||
, nullableFieldSqlType :: SqlType a
|
||||
} ->
|
||||
FieldDefinition 'Nullable a
|
||||
|
||||
fieldColumnName :: FieldDefinition null a -> String
|
||||
fieldColumnName = \case
|
||||
NotNullField n _ -> n
|
||||
NullableField n _ -> n
|
||||
NotNullField n _ -> n
|
||||
NullableField n _ -> n
|
||||
|
||||
fieldSqlTypeName :: FieldDefinition null a -> String
|
||||
fieldSqlTypeName = \case
|
||||
NotNullField _ st -> sqlTypeName st
|
||||
NullableField _ st -> sqlTypeName st
|
||||
NotNullField _ st -> sqlTypeName st
|
||||
NullableField _ st -> sqlTypeName st
|
||||
|
||||
fieldIsNullable :: FieldDefinition null a -> Bool
|
||||
fieldIsNullable = \case
|
||||
NotNullField _ _ -> False
|
||||
NullableField _ _ -> True
|
||||
NotNullField _ _ -> False
|
||||
NullableField _ _ -> True
|
||||
|
||||
fieldToSqlValue :: a -> FieldDefinition null a -> SQLite3.SQLData
|
||||
fieldToSqlValue val = \case
|
||||
NotNullField _ st -> sqlTypeToSql st val
|
||||
NullableField _ st -> sqlTypeToSql st val
|
||||
NotNullField _ st -> sqlTypeToSql st val
|
||||
NullableField _ st -> sqlTypeToSql st val
|
||||
|
||||
fieldFromSqlValue :: SQLite3.SQLData -> FieldDefinition null a -> Either String a
|
||||
fieldFromSqlValue sqlVal = \case
|
||||
NotNullField _ st -> sqlTypeFromSql st sqlVal
|
||||
NullableField _ st -> sqlTypeFromSql st sqlVal
|
||||
NotNullField _ st -> sqlTypeFromSql st sqlVal
|
||||
NullableField _ st -> sqlTypeFromSql st sqlVal
|
||||
|
||||
integerField :: String -> FieldDefinition 'NotNull Int64
|
||||
integerField name = NotNullField name integerType
|
||||
@@ -87,13 +89,13 @@ blobField name = NotNullField name blobType
|
||||
|
||||
nullableField :: FieldDefinition 'NotNull a -> FieldDefinition 'Nullable a
|
||||
nullableField = \case
|
||||
NotNullField n st -> NullableField n st
|
||||
NotNullField n st -> NullableField n st
|
||||
|
||||
convertField ::
|
||||
(a -> b) ->
|
||||
(b -> a) ->
|
||||
FieldDefinition null a ->
|
||||
FieldDefinition null b
|
||||
(a -> b) ->
|
||||
(b -> a) ->
|
||||
FieldDefinition null a ->
|
||||
FieldDefinition null b
|
||||
convertField to from = \case
|
||||
NotNullField n st -> NotNullField n (convertSqlType to from st)
|
||||
NullableField n st -> NullableField n (convertSqlType to from st)
|
||||
NotNullField n st -> NotNullField n (convertSqlType to from st)
|
||||
NullableField n st -> NullableField n (convertSqlType to from st)
|
||||
|
||||
+17
-17
@@ -1,24 +1,24 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Orville.SQLite.Monad
|
||||
( OrvilleM
|
||||
, withConnection
|
||||
, openConnection
|
||||
, closeConnection
|
||||
, runOrvilleM
|
||||
, withTransaction
|
||||
) where
|
||||
module Orville.SQLite.Monad (
|
||||
OrvilleM,
|
||||
withConnection,
|
||||
openConnection,
|
||||
closeConnection,
|
||||
runOrvilleM,
|
||||
withTransaction,
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Reader (ReaderT, runReaderT, ask, MonadReader)
|
||||
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
|
||||
newtype OrvilleM a = OrvilleM
|
||||
{ unOrvilleM :: ReaderT SQLite3.Database IO a
|
||||
}
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database)
|
||||
{ unOrvilleM :: ReaderT SQLite3.Database IO a
|
||||
}
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database)
|
||||
|
||||
runOrvilleM :: SQLite3.Database -> OrvilleM a -> IO a
|
||||
runOrvilleM db action = runReaderT (unOrvilleM action) db
|
||||
@@ -34,8 +34,8 @@ closeConnection = SQLite3.close
|
||||
|
||||
withTransaction :: OrvilleM a -> OrvilleM a
|
||||
withTransaction action = do
|
||||
db <- ask
|
||||
liftIO $ SQLite3.exec db "BEGIN TRANSACTION"
|
||||
result <- action
|
||||
liftIO $ SQLite3.exec db "COMMIT"
|
||||
pure result
|
||||
db <- ask
|
||||
liftIO $ SQLite3.exec db "BEGIN TRANSACTION"
|
||||
result <- action
|
||||
liftIO $ SQLite3.exec db "COMMIT"
|
||||
pure result
|
||||
|
||||
@@ -1,22 +1,22 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Orville.SQLite.RawSql
|
||||
( RawSql (..)
|
||||
, fromString
|
||||
, toRawSql
|
||||
, intercalate
|
||||
, fromText
|
||||
, space
|
||||
, comma
|
||||
, leftParen
|
||||
, rightParen
|
||||
, equals
|
||||
) where
|
||||
module Orville.SQLite.RawSql (
|
||||
RawSql (..),
|
||||
fromString,
|
||||
toRawSql,
|
||||
intercalate,
|
||||
fromText,
|
||||
space,
|
||||
comma,
|
||||
leftParen,
|
||||
rightParen,
|
||||
equals,
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
newtype RawSql = RawSql {unRawSql :: String}
|
||||
deriving (Show, Eq, Semigroup, Monoid)
|
||||
deriving (Show, Eq, Semigroup, Monoid)
|
||||
|
||||
fromString :: String -> RawSql
|
||||
fromString = RawSql
|
||||
|
||||
@@ -3,111 +3,111 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.SqlMarshaller
|
||||
( SqlMarshaller
|
||||
, FieldInfo (..)
|
||||
, marshallField
|
||||
, marshallReadOnlyField
|
||||
, marshallMaybe
|
||||
, marshallerFieldInfo
|
||||
, marshallerDerivedColumns
|
||||
, marshallerEncodeWrite
|
||||
, marshallerDecodeRow
|
||||
) where
|
||||
module Orville.SQLite.SqlMarshaller (
|
||||
SqlMarshaller,
|
||||
FieldInfo (..),
|
||||
marshallField,
|
||||
marshallReadOnlyField,
|
||||
marshallMaybe,
|
||||
marshallerFieldInfo,
|
||||
marshallerDerivedColumns,
|
||||
marshallerEncodeWrite,
|
||||
marshallerDecodeRow,
|
||||
) where
|
||||
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Orville.SQLite.FieldDefinition
|
||||
( FieldDefinition (..)
|
||||
, Nullability (..)
|
||||
, fieldColumnName
|
||||
, fieldToSqlValue
|
||||
, fieldFromSqlValue
|
||||
, fieldIsNullable
|
||||
, fieldSqlTypeName
|
||||
)
|
||||
import Orville.SQLite.FieldDefinition (
|
||||
FieldDefinition (..),
|
||||
Nullability (..),
|
||||
fieldColumnName,
|
||||
fieldFromSqlValue,
|
||||
fieldIsNullable,
|
||||
fieldSqlTypeName,
|
||||
fieldToSqlValue,
|
||||
)
|
||||
|
||||
data FieldInfo = FieldInfo
|
||||
{ fieldInfoName :: String
|
||||
, fieldInfoType :: String
|
||||
, fieldInfoIsNullable :: Bool
|
||||
}
|
||||
{ fieldInfoName :: String
|
||||
, fieldInfoType :: String
|
||||
, fieldInfoIsNullable :: Bool
|
||||
}
|
||||
|
||||
data SqlMarshaller writeEntity readEntity where
|
||||
MarshallPure :: readEntity -> SqlMarshaller writeEntity readEntity
|
||||
MarshallApply ::
|
||||
SqlMarshaller writeEntity (a -> b) ->
|
||||
SqlMarshaller writeEntity a ->
|
||||
SqlMarshaller writeEntity b
|
||||
MarshallNest ::
|
||||
(writeEntity -> a) ->
|
||||
SqlMarshaller a readEntity ->
|
||||
SqlMarshaller writeEntity readEntity
|
||||
MarshallField ::
|
||||
FieldDefinition nullability a ->
|
||||
SqlMarshaller a a
|
||||
MarshallMaybe ::
|
||||
FieldDefinition 'Nullable a ->
|
||||
SqlMarshaller (Maybe a) (Maybe a)
|
||||
MarshallReadOnly ::
|
||||
SqlMarshaller a readEntity ->
|
||||
SqlMarshaller b readEntity
|
||||
MarshallPure :: readEntity -> SqlMarshaller writeEntity readEntity
|
||||
MarshallApply ::
|
||||
SqlMarshaller writeEntity (a -> b) ->
|
||||
SqlMarshaller writeEntity a ->
|
||||
SqlMarshaller writeEntity b
|
||||
MarshallNest ::
|
||||
(writeEntity -> a) ->
|
||||
SqlMarshaller a readEntity ->
|
||||
SqlMarshaller writeEntity readEntity
|
||||
MarshallField ::
|
||||
FieldDefinition nullability a ->
|
||||
SqlMarshaller a a
|
||||
MarshallMaybe ::
|
||||
FieldDefinition 'Nullable a ->
|
||||
SqlMarshaller (Maybe a) (Maybe a)
|
||||
MarshallReadOnly ::
|
||||
SqlMarshaller a readEntity ->
|
||||
SqlMarshaller b readEntity
|
||||
|
||||
instance Functor (SqlMarshaller w) where
|
||||
fmap f m = MarshallPure f `MarshallApply` m
|
||||
fmap f m = MarshallPure f `MarshallApply` m
|
||||
|
||||
instance Applicative (SqlMarshaller w) where
|
||||
pure = MarshallPure
|
||||
(<*>) = MarshallApply
|
||||
pure = MarshallPure
|
||||
(<*>) = MarshallApply
|
||||
|
||||
marshallField ::
|
||||
(writeEntity -> a) ->
|
||||
FieldDefinition 'NotNull a ->
|
||||
SqlMarshaller writeEntity a
|
||||
(writeEntity -> a) ->
|
||||
FieldDefinition 'NotNull a ->
|
||||
SqlMarshaller writeEntity a
|
||||
marshallField accessor fieldDef =
|
||||
MarshallNest accessor (MarshallField fieldDef)
|
||||
MarshallNest accessor (MarshallField fieldDef)
|
||||
|
||||
marshallReadOnlyField ::
|
||||
FieldDefinition nullability a ->
|
||||
SqlMarshaller writeEntity a
|
||||
FieldDefinition nullability a ->
|
||||
SqlMarshaller writeEntity a
|
||||
marshallReadOnlyField fieldDef =
|
||||
MarshallReadOnly (MarshallField fieldDef)
|
||||
MarshallReadOnly (MarshallField fieldDef)
|
||||
|
||||
marshallMaybe ::
|
||||
(writeEntity -> Maybe a) ->
|
||||
FieldDefinition 'Nullable a ->
|
||||
SqlMarshaller writeEntity (Maybe a)
|
||||
(writeEntity -> Maybe a) ->
|
||||
FieldDefinition 'Nullable a ->
|
||||
SqlMarshaller writeEntity (Maybe a)
|
||||
marshallMaybe accessor fieldDef =
|
||||
MarshallNest accessor (MarshallMaybe fieldDef)
|
||||
MarshallNest accessor (MarshallMaybe fieldDef)
|
||||
|
||||
marshallerFieldInfo ::
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[FieldInfo]
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[FieldInfo]
|
||||
marshallerFieldInfo marshaller =
|
||||
reverse $ go marshaller []
|
||||
reverse $ go marshaller []
|
||||
where
|
||||
go :: SqlMarshaller w r -> [FieldInfo] -> [FieldInfo]
|
||||
go (MarshallPure _) acc = acc
|
||||
go (MarshallApply m1 m2) acc = go m1 (go m2 acc)
|
||||
go (MarshallNest _ m) acc = go m acc
|
||||
go (MarshallField fieldDef) acc =
|
||||
FieldInfo
|
||||
(fieldColumnName fieldDef)
|
||||
(fieldSqlTypeName fieldDef)
|
||||
(fieldIsNullable fieldDef)
|
||||
: acc
|
||||
FieldInfo
|
||||
(fieldColumnName fieldDef)
|
||||
(fieldSqlTypeName fieldDef)
|
||||
(fieldIsNullable fieldDef)
|
||||
: acc
|
||||
go (MarshallMaybe fieldDef) acc =
|
||||
FieldInfo
|
||||
(fieldColumnName fieldDef)
|
||||
(fieldSqlTypeName fieldDef)
|
||||
(True :: Bool)
|
||||
: acc
|
||||
FieldInfo
|
||||
(fieldColumnName fieldDef)
|
||||
(fieldSqlTypeName fieldDef)
|
||||
(True :: Bool)
|
||||
: acc
|
||||
go (MarshallReadOnly m) acc = go m acc
|
||||
|
||||
marshallerDerivedColumns ::
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[String]
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[String]
|
||||
marshallerDerivedColumns marshaller =
|
||||
reverse $ go marshaller []
|
||||
reverse $ go marshaller []
|
||||
where
|
||||
go :: SqlMarshaller w r -> [String] -> [String]
|
||||
go (MarshallPure _) acc = acc
|
||||
@@ -118,49 +118,49 @@ marshallerDerivedColumns marshaller =
|
||||
go (MarshallReadOnly m) acc = go m acc
|
||||
|
||||
marshallerEncodeWrite ::
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
[(String, SQLite3.SQLData)]
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
writeEntity ->
|
||||
[(String, SQLite3.SQLData)]
|
||||
marshallerEncodeWrite marshaller entity =
|
||||
reverse $ go marshaller entity []
|
||||
reverse $ go marshaller entity []
|
||||
where
|
||||
go :: SqlMarshaller w r -> w -> [(String, SQLite3.SQLData)] -> [(String, SQLite3.SQLData)]
|
||||
go (MarshallPure _) _ acc = acc
|
||||
go (MarshallApply m1 m2) w acc =
|
||||
go m1 w (go m2 w acc)
|
||||
go m1 w (go m2 w acc)
|
||||
go (MarshallNest accessor m) w acc =
|
||||
go m (accessor w) acc
|
||||
go m (accessor w) acc
|
||||
go (MarshallField fieldDef) a acc =
|
||||
(fieldColumnName fieldDef, fieldToSqlValue a fieldDef) : acc
|
||||
(fieldColumnName fieldDef, fieldToSqlValue a fieldDef) : acc
|
||||
go (MarshallMaybe fieldDef) a acc =
|
||||
case a of
|
||||
Nothing -> (fieldColumnName fieldDef, SQLite3.SQLNull) : acc
|
||||
Just val -> (fieldColumnName fieldDef, fieldToSqlValue val fieldDef) : acc
|
||||
case a of
|
||||
Nothing -> (fieldColumnName fieldDef, SQLite3.SQLNull) : acc
|
||||
Just val -> (fieldColumnName fieldDef, fieldToSqlValue val fieldDef) : acc
|
||||
go (MarshallReadOnly _) _ acc = acc
|
||||
|
||||
marshallerDecodeRow ::
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[(String, SQLite3.SQLData)] ->
|
||||
Either String readEntity
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
[(String, SQLite3.SQLData)] ->
|
||||
Either String readEntity
|
||||
marshallerDecodeRow marshaller rowData =
|
||||
go marshaller rowData
|
||||
go marshaller rowData
|
||||
where
|
||||
go :: SqlMarshaller w r -> [(String, SQLite3.SQLData)] -> Either String r
|
||||
go (MarshallPure r) _ = Right r
|
||||
go (MarshallApply m1 m2) rd = do
|
||||
f <- go m1 rd
|
||||
a <- go m2 rd
|
||||
Right (f a)
|
||||
f <- go m1 rd
|
||||
a <- go m2 rd
|
||||
Right (f a)
|
||||
go (MarshallNest _ m) rd = go m rd
|
||||
go (MarshallField fieldDef) rd =
|
||||
case lookup (fieldColumnName fieldDef) rd of
|
||||
Just sqlVal -> fieldFromSqlValue sqlVal fieldDef
|
||||
Nothing ->
|
||||
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
|
||||
case lookup (fieldColumnName fieldDef) rd of
|
||||
Just sqlVal -> fieldFromSqlValue sqlVal fieldDef
|
||||
Nothing ->
|
||||
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
|
||||
go (MarshallMaybe fieldDef) rd =
|
||||
case lookup (fieldColumnName fieldDef) rd of
|
||||
Just SQLite3.SQLNull -> Right Nothing
|
||||
Just sqlVal -> Just <$> fieldFromSqlValue sqlVal fieldDef
|
||||
Nothing ->
|
||||
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
|
||||
case lookup (fieldColumnName fieldDef) rd of
|
||||
Just SQLite3.SQLNull -> Right Nothing
|
||||
Just sqlVal -> Just <$> fieldFromSqlValue sqlVal fieldDef
|
||||
Nothing ->
|
||||
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
|
||||
go (MarshallReadOnly m) rd = go m rd
|
||||
|
||||
@@ -1,13 +1,13 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Orville.SQLite.SqlType
|
||||
( SqlType (..)
|
||||
, integerType
|
||||
, textType
|
||||
, realType
|
||||
, blobType
|
||||
, convertSqlType
|
||||
) where
|
||||
module Orville.SQLite.SqlType (
|
||||
SqlType (..),
|
||||
integerType,
|
||||
textType,
|
||||
realType,
|
||||
blobType,
|
||||
convertSqlType,
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Int (Int64)
|
||||
@@ -15,70 +15,70 @@ import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
|
||||
data SqlType a = SqlType
|
||||
{ sqlTypeName :: String
|
||||
, sqlTypeToSql :: a -> SQLite3.SQLData
|
||||
, sqlTypeFromSql :: SQLite3.SQLData -> Either String a
|
||||
}
|
||||
{ sqlTypeName :: String
|
||||
, sqlTypeToSql :: a -> SQLite3.SQLData
|
||||
, sqlTypeFromSql :: SQLite3.SQLData -> Either String a
|
||||
}
|
||||
|
||||
integerType :: SqlType Int64
|
||||
integerType =
|
||||
SqlType
|
||||
{ sqlTypeName = "INTEGER"
|
||||
, sqlTypeToSql = SQLite3.SQLInteger
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLInteger i -> Right i
|
||||
SQLite3.SQLNull -> Right 0
|
||||
other -> Left $ "Expected INTEGER, got " <> show (sqlDataKind other)
|
||||
}
|
||||
SqlType
|
||||
{ sqlTypeName = "INTEGER"
|
||||
, sqlTypeToSql = SQLite3.SQLInteger
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLInteger i -> Right i
|
||||
SQLite3.SQLNull -> Right 0
|
||||
other -> Left $ "Expected INTEGER, got " <> show (sqlDataKind other)
|
||||
}
|
||||
|
||||
textType :: SqlType T.Text
|
||||
textType =
|
||||
SqlType
|
||||
{ sqlTypeName = "TEXT"
|
||||
, sqlTypeToSql = SQLite3.SQLText
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLText t -> Right t
|
||||
SQLite3.SQLNull -> Right T.empty
|
||||
SQLite3.SQLInteger i -> Right (T.pack (show i))
|
||||
SQLite3.SQLFloat d -> Right (T.pack (show d))
|
||||
other -> Left $ "Expected TEXT, got " <> show (sqlDataKind other)
|
||||
}
|
||||
SqlType
|
||||
{ sqlTypeName = "TEXT"
|
||||
, sqlTypeToSql = SQLite3.SQLText
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLText t -> Right t
|
||||
SQLite3.SQLNull -> Right T.empty
|
||||
SQLite3.SQLInteger i -> Right (T.pack (show i))
|
||||
SQLite3.SQLFloat d -> Right (T.pack (show d))
|
||||
other -> Left $ "Expected TEXT, got " <> show (sqlDataKind other)
|
||||
}
|
||||
|
||||
realType :: SqlType Double
|
||||
realType =
|
||||
SqlType
|
||||
{ sqlTypeName = "REAL"
|
||||
, sqlTypeToSql = SQLite3.SQLFloat
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLFloat d -> Right d
|
||||
SQLite3.SQLInteger i -> Right (fromIntegral i)
|
||||
SQLite3.SQLNull -> Right 0.0
|
||||
other -> Left $ "Expected REAL, got " <> show (sqlDataKind other)
|
||||
}
|
||||
SqlType
|
||||
{ sqlTypeName = "REAL"
|
||||
, sqlTypeToSql = SQLite3.SQLFloat
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLFloat d -> Right d
|
||||
SQLite3.SQLInteger i -> Right (fromIntegral i)
|
||||
SQLite3.SQLNull -> Right 0.0
|
||||
other -> Left $ "Expected REAL, got " <> show (sqlDataKind other)
|
||||
}
|
||||
|
||||
blobType :: SqlType BS.ByteString
|
||||
blobType =
|
||||
SqlType
|
||||
{ sqlTypeName = "BLOB"
|
||||
, sqlTypeToSql = SQLite3.SQLBlob
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLBlob b -> Right b
|
||||
SQLite3.SQLNull -> Right BS.empty
|
||||
other -> Left $ "Expected BLOB, got " <> show (sqlDataKind other)
|
||||
}
|
||||
SqlType
|
||||
{ sqlTypeName = "BLOB"
|
||||
, sqlTypeToSql = SQLite3.SQLBlob
|
||||
, sqlTypeFromSql = \case
|
||||
SQLite3.SQLBlob b -> Right b
|
||||
SQLite3.SQLNull -> Right BS.empty
|
||||
other -> Left $ "Expected BLOB, got " <> show (sqlDataKind other)
|
||||
}
|
||||
|
||||
convertSqlType :: (a -> b) -> (b -> a) -> SqlType a -> SqlType b
|
||||
convertSqlType to from sqlType =
|
||||
SqlType
|
||||
{ sqlTypeName = sqlTypeName sqlType
|
||||
, sqlTypeToSql = sqlTypeToSql sqlType . from
|
||||
, sqlTypeFromSql = fmap to . sqlTypeFromSql sqlType
|
||||
}
|
||||
SqlType
|
||||
{ sqlTypeName = sqlTypeName sqlType
|
||||
, sqlTypeToSql = sqlTypeToSql sqlType . from
|
||||
, sqlTypeFromSql = fmap to . sqlTypeFromSql sqlType
|
||||
}
|
||||
|
||||
sqlDataKind :: SQLite3.SQLData -> String
|
||||
sqlDataKind = \case
|
||||
SQLite3.SQLInteger _ -> "SQLInteger"
|
||||
SQLite3.SQLFloat _ -> "SQLFloat"
|
||||
SQLite3.SQLText _ -> "SQLText"
|
||||
SQLite3.SQLBlob _ -> "SQLBlob"
|
||||
SQLite3.SQLNull -> "SQLNull"
|
||||
SQLite3.SQLInteger _ -> "SQLInteger"
|
||||
SQLite3.SQLFloat _ -> "SQLFloat"
|
||||
SQLite3.SQLText _ -> "SQLText"
|
||||
SQLite3.SQLBlob _ -> "SQLBlob"
|
||||
SQLite3.SQLNull -> "SQLNull"
|
||||
|
||||
@@ -2,60 +2,60 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.TableDefinition
|
||||
( PrimaryKey (..)
|
||||
, primaryKey
|
||||
, TableDefinition (..)
|
||||
, mkTableDefinition
|
||||
, mkTableDefinitionWithoutKey
|
||||
) where
|
||||
module Orville.SQLite.TableDefinition (
|
||||
PrimaryKey (..),
|
||||
primaryKey,
|
||||
TableDefinition (..),
|
||||
mkTableDefinition,
|
||||
mkTableDefinitionWithoutKey,
|
||||
) where
|
||||
|
||||
import Orville.SQLite.FieldDefinition
|
||||
( FieldDefinition
|
||||
, Nullability (..)
|
||||
, integerField
|
||||
, convertField
|
||||
)
|
||||
import Orville.SQLite.FieldDefinition (
|
||||
FieldDefinition,
|
||||
Nullability (..),
|
||||
convertField,
|
||||
integerField,
|
||||
)
|
||||
import Orville.SQLite.SqlMarshaller (SqlMarshaller)
|
||||
|
||||
data PrimaryKey writeEntity key where
|
||||
PrimaryKey ::
|
||||
PrimaryKey ::
|
||||
(writeEntity -> key) ->
|
||||
FieldDefinition 'NotNull key ->
|
||||
PrimaryKey writeEntity key
|
||||
|
||||
primaryKey ::
|
||||
(writeEntity -> key) ->
|
||||
FieldDefinition 'NotNull key ->
|
||||
PrimaryKey writeEntity key
|
||||
|
||||
primaryKey ::
|
||||
(writeEntity -> key) ->
|
||||
FieldDefinition 'NotNull key ->
|
||||
PrimaryKey writeEntity key
|
||||
primaryKey = PrimaryKey
|
||||
|
||||
data TableDefinition key writeEntity readEntity = TableDefinition
|
||||
{ tableName :: String
|
||||
, tablePrimaryKey :: PrimaryKey writeEntity key
|
||||
, tableMarshaller :: SqlMarshaller writeEntity readEntity
|
||||
}
|
||||
{ tableName :: String
|
||||
, tablePrimaryKey :: PrimaryKey writeEntity key
|
||||
, tableMarshaller :: SqlMarshaller writeEntity readEntity
|
||||
}
|
||||
|
||||
mkTableDefinition ::
|
||||
String ->
|
||||
PrimaryKey writeEntity key ->
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
TableDefinition key writeEntity readEntity
|
||||
String ->
|
||||
PrimaryKey writeEntity key ->
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
TableDefinition key writeEntity readEntity
|
||||
mkTableDefinition = TableDefinition
|
||||
|
||||
mkTableDefinitionWithoutKey ::
|
||||
String ->
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
TableDefinition () writeEntity readEntity
|
||||
String ->
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
TableDefinition () writeEntity readEntity
|
||||
mkTableDefinitionWithoutKey name marshaller =
|
||||
let
|
||||
dummyField ::
|
||||
FieldDefinition 'NotNull ()
|
||||
dummyField =
|
||||
convertField (\_ -> ()) (\() -> 0) (integerField "__rowid__")
|
||||
in
|
||||
TableDefinition
|
||||
{ tableName = name
|
||||
, tablePrimaryKey = PrimaryKey (const ()) dummyField
|
||||
, tableMarshaller = marshaller
|
||||
}
|
||||
let
|
||||
dummyField ::
|
||||
FieldDefinition 'NotNull ()
|
||||
dummyField =
|
||||
convertField (\_ -> ()) (\() -> 0) (integerField "__rowid__")
|
||||
in
|
||||
TableDefinition
|
||||
{ tableName = name
|
||||
, tablePrimaryKey = PrimaryKey (const ()) dummyField
|
||||
, tableMarshaller = marshaller
|
||||
}
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/topics/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: direct-sqlite-2.3.29@sha256:6ff3969a6eae383c8a9ab093abfee7f7b0ed76dab045c984a1497b7e1d71279d,4180
|
||||
pantry-tree:
|
||||
sha256: 794455a2e32dc749ff32d8907bc51d810f79b963d5e21c42bc8555bc34bbd625
|
||||
size: 770
|
||||
original:
|
||||
hackage: direct-sqlite-2.3.29
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 3c412a7c13dba6d3d808455a458e0776c58b6cf99b8a7961a2f5e55589d6f1d6
|
||||
size: 729011
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/43.yaml
|
||||
original: lts-24.43
|
||||
+56
-56
@@ -6,16 +6,16 @@ module Main where
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Test.Hspec
|
||||
import Orville.SQLite
|
||||
import Test.Hspec
|
||||
|
||||
data Person = Person
|
||||
{ personId :: Int64
|
||||
, firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
{ personId :: Int64
|
||||
, firstName :: Text
|
||||
, lastName :: Text
|
||||
, age :: Int64
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
personIdField :: FieldDefinition 'NotNull Int64
|
||||
personIdField = integerField "id"
|
||||
@@ -31,62 +31,62 @@ ageField = integerField "age"
|
||||
|
||||
personMarshaller :: SqlMarshaller Person Person
|
||||
personMarshaller =
|
||||
Person
|
||||
<$> marshallReadOnlyField personIdField
|
||||
<*> marshallField firstName firstNameField
|
||||
<*> marshallField lastName lastNameField
|
||||
<*> marshallField age ageField
|
||||
Person
|
||||
<$> marshallReadOnlyField personIdField
|
||||
<*> marshallField firstName firstNameField
|
||||
<*> marshallField lastName lastNameField
|
||||
<*> marshallField age ageField
|
||||
|
||||
personTable :: TableDefinition Int64 Person Person
|
||||
personTable =
|
||||
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
|
||||
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
|
||||
|
||||
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
|
||||
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 "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 "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 "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
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user