Add TableDefinition, AutoMigration, and Execution modules
This commit is contained in:
@@ -15,11 +15,14 @@ build-type: Simple
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Orville.SQLite.AutoMigration
|
||||
Orville.SQLite.Execution
|
||||
Orville.SQLite.FieldDefinition
|
||||
Orville.SQLite.Monad
|
||||
Orville.SQLite.RawSql
|
||||
Orville.SQLite.SqlMarshaller
|
||||
Orville.SQLite.SqlType
|
||||
Orville.SQLite.TableDefinition
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
base >=4.17 && <5
|
||||
|
||||
@@ -0,0 +1,218 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Orville.SQLite.AutoMigration
|
||||
( MigrationOptions (..)
|
||||
, defaultOptions
|
||||
, SchemaItem (..)
|
||||
, schemaTable
|
||||
, dropColumns
|
||||
, autoMigrateSchema
|
||||
, MigrationStep (..)
|
||||
, generateMigrationPlan
|
||||
, executeMigrationPlan
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.List (find, intercalate)
|
||||
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 (..))
|
||||
|
||||
data MigrationOptions = MigrationOptions
|
||||
{ runSchemaChanges :: Bool
|
||||
}
|
||||
|
||||
defaultOptions :: MigrationOptions
|
||||
defaultOptions = MigrationOptions{runSchemaChanges = True}
|
||||
|
||||
newtype SchemaItem = SchemaItem
|
||||
{ unSchemaItem :: SchemaItemRep
|
||||
}
|
||||
|
||||
data SchemaItemRep where
|
||||
SchemaTableItem ::
|
||||
{ schemaItemTableName :: String
|
||||
, schemaItemMarshaller :: SqlMarshaller w r
|
||||
, schemaItemPkName :: String
|
||||
, schemaItemDropColumns :: [String]
|
||||
} -> SchemaItemRep
|
||||
|
||||
schemaTable ::
|
||||
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
|
||||
}
|
||||
|
||||
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)
|
||||
|
||||
data ExistingColumn = ExistingColumn
|
||||
{ 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 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 []
|
||||
|
||||
marshallerExpectedColumns ::
|
||||
SqlMarshaller w r ->
|
||||
String ->
|
||||
[(String, String, Bool)]
|
||||
marshallerExpectedColumns marshaller pkName =
|
||||
[ ( fieldInfoName f
|
||||
, fieldInfoType f
|
||||
, fieldInfoName f == pkName || not (fieldInfoIsNullable f)
|
||||
)
|
||||
| f <- marshallerFieldInfo marshaller
|
||||
]
|
||||
|
||||
planTableChanges ::
|
||||
String ->
|
||||
[(String, String, Bool)] ->
|
||||
[ExistingColumn] ->
|
||||
[String] ->
|
||||
[MigrationStep]
|
||||
planTableChanges tableName' expected existing dropColsList
|
||||
| null existing = [CreateTable tableName' expected (findPk expected)]
|
||||
| otherwise = addColSteps ++ dropColSteps
|
||||
where
|
||||
existingNames = map existingName existing
|
||||
|
||||
addColSteps =
|
||||
[ AddColumn tableName' name colType
|
||||
| (name, colType, _) <- expected
|
||||
, name `notElem` existingNames
|
||||
]
|
||||
|
||||
dropColSteps =
|
||||
[ DropColumn tableName' name
|
||||
| name <- dropColsList
|
||||
, name `elem` existingNames
|
||||
]
|
||||
|
||||
findPk cols =
|
||||
case find (\(_, _, isNull) -> not isNull) cols of
|
||||
Just (name, _, _) -> name
|
||||
Nothing -> case cols of
|
||||
((name, _, _) : _) -> name
|
||||
[] -> ""
|
||||
|
||||
autoMigrateSchema :: MigrationOptions -> [SchemaItem] -> OrvilleM ()
|
||||
autoMigrateSchema opts items = do
|
||||
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
|
||||
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)] -> T.Text
|
||||
mkCreateTable name cols =
|
||||
T.pack $
|
||||
"CREATE TABLE IF NOT EXISTS "
|
||||
<> name
|
||||
<> " (\n "
|
||||
<> intercalate ",\n " (map mkColumnDef cols)
|
||||
<> "\n)"
|
||||
where
|
||||
mkColumnDef (colName, colType, notNullFlag) =
|
||||
colName
|
||||
<> " "
|
||||
<> colType
|
||||
<> if notNullFlag then " NOT NULL" else ""
|
||||
@@ -0,0 +1,169 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.Execution
|
||||
( insertEntity
|
||||
, findEntity
|
||||
, findAll
|
||||
, updateEntity
|
||||
, deleteEntity
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Database.SQLite3.Direct (columnCount)
|
||||
import Orville.SQLite.FieldDefinition (fieldColumnName, fieldToSqlValue)
|
||||
import Orville.SQLite.Monad (OrvilleM)
|
||||
import Orville.SQLite.SqlMarshaller
|
||||
( marshallerDerivedColumns
|
||||
, marshallerEncodeWrite
|
||||
, marshallerDecodeRow
|
||||
)
|
||||
import Orville.SQLite.TableDefinition (TableDefinition (..), PrimaryKey (..))
|
||||
|
||||
insertEntity ::
|
||||
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
|
||||
|
||||
findEntity ::
|
||||
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)
|
||||
|
||||
findAll ::
|
||||
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 []
|
||||
|
||||
updateEntity ::
|
||||
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
|
||||
|
||||
deleteEntity ::
|
||||
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
|
||||
|
||||
getRowData ::
|
||||
SQLite3.Statement ->
|
||||
[String] ->
|
||||
IO [(String, SQLite3.SQLData)]
|
||||
getRowData stmt cols = do
|
||||
colCount <- columnCount stmt
|
||||
let count :: Int = fromIntegral colCount
|
||||
indexes = take count [0 :: SQLite3.ColumnIndex ..]
|
||||
mapM
|
||||
( \i -> do
|
||||
let idx :: Int = fromIntegral i
|
||||
colName =
|
||||
if idx < length cols
|
||||
then cols !! idx
|
||||
else ""
|
||||
sqlVal <- SQLite3.column stmt i
|
||||
pure (colName, sqlVal)
|
||||
)
|
||||
indexes
|
||||
@@ -0,0 +1,61 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Orville.SQLite.TableDefinition
|
||||
( PrimaryKey (..)
|
||||
, primaryKey
|
||||
, TableDefinition (..)
|
||||
, mkTableDefinition
|
||||
, mkTableDefinitionWithoutKey
|
||||
) where
|
||||
|
||||
import Orville.SQLite.FieldDefinition
|
||||
( FieldDefinition
|
||||
, Nullability (..)
|
||||
, integerField
|
||||
, convertField
|
||||
)
|
||||
import Orville.SQLite.SqlMarshaller (SqlMarshaller)
|
||||
|
||||
data PrimaryKey writeEntity key where
|
||||
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
|
||||
}
|
||||
|
||||
mkTableDefinition ::
|
||||
String ->
|
||||
PrimaryKey writeEntity key ->
|
||||
SqlMarshaller writeEntity readEntity ->
|
||||
TableDefinition key writeEntity readEntity
|
||||
mkTableDefinition = TableDefinition
|
||||
|
||||
mkTableDefinitionWithoutKey ::
|
||||
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
|
||||
}
|
||||
Reference in New Issue
Block a user