Sqlite.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Database.Groundhog.Sqlite
  ( withSqlitePool,
    withSqliteConn,
    createSqlitePool,
    runDbConn,
    Sqlite (..),
    module Database.Groundhog,
    module Database.Groundhog.Generic.Sql.Functions,
  )
where

import Control.Arrow ((***))
import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Reader (ask, runReaderT)
import Control.Monad.Trans.State (mapStateT)
import Data.Acquire (mkAcquire)
import qualified Data.ByteString.Char8 as BS
import Data.Char (toUpper)
import Data.Function (on)
import qualified Data.HashMap.Strict as Map
import Data.IORef
import Data.Int (Int64)
import Data.List (groupBy, intercalate, isInfixOf, partition, sort)
import Data.Maybe (fromMaybe)
import Data.Pool
import qualified Data.Text as T
import Database.Groundhog
import Database.Groundhog.Core
import Database.Groundhog.Expression
import Database.Groundhog.Generic
import Database.Groundhog.Generic.Migration hiding (MigrationPack (..))
import qualified Database.Groundhog.Generic.Migration as GM
import qualified Database.Groundhog.Generic.PersistBackendHelpers as H
import Database.Groundhog.Generic.Sql
import Database.Groundhog.Generic.Sql.Functions
import qualified Database.SQLite3 as S
import qualified Database.SQLite3.Direct as SD

-- typical operations for connection: OPEN, BEGIN, COMMIT, ROLLBACK, CLOSE
data Sqlite = Sqlite S.Database (IORef (Map.HashMap BS.ByteString S.Statement))

instance DbDescriptor Sqlite where
  type AutoKeyType Sqlite = Int64
  type QueryRaw Sqlite = Snippet Sqlite
  backendName _ = "sqlite"

instance SqlDb Sqlite where
  append a b = mkExpr $ operator 50 "||" a b
  signum' x = mkExpr $
    Snippet $ \esc _ ->
      let x' = renderExpr esc (toExpr x)
       in ["case when (" <> x' <> ") > 0 then 1 when (" <> x' <> ") < 0 then -1 else 0 end"]
  quotRem' x y = (mkExpr $ operator 70 "/" x y, mkExpr $ operator 70 "%" x y)
  equalsOperator a b = a <> " IS " <> b
  notEqualsOperator a b = a <> " IS NOT " <> b

instance PersistBackendConn Sqlite where
  insert v = runDb' $ insert' v
  insert_ v = runDb' $ insert_' v
  insertBy u v = runDb' $ H.insertBy renderConfig queryRawCached' True u v
  insertByAll v = runDb' $ H.insertByAll renderConfig queryRawCached' True v
  replace k v = runDb' $ H.replace renderConfig queryRawCached' executeRawCached' insertIntoConstructorTable k v
  replaceBy k v = runDb' $ H.replaceBy renderConfig executeRawCached' k v
  select options = runDb' $ H.select renderConfig queryRawCached' preColumns "LIMIT -1" options
  selectStream options = runDb' $ H.selectStream renderConfig queryRawCached' preColumns "LIMIT -1" options
  selectAll = runDb' $ H.selectAll renderConfig queryRawCached'
  selectAllStream = runDb' $ H.selectAllStream renderConfig queryRawCached'
  get k = runDb' $ H.get renderConfig queryRawCached' k
  getBy k = runDb' $ H.getBy renderConfig queryRawCached' k
  update upds cond = runDb' $ H.update renderConfig executeRawCached' upds cond
  delete cond = runDb' $ H.delete renderConfig executeRawCached' cond
  deleteBy k = runDb' $ H.deleteBy renderConfig executeRawCached' k
  deleteAll v = runDb' $ H.deleteAll renderConfig executeRawCached' v
  count cond = runDb' $ H.count renderConfig queryRawCached' cond
  countAll fakeV = runDb' $ H.countAll renderConfig queryRawCached' fakeV
  project p options = runDb' $ H.project renderConfig queryRawCached' preColumns "LIMIT -1" p options
  projectStream p options = runDb' $ H.projectStream renderConfig queryRawCached' preColumns "LIMIT -1" p options
  migrate fakeV = mapStateT runDb' $ migrate' fakeV

  executeRaw False query ps = runDb' $ executeRaw' (fromString query) ps
  executeRaw True query ps = runDb' $ executeRawCached' (fromString query) ps
  queryRaw False query ps = runDb' $ queryRaw' (fromString query) ps
  queryRaw True query ps = runDb' $ queryRawCached' (fromString query) ps

  insertList l = runDb' $ insertList' l
  getList k = runDb' $ getList' k

