Add TableDefinition, AutoMigration, and Execution modules

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

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 ""

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

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
+      }