diff --git a/Database/Groundhog/Generic/Sql/Utf8.hs b/Database/Groundhog/Generic/Sql/Utf8.hs deleted file mode 100644 --- a/Database/Groundhog/Generic/Sql/Utf8.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Database.Groundhog.Generic.Sql.Utf8 - ( module Database.Groundhog.Generic.Sql - , Utf8 (..) - , fromUtf8 - ) where - -import Database.Groundhog.Core -import Database.Groundhog.Generic.Sql -import Blaze.ByteString.Builder -import qualified Blaze.ByteString.Builder.Char.Utf8 as B -import Data.ByteString -import Data.Monoid -import Data.String - -newtype Utf8 = Utf8 Builder - -fromUtf8 :: Utf8 -> ByteString -fromUtf8 (Utf8 a) = toByteString a - -instance Monoid Utf8 where - mempty = Utf8 mempty - mappend (Utf8 a) (Utf8 b) = Utf8 (mappend a b) - -instance IsString Utf8 where - fromString = Utf8 . B.fromString - -instance StringLike Utf8 where - fromChar = Utf8 . B.fromChar - -{-# SPECIALIZE (<>) :: RenderS Utf8 -> RenderS Utf8 -> RenderS Utf8 #-} - -{-# SPECIALIZE renderArith :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (Utf8 -> Utf8) -> Arith v c a -> RenderS Utf8 #-} - -{-# SPECIALIZE renderCond :: (PersistEntity v, Constructor c, DbDescriptor db) - => Proxy db - -> (Utf8 -> Utf8) - -> (Utf8 -> Utf8 -> Utf8) - -> (Utf8 -> Utf8 -> Utf8) - -> Cond v c -> Maybe (RenderS Utf8) #-} - -{-# SPECIALIZE renderOrders :: (PersistEntity v, Constructor c) => (Utf8 -> Utf8) -> [Order v c] -> Utf8 #-} - -{-# SPECIALIZE renderUpdates :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (Utf8 -> Utf8) -> [Update v c] -> Maybe (RenderS Utf8) #-} - -{-# SPECIALIZE renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8 #-} - -{-# SPECIALIZE renderChain :: (Utf8 -> Utf8) -> FieldChain -> [Utf8] -> [Utf8] #-} diff --git a/Database/Groundhog/Sqlite.hs b/Database/Groundhog/Sqlite.hs --- a/Database/Groundhog/Sqlite.hs +++ b/Database/Groundhog/Sqlite.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types, MultiParamTypeClasses #-} module Database.Groundhog.Sqlite ( withSqlitePool , withSqliteConn - , runSqlitePool - , runSqliteConn + , runDbConn , Sqlite , module Database.Groundhog + , module Database.Groundhog.Generic.Sql.Functions ) where import Database.Groundhog @@ -13,7 +13,8 @@ import Database.Groundhog.Generic import Database.Groundhog.Generic.Migration hiding (MigrationPack(..)) import qualified Database.Groundhog.Generic.Migration as GM -import Database.Groundhog.Generic.Sql.Utf8 +import Database.Groundhog.Generic.Sql +import Database.Groundhog.Generic.Sql.Functions import qualified Database.Groundhog.Generic.PersistBackendHelpers as H import qualified Database.Sqlite as S @@ -23,15 +24,15 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask) -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import Data.Char (toUpper) import Data.Function (on) 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 (maybeToList) -import Data.Conduit.Pool +import Data.Maybe (fromMaybe) +import Data.Pool import qualified Data.Text as T import GHC.Exts (inline) @@ -41,11 +42,17 @@ instance DbDescriptor Sqlite where type AutoKeyType Sqlite = Int64 + type QueryRaw Sqlite = Snippet Sqlite + backendName _ = "sqlite" +instance SqlDb Sqlite where + append a b = Expr $ operator 50 "||" a b + instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Sqlite m) where {-# SPECIALIZE instance PersistBackend (DbPersist Sqlite IO) #-} type PhantomDb (DbPersist Sqlite m) = Sqlite insert v = insert' v + insert_ v = insert_' v insertBy u v = H.insertBy escapeS queryRawTyped u v insertByAll v = H.insertByAll escapeS queryRawTyped v replace k v = H.replace escapeS queryRawTyped executeRawCached' insertIntoConstructorTable k v @@ -69,9 +76,17 @@ insertList l = insertList' l getList k = getList' k ---{-# SPECIALIZE INLINE H.get :: (MonadBaseControl IO m, MonadIO m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a) -> Key v BackendSpecific -> DbPersist Sqlite m (Maybe v) #-} +instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist Sqlite m) where + listTables _ = queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] (mapAllRows $ return . fst . fromPurePersistValues proxy) + listTableTriggers _ name = queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy) + analyzeTable = analyzeTable' + analyzeTrigger _ name = do + x <- queryRaw' "SELECT sql FROM sqlite_master WHERE type='trigger' AND name=?" [toPrimitivePersistValue proxy name] id + case x of + Nothing -> return Nothing + Just src -> return (fst $ fromPurePersistValues proxy src) + analyzeFunction = error "analyzeFunction: is not supported by Sqlite" ---{-# SPECIALIZE withSqlitePool :: String -> Int -> (Pool Sqlite -> IO a) -> IO a #-} withSqlitePool :: (MonadBaseControl IO m, MonadIO m) => String -> Int -- ^ number of connections to open @@ -87,20 +102,30 @@ -> m a withSqliteConn s = bracket (liftIO $ open' s) (liftIO . close') -{-# SPECIALIZE runSqlitePool :: DbPersist Sqlite IO a -> Pool Sqlite -> IO a #-} -runSqlitePool :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m a -> Pool Sqlite -> m a -runSqlitePool f pconn = withResource pconn $ runSqliteConn f +instance Savepoint Sqlite where + withConnSavepoint name m (Sqlite c _) = do + let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt + let name' = fromString name + liftIO $ runStmt $ "SAVEPOINT " <> name' + x <- onException m (liftIO $ runStmt $ "ROLLBACK TO " <> name') + liftIO $ runStmt $ "RELEASE " <> name' + return x -{-# SPECIALIZE runSqliteConn :: DbPersist Sqlite IO a -> Sqlite -> IO a #-} -{-# INLINE runSqliteConn #-} -runSqliteConn :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m a -> Sqlite -> m a -runSqliteConn f conn@(Sqlite c _) = do - let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt - liftIO $ runStmt "BEGIN" - x <- onException (runDbPersist f conn) (liftIO $ runStmt "ROLLBACK") - liftIO $ runStmt "COMMIT" - return x +instance ConnectionManager Sqlite Sqlite where + withConn f conn@(Sqlite c _) = do + let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt + liftIO $ runStmt "BEGIN" + x <- onException (f conn) (liftIO $ runStmt "ROLLBACK") + liftIO $ runStmt "COMMIT" + return x + withConnNoTransaction f conn = f conn +instance ConnectionManager (Pool Sqlite) Sqlite where + withConn f pconn = withResource pconn (withConn f) + withConnNoTransaction f pconn = withResource pconn (withConnNoTransaction f) + +instance SingleConnectionManager Sqlite Sqlite + open' :: String -> IO Sqlite open' s = do conn <- S.open s @@ -121,12 +146,12 @@ compareTypes compareRefs compareUniqs - checkTable migTriggerOnDelete migTriggerOnUpdate GM.defaultMigConstr escape - "INTEGER PRIMARY KEY" + DbInt64 + "INTEGER PRIMARY KEY NOT NULL" "INTEGER" mainTableId defaultPriority @@ -136,87 +161,75 @@ addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable]) addUniquesReferences uniques refs = (map sqlUnique constraints ++ map sqlReference refs, map AddUnique indexes) where - (constraints, indexes) = partition (\(UniqueDef' _ uType _) -> uType == UniqueConstraint) uniques + (constraints, indexes) = partition ((/= UniqueIndex) . uniqueDefType) uniques --- it handles only delete operations. So far when list replace is not allowed, it is ok -migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB]) -migTriggerOnDelete name deletes = do - let addTrigger = AddTriggerOnDelete name name (concatMap snd deletes) - x <- checkTrigger name +migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB]) +migTriggerOnDelete schema name deletes = do + let addTrigger = AddTriggerOnDelete Nothing name Nothing name (concatMap snd deletes) + x <- analyzeTrigger schema name return $ 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 name name] + then [DropTrigger Nothing name Nothing name] else if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger then [] -- this can happen when an ephemeral field was added or removed. - else [DropTrigger name name, addTrigger]) + else [DropTrigger Nothing name Nothing name, addTrigger]) --- | Table name and a list of field names and according delete statements +-- | 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 :: (MonadBaseControl IO m, MonadIO m) => String -> String -> String -> DbPersist Sqlite m (Bool, [AlterDB]) -migTriggerOnUpdate name fieldName del = do +migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m [(Bool, [AlterDB])] +migTriggerOnUpdate schema name dels = forM dels $ \(fieldName, del) -> do let trigName = name ++ delim : fieldName - let addTrigger = AddTriggerOnUpdate trigName name fieldName del - x <- checkTrigger trigName + let addTrigger = AddTriggerOnUpdate Nothing trigName Nothing name (Just fieldName) del + x <- analyzeTrigger schema trigName return $ case x of Nothing -> (False, [addTrigger]) Just sql -> (True, if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger then [] - else [DropTrigger trigName name, addTrigger]) - -checkTrigger :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String) -checkTrigger = checkSqliteMaster "trigger" - -checkSqliteMaster :: (MonadBaseControl IO m, MonadIO m) => String -> String -> DbPersist Sqlite m (Maybe String) -checkSqliteMaster vtype name = do - let query = "SELECT sql FROM sqlite_master WHERE type = ? AND name = ?" - x <- queryRawTyped query [DbString] [toPrimitivePersistValue proxy vtype, toPrimitivePersistValue proxy name] id - let throwErr = error . ("Unexpected result from sqlite_master: " ++) - case x of - Nothing -> return Nothing - Just [hsql] -> case hsql of - PersistString sql -> return $ Just sql - err -> throwErr $ "column sql is not string: " ++ show err - Just xs -> throwErr $ "requested 1 column, returned " ++ show xs + else [DropTrigger Nothing trigName Nothing name, addTrigger]) -checkTable :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe (Either [String] TableInfo)) -checkTable tableName = do +analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Sqlite m (Either [String] (Maybe TableInfo)) +analyzeTable' _ tName = do let fromName = escapeS . fromString - tableInfo <- queryRaw' ("pragma table_info(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) + tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) case tableInfo of - [] -> return Nothing - xs -> liftM Just $ do - let rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 0) xs + [] -> return $ Right 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 + let primaryKeyColumnNames = foldr (\(_ , (name, _, _, _, isPrimary)) xs -> if isPrimary == 1 then name:xs else xs) [] rawColumns let columns = map mkColumn rawColumns - indexList <- queryRaw' ("pragma index_list(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) + indexList <- queryRaw' ("pragma index_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) let uniqueNames = map (\(_ :: Int, name, _) -> name) $ filter (\(_, _, isUnique) -> isUnique) indexList uniques <- forM uniqueNames $ \name -> do uFields <- queryRaw' ("pragma index_info(" <> fromName name <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) sql <- queryRaw' ("select sql from sqlite_master where type = 'index' and name = ?") [toPrimitivePersistValue proxy name] id - let uType = if sql == Just [PersistNull] then UniqueConstraint else UniqueIndex - return $ UniqueDef' name uType $ map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)]) - foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) + let columnNames = map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)]) + let uType = if sql == Just [PersistNull] + then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary else UniqueConstraint + else UniqueIndex + return $ UniqueDef' (Just name) uType columnNames + foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) (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, _, _)) = head rows + let (_, (_, foreignTable, _, (onUpdate, onDelete, _))) = head rows refs <- forM rows $ \(_, (_, _, (child, parent), _)) -> case parent of - Nothing -> checkPrimaryKey foreignTable >>= \x -> case x of + Nothing -> analyzePrimaryKey foreignTable >>= \x -> case x of Just primaryKeyName -> return (child, primaryKeyName) - Nothing -> error $ "checkTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names" + Nothing -> error $ "analyzeTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names" Just columnName -> return (child, columnName) - return (Nothing, (foreignTable, refs)) - primaryKey <- checkPrimaryKey tableName - return $ Right $ TableInfo primaryKey columns uniques foreigns + return (Nothing, Reference Nothing foreignTable refs (mkAction onDelete) (mkAction onUpdate)) + let uniques' = uniques ++ if length primaryKeyColumnNames == 1 then [UniqueDef' Nothing UniquePrimary primaryKeyColumnNames] else [] + return $ Right $ Just $ TableInfo columns uniques' foreigns -checkPrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String) -checkPrimaryKey tableName = do - tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tableName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) +analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String) +analyzePrimaryKey tName = do + tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) let rawColumns :: [(Int, (String, String, Int, Maybe String, Int))] rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 1) tableInfo return $ case rawColumns of @@ -254,10 +267,10 @@ showSqlType DbDayTime = "TIMESTAMP" showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE" showSqlType DbBlob = "BLOB" -showSqlType (DbOther name) = name +showSqlType (DbOther (OtherTypeDef f)) = f showSqlType showSqlType (DbMaybe t) = showSqlType t showSqlType (DbList _ _) = showSqlType DbInt64 -showSqlType (DbEntity Nothing _) = showSqlType DbInt64 +showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64 showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t readSqlType :: String -> DbType @@ -270,26 +283,12 @@ readSqlType "TIMESTAMP" = DbDayTime readSqlType "TIMESTAMP WITH TIME ZONE" = DbDayTimeZoned readSqlType "BLOB" = DbBlob -readSqlType typ = DbOther typ +readSqlType typ = DbOther $ OtherTypeDef $ const typ data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show) dbTypeAffinity :: DbType -> Affinity -dbTypeAffinity DbString = TEXT -dbTypeAffinity DbInt32 = INTEGER -dbTypeAffinity DbInt64 = INTEGER -dbTypeAffinity DbReal = REAL -dbTypeAffinity DbBool = NUMERIC -dbTypeAffinity DbDay = NUMERIC -dbTypeAffinity DbTime = NUMERIC -dbTypeAffinity DbDayTime = NUMERIC -dbTypeAffinity DbDayTimeZoned = NUMERIC -dbTypeAffinity DbBlob = NONE -dbTypeAffinity (DbOther name) = readSqlTypeAffinity name -dbTypeAffinity (DbMaybe t) = dbTypeAffinity t -dbTypeAffinity (DbList _ _) = INTEGER -dbTypeAffinity (DbEntity Nothing _) = INTEGER -dbTypeAffinity t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t +dbTypeAffinity = readSqlTypeAffinity . showSqlType readSqlTypeAffinity :: String -> Affinity readSqlTypeAffinity typ = affinity where @@ -308,18 +307,23 @@ else "" sqlReference :: Reference -> String -sqlReference (tname, columns) = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape tname ++ "(" ++ foreign ++ ")" where - (our, foreign) = f *** f $ unzip columns +sqlReference Reference{..} = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape referencedTableName ++ "(" ++ foreign ++ ")" ++ actions where + actions = maybe "" ((" ON DELETE " ++) . showReferenceAction) referenceOnDelete + ++ maybe "" ((" ON UPDATE " ++) . showReferenceAction) referenceOnUpdate + (our, foreign) = f *** f $ unzip referencedColumns f = intercalate ", " . map escape sqlUnique :: UniqueDef' -> String -sqlUnique (UniqueDef' name _ cols) = concat - [ "CONSTRAINT " - , escape name - , " UNIQUE (" - , intercalate "," $ map escape cols - , ")" - ] +sqlUnique (UniqueDef' name typ cols) = concat [ + maybe "" ((" CONSTRAINT " ++) . escape) name + , constraintType + , intercalate "," $ map escape cols + , ")" + ] where + constraintType = case typ of + UniquePrimary -> " PRIMARY KEY(" + UniqueConstraint -> " UNIQUE(" + UniqueIndex -> error "sqlUnique: does not handle indexes" {-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Sqlite IO (AutoKey v) #-} insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m (AutoKey v) @@ -327,35 +331,55 @@ -- constructor number and the rest of the field values vals <- toEntityPersistValues' v let e = entityDef v - let name = persistName v let constructorNum = fromPrimitivePersistValue proxy (head vals) liftM fst $ if isSimple (constructors e) then do let constr = head $ constructors e - let query = insertIntoConstructorTable False name constr - executeRawCached' query (tail vals) + 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 cName = name ++ [delim] ++ constrName constr - let query = "INSERT INTO " <> escapeS (fromString name) <> "(discr)VALUES(?)" + let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)" executeRawCached' query $ take 1 vals rowid <- getLastInsertRowId - let cQuery = insertIntoConstructorTable True cName constr - executeRawCached' cQuery $ rowid:(tail vals) + let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals) + executeRawCached' cQuery (vals' []) pureFromPersistValue [rowid] +{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Sqlite IO () #-} +insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m () +insert_' v = do + -- constructor number and the rest of the field values + vals <- toEntityPersistValues' v + let e = entityDef v + let constructorNum = fromPrimitivePersistValue proxy (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 -> String -> ConstructorDef -> Utf8 -insertIntoConstructorTable withId tName c = "INSERT INTO " <> escapeS (fromString tName) <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" where +insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r +insertIntoConstructorTable withId tName c vals = RenderS query vals' where + query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" fields = case constrAutoKeyName c of Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c _ -> constrParams c fieldNames = renderFields escapeS fields - placeholders = renderFields (const $ fromChar '?') fields + RenderS placeholders vals' = commasJoin $ map renderPersistValue vals insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64 insertList' l = do @@ -398,16 +422,17 @@ go _ [] = return () go i (x:xs) = do case x of - PersistInt64 int64 -> S.bindInt64 stmt i int64 - 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 + PersistInt64 int64 -> S.bindInt64 stmt i int64 + 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' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m () @@ -475,13 +500,13 @@ typeToSqlite (DbOther _) = Nothing typeToSqlite (DbMaybe _) = Nothing typeToSqlite (DbList _ _) = Just S.IntegerColumn -typeToSqlite (DbEntity Nothing _) = Just S.IntegerColumn +typeToSqlite (DbEntity Nothing _ _ _) = Just S.IntegerColumn typeToSqlite t = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t getDbTypes :: DbType -> [DbType] -> [DbType] getDbTypes typ acc = case typ of DbEmbedded (EmbeddedDef _ ts) -> foldr (getDbTypes . snd) acc ts - DbEntity (Just (EmbeddedDef _ ts, _)) _ -> foldr (getDbTypes . snd) acc ts + DbEntity (Just (EmbeddedDef _ ts, _)) _ _ _ -> foldr (getDbTypes . snd) acc ts t -> t:acc pFromSql :: S.SQLData -> PersistValue @@ -498,15 +523,13 @@ escapeS :: Utf8 -> Utf8 escapeS a = let q = fromChar '"' in q <> a <> q -renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> Maybe (RenderS Utf8) -renderCond' = renderCond proxy escapeS renderEquals renderNotEquals where +renderCond' :: Cond Sqlite r -> Maybe (RenderS Sqlite r) +renderCond' = renderCond escapeS renderEquals renderNotEquals where renderEquals a b = a <> " IS " <> b renderNotEquals a b = a <> " IS NOT " <> b -defaultPriority :: Int +defaultPriority, triggerPriority :: Int defaultPriority = 0 - -triggerPriority :: Int triggerPriority = 1 proxy :: Proxy Sqlite @@ -519,10 +542,17 @@ toEntityPersistValues' = liftM ($ []) . toEntityPersistValues compareUniqs :: UniqueDef' -> UniqueDef' -> Bool +compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2 +-- only one of the uniques is primary +compareUniqs (UniqueDef' _ type1 _) (UniqueDef' _ type2 _) | UniquePrimary `elem` [type1, type2] = False compareUniqs (UniqueDef' _ type1 cols1) (UniqueDef' _ type2 cols2) = haveSameElems (==) cols1 cols2 && type1 == type2 compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool -compareRefs (_, (tbl1, pairs1)) (_, (tbl2, pairs2)) = unescape tbl1 == unescape tbl2 && haveSameElems (==) pairs1 pairs2 where +compareRefs (_, Reference _ tbl1 pairs1 onDel1 onUpd1) (_, Reference _ tbl2 pairs2 onDel2 onUpd2) = + unescape tbl1 == unescape 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 :: DbType -> DbType -> Bool @@ -534,7 +564,7 @@ showAlterDb :: AlterDB -> SingleMigration showAlterDb (AddTable s) = Right [(False, defaultPriority, s)] -showAlterDb (AlterTable table createTable (TableInfo oldId oldCols _ _) (TableInfo newId newCols _ _) alts) = case mapM (showAlterTable table) alts of +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 ++ ")") @@ -547,20 +577,37 @@ 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 $ maybeToList (newId >> oldId) ++ map (colName . snd) commonColumns - columnsNew = intercalate "," $ map escape $ maybeToList (oldId >> newId) ++ map (colName . snd) commonColumns -showAlterDb (DropTrigger name _) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape name)] -showAlterDb (AddTriggerOnDelete trigName tableName body) = Right [(False, triggerPriority, - "CREATE TRIGGER " ++ escape trigName ++ " DELETE ON " ++ escape tableName ++ " BEGIN " ++ body ++ "END")] -showAlterDb (AddTriggerOnUpdate trigName tableName fieldName body) = Right [(False, triggerPriority, - "CREATE TRIGGER " ++ escape trigName ++ " UPDATE OF " ++ escape fieldName ++ " ON " ++ escape tableName ++ " BEGIN " ++ body ++ "END")] + columnsTmp = intercalate "," $ map (escape . colName . snd) commonColumns + columnsNew = intercalate "," $ map (escape . colName . snd) commonColumns +showAlterDb (DropTrigger _ name _ _) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape name)] +showAlterDb (AddTriggerOnDelete _ trigName _ tName body) = Right [(False, triggerPriority, + "CREATE TRIGGER " ++ escape trigName ++ " DELETE ON " ++ escape tName ++ " BEGIN " ++ body ++ "END")] +showAlterDb (AddTriggerOnUpdate _ trigName _ tName fieldName body) = Right [(False, triggerPriority, + "CREATE TRIGGER " ++ escape trigName ++ " UPDATE OF " ++ fieldName' ++ " ON " ++ escape tName ++ " BEGIN " ++ body ++ "END")] where + fieldName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ trigName) escape fieldName showAlterDb alt = error $ "showAlterDb: does not support " ++ show alt showAlterTable :: String -> AlterTable -> Maybe (Bool, Int, String) -showAlterTable table (AlterColumn alt) = showAlterColumn table alt +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 " - , escape uName + , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName , " ON " , escape table , "(" @@ -572,23 +619,3 @@ , escape uName ]) showAlterTable _ _ = Nothing - -showAlterColumn :: String -> AlterColumn' -> Maybe (Bool, Int, String) -showAlterColumn table (_, Add col) = Just (False, defaultPriority, concat - [ "ALTER TABLE " - , escape table - , " ADD COLUMN " - , showColumn col - ]) -showAlterColumn table (n, UpdateValue s) = Just (False, defaultPriority, concat - [ "UPDATE " - , escape table - , " SET " - , escape n - , "=" - , s - , " WHERE " - , escape n - , " IS NULL" - ]) -showAlterColumn _ _ = Nothing 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.2.0 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -19,16 +19,14 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 && < 0.4 - , groundhog >= 0.2.0 && < 0.3.0 + , groundhog >= 0.3.0 && < 0.4.0 , monad-control >= 0.3 && < 0.4 , containers >= 0.2 , text >= 0.8 && < 0.12 - , blaze-builder >= 0.3.0.0 && < 0.4 - , pool-conduit >= 0.1 && < 0.2 + , resource-pool >= 0.2.1 && < 0.3 , unordered-containers exposed-modules: Database.Sqlite Database.Groundhog.Sqlite - other-modules: Database.Groundhog.Generic.Sql.Utf8 ghc-options: -Wall -fno-warn-unused-do-bind if flag(systemlib) extra-libraries: sqlite3