instance SchemaAnalyzer Sqlite where
  schemaExists _ = fail "schemaExists: is not supported by Sqlite"
  getCurrentSchema = pure Nothing
  listTables Nothing = runDb' $ queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
  listTables sch = fail $ "listTables: schemas are not supported by Sqlite: " ++ show sch
  listTableTriggers (Nothing, name) = runDb' $ queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue name] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
  listTableTriggers (sch, _) = fail $ "listTableTriggers: schemas are not supported by Sqlite: " ++ show sch
  analyzeTable = runDb' . analyzeTable'
  analyzeTrigger (Nothing, name) = runDb' $ do
    x <- queryRaw' "SELECT sql FROM sqlite_master WHERE type='trigger' AND name=?" [toPrimitivePersistValue name] >>= firstRow
    case x of
      Nothing -> pure Nothing
      Just src -> pure (fst $ fromPurePersistValues src)
  analyzeTrigger (sch, _) = fail $ "analyzeTrigger: schemas are not supported by Sqlite: " ++ show sch
  analyzeFunction _ = fail "analyzeFunction: is not supported by Sqlite"
  getMigrationPack = pure migrationPack

withSqlitePool ::
  (MonadBaseControl IO m, MonadIO m) =>
  -- | connection string
  String ->
  -- | number of connections to open
  Int ->
  (Pool Sqlite -> m a) ->
  m a
withSqlitePool s connCount f = createSqlitePool s connCount >>= f

withSqliteConn ::
  (MonadBaseControl IO m, MonadIO m) =>
  -- | connection string
  String ->
  (Sqlite -> m a) ->
  m a
withSqliteConn s = bracket (liftIO $ open' s) (liftIO . close')

createSqlitePool ::
  MonadIO m =>
  -- | connection string
  String ->
  -- | number of connections to open
  Int ->
  m (Pool Sqlite)
