diff --git a/Database/Groundhog/Sqlite.hs b/Database/Groundhog/Sqlite.hs --- a/Database/Groundhog/Sqlite.hs +++ b/Database/Groundhog/Sqlite.hs @@ -1,44 +1,52 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types, MultiParamTypeClasses, TemplateHaskell #-} -module Database.Groundhog.Sqlite - ( withSqlitePool - , withSqliteConn - , createSqlitePool - , runDbConn - , Sqlite(..) - , module Database.Groundhog - , module Database.Groundhog.Generic.Sql.Functions - ) where - -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 Database.Groundhog.Generic.Sql -import Database.Groundhog.Generic.Sql.Functions -import qualified Database.Groundhog.Generic.PersistBackendHelpers as H +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -import qualified Database.SQLite3 as S -import qualified Database.SQLite3.Direct as SD +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 (liftM, forM) +import Control.Monad (forM) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask, runReaderT) import Control.Monad.Trans.State (mapStateT) -import qualified Data.ByteString.Char8 as BS 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.IORef -import qualified Data.HashMap.Strict as Map 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)) @@ -50,9 +58,10 @@ 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"] + 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 @@ -64,8 +73,8 @@ 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 + 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 @@ -90,38 +99,46 @@ instance SchemaAnalyzer Sqlite where schemaExists _ = fail "schemaExists: is not supported by Sqlite" - getCurrentSchema = return Nothing - listTables Nothing = runDb' $ queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList + 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 (return . fst . fromPurePersistValues) >>= streamToList + 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 -> return Nothing - Just src -> return (fst $ fromPurePersistValues src) + 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 = return migrationPack + getMigrationPack = pure migrationPack -withSqlitePool :: (MonadBaseControl IO m, MonadIO m) - => String -- ^ connection string - -> Int -- ^ number of connections to open - -> (Pool Sqlite -> m a) - -> m a +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) - => String -- ^ connection string - -> (Sqlite -> m a) - -> m a +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 - => String -- ^ connection string - -> Int -- ^ number of connections to open - -> m (Pool Sqlite) +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 @@ -130,14 +147,14 @@ liftIO $ S.exec c $ "SAVEPOINT " <> name' x <- onException m (liftIO $ S.exec c $ "ROLLBACK TO " <> name') liftIO $ S.exec c $ "RELEASE " <> name' - return x + 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" - return x + pure x instance TryConnectionManager Sqlite where tryWithConn f g conn@(Sqlite c _) = do @@ -146,7 +163,7 @@ case x of Left _ -> liftIO $ S.exec c "ROLLBACK" Right _ -> liftIO $ S.exec c "COMMIT" - return x + pure x instance ExtractConnection Sqlite Sqlite where extractConn f conn = f conn @@ -159,7 +176,7 @@ conn <- S.open $ T.pack s S.prepare conn "PRAGMA foreign_keys = ON" >>= \stmt -> S.step stmt >> S.finalize stmt cache <- newIORef Map.empty - return $ Sqlite conn cache + pure $ Sqlite conn cache close' :: Sqlite -> IO () close' (Sqlite conn smap) = do @@ -167,46 +184,52 @@ S.close conn migrate' :: PersistEntity v => v -> Migration (Action Sqlite) -migrate' = migrateRecursively (const $ return $ Right []) (migrateEntity migrationPack) (migrateList migrationPack) +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 +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 +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 - return $ case x of + 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 [] - -- this can happen when an ephemeral field was added or removed. - else [DropTrigger qualifiedName qualifiedName, 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])] @@ -214,66 +237,73 @@ let trigName = (Nothing, snd name ++ delim : fieldName) let addTrigger = AddTriggerOnUpdate trigName name (Just fieldName) del x <- analyzeTrigger trigName - return $ case x of + pure $ case x of Nothing -> (False, [addTrigger]) - Just sql -> (True, if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger - then [] - else [DropTrigger trigName name, 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 (return . fst . fromPurePersistValues) >>= streamToList + tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList case tableInfo of - [] -> return Nothing + [] -> 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 + 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 (return . fst . fromPurePersistValues) >>= streamToList + 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 (return . fst . fromPurePersistValues) >>= streamToList - sql <- queryRaw' ("select sql from sqlite_master where type = 'index' and name = ?") [toPrimitivePersistValue name] >>= firstRow + 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 - return $ UniqueDef (Just name) uType (map Left columnNames) - foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList + 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 >>= \x -> case x of - Just primaryCols -> return primaryCols + 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 _ -> return $ map (fromMaybe (error "analyzeTable: all parents must be either NULL or values")) parents - let refs = zip children parents' - return (Nothing, Reference (Nothing, foreignTable) refs (mkAction onDelete) (mkAction onUpdate)) + 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 [] - return $ Just $ TableInfo columns uniques' foreigns + 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 (return . fst . fromPurePersistValues) >>= streamToList - let cols = map (\(_ , (name, _, _, _, primaryIndex)) -> (primaryIndex, name)) (tableInfo :: [(Int, (String, String, Int, Maybe String, Int))]) + 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 - return $ if null cols' - then Nothing - else Just cols' + pure $ + if null cols' + then Nothing + else Just cols' getStatementCached :: Utf8 -> Action Sqlite S.Statement getStatementCached sql = do @@ -285,8 +315,8 @@ Nothing -> do stmt <- S.prepareUtf8 conn $ SD.Utf8 sql' writeIORef smap (Map.insert sql' stmt smap') - return stmt - Just stmt -> return stmt + pure stmt + Just stmt -> pure stmt getStatement :: Utf8 -> Action Sqlite S.Statement getStatement sql = do @@ -326,35 +356,40 @@ 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 +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 = concat [ - if not nullable then " NOT NULL" else "", - maybe "" (" DEFAULT " ++) def] +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 +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 +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(" @@ -367,22 +402,23 @@ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue (head vals) - liftM 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] + 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 @@ -401,22 +437,23 @@ 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) + 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 +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' :: 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") [] @@ -425,22 +462,22 @@ 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 _ [] = return () + go n (x : xs) = do + x' <- toPersistValues x + executeRawCached' query $ (k :) . (toPrimitivePersistValue n :) . x' $ [] + go (n + 1) xs + go _ [] = pure () go 0 l - return $ fromPrimitivePersistValue k - -getList' :: forall a . PersistField a => Int64 -> Action Sqlite [a] + 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 (liftM fst . fromPersistValues) >>= streamToList - + queryRawCached' query [toPrimitivePersistValue k] >>= mapStream (fmap fst . fromPersistValues) >>= streamToList + getLastInsertRowId :: Action Sqlite PersistValue getLastInsertRowId = do Sqlite conn _ <- ask @@ -449,41 +486,44 @@ ---------- bind :: S.Statement -> [PersistValue] -> IO () -bind stmt = go 1 where - go _ [] = return () - 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 +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 + -- $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 - return () + 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 + -- $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 - return () + 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 @@ -492,13 +532,13 @@ let open = do stmt <- runReaderT (getStmt query) conn bind stmt vals - return stmt + pure stmt mkNext stmt = do x <- S.step stmt case x of - S.Done -> return Nothing - S.Row -> fmap (Just . map pFromSql) $ S.columns stmt - return $ fmap mkNext $ mkAcquire open close + 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 @@ -506,10 +546,10 @@ 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 +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 @@ -519,9 +559,10 @@ escapeS a = let q = fromChar '"' in q <> a <> q renderConfig :: RenderConfig -renderConfig = RenderConfig { - esc = escapeS -} +renderConfig = + RenderConfig + { esc = escapeS + } defaultPriority, triggerPriority :: Int defaultPriority = 0 @@ -534,7 +575,7 @@ delim' = fromChar delim toEntityPersistValues' :: PersistEntity v => v -> Action Sqlite [PersistValue] -toEntityPersistValues' = liftM ($ []) . toEntityPersistValues +toEntityPersistValues' = fmap ($ []) . toEntityPersistValues compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2 @@ -542,14 +583,16 @@ 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 + 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 @@ -562,58 +605,88 @@ 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 + 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 +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, concat - [ "DROP INDEX " - , escape uName - ]) +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 diff --git a/groundhog-sqlite.cabal b/groundhog-sqlite.cabal --- a/groundhog-sqlite.cabal +++ b/groundhog-sqlite.cabal @@ -1,5 +1,5 @@ name: groundhog-sqlite -version: 0.11.0 +version: 0.12.0 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -8,7 +8,7 @@ description: It depends on direct-sqlite library which includes Sqlite C sources, so there are no system dependencies. category: Database stability: Stable -cabal-version: >= 1.6 +cabal-version: >= 1.10 build-type: Simple extra-source-files: @@ -18,7 +18,7 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 - , groundhog >= 0.11.0 && < 0.12 + , groundhog >= 0.12.0 && < 0.13 , monad-control >= 0.3 && < 1.1 , containers >= 0.2 , text >= 0.8 @@ -28,6 +28,7 @@ , resourcet >= 1.1.2 exposed-modules: Database.Groundhog.Sqlite ghc-options: -Wall -fno-warn-unused-do-bind + default-language: Haskell2010 source-repository head type: git