diff --git a/orville-sqlite.cabal b/orville-sqlite.cabal index bb472ae..b20ecd9 100644 --- a/orville-sqlite.cabal +++ b/orville-sqlite.cabal @@ -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 diff --git a/src/Orville/SQLite/AutoMigration.hs b/src/Orville/SQLite/AutoMigration.hs new file mode 100644 index 0000000..5d49bfe --- /dev/null +++ b/src/Orville/SQLite/AutoMigration.hs @@ -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 "" diff --git a/src/Orville/SQLite/Execution.hs b/src/Orville/SQLite/Execution.hs new file mode 100644 index 0000000..98de332 --- /dev/null +++ b/src/Orville/SQLite/Execution.hs @@ -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 diff --git a/src/Orville/SQLite/TableDefinition.hs b/src/Orville/SQLite/TableDefinition.hs new file mode 100644 index 0000000..3c847f0 --- /dev/null +++ b/src/Orville/SQLite/TableDefinition.hs @@ -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 + }