createSqlitePool s connCount = liftIO $ createPool (open' s) close' 1 20 connCount

instance Savepoint Sqlite where
  withConnSavepoint name m (Sqlite c _) = do
    let name' = fromString name
    liftIO $ S.exec c $ "SAVEPOINT " <> name'
    x <- onException m (liftIO $ S.exec c $ "ROLLBACK TO " <> name')
    liftIO $ S.exec c $ "RELEASE " <> name'
    pure x

instance ConnectionManager Sqlite where
  withConn f conn@(Sqlite c _) = do
    liftIO $ S.exec c "BEGIN"
    x <- onException (f conn) (liftIO $ S.exec c "ROLLBACK")
    liftIO $ S.exec c "COMMIT"
    pure x

instance TryConnectionManager Sqlite where
  tryWithConn f g conn@(Sqlite c _) = do
    liftIO $ S.exec c "BEGIN"
    x <- g (f conn)
    case x of
      Left _ -> liftIO $ S.exec c "ROLLBACK"
      Right _ -> liftIO $ S.exec c "COMMIT"
    pure x

instance ExtractConnection Sqlite Sqlite where
  extractConn f conn = f conn

instance ExtractConnection (Pool Sqlite) Sqlite where
  extractConn f pconn = withResource pconn f

open' :: String -> IO Sqlite
open' s = do
  conn <- S.open $ T.pack s
  S.prepare conn "PRAGMA foreign_keys = ON" >>= \stmt -> S.step stmt >> S.finalize stmt
  cache <- newIORef Map.empty
  pure $ Sqlite conn cache

close' :: Sqlite -> IO ()
close' (Sqlite conn smap) = do
  readIORef smap >>= mapM_ S.finalize . Map.elems
  S.close conn

migrate' :: PersistEntity v => v -> Migration (Action Sqlite)
migrate' = migrateRecursively (const $ pure $ Right []) (migrateEntity migrationPack) (migrateList migrationPack)

migrationPack :: GM.MigrationPack Sqlite
migrationPack =
  GM.MigrationPack
    compareTypes
    compareRefs
    compareUniqs
    compareDefaults
    migTriggerOnDelete
    migTriggerOnUpdate
    (GM.defaultMigConstr migrationPack)
    escape
    "INTEGER PRIMARY KEY NOT NULL"
    mainTableId
    defaultPriority
    addUniquesReferences
    showSqlType
    showColumn
    showAlterDb
    NoAction
    NoAction

addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
addUniquesReferences uniques refs = (map sqlUnique constraints ++ map sqlReference refs, map AddUnique indexes)
  where
    (constraints, indexes) = partition ((/= UniqueIndex) . uniqueDefType) uniques

migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action Sqlite (Bool, [AlterDB])
migTriggerOnDelete qualifiedName deletes = do
  let addTrigger = AddTriggerOnDelete qualifiedName qualifiedName (concatMap snd deletes)
  x <- analyzeTrigger qualifiedName
  pure $ case x of
    Nothing | null deletes -> (False, [])
    Nothing -> (False, [addTrigger])
    Just sql ->
      ( True,
        if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types
          then [DropTrigger qualifiedName qualifiedName]
          else
            if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger
              then []
              else -- this can happen when an ephemeral field was added or removed.
                [DropTrigger qualifiedName qualifiedName, addTrigger]
      )

-- | Schema name, table name and a list of field names and according delete statements
-- assume that this function is called only for ephemeral fields
migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action Sqlite [(Bool, [AlterDB])]
migTriggerOnUpdate name dels = forM dels $ \(fieldName, del) -> do
  let trigName = (Nothing, snd name ++ delim : fieldName)
  let addTrigger = AddTriggerOnUpdate trigName name (Just fieldName) del
  x <- analyzeTrigger trigName
  pure $ case x of
    Nothing -> (False, [addTrigger])
    Just sql ->
      ( True,
        if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger
          then []
          else [DropTrigger trigName name, addTrigger]
      )

analyzeTable' :: QualifiedName -> Action Sqlite (Maybe TableInfo)
analyzeTable' (Nothing, tName) = do
  let fromName = escapeS . fromString
  tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
  case tableInfo of
    [] -> pure Nothing
    rawColumns -> do
      let mkColumn :: (Int, (String, String, Int, Maybe String, Int)) -> Column
          mkColumn (_, (name, typ, isNotNull, defaultValue, _)) = Column name (isNotNull == 0) (readSqlType typ) defaultValue
          primaryKeyColumnNames = foldr (\(_, (name, _, _, _, primaryIndex)) xs -> if primaryIndex > 0 then name : xs else xs) [] rawColumns
          columns = map mkColumn rawColumns
      indexList <- queryRaw' ("pragma index_list(" <> fromName tName <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
      let uniqueNames = map (\(_ :: Int, name, _) -> name) $ filter (\(_, _, isUnique) -> isUnique) indexList
      uniques <- forM uniqueNames $ \name -> do
        uFields <- queryRaw' ("pragma index_info(" <> fromName name <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
        sql <- queryRaw' "select sql from sqlite_master where type = 'index' and name = ?" [toPrimitivePersistValue name] >>= firstRow
        let columnNames = map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)])
            uType =
              if sql == Just [PersistNull]
                then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary False else UniqueConstraint
                else UniqueIndex
        pure $ UniqueDef (Just name) uType (map Left columnNames)
      foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
      (foreigns :: [(Maybe String, Reference)]) <- do
        let foreigns :: [[(Int, (Int, String, (String, Maybe String), (String, String, String)))]]
            foreigns = groupBy ((==) `on` fst) . sort $ foreignKeyList -- sort by foreign key number and column number inside key (first and second integers)
            mkAction c = Just $ fromMaybe (error $ "unknown reference action type: " ++ c) $ readReferenceAction c
        forM foreigns $ \rows -> do
          let (_, (_, foreignTable, _, (onUpdate, onDelete, _))) = head rows
              (children, parents) = unzip $ map (\(_, (_, _, pair, _)) -> pair) rows
          parents' <- case head parents of
            Nothing ->
              analyzePrimaryKey foreignTable >>= \case
                Just primaryCols -> pure primaryCols
                Nothing -> error $ "analyzeTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"
            Just _ -> pure $ map (fromMaybe (error "analyzeTable: all parents must be either NULL or values")) parents
          let refs = zip children parents'
          pure (Nothing, Reference (Nothing, foreignTable) refs (mkAction onDelete) (mkAction onUpdate))
      let notPrimary x = case x of
            UniquePrimary _ -> False
            _ -> True
          uniques' =
            uniques
              ++ if all (notPrimary . uniqueDefType) uniques && not (null primaryKeyColumnNames)
                then [UniqueDef Nothing (UniquePrimary True) (map Left primaryKeyColumnNames)]
                else []
      pure $ Just $ TableInfo columns uniques' foreigns
