jbrechtel/orville-sqlite
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Format code with fourmolu

Browse Source
This commit is contained in:
James Brechtel
2026-05-29 23:24:26 -04:00
parent c2cd26694b
commit 9d0e9ebbe5
13 changed files with 813 additions and 619 deletions
Download Patch File Download Diff File Expand all files Collapse all files
AGENTS.md
+76
View File
@@ -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
README.md
+61
View File
@@ -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
hs
Executable
+35
View File
@@ -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}" \
"$@"
src/Orville/SQLite/AutoMigration.hs
+148 -147
View File
@@ -3,17 +3,17 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Orville.SQLite.AutoMigration module Orville.SQLite.AutoMigration (
( MigrationOptions (..) MigrationOptions (..),
, defaultOptions defaultOptions,
, SchemaItem (..) SchemaItem (..),
, schemaTable schemaTable,
, dropColumns dropColumns,
, autoMigrateSchema autoMigrateSchema,
, MigrationStep (..) MigrationStep (..),
, generateMigrationPlan generateMigrationPlan,
, executeMigrationPlan executeMigrationPlan,
) where ) where
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@@ -23,192 +23,193 @@ import qualified Data.Text as T
import qualified Database.SQLite3 as SQLite3 import qualified Database.SQLite3 as SQLite3
import Orville.SQLite.FieldDefinition (fieldColumnName) import Orville.SQLite.FieldDefinition (fieldColumnName)
import Orville.SQLite.Monad (OrvilleM) import Orville.SQLite.Monad (OrvilleM)
import Orville.SQLite.SqlMarshaller import Orville.SQLite.SqlMarshaller (
( FieldInfo (..) FieldInfo (..),
, SqlMarshaller SqlMarshaller,
, marshallerFieldInfo marshallerFieldInfo,
) )
import Orville.SQLite.TableDefinition (TableDefinition (..), PrimaryKey (..)) import Orville.SQLite.TableDefinition (PrimaryKey (..), TableDefinition (..))
data MigrationOptions = MigrationOptions data MigrationOptions = MigrationOptions
{ runSchemaChanges :: Bool { runSchemaChanges :: Bool
} }
defaultOptions :: MigrationOptions defaultOptions :: MigrationOptions
defaultOptions = MigrationOptions{runSchemaChanges = True} defaultOptions = MigrationOptions{runSchemaChanges = True}
newtype SchemaItem = SchemaItem newtype SchemaItem = SchemaItem
{ unSchemaItem :: SchemaItemRep { unSchemaItem :: SchemaItemRep
} }
data SchemaItemRep where data SchemaItemRep where
SchemaTableItem :: SchemaTableItem ::
{ schemaItemTableName :: String { schemaItemTableName :: String
, schemaItemMarshaller :: SqlMarshaller w r , schemaItemMarshaller :: SqlMarshaller w r
, schemaItemPkName :: String , schemaItemPkName :: String
, schemaItemDropColumns :: [String] , schemaItemDropColumns :: [String]
} -> SchemaItemRep } ->
SchemaItemRep
schemaTable :: schemaTable ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
[String] -> [String] ->
SchemaItem SchemaItem
schemaTable tableDef dropCols = schemaTable tableDef dropCols =
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
in SchemaItem in SchemaItem
SchemaTableItem SchemaTableItem
{ schemaItemTableName = tableName tableDef { schemaItemTableName = tableName tableDef
, schemaItemMarshaller = tableMarshaller tableDef , schemaItemMarshaller = tableMarshaller tableDef
, schemaItemPkName = fieldColumnName pkFieldDef , schemaItemPkName = fieldColumnName pkFieldDef
, schemaItemDropColumns = dropCols , schemaItemDropColumns = dropCols
} }
dropColumns :: [String] -> TableDefinition key w r -> [String] dropColumns :: [String] -> TableDefinition key w r -> [String]
dropColumns = const dropColumns = const
data MigrationStep data MigrationStep
= CreateTable String [(String, String, Bool)] String = CreateTable String [(String, String, Bool)] String
| AddColumn String String String | AddColumn String String String
| DropColumn String String | DropColumn String String
deriving (Show, Eq) deriving (Show, Eq)
data ExistingColumn = ExistingColumn data ExistingColumn = ExistingColumn
{ existingName :: String { existingName :: String
, existingType :: String , existingType :: String
, existingNotNull :: Bool , existingNotNull :: Bool
, existingPk :: Bool , existingPk :: Bool
} }
deriving (Show, Eq) deriving (Show, Eq)
generateMigrationPlan :: [SchemaItem] -> OrvilleM [MigrationStep] generateMigrationPlan :: [SchemaItem] -> OrvilleM [MigrationStep]
generateMigrationPlan items = concat <$> mapM planItem items generateMigrationPlan items = concat <$> mapM planItem items
planItem :: SchemaItem -> OrvilleM [MigrationStep] planItem :: SchemaItem -> OrvilleM [MigrationStep]
planItem (SchemaItem (SchemaTableItem tableName' marshaller pkName dropColsList)) = do planItem (SchemaItem (SchemaTableItem tableName' marshaller pkName dropColsList)) = do
existingCols <- getExistingColumns tableName' existingCols <- getExistingColumns tableName'
let expectedCols = marshallerExpectedColumns marshaller pkName let expectedCols = marshallerExpectedColumns marshaller pkName
pure $ planTableChanges tableName' expectedCols existingCols pkName dropColsList pure $ planTableChanges tableName' expectedCols existingCols pkName dropColsList
getExistingColumns :: String -> OrvilleM [ExistingColumn] getExistingColumns :: String -> OrvilleM [ExistingColumn]
getExistingColumns tableName' = do getExistingColumns tableName' = do
db <- ask db <- ask
liftIO $ do liftIO $ do
stmt <- stmt <-
SQLite3.prepare db ("PRAGMA table_info(" <> T.pack tableName' <> ")") SQLite3.prepare db ("PRAGMA table_info(" <> T.pack tableName' <> ")")
let loop acc = do let loop acc = do
stepResult <- SQLite3.step stmt stepResult <- SQLite3.step stmt
case stepResult of case stepResult of
SQLite3.Row -> do SQLite3.Row -> do
name <- SQLite3.columnText stmt 1 name <- SQLite3.columnText stmt 1
colType <- SQLite3.columnText stmt 2 colType <- SQLite3.columnText stmt 2
notNullVal <- SQLite3.column stmt 3 notNullVal <- SQLite3.column stmt 3
isPkVal <- SQLite3.column stmt 5 isPkVal <- SQLite3.column stmt 5
let notNullFlag = let notNullFlag =
case notNullVal of case notNullVal of
SQLite3.SQLInteger n -> n /= 0 SQLite3.SQLInteger n -> n /= 0
_ -> False _ -> False
let isPkFlag = let isPkFlag =
case isPkVal of case isPkVal of
SQLite3.SQLInteger n -> n /= 0 SQLite3.SQLInteger n -> n /= 0
_ -> False _ -> False
loop loop
( ExistingColumn ( ExistingColumn
(T.unpack name) (T.unpack name)
(T.unpack colType) (T.unpack colType)
notNullFlag notNullFlag
isPkFlag isPkFlag
: acc : acc
) )
SQLite3.Done -> do SQLite3.Done -> do
SQLite3.finalize stmt SQLite3.finalize stmt
pure (reverse acc) pure (reverse acc)
loop [] loop []
marshallerExpectedColumns :: marshallerExpectedColumns ::
SqlMarshaller w r -> SqlMarshaller w r ->
String -> String ->
[(String, String, Bool)] [(String, String, Bool)]
marshallerExpectedColumns marshaller pkName = marshallerExpectedColumns marshaller pkName =
[ ( fieldInfoName f [ ( fieldInfoName f
, fieldInfoType f , fieldInfoType f
, fieldInfoName f == pkName || not (fieldInfoIsNullable f) , fieldInfoName f == pkName || not (fieldInfoIsNullable f)
) )
| f <- marshallerFieldInfo marshaller | f <- marshallerFieldInfo marshaller
] ]
planTableChanges :: planTableChanges ::
String -> String ->
[(String, String, Bool)] -> [(String, String, Bool)] ->
[ExistingColumn] -> [ExistingColumn] ->
String -> String ->
[String] -> [String] ->
[MigrationStep] [MigrationStep]
planTableChanges tableName' expected existing pkName dropColsList planTableChanges tableName' expected existing pkName dropColsList
| null existing = [CreateTable tableName' expected pkName] | null existing = [CreateTable tableName' expected pkName]
| otherwise = addColSteps ++ dropColSteps | otherwise = addColSteps ++ dropColSteps
where where
existingNames = map existingName existing existingNames = map existingName existing
addColSteps = addColSteps =
[ AddColumn tableName' name colType [ AddColumn tableName' name colType
| (name, colType, _) <- expected | (name, colType, _) <- expected
, name `notElem` existingNames , name `notElem` existingNames
] ]
dropColSteps = dropColSteps =
[ DropColumn tableName' name [ DropColumn tableName' name
| name <- dropColsList | name <- dropColsList
, name `elem` existingNames , name `elem` existingNames
] ]
autoMigrateSchema :: MigrationOptions -> [SchemaItem] -> OrvilleM () autoMigrateSchema :: MigrationOptions -> [SchemaItem] -> OrvilleM ()
autoMigrateSchema opts items = do autoMigrateSchema opts items = do
plan <- generateMigrationPlan items plan <- generateMigrationPlan items
when (runSchemaChanges opts) $ when (runSchemaChanges opts) $
executeMigrationPlan plan executeMigrationPlan plan
executeMigrationPlan :: [MigrationStep] -> OrvilleM () executeMigrationPlan :: [MigrationStep] -> OrvilleM ()
executeMigrationPlan = mapM_ executeStep executeMigrationPlan = mapM_ executeStep
where where
executeStep step = do executeStep step = do
db <- ask db <- ask
case step of case step of
CreateTable name cols pkName -> CreateTable name cols pkName ->
liftIO $ liftIO $
SQLite3.exec db $ SQLite3.exec db $
mkCreateTable name cols pkName mkCreateTable name cols pkName
AddColumn name colName colType -> AddColumn name colName colType ->
liftIO $ liftIO $
SQLite3.exec db $ SQLite3.exec db $
T.pack $ T.pack $
"ALTER TABLE " "ALTER TABLE "
<> name <> name
<> " ADD COLUMN " <> " ADD COLUMN "
<> colName <> colName
<> " " <> " "
<> colType <> colType
DropColumn name colName -> DropColumn name colName ->
liftIO $ liftIO $
SQLite3.exec db $ SQLite3.exec db $
T.pack $ T.pack $
"ALTER TABLE " "ALTER TABLE "
<> name <> name
<> " DROP COLUMN " <> " DROP COLUMN "
<> colName <> colName
mkCreateTable :: String -> [(String, String, Bool)] -> String -> T.Text mkCreateTable :: String -> [(String, String, Bool)] -> String -> T.Text
mkCreateTable name cols pkName = mkCreateTable name cols pkName =
T.pack $ T.pack $
"CREATE TABLE IF NOT EXISTS " "CREATE TABLE IF NOT EXISTS "
<> name <> name
<> " (\n " <> " (\n "
<> intercalate ",\n " (map mkColumnDef cols) <> intercalate ",\n " (map mkColumnDef cols)
<> "\n)" <> "\n)"
where where
mkColumnDef (colName, colType, notNullFlag) mkColumnDef (colName, colType, notNullFlag)
| colName == pkName = | colName == pkName =
colName <> " " <> colType <> " PRIMARY KEY" colName <> " " <> colType <> " PRIMARY KEY"
| notNullFlag = | notNullFlag =
colName <> " " <> colType <> " NOT NULL" colName <> " " <> colType <> " NOT NULL"
| otherwise = | otherwise =
colName <> " " <> colType colName <> " " <> colType
src/Orville/SQLite/Execution.hs
+138 -138
View File
@@ -2,13 +2,13 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Orville.SQLite.Execution module Orville.SQLite.Execution (
( insertEntity insertEntity,
, findEntity findEntity,
, findAll findAll,
, updateEntity updateEntity,
, deleteEntity deleteEntity,
) where ) where
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
@@ -18,152 +18,152 @@ import qualified Database.SQLite3 as SQLite3
import Database.SQLite3.Direct (columnCount) import Database.SQLite3.Direct (columnCount)
import Orville.SQLite.FieldDefinition (fieldColumnName, fieldToSqlValue) import Orville.SQLite.FieldDefinition (fieldColumnName, fieldToSqlValue)
import Orville.SQLite.Monad (OrvilleM) import Orville.SQLite.Monad (OrvilleM)
import Orville.SQLite.SqlMarshaller import Orville.SQLite.SqlMarshaller (
( marshallerDerivedColumns marshallerDecodeRow,
, marshallerEncodeWrite marshallerDerivedColumns,
, marshallerDecodeRow marshallerEncodeWrite,
) )
import Orville.SQLite.TableDefinition (TableDefinition (..), PrimaryKey (..)) import Orville.SQLite.TableDefinition (PrimaryKey (..), TableDefinition (..))
insertEntity :: insertEntity ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
writeEntity -> writeEntity ->
OrvilleM () OrvilleM ()
insertEntity tableDef entity = do insertEntity tableDef entity = do
db <- ask db <- ask
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
let colNames = map fst pairs let colNames = map fst pairs
let placeholders = map (const "?") colNames let placeholders = map (const "?") colNames
let sql = let sql =
"INSERT INTO " "INSERT INTO "
<> T.pack (tableName tableDef) <> T.pack (tableName tableDef)
<> " (" <> " ("
<> T.pack (intercalate ", " colNames) <> T.pack (intercalate ", " colNames)
<> ") VALUES (" <> ") VALUES ("
<> T.pack (intercalate ", " placeholders) <> T.pack (intercalate ", " placeholders)
<> ")" <> ")"
liftIO $ do liftIO $ do
stmt <- SQLite3.prepare db sql stmt <- SQLite3.prepare db sql
SQLite3.bind stmt (map snd pairs) SQLite3.bind stmt (map snd pairs)
_ <- SQLite3.step stmt _ <- SQLite3.step stmt
SQLite3.finalize stmt SQLite3.finalize stmt
findEntity :: findEntity ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
key -> key ->
OrvilleM (Maybe readEntity) OrvilleM (Maybe readEntity)
findEntity tableDef key = do findEntity tableDef key = do
db <- ask db <- ask
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
let cols = marshallerDerivedColumns (tableMarshaller tableDef) let cols = marshallerDerivedColumns (tableMarshaller tableDef)
let sql = let sql =
"SELECT " "SELECT "
<> T.pack (intercalate ", " cols) <> T.pack (intercalate ", " cols)
<> " FROM " <> " FROM "
<> T.pack (tableName tableDef) <> T.pack (tableName tableDef)
<> " WHERE " <> " WHERE "
<> T.pack (fieldColumnName pkFieldDef) <> T.pack (fieldColumnName pkFieldDef)
<> " = ?" <> " = ?"
liftIO $ do liftIO $ do
stmt <- SQLite3.prepare db sql stmt <- SQLite3.prepare db sql
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef] SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
stepResult <- SQLite3.step stmt stepResult <- SQLite3.step stmt
case stepResult of case stepResult of
SQLite3.Done -> do SQLite3.Done -> do
SQLite3.finalize stmt SQLite3.finalize stmt
pure Nothing pure Nothing
SQLite3.Row -> do SQLite3.Row -> do
rowData <- getRowData stmt cols rowData <- getRowData stmt cols
SQLite3.finalize stmt SQLite3.finalize stmt
case marshallerDecodeRow (tableMarshaller tableDef) rowData of case marshallerDecodeRow (tableMarshaller tableDef) rowData of
Left err -> error $ "Decode error in findEntity: " <> err Left err -> error $ "Decode error in findEntity: " <> err
Right entity -> pure (Just entity) Right entity -> pure (Just entity)
findAll :: findAll ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
OrvilleM [readEntity] OrvilleM [readEntity]
findAll tableDef = do findAll tableDef = do
db <- ask db <- ask
let cols = marshallerDerivedColumns (tableMarshaller tableDef) let cols = marshallerDerivedColumns (tableMarshaller tableDef)
let sql = let sql =
"SELECT " "SELECT "
<> T.pack (intercalate ", " cols) <> T.pack (intercalate ", " cols)
<> " FROM " <> " FROM "
<> T.pack (tableName tableDef) <> T.pack (tableName tableDef)
liftIO $ do liftIO $ do
stmt <- SQLite3.prepare db sql stmt <- SQLite3.prepare db sql
let loop acc = do let loop acc = do
stepResult <- SQLite3.step stmt stepResult <- SQLite3.step stmt
case stepResult of case stepResult of
SQLite3.Done -> do SQLite3.Done -> do
SQLite3.finalize stmt SQLite3.finalize stmt
pure (reverse acc) pure (reverse acc)
SQLite3.Row -> do SQLite3.Row -> do
rowData <- getRowData stmt cols rowData <- getRowData stmt cols
case marshallerDecodeRow (tableMarshaller tableDef) rowData of case marshallerDecodeRow (tableMarshaller tableDef) rowData of
Left err -> error $ "Decode error in findAll: " <> err Left err -> error $ "Decode error in findAll: " <> err
Right entity -> loop (entity : acc) Right entity -> loop (entity : acc)
loop [] loop []
updateEntity :: updateEntity ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
writeEntity -> writeEntity ->
OrvilleM () OrvilleM ()
updateEntity tableDef entity = do updateEntity tableDef entity = do
db <- ask db <- ask
let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity let pairs = marshallerEncodeWrite (tableMarshaller tableDef) entity
let PrimaryKey pkAccessor pkFieldDef = tablePrimaryKey tableDef let PrimaryKey pkAccessor pkFieldDef = tablePrimaryKey tableDef
let pkValue = pkAccessor entity let pkValue = pkAccessor entity
let setClauses = map (\(col, _) -> col <> " = ?") pairs let setClauses = map (\(col, _) -> col <> " = ?") pairs
let sql = let sql =
"UPDATE " "UPDATE "
<> T.pack (tableName tableDef) <> T.pack (tableName tableDef)
<> " SET " <> " SET "
<> T.pack (intercalate ", " setClauses) <> T.pack (intercalate ", " setClauses)
<> " WHERE " <> " WHERE "
<> T.pack (fieldColumnName pkFieldDef) <> T.pack (fieldColumnName pkFieldDef)
<> " = ?" <> " = ?"
liftIO $ do liftIO $ do
stmt <- SQLite3.prepare db sql stmt <- SQLite3.prepare db sql
SQLite3.bind stmt (map snd pairs ++ [fieldToSqlValue pkValue pkFieldDef]) SQLite3.bind stmt (map snd pairs ++ [fieldToSqlValue pkValue pkFieldDef])
_ <- SQLite3.step stmt _ <- SQLite3.step stmt
SQLite3.finalize stmt SQLite3.finalize stmt
deleteEntity :: deleteEntity ::
TableDefinition key writeEntity readEntity -> TableDefinition key writeEntity readEntity ->
key -> key ->
OrvilleM () OrvilleM ()
deleteEntity tableDef key = do deleteEntity tableDef key = do
db <- ask db <- ask
let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef let PrimaryKey _ pkFieldDef = tablePrimaryKey tableDef
let sql = let sql =
"DELETE FROM " "DELETE FROM "
<> T.pack (tableName tableDef) <> T.pack (tableName tableDef)
<> " WHERE " <> " WHERE "
<> T.pack (fieldColumnName pkFieldDef) <> T.pack (fieldColumnName pkFieldDef)
<> " = ?" <> " = ?"
liftIO $ do liftIO $ do
stmt <- SQLite3.prepare db sql stmt <- SQLite3.prepare db sql
SQLite3.bind stmt [fieldToSqlValue key pkFieldDef] SQLite3.bind stmt [fieldToSqlValue key pkFieldDef]
_ <- SQLite3.step stmt _ <- SQLite3.step stmt
SQLite3.finalize stmt SQLite3.finalize stmt
getRowData :: getRowData ::
SQLite3.Statement -> SQLite3.Statement ->
[String] -> [String] ->
IO [(String, SQLite3.SQLData)] IO [(String, SQLite3.SQLData)]
getRowData stmt cols = do getRowData stmt cols = do
colCount <- columnCount stmt colCount <- columnCount stmt
let count :: Int = fromIntegral colCount let count :: Int = fromIntegral colCount
indexes = take count [0 :: SQLite3.ColumnIndex ..] indexes = take count [0 :: SQLite3.ColumnIndex ..]
mapM mapM
( \i -> do ( \i -> do
let idx :: Int = fromIntegral i let idx :: Int = fromIntegral i
colName = colName =
if idx < length cols if idx < length cols
then cols !! idx then cols !! idx
else "" else ""
sqlVal <- SQLite3.column stmt i sqlVal <- SQLite3.column stmt i
pure (colName, sqlVal) pure (colName, sqlVal)
) )
indexes indexes
src/Orville/SQLite/FieldDefinition.hs
+54 -52
View File
@@ -3,75 +3,77 @@
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Orville.SQLite.FieldDefinition module Orville.SQLite.FieldDefinition (
( Nullability (..) Nullability (..),
, FieldDefinition (..) FieldDefinition (..),
, integerField integerField,
, textField textField,
, realField realField,
, blobField blobField,
, nullableField nullableField,
, convertField convertField,
, fieldToSqlValue fieldToSqlValue,
, fieldFromSqlValue fieldFromSqlValue,
, fieldColumnName fieldColumnName,
, fieldSqlTypeName fieldSqlTypeName,
, fieldIsNullable fieldIsNullable,
) where ) where
import Data.Kind (Type)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Int (Int64) import Data.Int (Int64)
import Data.Kind (Type)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.SQLite3 as SQLite3 import qualified Database.SQLite3 as SQLite3
import Orville.SQLite.SqlType import Orville.SQLite.SqlType (
( SqlType SqlType,
, convertSqlType blobType,
, integerType convertSqlType,
, realType integerType,
, blobType realType,
, sqlTypeFromSql sqlTypeFromSql,
, sqlTypeName sqlTypeName,
, sqlTypeToSql sqlTypeToSql,
, textType textType,
) )
data Nullability = NotNull | Nullable data Nullability = NotNull | Nullable
data FieldDefinition (nullability :: Nullability) :: Type -> Type where data FieldDefinition (nullability :: Nullability) :: Type -> Type where
NotNullField :: NotNullField ::
{ notNullFieldName :: String { notNullFieldName :: String
, notNullFieldSqlType :: SqlType a , notNullFieldSqlType :: SqlType a
} -> FieldDefinition 'NotNull a } ->
NullableField :: FieldDefinition 'NotNull a
{ nullableFieldName :: String NullableField ::
, nullableFieldSqlType :: SqlType a { nullableFieldName :: String
} -> FieldDefinition 'Nullable a , nullableFieldSqlType :: SqlType a
} ->
FieldDefinition 'Nullable a
fieldColumnName :: FieldDefinition null a -> String fieldColumnName :: FieldDefinition null a -> String
fieldColumnName = \case fieldColumnName = \case
NotNullField n _ -> n NotNullField n _ -> n
NullableField n _ -> n NullableField n _ -> n
fieldSqlTypeName :: FieldDefinition null a -> String fieldSqlTypeName :: FieldDefinition null a -> String
fieldSqlTypeName = \case fieldSqlTypeName = \case
NotNullField _ st -> sqlTypeName st NotNullField _ st -> sqlTypeName st
NullableField _ st -> sqlTypeName st NullableField _ st -> sqlTypeName st
fieldIsNullable :: FieldDefinition null a -> Bool fieldIsNullable :: FieldDefinition null a -> Bool
fieldIsNullable = \case fieldIsNullable = \case
NotNullField _ _ -> False NotNullField _ _ -> False
NullableField _ _ -> True NullableField _ _ -> True
fieldToSqlValue :: a -> FieldDefinition null a -> SQLite3.SQLData fieldToSqlValue :: a -> FieldDefinition null a -> SQLite3.SQLData
fieldToSqlValue val = \case fieldToSqlValue val = \case
NotNullField _ st -> sqlTypeToSql st val NotNullField _ st -> sqlTypeToSql st val
NullableField _ st -> sqlTypeToSql st val NullableField _ st -> sqlTypeToSql st val
fieldFromSqlValue :: SQLite3.SQLData -> FieldDefinition null a -> Either String a fieldFromSqlValue :: SQLite3.SQLData -> FieldDefinition null a -> Either String a
fieldFromSqlValue sqlVal = \case fieldFromSqlValue sqlVal = \case
NotNullField _ st -> sqlTypeFromSql st sqlVal NotNullField _ st -> sqlTypeFromSql st sqlVal
NullableField _ st -> sqlTypeFromSql st sqlVal NullableField _ st -> sqlTypeFromSql st sqlVal
integerField :: String -> FieldDefinition 'NotNull Int64 integerField :: String -> FieldDefinition 'NotNull Int64
integerField name = NotNullField name integerType integerField name = NotNullField name integerType
@@ -87,13 +89,13 @@ blobField name = NotNullField name blobType
nullableField :: FieldDefinition 'NotNull a -> FieldDefinition 'Nullable a nullableField :: FieldDefinition 'NotNull a -> FieldDefinition 'Nullable a
nullableField = \case nullableField = \case
NotNullField n st -> NullableField n st NotNullField n st -> NullableField n st
convertField :: convertField ::
(a -> b) -> (a -> b) ->
(b -> a) -> (b -> a) ->
FieldDefinition null a -> FieldDefinition null a ->
FieldDefinition null b FieldDefinition null b
convertField to from = \case convertField to from = \case
NotNullField n st -> NotNullField n (convertSqlType to from st) NotNullField n st -> NotNullField n (convertSqlType to from st)
NullableField n st -> NullableField n (convertSqlType to from st) NullableField n st -> NullableField n (convertSqlType to from st)
src/Orville/SQLite/Monad.hs
+17 -17
View File
@@ -1,24 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Orville.SQLite.Monad module Orville.SQLite.Monad (
( OrvilleM OrvilleM,
, withConnection withConnection,
, openConnection openConnection,
, closeConnection closeConnection,
, runOrvilleM runOrvilleM,
, withTransaction withTransaction,
) where ) where
import Control.Monad.IO.Class (MonadIO (liftIO)) 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 Data.Text as T
import qualified Database.SQLite3 as SQLite3 import qualified Database.SQLite3 as SQLite3
newtype OrvilleM a = OrvilleM newtype OrvilleM a = OrvilleM
{ unOrvilleM :: ReaderT SQLite3.Database IO a { unOrvilleM :: ReaderT SQLite3.Database IO a
} }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database) deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database)
runOrvilleM :: SQLite3.Database -> OrvilleM a -> IO a runOrvilleM :: SQLite3.Database -> OrvilleM a -> IO a
runOrvilleM db action = runReaderT (unOrvilleM action) db runOrvilleM db action = runReaderT (unOrvilleM action) db
@@ -34,8 +34,8 @@ closeConnection = SQLite3.close
withTransaction :: OrvilleM a -> OrvilleM a withTransaction :: OrvilleM a -> OrvilleM a
withTransaction action = do withTransaction action = do
db <- ask db <- ask
liftIO $ SQLite3.exec db "BEGIN TRANSACTION" liftIO $ SQLite3.exec db "BEGIN TRANSACTION"
result <- action result <- action
liftIO $ SQLite3.exec db "COMMIT" liftIO $ SQLite3.exec db "COMMIT"
pure result pure result
src/Orville/SQLite/RawSql.hs
+13 -13
View File
@@ -1,22 +1,22 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Orville.SQLite.RawSql module Orville.SQLite.RawSql (
( RawSql (..) RawSql (..),
, fromString fromString,
, toRawSql toRawSql,
, intercalate intercalate,
, fromText fromText,
, space space,
, comma comma,
, leftParen leftParen,
, rightParen rightParen,
, equals equals,
) where ) where
import qualified Data.Text as T import qualified Data.Text as T
newtype RawSql = RawSql {unRawSql :: String} newtype RawSql = RawSql {unRawSql :: String}
deriving (Show, Eq, Semigroup, Monoid) deriving (Show, Eq, Semigroup, Monoid)
fromString :: String -> RawSql fromString :: String -> RawSql
fromString = RawSql fromString = RawSql
src/Orville/SQLite/SqlMarshaller.hs
+98 -98
View File
@@ -3,111 +3,111 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Orville.SQLite.SqlMarshaller module Orville.SQLite.SqlMarshaller (
( SqlMarshaller SqlMarshaller,
, FieldInfo (..) FieldInfo (..),
, marshallField marshallField,
, marshallReadOnlyField marshallReadOnlyField,
, marshallMaybe marshallMaybe,
, marshallerFieldInfo marshallerFieldInfo,
, marshallerDerivedColumns marshallerDerivedColumns,
, marshallerEncodeWrite marshallerEncodeWrite,
, marshallerDecodeRow marshallerDecodeRow,
) where ) where
import qualified Database.SQLite3 as SQLite3 import qualified Database.SQLite3 as SQLite3
import Orville.SQLite.FieldDefinition import Orville.SQLite.FieldDefinition (
( FieldDefinition (..) FieldDefinition (..),
, Nullability (..) Nullability (..),
, fieldColumnName fieldColumnName,
, fieldToSqlValue fieldFromSqlValue,
, fieldFromSqlValue fieldIsNullable,
, fieldIsNullable fieldSqlTypeName,
, fieldSqlTypeName fieldToSqlValue,
) )
data FieldInfo = FieldInfo data FieldInfo = FieldInfo
{ fieldInfoName :: String { fieldInfoName :: String
, fieldInfoType :: String , fieldInfoType :: String
, fieldInfoIsNullable :: Bool , fieldInfoIsNullable :: Bool
} }
data SqlMarshaller writeEntity readEntity where data SqlMarshaller writeEntity readEntity where
MarshallPure :: readEntity -> SqlMarshaller writeEntity readEntity MarshallPure :: readEntity -> SqlMarshaller writeEntity readEntity
MarshallApply :: MarshallApply ::
SqlMarshaller writeEntity (a -> b) -> SqlMarshaller writeEntity (a -> b) ->
SqlMarshaller writeEntity a -> SqlMarshaller writeEntity a ->
SqlMarshaller writeEntity b SqlMarshaller writeEntity b
MarshallNest :: MarshallNest ::
(writeEntity -> a) -> (writeEntity -> a) ->
SqlMarshaller a readEntity -> SqlMarshaller a readEntity ->
SqlMarshaller writeEntity readEntity SqlMarshaller writeEntity readEntity
MarshallField :: MarshallField ::
FieldDefinition nullability a -> FieldDefinition nullability a ->
SqlMarshaller a a SqlMarshaller a a
MarshallMaybe :: MarshallMaybe ::
FieldDefinition 'Nullable a -> FieldDefinition 'Nullable a ->
SqlMarshaller (Maybe a) (Maybe a) SqlMarshaller (Maybe a) (Maybe a)
MarshallReadOnly :: MarshallReadOnly ::
SqlMarshaller a readEntity -> SqlMarshaller a readEntity ->
SqlMarshaller b readEntity SqlMarshaller b readEntity
instance Functor (SqlMarshaller w) where instance Functor (SqlMarshaller w) where
fmap f m = MarshallPure f `MarshallApply` m fmap f m = MarshallPure f `MarshallApply` m
instance Applicative (SqlMarshaller w) where instance Applicative (SqlMarshaller w) where
pure = MarshallPure pure = MarshallPure
(<*>) = MarshallApply (<*>) = MarshallApply
marshallField :: marshallField ::
(writeEntity -> a) -> (writeEntity -> a) ->
FieldDefinition 'NotNull a -> FieldDefinition 'NotNull a ->
SqlMarshaller writeEntity a SqlMarshaller writeEntity a
marshallField accessor fieldDef = marshallField accessor fieldDef =
MarshallNest accessor (MarshallField fieldDef) MarshallNest accessor (MarshallField fieldDef)
marshallReadOnlyField :: marshallReadOnlyField ::
FieldDefinition nullability a -> FieldDefinition nullability a ->
SqlMarshaller writeEntity a SqlMarshaller writeEntity a
marshallReadOnlyField fieldDef = marshallReadOnlyField fieldDef =
MarshallReadOnly (MarshallField fieldDef) MarshallReadOnly (MarshallField fieldDef)
marshallMaybe :: marshallMaybe ::
(writeEntity -> Maybe a) -> (writeEntity -> Maybe a) ->
FieldDefinition 'Nullable a -> FieldDefinition 'Nullable a ->
SqlMarshaller writeEntity (Maybe a) SqlMarshaller writeEntity (Maybe a)
marshallMaybe accessor fieldDef = marshallMaybe accessor fieldDef =
MarshallNest accessor (MarshallMaybe fieldDef) MarshallNest accessor (MarshallMaybe fieldDef)
marshallerFieldInfo :: marshallerFieldInfo ::
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
[FieldInfo] [FieldInfo]
marshallerFieldInfo marshaller = marshallerFieldInfo marshaller =
reverse $ go marshaller [] reverse $ go marshaller []
where where
go :: SqlMarshaller w r -> [FieldInfo] -> [FieldInfo] go :: SqlMarshaller w r -> [FieldInfo] -> [FieldInfo]
go (MarshallPure _) acc = acc go (MarshallPure _) acc = acc
go (MarshallApply m1 m2) acc = go m1 (go m2 acc) go (MarshallApply m1 m2) acc = go m1 (go m2 acc)
go (MarshallNest _ m) acc = go m acc go (MarshallNest _ m) acc = go m acc
go (MarshallField fieldDef) acc = go (MarshallField fieldDef) acc =
FieldInfo FieldInfo
(fieldColumnName fieldDef) (fieldColumnName fieldDef)
(fieldSqlTypeName fieldDef) (fieldSqlTypeName fieldDef)
(fieldIsNullable fieldDef) (fieldIsNullable fieldDef)
: acc : acc
go (MarshallMaybe fieldDef) acc = go (MarshallMaybe fieldDef) acc =
FieldInfo FieldInfo
(fieldColumnName fieldDef) (fieldColumnName fieldDef)
(fieldSqlTypeName fieldDef) (fieldSqlTypeName fieldDef)
(True :: Bool) (True :: Bool)
: acc : acc
go (MarshallReadOnly m) acc = go m acc go (MarshallReadOnly m) acc = go m acc
marshallerDerivedColumns :: marshallerDerivedColumns ::
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
[String] [String]
marshallerDerivedColumns marshaller = marshallerDerivedColumns marshaller =
reverse $ go marshaller [] reverse $ go marshaller []
where where
go :: SqlMarshaller w r -> [String] -> [String] go :: SqlMarshaller w r -> [String] -> [String]
go (MarshallPure _) acc = acc go (MarshallPure _) acc = acc
@@ -118,49 +118,49 @@ marshallerDerivedColumns marshaller =
go (MarshallReadOnly m) acc = go m acc go (MarshallReadOnly m) acc = go m acc
marshallerEncodeWrite :: marshallerEncodeWrite ::
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
writeEntity -> writeEntity ->
[(String, SQLite3.SQLData)] [(String, SQLite3.SQLData)]
marshallerEncodeWrite marshaller entity = marshallerEncodeWrite marshaller entity =
reverse $ go marshaller entity [] reverse $ go marshaller entity []
where where
go :: SqlMarshaller w r -> w -> [(String, SQLite3.SQLData)] -> [(String, SQLite3.SQLData)] go :: SqlMarshaller w r -> w -> [(String, SQLite3.SQLData)] -> [(String, SQLite3.SQLData)]
go (MarshallPure _) _ acc = acc go (MarshallPure _) _ acc = acc
go (MarshallApply m1 m2) w 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 (MarshallNest accessor m) w acc =
go m (accessor w) acc go m (accessor w) acc
go (MarshallField fieldDef) a acc = go (MarshallField fieldDef) a acc =
(fieldColumnName fieldDef, fieldToSqlValue a fieldDef) : acc (fieldColumnName fieldDef, fieldToSqlValue a fieldDef) : acc
go (MarshallMaybe fieldDef) a acc = go (MarshallMaybe fieldDef) a acc =
case a of case a of
Nothing -> (fieldColumnName fieldDef, SQLite3.SQLNull) : acc Nothing -> (fieldColumnName fieldDef, SQLite3.SQLNull) : acc
Just val -> (fieldColumnName fieldDef, fieldToSqlValue val fieldDef) : acc Just val -> (fieldColumnName fieldDef, fieldToSqlValue val fieldDef) : acc
go (MarshallReadOnly _) _ acc = acc go (MarshallReadOnly _) _ acc = acc
marshallerDecodeRow :: marshallerDecodeRow ::
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
[(String, SQLite3.SQLData)] -> [(String, SQLite3.SQLData)] ->
Either String readEntity Either String readEntity
marshallerDecodeRow marshaller rowData = marshallerDecodeRow marshaller rowData =
go marshaller rowData go marshaller rowData
where where
go :: SqlMarshaller w r -> [(String, SQLite3.SQLData)] -> Either String r go :: SqlMarshaller w r -> [(String, SQLite3.SQLData)] -> Either String r
go (MarshallPure r) _ = Right r go (MarshallPure r) _ = Right r
go (MarshallApply m1 m2) rd = do go (MarshallApply m1 m2) rd = do
f <- go m1 rd f <- go m1 rd
a <- go m2 rd a <- go m2 rd
Right (f a) Right (f a)
go (MarshallNest _ m) rd = go m rd go (MarshallNest _ m) rd = go m rd
go (MarshallField fieldDef) rd = go (MarshallField fieldDef) rd =
case lookup (fieldColumnName fieldDef) rd of case lookup (fieldColumnName fieldDef) rd of
Just sqlVal -> fieldFromSqlValue sqlVal fieldDef Just sqlVal -> fieldFromSqlValue sqlVal fieldDef
Nothing -> Nothing ->
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row" Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
go (MarshallMaybe fieldDef) rd = go (MarshallMaybe fieldDef) rd =
case lookup (fieldColumnName fieldDef) rd of case lookup (fieldColumnName fieldDef) rd of
Just SQLite3.SQLNull -> Right Nothing Just SQLite3.SQLNull -> Right Nothing
Just sqlVal -> Just <$> fieldFromSqlValue sqlVal fieldDef Just sqlVal -> Just <$> fieldFromSqlValue sqlVal fieldDef
Nothing -> Nothing ->
Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row" Left $ "Column '" <> fieldColumnName fieldDef <> "' not found in result row"
go (MarshallReadOnly m) rd = go m rd go (MarshallReadOnly m) rd = go m rd
src/Orville/SQLite/SqlType.hs
+57 -57
View File
@@ -1,13 +1,13 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Orville.SQLite.SqlType module Orville.SQLite.SqlType (
( SqlType (..) SqlType (..),
, integerType integerType,
, textType textType,
, realType realType,
, blobType blobType,
, convertSqlType convertSqlType,
) where ) where
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Int (Int64) import Data.Int (Int64)
@@ -15,70 +15,70 @@ import qualified Data.Text as T
import qualified Database.SQLite3 as SQLite3 import qualified Database.SQLite3 as SQLite3
data SqlType a = SqlType data SqlType a = SqlType
{ sqlTypeName :: String { sqlTypeName :: String
, sqlTypeToSql :: a -> SQLite3.SQLData , sqlTypeToSql :: a -> SQLite3.SQLData
, sqlTypeFromSql :: SQLite3.SQLData -> Either String a , sqlTypeFromSql :: SQLite3.SQLData -> Either String a
} }
integerType :: SqlType Int64 integerType :: SqlType Int64
integerType = integerType =
SqlType SqlType
{ sqlTypeName = "INTEGER" { sqlTypeName = "INTEGER"
, sqlTypeToSql = SQLite3.SQLInteger , sqlTypeToSql = SQLite3.SQLInteger
, sqlTypeFromSql = \case , sqlTypeFromSql = \case
SQLite3.SQLInteger i -> Right i SQLite3.SQLInteger i -> Right i
SQLite3.SQLNull -> Right 0 SQLite3.SQLNull -> Right 0
other -> Left $ "Expected INTEGER, got " <> show (sqlDataKind other) other -> Left $ "Expected INTEGER, got " <> show (sqlDataKind other)
} }
textType :: SqlType T.Text textType :: SqlType T.Text
textType = textType =
SqlType SqlType
{ sqlTypeName = "TEXT" { sqlTypeName = "TEXT"
, sqlTypeToSql = SQLite3.SQLText , sqlTypeToSql = SQLite3.SQLText
, sqlTypeFromSql = \case , sqlTypeFromSql = \case
SQLite3.SQLText t -> Right t SQLite3.SQLText t -> Right t
SQLite3.SQLNull -> Right T.empty SQLite3.SQLNull -> Right T.empty
SQLite3.SQLInteger i -> Right (T.pack (show i)) SQLite3.SQLInteger i -> Right (T.pack (show i))
SQLite3.SQLFloat d -> Right (T.pack (show d)) SQLite3.SQLFloat d -> Right (T.pack (show d))
other -> Left $ "Expected TEXT, got " <> show (sqlDataKind other) other -> Left $ "Expected TEXT, got " <> show (sqlDataKind other)
} }
realType :: SqlType Double realType :: SqlType Double
realType = realType =
SqlType SqlType
{ sqlTypeName = "REAL" { sqlTypeName = "REAL"
, sqlTypeToSql = SQLite3.SQLFloat , sqlTypeToSql = SQLite3.SQLFloat
, sqlTypeFromSql = \case , sqlTypeFromSql = \case
SQLite3.SQLFloat d -> Right d SQLite3.SQLFloat d -> Right d
SQLite3.SQLInteger i -> Right (fromIntegral i) SQLite3.SQLInteger i -> Right (fromIntegral i)
SQLite3.SQLNull -> Right 0.0 SQLite3.SQLNull -> Right 0.0
other -> Left $ "Expected REAL, got " <> show (sqlDataKind other) other -> Left $ "Expected REAL, got " <> show (sqlDataKind other)
} }
blobType :: SqlType BS.ByteString blobType :: SqlType BS.ByteString
blobType = blobType =
SqlType SqlType
{ sqlTypeName = "BLOB" { sqlTypeName = "BLOB"
, sqlTypeToSql = SQLite3.SQLBlob , sqlTypeToSql = SQLite3.SQLBlob
, sqlTypeFromSql = \case , sqlTypeFromSql = \case
SQLite3.SQLBlob b -> Right b SQLite3.SQLBlob b -> Right b
SQLite3.SQLNull -> Right BS.empty SQLite3.SQLNull -> Right BS.empty
other -> Left $ "Expected BLOB, got " <> show (sqlDataKind other) other -> Left $ "Expected BLOB, got " <> show (sqlDataKind other)
} }
convertSqlType :: (a -> b) -> (b -> a) -> SqlType a -> SqlType b convertSqlType :: (a -> b) -> (b -> a) -> SqlType a -> SqlType b
convertSqlType to from sqlType = convertSqlType to from sqlType =
SqlType SqlType
{ sqlTypeName = sqlTypeName sqlType { sqlTypeName = sqlTypeName sqlType
, sqlTypeToSql = sqlTypeToSql sqlType . from , sqlTypeToSql = sqlTypeToSql sqlType . from
, sqlTypeFromSql = fmap to . sqlTypeFromSql sqlType , sqlTypeFromSql = fmap to . sqlTypeFromSql sqlType
} }
sqlDataKind :: SQLite3.SQLData -> String sqlDataKind :: SQLite3.SQLData -> String
sqlDataKind = \case sqlDataKind = \case
SQLite3.SQLInteger _ -> "SQLInteger" SQLite3.SQLInteger _ -> "SQLInteger"
SQLite3.SQLFloat _ -> "SQLFloat" SQLite3.SQLFloat _ -> "SQLFloat"
SQLite3.SQLText _ -> "SQLText" SQLite3.SQLText _ -> "SQLText"
SQLite3.SQLBlob _ -> "SQLBlob" SQLite3.SQLBlob _ -> "SQLBlob"
SQLite3.SQLNull -> "SQLNull" SQLite3.SQLNull -> "SQLNull"
src/Orville/SQLite/TableDefinition.hs
+41 -41
View File
@@ -2,60 +2,60 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Orville.SQLite.TableDefinition module Orville.SQLite.TableDefinition (
( PrimaryKey (..) PrimaryKey (..),
, primaryKey primaryKey,
, TableDefinition (..) TableDefinition (..),
, mkTableDefinition mkTableDefinition,
, mkTableDefinitionWithoutKey mkTableDefinitionWithoutKey,
) where ) where
import Orville.SQLite.FieldDefinition import Orville.SQLite.FieldDefinition (
( FieldDefinition FieldDefinition,
, Nullability (..) Nullability (..),
, integerField convertField,
, convertField integerField,
) )
import Orville.SQLite.SqlMarshaller (SqlMarshaller) import Orville.SQLite.SqlMarshaller (SqlMarshaller)
data PrimaryKey writeEntity key where data PrimaryKey writeEntity key where
PrimaryKey :: PrimaryKey ::
(writeEntity -> key) ->
FieldDefinition 'NotNull key ->
PrimaryKey writeEntity key
primaryKey ::
(writeEntity -> key) -> (writeEntity -> key) ->
FieldDefinition 'NotNull key -> FieldDefinition 'NotNull key ->
PrimaryKey writeEntity key PrimaryKey writeEntity key
primaryKey ::
(writeEntity -> key) ->
FieldDefinition 'NotNull key ->
PrimaryKey writeEntity key
primaryKey = PrimaryKey primaryKey = PrimaryKey
data TableDefinition key writeEntity readEntity = TableDefinition data TableDefinition key writeEntity readEntity = TableDefinition
{ tableName :: String { tableName :: String
, tablePrimaryKey :: PrimaryKey writeEntity key , tablePrimaryKey :: PrimaryKey writeEntity key
, tableMarshaller :: SqlMarshaller writeEntity readEntity , tableMarshaller :: SqlMarshaller writeEntity readEntity
} }
mkTableDefinition :: mkTableDefinition ::
String -> String ->
PrimaryKey writeEntity key -> PrimaryKey writeEntity key ->
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
TableDefinition key writeEntity readEntity TableDefinition key writeEntity readEntity
mkTableDefinition = TableDefinition mkTableDefinition = TableDefinition
mkTableDefinitionWithoutKey :: mkTableDefinitionWithoutKey ::
String -> String ->
SqlMarshaller writeEntity readEntity -> SqlMarshaller writeEntity readEntity ->
TableDefinition () writeEntity readEntity TableDefinition () writeEntity readEntity
mkTableDefinitionWithoutKey name marshaller = mkTableDefinitionWithoutKey name marshaller =
let let
dummyField :: dummyField ::
FieldDefinition 'NotNull () FieldDefinition 'NotNull ()
dummyField = dummyField =
convertField (\_ -> ()) (\() -> 0) (integerField "__rowid__") convertField (\_ -> ()) (\() -> 0) (integerField "__rowid__")
in in
TableDefinition TableDefinition
{ tableName = name { tableName = name
, tablePrimaryKey = PrimaryKey (const ()) dummyField , tablePrimaryKey = PrimaryKey (const ()) dummyField
, tableMarshaller = marshaller , tableMarshaller = marshaller
} }
stack.yaml.lock
+19
View File
@@ -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
test/Main.hs
+56 -56
View File
@@ -6,16 +6,16 @@ module Main where
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import Test.Hspec
import Orville.SQLite import Orville.SQLite
import Test.Hspec
data Person = Person data Person = Person
{ personId :: Int64 { personId :: Int64
, firstName :: Text , firstName :: Text
, lastName :: Text , lastName :: Text
, age :: Int64 , age :: Int64
} }
deriving (Show, Eq) deriving (Show, Eq)
personIdField :: FieldDefinition 'NotNull Int64 personIdField :: FieldDefinition 'NotNull Int64
personIdField = integerField "id" personIdField = integerField "id"
@@ -31,62 +31,62 @@ ageField = integerField "age"
personMarshaller :: SqlMarshaller Person Person personMarshaller :: SqlMarshaller Person Person
personMarshaller = personMarshaller =
Person Person
<$> marshallReadOnlyField personIdField <$> marshallReadOnlyField personIdField
<*> marshallField firstName firstNameField <*> marshallField firstName firstNameField
<*> marshallField lastName lastNameField <*> marshallField lastName lastNameField
<*> marshallField age ageField <*> marshallField age ageField
personTable :: TableDefinition Int64 Person Person personTable :: TableDefinition Int64 Person Person
personTable = personTable =
mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller
main :: IO () main :: IO ()
main = hspec $ do main = hspec $ do
describe "Orville.SQLite" $ do describe "Orville.SQLite" $ do
it "creates a table and inserts a row" $ do it "creates a table and inserts a row" $ do
db <- openConnection ":memory:" db <- openConnection ":memory:"
withConnection db $ do withConnection db $ do
autoMigrateSchema defaultOptions [schemaTable personTable []] autoMigrateSchema defaultOptions [schemaTable personTable []]
insertEntity personTable (Person 0 "Alice" "Smith" 30) insertEntity personTable (Person 0 "Alice" "Smith" 30)
mAlice <- findEntity personTable 1 mAlice <- findEntity personTable 1
liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30) liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30)
closeConnection db closeConnection db
it "finds all rows" $ do it "finds all rows" $ do
db <- openConnection ":memory:" db <- openConnection ":memory:"
withConnection db $ do withConnection db $ do
autoMigrateSchema defaultOptions [schemaTable personTable []] autoMigrateSchema defaultOptions [schemaTable personTable []]
insertEntity personTable (Person 0 "Alice" "Smith" 30) insertEntity personTable (Person 0 "Alice" "Smith" 30)
insertEntity personTable (Person 0 "Bob" "Jones" 25) insertEntity personTable (Person 0 "Bob" "Jones" 25)
results <- findAll personTable results <- findAll personTable
liftIO $ length results `shouldBe` 2 liftIO $ length results `shouldBe` 2
closeConnection db closeConnection db
it "updates a row" $ do it "updates a row" $ do
db <- openConnection ":memory:" db <- openConnection ":memory:"
withConnection db $ do withConnection db $ do
autoMigrateSchema defaultOptions [schemaTable personTable []] autoMigrateSchema defaultOptions [schemaTable personTable []]
insertEntity personTable (Person 0 "Alice" "Smith" 30) insertEntity personTable (Person 0 "Alice" "Smith" 30)
updateEntity personTable (Person 1 "Alice" "Jones" 31) updateEntity personTable (Person 1 "Alice" "Jones" 31)
mAlice <- findEntity personTable 1 mAlice <- findEntity personTable 1
liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Jones" 31) liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Jones" 31)
closeConnection db closeConnection db
it "deletes a row" $ do it "deletes a row" $ do
db <- openConnection ":memory:" db <- openConnection ":memory:"
withConnection db $ do withConnection db $ do
autoMigrateSchema defaultOptions [schemaTable personTable []] autoMigrateSchema defaultOptions [schemaTable personTable []]
insertEntity personTable (Person 0 "Alice" "Smith" 30) insertEntity personTable (Person 0 "Alice" "Smith" 30)
deleteEntity personTable 1 deleteEntity personTable 1
mAlice <- findEntity personTable 1 mAlice <- findEntity personTable 1
liftIO $ mAlice `shouldBe` Nothing liftIO $ mAlice `shouldBe` Nothing
closeConnection db closeConnection db
it "returns Nothing for missing row" $ do it "returns Nothing for missing row" $ do
db <- openConnection ":memory:" db <- openConnection ":memory:"
withConnection db $ do withConnection db $ do
autoMigrateSchema defaultOptions [schemaTable personTable []] autoMigrateSchema defaultOptions [schemaTable personTable []]
mAlice <- findEntity personTable 999 mAlice <- findEntity personTable 999
liftIO $ mAlice `shouldBe` Nothing liftIO $ mAlice `shouldBe` Nothing
closeConnection db closeConnection db