analyzeTable' (sch, _) = fail $ "analyzeTable: schemas are not supported by Sqlite: " ++ show sch

analyzePrimaryKey :: String -> Action Sqlite (Maybe [String])
analyzePrimaryKey tName = do
  tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tName) <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList
  let cols = map (\(_, (name, _, _, _, primaryIndex)) -> (primaryIndex, name)) (tableInfo :: [(Int, (String, String, Int, Maybe String, Int))])
      cols' = map snd $ sort $ filter ((> 0) . fst) cols
  pure $
    if null cols'
      then Nothing
      else Just cols'

getStatementCached :: Utf8 -> Action Sqlite S.Statement
getStatementCached sql = do
  Sqlite conn smap <- ask
  liftIO $ do
    smap' <- readIORef smap
    let sql' = fromUtf8 sql
    case Map.lookup sql' smap' of
      Nothing -> do
        stmt <- S.prepareUtf8 conn $ SD.Utf8 sql'
        writeIORef smap (Map.insert sql' stmt smap')
        pure stmt
      Just stmt -> pure stmt

getStatement :: Utf8 -> Action Sqlite S.Statement
getStatement sql = do
  Sqlite conn _ <- ask
  liftIO $ S.prepareUtf8 conn $ SD.Utf8 $ fromUtf8 sql

showSqlType :: DbTypePrimitive -> String
showSqlType t = case t of
  DbString -> "VARCHAR"
  DbInt32 -> "INTEGER"
  DbInt64 -> "INTEGER"
  DbReal -> "REAL"
  DbBool -> "BOOLEAN"
  DbDay -> "DATE"
  DbTime -> "TIME"
  DbDayTime -> "TIMESTAMP"
  DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE"
  DbBlob -> "BLOB"
  DbOther (OtherTypeDef ts) -> concatMap (either id showSqlType) ts

readSqlType :: String -> DbTypePrimitive
readSqlType typ = case map toUpper typ of
  "VARCHAR" -> DbString
  "INTEGER" -> DbInt64
  "REAL" -> DbReal
  "BOOLEAN" -> DbBool
  "DATE" -> DbDay
  "TIME" -> DbTime
  "TIMESTAMP" -> DbDayTime
  "TIMESTAMP WITH TIME ZONE" -> DbDayTimeZoned
  "BLOB" -> DbBlob
  _ -> DbOther $ OtherTypeDef [Left typ]

data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show)

dbTypeAffinity :: DbTypePrimitive -> Affinity
dbTypeAffinity = readSqlTypeAffinity . showSqlType

readSqlTypeAffinity :: String -> Affinity
readSqlTypeAffinity typ = affinity
  where
    contains = any (`isInfixOf` map toUpper typ)
    affinity = case () of
      _ | contains ["INT"] -> INTEGER
      _ | contains ["CHAR", "CLOB", "TEXT"] -> TEXT
      _ | contains ["BLOB"] || null typ -> NONE
      _ | contains ["REAL", "FLOA", "DOUB"] -> REAL
      _ -> NUMERIC

showColumn :: Column -> String
showColumn (Column name nullable typ def) = escape name ++ " " ++ showSqlType typ ++ rest
  where
    rest =
      (if not nullable then " NOT NULL" else "") ++ maybe "" (" DEFAULT " ++) def

sqlReference :: Reference -> String
sqlReference Reference {..} = "FOREIGN KEY(" ++ ourKey ++ ") REFERENCES " ++ escape (snd referencedTableName) ++ "(" ++ foreignKey ++ ")" ++ actions
  where
    actions =
      maybe "" ((" ON DELETE " ++) . showReferenceAction) referenceOnDelete
        ++ maybe "" ((" ON UPDATE " ++) . showReferenceAction) referenceOnUpdate
    (ourKey, foreignKey) = f *** f $ unzip referencedColumns
    f = intercalate ", " . map escape

sqlUnique :: UniqueDefInfo -> String
sqlUnique (UniqueDef name typ cols) =
  concat
    [ maybe "" (\x -> "CONSTRAINT " ++ escape x ++ " ") name,
      constraintType,
      intercalate "," $ map (either escape id) cols,
      ")"
    ]
  where
    constraintType = case typ of
      UniquePrimary _ -> "PRIMARY KEY("
      UniqueConstraint -> "UNIQUE("
      UniqueIndex -> error "sqlUnique: does not handle indexes"

insert' :: PersistEntity v => v -> Action Sqlite (AutoKey v)
insert' v = do
  -- constructor number and the rest of the field values
  vals <- toEntityPersistValues' v
  let e = entityDef proxy v
  let constructorNum = fromPrimitivePersistValue (head vals)

  fmap fst $
    if isSimple (constructors e)
      then do
        let constr = head $ constructors e
        let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)
        executeRawCached' query (vals' [])
        case constrAutoKeyName constr of
          Nothing -> pureFromPersistValue []
          Just _ -> getLastInsertRowId >>= \rowid -> pureFromPersistValue [rowid]
      else do
        let constr = constructors e !! constructorNum
        let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"
        executeRawCached' query $ take 1 vals
        rowid <- getLastInsertRowId
        let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid : tail vals)
        executeRawCached' cQuery (vals' [])
        pureFromPersistValue [rowid]

insert_' :: PersistEntity v => v -> Action Sqlite ()
insert_' v = do
  -- constructor number and the rest of the field values
  vals <- toEntityPersistValues' v
  let e = entityDef proxy v
  let constructorNum = fromPrimitivePersistValue (head vals)

  if isSimple (constructors e)
    then do
      let constr = head $ constructors e
      let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)
      executeRawCached' query (vals' [])
    else do
      let constr = constructors e !! constructorNum
      let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"
      executeRawCached' query $ take 1 vals
      rowid <- getLastInsertRowId
      let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid : tail vals)
      executeRawCached' cQuery (vals' [])

-- TODO: In Sqlite we can insert null to the id column. If so, id will be generated automatically. Check performance change from this.
insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r
insertIntoConstructorTable withId tName c vals = RenderS query vals'
  where
    query = "INSERT INTO " <> tName <> columnsValues
    fields = case constrAutoKeyName c of
      Just idName | withId -> (idName, dbType proxy (0 :: Int64)) : constrParams c
      _ -> constrParams c
    columnsValues = case foldr (flatten escapeS) [] fields of
      [] -> " DEFAULT VALUES"
      xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")"
    RenderS placeholders vals' = commasJoin $ map renderPersistValue vals

insertList' :: forall a. PersistField a => [a] -> Action Sqlite Int64
insertList' l = do
  let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))
  executeRawCached' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES") []
  k <- getLastInsertRowId
  let valuesName = mainName <> delim' <> "values"
  let fields = [("ord", dbType proxy (0 :: Int)), ("value", dbType proxy (undefined :: a))]
  let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")"
  let go :: Int -> [a] -> Action Sqlite ()
      go n (x : xs) = do
        x' <- toPersistValues x
        executeRawCached' query $ (k :) . (toPrimitivePersistValue n :) . x' $ []
        go (n + 1) xs
      go _ [] = pure ()
  go 0 l
  pure $ fromPrimitivePersistValue k

getList' :: forall a. PersistField a => Int64 -> Action Sqlite [a]
getList' k = do
  let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))
      valuesName = mainName <> delim' <> "values"
      value = ("value", dbType proxy (undefined :: a))
      query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"
  queryRawCached' query [toPrimitivePersistValue k] >>= mapStream (fmap fst . fromPersistValues) >>= streamToList

getLastInsertRowId :: Action Sqlite PersistValue
getLastInsertRowId = do
  Sqlite conn _ <- ask
  liftIO (SD.lastInsertRowId conn) >>= toSinglePersistValue

----------

bind :: S.Statement -> [PersistValue] -> IO ()
bind stmt = go 1
  where
    go _ [] = pure ()
    go i (x : xs) = do
      case x of
        PersistInt64 int64 -> S.bindInt64 stmt i int64
        PersistText text -> S.bindText stmt i text
        PersistString text -> S.bindText stmt i $ T.pack text
        PersistDouble double -> S.bindDouble stmt i double
        PersistBool b -> S.bindInt64 stmt i $ if b then 1 else 0
        PersistByteString blob -> S.bindBlob stmt i blob
        PersistNull -> S.bindNull stmt i
        PersistDay d -> S.bindText stmt i $ T.pack $ show d
        PersistTimeOfDay d -> S.bindText stmt i $ T.pack $ show d
        PersistUTCTime d -> S.bindText stmt i $ T.pack $ show d
        PersistZonedTime (ZT d) -> S.bindText stmt i $ T.pack $ show d
        PersistCustom _ _ -> error "bind: unexpected PersistCustom"
      go (i + 1) xs

executeRaw' :: Utf8 -> [PersistValue] -> Action Sqlite ()
executeRaw' query vals = do
  --  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals
  stmt <- getStatement query
  liftIO $
    flip finally (S.finalize stmt) $ do
      bind stmt vals
      S.Done <- S.step stmt
      pure ()

executeRawCached' :: Utf8 -> [PersistValue] -> Action Sqlite ()
executeRawCached' query vals = do
  --  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals
  stmt <- getStatementCached query
  liftIO $
    flip finally (S.reset stmt) $ do
      bind stmt vals
      S.Done <- S.step stmt
      pure ()

runQuery :: (Utf8 -> Action Sqlite S.Statement) -> (S.Statement -> IO ()) -> Utf8 -> [PersistValue] -> Action Sqlite (RowStream [PersistValue])
runQuery getStmt close query vals = do
  --  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals
  conn <- ask
  let open = do
        stmt <- runReaderT (getStmt query) conn
        bind stmt vals
        pure stmt
      mkNext stmt = do
        x <- S.step stmt
        case x of
          S.Done -> pure Nothing
          S.Row -> Just . map pFromSql <$> S.columns stmt
  pure $ mkNext <$> mkAcquire open close

queryRaw', queryRawCached' :: Utf8 -> [PersistValue] -> Action Sqlite (RowStream [PersistValue])
queryRaw' = runQuery getStatement S.finalize
queryRawCached' = runQuery getStatementCached S.reset

pFromSql :: S.SQLData -> PersistValue
pFromSql (S.SQLInteger i) = PersistInt64 i
pFromSql (S.SQLFloat i) = PersistDouble i
pFromSql (S.SQLText s) = PersistText s
pFromSql (S.SQLBlob bs) = PersistByteString bs
pFromSql S.SQLNull = PersistNull

-- It is used to escape table names and columns, which can include only symbols allowed in Haskell datatypes and '$' delimiter. We need it mostly to support names that coincide with SQL keywords
escape :: String -> String
escape s = '\"' : s ++ "\""

escapeS :: Utf8 -> Utf8
escapeS a = let q = fromChar '"' in q <> a <> q

renderConfig :: RenderConfig
renderConfig =
  RenderConfig
    { esc = escapeS
    }

defaultPriority, triggerPriority :: Int
defaultPriority = 0
triggerPriority = 1

proxy :: proxy Sqlite
proxy = error "proxy Sqlite"

delim' :: Utf8
delim' = fromChar delim

toEntityPersistValues' :: PersistEntity v => v -> Action Sqlite [PersistValue]
toEntityPersistValues' = fmap ($ []) . toEntityPersistValues

compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2
compareUniqs (UniqueDef _ type1 cols1) (UniqueDef _ type2 cols2) = haveSameElems (==) cols1 cols2 && type1 == type2

compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareRefs (_, Reference tbl1 pairs1 onDel1 onUpd1) (_, Reference tbl2 pairs2 onDel2 onUpd2) =
  unescape (snd tbl1) == unescape (snd tbl2)
    && haveSameElems (==) pairs1 pairs2
    && fromMaybe NoAction onDel1 == fromMaybe NoAction onDel2
    && fromMaybe NoAction onUpd1 == fromMaybe NoAction onUpd2
  where
    unescape name = if head name == '"' && last name == '"' then tail $ init name else name

compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
compareTypes type1 type2 = dbTypeAffinity type1 == dbTypeAffinity type2

--compareTypes type1 type2 = showSqlType type1 == showSqlType type2

compareDefaults :: String -> String -> Bool
compareDefaults = (==)

mainTableId :: String
mainTableId = "id"

showAlterDb :: AlterDB -> SingleMigration
showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]
showAlterDb (AlterTable (_, table) createTable (TableInfo oldCols _ _) (TableInfo newCols _ _) alts) = case mapM (showAlterTable table) alts of
  Just alts' -> Right alts'
  Nothing ->
    Right
      [ (False, defaultPriority, "CREATE TEMP TABLE " ++ escape tableTmp ++ "(" ++ columnsTmp ++ ")"),
        (False, defaultPriority, copy (table, columnsTmp) (tableTmp, columnsTmp)),
        (not (null oldOnlyColumns), defaultPriority, "DROP TABLE " ++ escape table),
        (False, defaultPriority, createTable),
        (False, defaultPriority, copy (tableTmp, columnsTmp) (table, columnsNew)),
        (False, defaultPriority, "DROP TABLE " ++ escape tableTmp)
      ]
    where
      tableTmp = table ++ "_backup"
      copy (from, fromCols) (to, toCols) = "INSERT INTO " ++ escape to ++ "(" ++ toCols ++ ") SELECT " ++ fromCols ++ " FROM " ++ escape from
      (oldOnlyColumns, _, commonColumns) = matchElements ((==) `on` colName) oldCols newCols
      columnsTmp = intercalate "," $ map (escape . colName . snd) commonColumns
      columnsNew = intercalate "," $ map (escape . colName . snd) commonColumns
showAlterDb (DropTrigger trigName _) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape (snd trigName))]
showAlterDb (AddTriggerOnDelete trigName tName body) =
  Right
    [ ( False,
        triggerPriority,
        "CREATE TRIGGER " ++ escape (snd trigName) ++ " DELETE ON " ++ escape (snd tName) ++ " BEGIN " ++ body ++ "END"
      )
    ]
showAlterDb (AddTriggerOnUpdate trigName tName fieldName body) =
  Right
    [ ( False,
        triggerPriority,
        "CREATE TRIGGER " ++ escape (snd trigName) ++ " UPDATE OF " ++ fieldName' ++ " ON " ++ escape (snd tName) ++ " BEGIN " ++ body ++ "END"
      )
    ]
  where
    fieldName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ show trigName) escape fieldName
showAlterDb alt = error $ "showAlterDb: does not support " ++ show alt

showAlterTable :: String -> AlterTable -> Maybe (Bool, Int, String)
showAlterTable table (AddColumn col) =
  Just
    ( False,
      defaultPriority,
      concat
        [ "ALTER TABLE ",
          escape table,
          " ADD COLUMN ",
          showColumn col
        ]
    )
showAlterTable table (AlterColumn col [UpdateValue s]) =
  Just
    ( False,
      defaultPriority,
      concat
        [ "UPDATE ",
          escape table,
          " SET ",
          escape (colName col),
          "=",
          s,
          " WHERE ",
          escape (colName col),
          " IS NULL"
        ]
    )
showAlterTable table (AddUnique (UniqueDef uName UniqueIndex cols)) =
  Just
    ( False,
      defaultPriority,
      concat
        [ "CREATE UNIQUE INDEX ",
          maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName,
          " ON ",
          escape table,
          "(",
          intercalate "," $ map (either escape id) cols,
          ")"
        ]
    )
showAlterTable _ (DropIndex uName) =
  Just
    ( False,
      defaultPriority,
      "DROP INDEX " ++ escape uName
    )
showAlterTable _ _ = Nothing

preColumns :: HasSelectOptions opts db r => opts -> RenderS db r
preColumns _ = mempty