groundhog-sqlite 0.0.1.1 → 0.1.0
raw patch · 5 files changed
+407/−620 lines, 5 filesdep +blaze-builderdep +pool-conduitdep +unordered-containersdep −enumeratordep −pooldep ~groundhogdep ~monad-controldep ~transformers
Dependencies added: blaze-builder, pool-conduit, unordered-containers
Dependencies removed: enumerator, pool
Dependency ranges changed: groundhog, monad-control, transformers
Files
- Database/Groundhog/Generic/Sql/Utf8.hs +47/−0
- Database/Groundhog/Sqlite.hs +335/−594
- Database/Sqlite.hs +11/−17
- cbits/sqlite3.c too large to diff
- groundhog-sqlite.cabal +14/−9
+ Database/Groundhog/Generic/Sql/Utf8.hs view
@@ -0,0 +1,47 @@+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] #-}
Database/Groundhog/Sqlite.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types #-} module Database.Groundhog.Sqlite ( withSqlitePool , withSqliteConn@@ -11,77 +11,88 @@ import Database.Groundhog import Database.Groundhog.Core import Database.Groundhog.Generic-import Database.Groundhog.Generic.Sql+import Database.Groundhog.Generic.Migration hiding (MigrationPack(..))+import qualified Database.Groundhog.Generic.Migration as GM+import Database.Groundhog.Generic.Sql.Utf8+import qualified Database.Groundhog.Generic.PersistBackendHelpers as H import qualified Database.Sqlite as S -import Control.Exception.Control (bracket, onException, finally)-import Control.Monad(liftM, forM, (>=>))-import Control.Monad.IO.Control (MonadControlIO)+import Control.Arrow ((***))+import Control.Monad (liftM, forM)+import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Class(MonadTrans(..))-import Control.Monad.Trans.Reader(ask)-import Data.Enumerator(Enumerator, Iteratee(..), Stream(..), checkContinue0, (>>==), joinE, runIteratee, continue, concatEnums)-import qualified Data.Enumerator.List as EL+import Control.Monad.Trans.Reader (ask)+import qualified Data.ByteString as BS+import Data.Char (toUpper)+import Data.Function (on) import Data.Int (Int64)-import Data.List (intercalate)+import Data.List (groupBy, intercalate, isInfixOf, sort) import Data.IORef-import qualified Data.Map as Map-import Data.Pool+import qualified Data.HashMap.Strict as Map+import Data.Maybe (maybeToList)+import Data.Conduit.Pool +import GHC.Exts (inline)+ -- typical operations for connection: OPEN, BEGIN, COMMIT, ROLLBACK, CLOSE-data Sqlite = Sqlite S.Database (IORef (Map.Map String S.Statement))+data Sqlite = Sqlite S.Database (IORef (Map.HashMap BS.ByteString S.Statement)) -instance MonadControlIO m => PersistBackend (DbPersist Sqlite m) where+instance DbDescriptor Sqlite where+ type AutoKeyType Sqlite = Int64++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- insertBy v = insertBy' v- replace k v = replace' k v- selectEnum cond ords limit offset = selectEnum' cond ords limit offset- selectAllEnum = selectAllEnum'- select cond ords limit offset = select' cond ords limit offset- selectAll = selectAll'- get k = get' k- update upds cond = update' upds cond- delete cond = delete' cond- deleteByKey k = deleteByKey' k- count cond = count' cond- countAll fakeV = countAll' fakeV+ 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+ select options = H.select escapeS queryRawTyped "LIMIT -1" renderCond' options -- select' options+ selectAll = H.selectAll escapeS queryRawTyped+ get k = inline $ H.get escapeS queryRawTyped k+ getBy k = H.getBy escapeS queryRawTyped k+ update upds cond = H.update escapeS executeRawCached' renderCond' upds cond+ delete cond = H.delete escapeS executeRawCached' renderCond' cond+ deleteByKey k = H.deleteByKey escapeS executeRawCached' k+ count cond = H.count escapeS queryRawTyped renderCond' cond+ countAll fakeV = H.countAll escapeS queryRawTyped fakeV+ project p options = H.project escapeS queryRawTyped "LIMIT -1" renderCond' p options migrate fakeV = migrate' fakeV - executeRaw False query ps = executeRaw' query ps- executeRaw True query ps = executeRawCached' query ps- queryRaw False query ps f = queryRaw' query ps f- queryRaw True query ps f = queryRawCached' query ps f+ executeRaw False query ps = executeRaw' (fromString query) ps+ executeRaw True query ps = executeRawCached' (fromString query) ps+ queryRaw False query ps f = queryRaw' (fromString query) ps f+ queryRaw True query ps f = queryRawCached' (fromString query) ps f insertList l = insertList' l getList k = getList' k- insertTuple t ts = insertTuple' t ts- getTuple t k = getTuple' t 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) #-}+ --{-# SPECIALIZE withSqlitePool :: String -> Int -> (Pool Sqlite -> IO a) -> IO a #-}-withSqlitePool :: MonadControlIO m+withSqlitePool :: (MonadBaseControl IO m, MonadIO m) => String -> Int -- ^ number of connections to open -> (Pool Sqlite -> m a) -> m a-withSqlitePool s = createPool (open' s) close'+withSqlitePool s connCount f = liftIO (createPool (open' s) close' 1 20 connCount) >>= f {-# SPECIALIZE withSqliteConn :: String -> (Sqlite -> IO a) -> IO a #-} {-# INLINE withSqliteConn #-}-withSqliteConn :: MonadControlIO m+withSqliteConn :: (MonadBaseControl IO m, MonadIO m) => String -> (Sqlite -> m a) -> m a-withSqliteConn s = bracket (liftIO $ open' s) (liftIO.close')+withSqliteConn s = bracket (liftIO $ open' s) (liftIO . close') {-# SPECIALIZE runSqlitePool :: DbPersist Sqlite IO a -> Pool Sqlite -> IO a #-}-runSqlitePool :: MonadControlIO m => DbPersist Sqlite m a -> Pool Sqlite -> m a-runSqlitePool = flip withPool' . runSqliteConn+runSqlitePool :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m a -> Pool Sqlite -> m a+runSqlitePool f pconn = withResource pconn $ runSqliteConn f {-# SPECIALIZE runSqliteConn :: DbPersist Sqlite IO a -> Sqlite -> IO a #-} {-# INLINE runSqliteConn #-}-runSqliteConn :: MonadControlIO m => DbPersist Sqlite m a -> Sqlite -> m a+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"@@ -92,6 +103,7 @@ open' :: String -> IO Sqlite open' s = do conn <- S.open s+ S.prepare conn "PRAGMA foreign_keys = ON" >>= \stmt -> S.step stmt >> S.finalize stmt cache <- newIORef Map.empty return $ Sqlite conn cache @@ -100,181 +112,63 @@ readIORef smap >>= mapM_ S.finalize . Map.elems S.close conn -{- ********************RULES******************** ---For type with a single constructor, a single table is created.-TABLE Entity(id, [fields])-If constructor has no fields, then ????--For type with a multiple constructors, the main table is created.-TABLE(id, discriminator)-where discriminator is defined by constructor.-Each constructor has its table, where id is the same as in -TABLE EntityConstructor2(id, [fields])--In Java Hibernate each class member of list type is stored in a separate table-TABLE Student$Phones(studentId, phone)-Here we can use triggers to automatically remove list after Student removal.-However, toPersistValue :: a -> DbPersist conn m () becomes impossible because we must know container id--We can either follow this scheme or store same type lists from different types in one table-TABLE List$Int(id, value)---- ********************************************* --}-migrate' :: (PersistEntity v, MonadControlIO m) => v -> Migration (DbPersist Sqlite m)-migrate' = migrateRecursively migE migT migL where- migE e = do- let name = getEntityName e- let constrs = constructors e- let mainTableQuery = "CREATE TABLE " ++ escape name ++ " (id INTEGER PRIMARY KEY, discr INTEGER NOT NULL)"- if isSimple constrs- then do- x <- checkTable name- -- check whether the table was created for multiple constructors before- case x of- Just sql | sql == mainTableQuery -> do- return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]- _ -> liftM snd $ migConstrAndTrigger True name $ head constrs- else do- mainsql <- checkTable name- let constrTable c = name ++ [defDelim] ++ constrName c- res <- mapM (\c -> migConstrAndTrigger False name c) constrs- case mainsql of- Nothing -> do- -- no constructor tables can exist if there is no main data table- let orphans = filter fst res- return $ if null orphans- then mergeMigrations $ Right [(False, mainTableQuery)]:map snd res- else Left $ foldl (\l (_, c) -> ("Orphan constructor table found: " ++ constrTable c):l) [] $ filter (fst.fst) $ zip res constrs- Just sql -> do- if sql == mainTableQuery- then do -- the datatype had also many constructors before--- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end- return $ if any (not.fst) res- then Left ["Migration with constructors addition will be implemented soon. Datatype: " ++ name]- else mergeMigrations $ map snd res- else do- return $ Left ["Migration from one constructor to many will be implemented soon. Datatype: " ++ name]- - -- we don't need any escaping because tuple table name and fields are always valid- migT n ts = do- let name = intercalate "$" $ ("Tuple" ++ show n ++ "$") : map getName ts- let fields = zipWith (\i t -> ("val" ++ show i, t)) [0::Int ..] ts- (_, trigger) <- migTriggerOnDelete name $ mkDeletesOnDelete fields- x <- checkTable name- let fields' = concatMap (\(s, t) -> sqlColumn s (getType t)) fields- let query = "CREATE TABLE " ++ name ++ " (id INTEGER PRIMARY KEY" ++ fields' ++ ")"- return $ case x of- Nothing -> mergeMigrations [Right [(False, query)], trigger]- Just sql -> if sql == query- then Right []- else Left ["Tuple table " ++ name ++ " has unexpected structure"]-- -- we should consider storing tuples as is, not their id. For example for [(a, b)] this will prevent many unnecessary queries- --TODO:finish- migL t = do- let mainName = "List$" ++ "$" ++ getName t- let valuesName = mainName ++ "$" ++ "values"- let mainQuery = "CREATE TABLE " ++ mainName ++ " (id INTEGER PRIMARY KEY)"- let valuesQuery = "CREATE TABLE " ++ valuesName ++ " (id INTEGER, ord$ INTEGER NOT NULL" ++ sqlColumn "value" (getType t) ++ ")"- x <- checkTable mainName- y <- checkTable valuesName- (_, triggerMain) <- migTriggerOnDelete mainName ["DELETE FROM " ++ valuesName ++ " WHERE id=old.id;"]- (_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletesOnDelete [("value", t)]- let f name a b = if a /= b then ["List table " ++ name ++ " error. Expected: " ++ a ++ ". Found: " ++ b] else []- return $ case (x, y) of- (Nothing, Nothing) -> mergeMigrations [Right [(False, mainQuery), (False, valuesQuery)], triggerMain, triggerValues]- (Just sql1, Just sql2) -> let errors = f mainName mainQuery sql1 ++ f valuesName valuesQuery sql2- in if null errors then Right [] else Left errors- (_, Nothing) -> Left ["Found orphan main list table " ++ mainName]- (Nothing, _) -> Left ["Found orphan list values table " ++ valuesName]--migConstrAndTrigger :: MonadControlIO m => Bool -> String -> ConstructorDef -> DbPersist Sqlite m (Bool, SingleMigration)-migConstrAndTrigger simple name constr = do- let cName = if simple then name else name ++ [defDelim] ++ constrName constr- (constrExisted, mig) <- migConstr cName constr- let dels = mkDeletesOnDelete $ constrParams constr- let allDels = if simple then dels else ("DELETE FROM " ++ escape name ++ " WHERE id=old." ++ constrId ++ ";"):dels- (triggerExisted, delTrigger) <- migTriggerOnDelete cName allDels- let updDels = mkDeletesOnUpdate $ constrParams constr- updTriggers <- mapM (liftM snd . uncurry (migTriggerOnUpdate cName)) updDels- return $ if constrExisted == triggerExisted || (constrExisted && null allDels)- then (constrExisted, mergeMigrations ([mig, delTrigger] ++ updTriggers))- -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error- else (constrExisted, Left ["Trigger and constructor table must exist together: " ++ cName])+migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Sqlite m)+migrate' = migrateRecursively (migrateEntity migrationPack) (migrateList migrationPack) -migConstr :: MonadControlIO m => String -> ConstructorDef -> DbPersist Sqlite m (Bool, SingleMigration)-migConstr name constr = do- let fields = constrParams constr- let uniques = constrConstrs constr- let query = "CREATE TABLE " ++ escape name ++ " (" ++ constrId ++ " INTEGER PRIMARY KEY" ++ concatMap (\(n, t) -> sqlColumn n (getType t)) fields ++ concatMap sqlUnique uniques ++ ")"- x <- checkTable name- return $ case x of- Nothing -> (False, Right [(False, query)])- Just sql -> (True, if sql == query- then Right []- else Left ["Constructor table must be altered: " ++ name])+migrationPack :: (MonadBaseControl IO m, MonadIO m) => GM.MigrationPack (DbPersist Sqlite m) Affinity+migrationPack = GM.MigrationPack+ compareColumns+ compareRefs+ compareUniqs+ checkTable+ migTriggerOnDelete+ migTriggerOnUpdate+ GM.defaultMigConstr+ escape+ "INTEGER PRIMARY KEY"+ "INTEGER"+ mainTableId+ defaultPriority+ dbTypeAffinity+ (\uniques refs -> (map sqlUnique uniques ++ map sqlReference refs, []))+ showColumn+ showAlterDb --- it handles only delete operations. So far when list or tuple replace is not allowed, it is ok-migTriggerOnDelete :: MonadControlIO m => String -> [String] -> DbPersist Sqlite m (Bool, SingleMigration)+-- 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 Affinity]) migTriggerOnDelete name deletes = do- let query = "CREATE TRIGGER " ++ escape name ++ " DELETE ON " ++ escape name ++ " BEGIN " ++ concat deletes ++ "END"+ let addTrigger = AddTriggerOnDelete name name (concatMap snd deletes) x <- checkTrigger name return $ case x of- Nothing | null deletes -> (False, Right [])- Nothing -> (False, Right [(False, query)])+ 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 Right [(False, "DROP TRIGGER " ++ escape name)]- else if sql == query- then Right []- -- this can happen when a field was added or removed. Consider trigger replacement.- else Left ["The trigger " ++ name ++ " is different from expected. Manual migration required.\n" ++ sql ++ "\n" ++ query])+ then [DropTrigger name 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]) -- | Table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields-migTriggerOnUpdate :: MonadControlIO m => String -> String -> String -> DbPersist Sqlite m (Bool, SingleMigration)+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => String -> String -> String -> DbPersist Sqlite m (Bool, [AlterDB Affinity]) migTriggerOnUpdate name fieldName del = do- let tname = name ++ "$" ++ fieldName- let query = "CREATE TRIGGER " ++ escape tname ++ " UPDATE OF " ++ escape fieldName ++ " ON " ++ escape name ++ " BEGIN " ++ del ++ "END"- x <- checkTrigger tname+ let trigName = name ++ delim : fieldName+ let addTrigger = AddTriggerOnUpdate trigName name fieldName del+ x <- checkTrigger trigName return $ case x of- Nothing -> (False, Right [(False, query)])- Just sql -> (True, if sql == query- then Right []- else Left ["The trigger " ++ tname ++ " is different from expected. Manual migration required.\n" ++ sql ++ "\n" ++ query])---- on delete removes all ephemeral data--- TODO: merge several delete queries for a case when a constructor has several fields of the same ephemeral type-mkDeletesOnDelete :: [(String, NamedType)] -> [String]-mkDeletesOnDelete types = map (uncurry delField) ephemerals where- -- we have the same query structure for tuples and lists- delField field t = "DELETE FROM " ++ tname ++ " WHERE id=old." ++ escape field ++ ";" where- tname = getName t- ephemerals = filter (isEphemeral.snd) types+ Nothing -> (False, [addTrigger])+ Just sql -> (True, if Right [(False, triggerPriority, sql)] == showAlterDb addTrigger+ then []+ else [DropTrigger trigName name, addTrigger]) --- on delete removes all ephemeral data-mkDeletesOnUpdate :: [(String, NamedType)] -> [(String, String)]-mkDeletesOnUpdate types = map (uncurry delField) ephemerals where- -- we have the same query structure for tuples and lists- delField field t = (field, "DELETE FROM " ++ tname ++ " WHERE id=old." ++ escape field ++ ";") where- tname = getName t- ephemerals = filter (isEphemeral.snd) types--isEphemeral :: NamedType -> Bool-isEphemeral a = case getType a of- DbList _ -> True- DbTuple _ _ -> True- _ -> False--checkTrigger :: MonadControlIO m => String -> DbPersist Sqlite m (Maybe String)+checkTrigger :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String) checkTrigger = checkSqliteMaster "trigger" -checkTable :: MonadControlIO m => String -> DbPersist Sqlite m (Maybe String)-checkTable = checkSqliteMaster "table"--checkSqliteMaster :: MonadControlIO m => String -> String -> DbPersist Sqlite m (Maybe String)+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] [toPrim vtype, toPrim name] firstRow+ 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@@ -283,22 +177,71 @@ err -> throwErr $ "column sql is not string: " ++ show err Just xs -> throwErr $ "requested 1 column, returned " ++ show xs -getStatementCached :: MonadIO m => String -> DbPersist Sqlite m S.Statement+checkTable :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe (Either [String] (TableInfo Affinity)))+checkTable tableName = do+ let fromName = escapeS . fromString+ tableInfo <- queryRaw' ("pragma table_info(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+ case tableInfo of+ [] -> return Nothing+ xs -> liftM Just $ do+ let rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 0) xs+ let mkColumn :: (Int, (String, String, Int, Maybe String, Int)) -> Column Affinity+ mkColumn (_, (name, typ, isNotNull, defaultValue, _)) = Column name (isNotNull == 0) (readSqlTypeAffinity typ) defaultValue+ let columns = map mkColumn rawColumns+ indexList <- queryRaw' ("pragma index_list(" <> fromName tableName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+ let uniqueNames = map (\(_ :: Int, name, _) -> name) $ filter (\(_, _, isUnique) -> isUnique) indexList+ uniques <- forM uniqueNames $ \name -> do+ let mkUnique :: [(Int, Int, String)] -> UniqueDef'+ mkUnique us = UniqueDef'+ ""+ (map (\(_, _, columnName) -> columnName) us)+ queryRaw' ("pragma index_info(" <> fromName name <> ")") [] $ liftM mkUnique . mapAllRows (return . fst . fromPurePersistValues proxy)+ foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tableName <> ")") [] $ 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)+ --mkForeignKey :: [(Int, (Int, String, (String, Maybe String), (String, String, String)))] -> (Maybe String, Reference)+ forM foreigns $ \rows -> do + let (_, (_, foreignTable, _, _)) = head rows+ refs <- forM rows $ \(_, (_, _, (child, parent), _)) -> case parent of+ Nothing -> checkPrimaryKey foreignTable >>= \x -> case x of+ Left (Just primaryKeyName) -> return (child, primaryKeyName)+ _ -> error $ "checkTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"+ Just columnName -> return (child, columnName)+ return (Nothing, (foreignTable, refs))+ primaryKeyResult <- checkPrimaryKey tableName+ let (primaryKey, uniques') = case primaryKeyResult of+ Left primaryKeyName -> (primaryKeyName, uniques)+ Right u -> (Nothing, u:uniques)+ return $ Right $ TableInfo primaryKey columns uniques' foreigns++checkPrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Either (Maybe String) UniqueDef')+checkPrimaryKey tableName = do+ tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tableName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)+ let rawColumns :: [(Int, (String, String, Int, Maybe String, Int))]+ rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 1) tableInfo+ return $ case rawColumns of+ [] -> Left Nothing+ [(_, (name, _, _, _, _))] -> Left (Just name)+ us -> Right $ UniqueDef' "" (map (\(_, (name, _, _, _, _)) -> name) us)++getStatementCached :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> DbPersist Sqlite m S.Statement getStatementCached sql = do Sqlite conn smap <- DbPersist ask liftIO $ do smap' <- readIORef smap- case Map.lookup sql smap' of+ let sql' = fromUtf8 sql+ case Map.lookup sql' smap' of Nothing -> do- stmt <- S.prepare conn sql- writeIORef smap (Map.insert sql stmt smap')+ stmt <- S.prepare conn sql'+ writeIORef smap (Map.insert sql' stmt smap') return stmt Just stmt -> return stmt -getStatement :: MonadIO m => String -> DbPersist Sqlite m S.Statement+getStatement :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> DbPersist Sqlite m S.Statement getStatement sql = do Sqlite conn _ <- DbPersist ask- liftIO $ S.prepare conn sql+ liftIO $ S.prepare conn (fromUtf8 sql) showSqlType :: DbType -> String showSqlType DbString = "VARCHAR"@@ -309,392 +252,131 @@ showSqlType DbDay = "DATE" showSqlType DbTime = "TIME" showSqlType DbDayTime = "TIMESTAMP"+showSqlType DbDayTimeZoned = "TIMESTAMP" showSqlType DbBlob = "BLOB"-showSqlType (DbMaybe t) = showSqlType (getType t)-showSqlType (DbList _) = "INTEGER"-showSqlType (DbTuple _ _) = "INTEGER"-showSqlType (DbEntity _) = "INTEGER"+showSqlType (DbMaybe t) = showSqlType t+showSqlType (DbList _ _) = showSqlType DbInt64+showSqlType (DbEntity Nothing _) = showSqlType DbInt64+showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t -{--DbMaybe prim -> name type-prim -> name type NOT NULL-comp -> name type NOT NULL REFERENCES table-DbMaybe comp -> name type REFERENCES table--}+data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show) -sqlColumn :: String -> DbType -> String-sqlColumn name typ = ", " ++ escape name ++ " " ++ showSqlType typ ++ f typ where- f (DbMaybe t) = g (getType t)- f t = " NOT NULL" ++ g t- -- TODO: add references for tuple and list- g (DbEntity t) = " REFERENCES " ++ escape (getEntityName t)- g (DbTuple n ts) = " REFERENCES " ++ (intercalate "$" $ ("Tuple" ++ show n ++ "$") : map getName ts)- g (DbList t) = " REFERENCES " ++ "List$$" ++ getName t- g _ = ""+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 (DbMaybe t) = dbTypeAffinity t+dbTypeAffinity (DbList _ _) = INTEGER+dbTypeAffinity (DbEntity Nothing _) = INTEGER+dbTypeAffinity t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t -sqlUnique :: Constraint -> String-sqlUnique (cname, cols) = concat- [ ", CONSTRAINT "- , escape cname+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 DbType -> String+showColumn (Column name isNull typ _) = escape name ++ " " ++ showSqlType typ ++ rest where+ rest = if not isNull + then " NOT NULL"+ else ""++sqlReference :: Reference -> String+sqlReference (tname, columns) = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape tname ++ "(" ++ foreign ++ ")" where+ (our, foreign) = f *** f $ unzip columns+ f = intercalate ", " . map escape++sqlUnique :: UniqueDef' -> String+sqlUnique (UniqueDef' name cols) = concat+ [ "CONSTRAINT "+ , escape name , " UNIQUE (" , intercalate "," $ map escape cols , ")" ] -{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Sqlite IO (Key v) #-}+{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Sqlite IO (AutoKey v) #-} {-# INLINE insert' #-}-insert' :: (PersistEntity v, MonadControlIO m) => v -> DbPersist Sqlite m (Key v)+insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m (AutoKey v) insert' v = do -- constructor number and the rest of the field values- vals <- toPersistValues v+ vals <- toEntityPersistValues' v let e = entityDef v- let name = getEntityName e- let constructorNum = fromPrim (head vals)+ let name = persistName v+ let constructorNum = fromPrimitivePersistValue proxy (head vals) - if isSimple (constructors e)+ liftM fst $ if isSimple (constructors e) then do let constr = head $ constructors e let query = insertIntoConstructorTable False name constr- executeRaw True query (tail vals)- rowid <- getLastInsertRowId- return $ Key rowid+ executeRawCached' query (tail vals)+ case constrAutoKeyName constr of+ Nothing -> pureFromPersistValue []+ Just _ -> getLastInsertRowId >>= \rowid -> pureFromPersistValue [rowid] else do let constr = constructors e !! constructorNum- let cName = name ++ [defDelim] ++ constrName constr- let query = "INSERT INTO " ++ escape name ++ "(discr)VALUES(?)"- executeRaw True query $ take 1 vals+ let cName = name ++ [delim] ++ constrName constr+ let query = "INSERT INTO " <> escapeS (fromString name) <> "(discr)VALUES(?)"+ executeRawCached' query $ take 1 vals rowid <- getLastInsertRowId let cQuery = insertIntoConstructorTable True cName constr- executeRaw True cQuery $ PersistInt64 rowid:(tail vals)- return $ Key rowid---- in Sqlite we can insert null to the id column. If so, id will be generated automatically-insertIntoConstructorTable :: Bool -> String -> ConstructorDef -> String-insertIntoConstructorTable withId tName c = "INSERT INTO " ++ escape tName ++ "(" ++ fieldNames ++ ")VALUES(" ++ placeholders ++ ")" where- fieldNames = intercalate "," $ (if withId then (constrId:) else id) $ map (escape.fst) (constrParams c)- placeholders = intercalate "," $ (if withId then ("?":) else id) $ map (const "?") (constrParams c)--{-# SPECIALIZE insertBy' :: PersistEntity v => v -> DbPersist Sqlite IO (Either (Key v) (Key v)) #-}-insertBy' :: (MonadControlIO m, PersistEntity v) => v -> DbPersist Sqlite m (Either (Key v) (Key v))-insertBy' v = do- let e = entityDef v- let name = getEntityName e-- let constraints = getConstraints v- let constructorNum = fst constraints- let constraintFields = map snd $ snd constraints- let constrCond = intercalate " OR " $ map (intercalate " AND " . map (\(fname, _) -> escape fname ++ "=?")) constraintFields-- let ifAbsent tname ins = if null constraintFields- then liftM (Right . Key) ins- else do- let query = "SELECT " ++ constrId ++ " FROM " ++ escape tname ++ " WHERE " ++ constrCond- x <- queryRawTyped query [DbInt64] (concatMap (map snd) constraintFields) firstRow- case x of- Nothing -> liftM (Right . Key) ins- Just [k] -> return $ Left $ fromPrim k- Just xs -> fail $ "unexpected query result: " ++ show xs-- if isSimple (constructors e)- then do- let constr = head $ constructors e- ifAbsent name $ do- let query = insertIntoConstructorTable False name constr- vals <- toPersistValues v- executeRaw True query (tail vals)- getLastInsertRowId- else do- let constr = constructors e !! constructorNum- let cName = name ++ [defDelim] ++ constrName constr- ifAbsent cName $ do- let query = "INSERT INTO " ++ escape name ++ "(discr)VALUES(?)"- vals <- toPersistValues v- executeRaw True query $ take 1 vals- rowid <- getLastInsertRowId- let cQuery = insertIntoConstructorTable True cName constr- executeRaw True cQuery $ PersistInt64 rowid :(tail vals)- return rowid--replace' :: (MonadControlIO m, PersistEntity v) => Key v -> v -> DbPersist Sqlite m ()-replace' k v = do- vals <- toPersistValues v- let e = entityDef v- let name = getEntityName e- let constructorNum = fromPrim (head vals)- let constr = constructors e !! constructorNum-- let upds = intercalate "," $ map (\f -> escape (fst f) ++ "=?") $ constrParams constr- let mkQuery tname = "UPDATE " ++ escape tname ++ " SET " ++ upds ++ " WHERE " ++ constrId ++ "=?"-- if isSimple (constructors e)- then executeRaw True (mkQuery name) (tail vals ++ [toPrim k])- else do- let query = "SELECT discr FROM " ++ escape name ++ " WHERE id=?"- x <- queryRawTyped query [DbInt32] [toPrim k] (firstRow >=> return.fmap (fromPrim . head))- case x of- Just discr -> do- let cName = name ++ [defDelim] ++ constrName constr-- if discr == constructorNum- then executeRaw True (mkQuery cName) (tail vals ++ [toPrim k])- else do- let insQuery = insertIntoConstructorTable True cName constr- executeRaw True insQuery (toPrim k:tail vals)-- let oldCName = name ++ [defDelim] ++ constrName (constructors e !! discr)- let delQuery = "DELETE FROM " ++ escape oldCName ++ " WHERE " ++ constrId ++ "=?"- executeRaw True delQuery [toPrim k]-- -- UGLY: reinsert entry with a new discr to the main table after it was deleted by a trigger.- let reInsQuery = "INSERT INTO " ++ escape name ++ "(id,discr)VALUES(?,?)"- executeRaw True reInsQuery [toPrim k, head vals]- Nothing -> return ()---- | receives constructor number and row of values from the constructor table-mkEntity :: (PersistEntity v, PersistBackend m) => Int -> [PersistValue] -> m (Key v, v)-mkEntity i (k:xs) = fromPersistValues (toPrim i:xs) >>= \v -> return (fromPrim k, v)-mkEntity _ [] = error "Unable to create entity. No values supplied"--selectEnum' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> [Order v c] -> Int -> Int -> Enumerator (Key v, v) (DbPersist Sqlite m) a-selectEnum' (cond :: Cond v c) ords limit offset = start where- start = if isSimple (constructors e)- then joinE (queryEnum (mkQuery name) types binds) (EL.mapM (mkEntity 0))- else let- query = mkQuery $ name ++ [defDelim] ++ constrName constr- in joinE (queryEnum query types binds) (EL.mapM (mkEntity $ constrNum constr))-- e = entityDef (undefined :: v)- orders = renderOrders escape ords- name = getEntityName e- (lim, limps) = case (limit, offset) of- (0, 0) -> ("", [])- (0, o) -> (" LIMIT -1 OFFSET ?", [toPrim o])- (l, 0) -> (" LIMIT ?", [toPrim l])- (l, o) -> (" LIMIT ? OFFSET ?", [toPrim l, toPrim o])- (conds, condps) = renderCond' cond- mkQuery tname = "SELECT * FROM " ++ escape tname ++ " WHERE " ++ (conds . orders $ lim)- binds = condps limps- constr = (constructors e) !! phantomConstrNum (undefined :: c)- types = DbInt64:getConstructorTypes constr--selectAllEnum' :: forall m v a.(MonadControlIO m, PersistEntity v) => Enumerator (Key v, v) (DbPersist Sqlite m) a-selectAllEnum' = start where- start = if isSimple (constructors e)- then let- query = "SELECT * FROM " ++ escape name- types = DbInt64:(getConstructorTypes $ head $ constructors e)- in joinE (queryEnum query types []) (EL.mapM (mkEntity 0))- else concatEnums $ zipWith q [0..] (constructors e) where- q cNum constr = let- cName = name ++ [defDelim] ++ constrName constr- query = "SELECT * FROM " ++ escape cName- types = DbInt64:getConstructorTypes constr- in joinE (queryEnum query types []) (EL.mapM (mkEntity cNum))-- e = entityDef (undefined :: v)- name = getEntityName e---- unfortunately, running consume on Enumerator is ~50% slower. So, lets duplicate the code-select' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> [Order v c] -> Int -> Int -> DbPersist Sqlite m [(Key v, v)]-select' (cond :: Cond v c) ords limit offset = start where- start = if isSimple (constructors e)- then doSelectQuery (mkQuery name) 0- else let- cName = name ++ [defDelim] ++ constrName constr- in doSelectQuery (mkQuery cName) $ constrNum constr-- e = entityDef (undefined :: v)- orders = renderOrders escape ords- name = getEntityName e- (lim, limps) = case (limit, offset) of- (0, 0) -> ("", [])- (0, o) -> (" LIMIT -1 OFFSET ?", [toPrim o])- (l, 0) -> (" LIMIT ?", [toPrim l])- (l, o) -> (" LIMIT ? OFFSET ?", [toPrim l, toPrim o])- (conds, condps) = renderCond' cond- mkQuery tname = "SELECT * FROM " ++ escape tname ++ " WHERE " ++ (conds . orders $ lim)- doSelectQuery query cNum = queryRawTyped query types binds $ mapAllRows (mkEntity cNum)- binds = condps limps- constr = constructors e !! phantomConstrNum (undefined :: c)- types = DbInt64:getConstructorTypes constr--selectAll' :: forall m v.(MonadControlIO m, PersistEntity v) => DbPersist Sqlite m [(Key v, v)]-selectAll' = start where- start = if isSimple (constructors e)- then let- query = "SELECT * FROM " ++ escape name- types = DbInt64:(getConstructorTypes $ head $ constructors e)- in queryRawTyped query types [] $ mapAllRows (mkEntity 0)- else liftM concat $ forM (zip [0..] (constructors e)) $ \(i, constr) -> do- let cName = name ++ [defDelim] ++ constrName constr- let query = "SELECT * FROM " ++ escape cName- let types = DbInt64:getConstructorTypes constr- queryRawTyped query types [] $ mapAllRows (mkEntity i)-- e = entityDef (undefined :: v)- name = getEntityName e--{--insertList :: PersistField a => [a] -> DbPersist conn m Int64-insertList xs = do- xs' <- mapM toPersistValue xs- let name = persistName xs- let query = "INSERT INTO " ++ name ++ " ("- getStatement --}--insertTuple' :: MonadIO m => NamedType -> [PersistValue] -> DbPersist Sqlite m Int64-insertTuple' t vals = do- let name = getName t- let (DbTuple _ ts) = getType t- let fields = map (\i -> "val" ++ show i) [0 .. length ts - 1] - let query = "INSERT INTO " ++ name ++ " (" ++ intercalate ", " fields ++ ")VALUES(" ++ intercalate ", " (replicate (length ts) "?") ++ ")"- executeRawCached' query vals- getLastInsertRowId--getTuple' :: MonadControlIO m => NamedType -> Int64 -> DbPersist Sqlite m [PersistValue]-getTuple' t k = do- let name = getName t- let (DbTuple _ ts) = getType t- let query = "SELECT * FROM " ++ name ++ " WHERE id = ?"- x <- queryRawTyped query (DbInt64:map getType ts) [toPrim k] firstRow- maybe (fail $ "No tuple with id " ++ show k) (return . tail) x--{-# SPECIALIZE get' :: PersistEntity v => Key v -> DbPersist Sqlite IO (Maybe v) #-}-{-# INLINE get' #-}-get' :: (MonadControlIO m, PersistEntity v) => Key v -> DbPersist Sqlite m (Maybe v)-get' (k :: Key v) = do- let e = entityDef (undefined :: v)- let name = getEntityName e- if isSimple (constructors e)- then do- let constr = head $ constructors e- let query = "SELECT * FROM " ++ escape name ++ " WHERE " ++ constrId ++ "=?"- x <- queryRawTyped query (DbInt64:getConstructorTypes constr) [toPrim k] firstRow- case x of- Just (_:xs) -> liftM Just $ fromPersistValues $ PersistInt64 0:xs- Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'- Nothing -> return Nothing- else do- let query = "SELECT discr FROM " ++ escape name ++ " WHERE id=?"- x <- queryRawTyped query [DbInt64] [toPrim k] firstRow- case x of- Just [discr] -> do- let constructorNum = fromPrim discr- let constr = constructors e !! constructorNum- let cName = name ++ [defDelim] ++ constrName constr- let cQuery = "SELECT * FROM " ++ escape cName ++ " WHERE " ++ constrId ++ "=?"- x2 <- queryRawTyped cQuery (DbInt64:getConstructorTypes constr) [toPrim k] firstRow- case x2 of- Just (_:xs) -> liftM Just $ fromPersistValues $ discr:xs- Just x2' -> fail $ "Unexpected number of columns returned: " ++ show x2'- Nothing -> fail "Missing entry in constructor table"- Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'- Nothing -> return Nothing--update' :: (PersistBackend m, PersistEntity v, Constructor c) => [Update v c] -> Cond v c -> m ()-update' upds (cond :: Cond v c) = do- let e = entityDef (undefined :: v)- let name = getEntityName e- let (conds, condps) = renderCond' cond- let (upds', ps) = renderUpdates escape upds- let mkQuery tname = "UPDATE " ++ escape tname ++ " SET " ++ (upds' . (" WHERE " ++) . conds $ "")- if isSimple (constructors e)- then executeRaw True (mkQuery name) (ps $ condps [])- else do- let cName = name ++ [defDelim] ++ phantomConstrName (undefined :: c)- executeRaw True (mkQuery cName) (ps $ condps [])--delete' :: (PersistBackend m, PersistEntity v, Constructor c) => Cond v c -> m ()-delete' (cond :: Cond v c) = do- let e = entityDef (undefined :: v)- let (conds, condps) = renderCond' cond- let name = getEntityName e- if isSimple (constructors e)- then do- let query = "DELETE FROM " ++ escape name ++ " WHERE " ++ conds ""- executeRaw True query (condps [])- else do- -- after removal from the constructor table, entry from the main table is removed by trigger- let cName = name ++ [defDelim] ++ phantomConstrName (undefined :: c)- let query = "DELETE FROM " ++ escape cName ++ " WHERE " ++ conds ""- executeRaw True query (condps [])- -deleteByKey' :: (MonadControlIO m, PersistEntity v) => Key v -> DbPersist Sqlite m ()-deleteByKey' (k :: Key v) = do- let e = entityDef (undefined :: v)- let name = getEntityName e- if isSimple (constructors e)- then do- let query = "DELETE FROM " ++ escape name ++ " WHERE id$=?"- executeRaw True query [toPrim k]- else do- let query = "SELECT discr FROM " ++ escape name- x <- queryRawTyped query [DbInt64] [] firstRow- case x of- Just [discr] -> do- let cName = name ++ [defDelim] ++ constrName (constructors e !! fromPrim discr)- let cQuery = "DELETE FROM " ++ escape cName ++ " WHERE id$=?"- executeRaw True cQuery [toPrim k]- Just xs -> fail $ "requested 1 column, returned " ++ show xs- Nothing -> return ()+ executeRawCached' cQuery $ rowid:(tail vals)+ pureFromPersistValue [rowid] -{-# SPECIALIZE count' :: (PersistEntity v, Constructor c) => Cond v c -> DbPersist Sqlite IO Int #-}-count' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> DbPersist Sqlite m Int-count' (cond :: Cond v c) = do- let cName = persistName (undefined :: v) ++ [defDelim] ++ phantomConstrName (undefined :: c)- let (conds, condps) = renderCond' cond- let query = "SELECT COUNT(*) FROM " ++ cName ++ " WHERE " ++ conds ""- x <- queryRawTyped query [DbInt64] (condps []) firstRow- case x of- Just [num] -> return $ fromPrim num- Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)- Nothing -> fail $ "COUNT returned no rows"+-- 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+ 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 -{-# SPECIALIZE countAll' :: PersistEntity v => v -> DbPersist Sqlite IO Int #-}-countAll' :: (MonadControlIO m, PersistEntity v) => v -> DbPersist Sqlite m Int-countAll' (_ :: v) = do- let name = persistName (undefined :: v)- let query = "SELECT COUNT(*) FROM " ++ name- x <- queryRawTyped query [DbInt64] [] firstRow- case x of- Just [num] -> return $ fromPrim num- Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)- Nothing -> fail $ "COUNT returned no rows"- -insertList' :: forall m a.(MonadControlIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64+insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64 insertList' l = do- let mainName = "List$$" ++ persistName (undefined :: a)- executeRaw True ("INSERT INTO " ++ mainName ++ " DEFAULT VALUES") []+ let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))+ executeRawCached' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES") [] k <- getLastInsertRowId- let valuesName = mainName ++ "$" ++ "values"- let query = "INSERT INTO " ++ valuesName ++ "(id,ord$,value)VALUES(?,?,?)"+ let valuesName = mainName <> delim' <> "values"+ let fields = [("ord", dbType (0 :: Int)), ("value", dbType (undefined :: a))]+ let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")" let go :: Int -> [a] -> DbPersist Sqlite m () go n (x:xs) = do- x' <- toPersistValue x- executeRaw True query [toPrim k, toPrim n, x']+ x' <- toPersistValues x+ executeRawCached' query $ (k:) . (toPrimitivePersistValue proxy n:) . x' $ [] go (n + 1) xs go _ [] = return () go 0 l- return k+ return $ fromPrimitivePersistValue proxy k -getList' :: forall m a.(MonadControlIO m, PersistField a) => Int64 -> DbPersist Sqlite m [a]+getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist Sqlite m [a] getList' k = do- let mainName = "List$$" ++ persistName (undefined :: a)- let valuesName = mainName ++ "$" ++ "values"- queryRawTyped ("SELECT value FROM " ++ valuesName ++ " WHERE id=? ORDER BY ord$") [dbType (undefined :: a)] [toPrim k] $ mapAllRows (fromPersistValue.head)+ let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))+ let valuesName = mainName <> delim' <> "values"+ let value = ("value", dbType (undefined :: a))+ let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"+ queryRawTyped query (getDbTypes (dbType (undefined :: a)) []) [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues) -{-# SPECIALIZE getLastInsertRowId :: DbPersist Sqlite IO Int64 #-}-getLastInsertRowId :: MonadIO m => DbPersist Sqlite m Int64+{-# SPECIALIZE getLastInsertRowId :: DbPersist Sqlite IO PersistValue #-}+getLastInsertRowId :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m PersistValue getLastInsertRowId = do stmt <- getStatementCached "SELECT last_insert_rowid()" liftIO $ flip finally (liftIO $ S.reset stmt) $ do S.step stmt x <- S.column stmt 0- return $ fromPrim $ pFromSql x--constrId :: String-constrId = defId+ return $ pFromSql x ---------- @@ -712,9 +394,10 @@ PersistDay d -> S.bindText stmt i $ show d PersistTimeOfDay d -> S.bindText stmt i $ show d PersistUTCTime d -> S.bindText stmt i $ show d- go (i+1) xs+ PersistZonedTime (ZT d)-> S.bindText stmt i $ show d+ go (i + 1) xs -executeRaw' :: MonadIO m => String -> [PersistValue] -> DbPersist Sqlite m ()+executeRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m () executeRaw' query vals = do stmt <- getStatement query liftIO $ flip finally (S.finalize stmt) $ do@@ -722,8 +405,8 @@ S.Done <- S.step stmt return () -{-# SPECIALIZE executeRawCached' :: String -> [PersistValue] -> DbPersist Sqlite IO () #-}-executeRawCached' :: MonadIO m => String -> [PersistValue] -> DbPersist Sqlite m ()+{-# SPECIALIZE executeRawCached' :: Utf8 -> [PersistValue] -> DbPersist Sqlite IO () #-}+executeRawCached' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m () executeRawCached' query vals = do stmt <- getStatementCached query liftIO $ flip finally (S.reset stmt) $ do@@ -731,7 +414,7 @@ S.Done <- S.step stmt return () -queryRaw' :: MonadControlIO m => String -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRaw' query vals f = do stmt <- getStatement query flip finally (liftIO $ S.finalize stmt) $ do@@ -742,7 +425,7 @@ S.Done -> return Nothing S.Row -> liftM (Just . map pFromSql) $ S.columns stmt -queryRawCached' :: MonadControlIO m => String -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRawCached' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRawCached' query vals f = do stmt <- getStatementCached query flip finally (liftIO $ S.reset stmt) $ do@@ -753,7 +436,7 @@ S.Done -> return Nothing S.Row -> fmap (Just . map pFromSql) $ S.columns stmt -queryRawTyped :: MonadControlIO m => String -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRawTyped :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRawTyped query types vals f = do stmt <- getStatementCached query let types' = map typeToSqlite types@@ -765,20 +448,6 @@ S.Done -> return Nothing S.Row -> fmap (Just . map pFromSql) $ S.unsafeColumns stmt types' -queryEnum :: MonadControlIO m => String -> [DbType] -> [PersistValue] -> Enumerator [PersistValue] (DbPersist Sqlite m) b-queryEnum query types vals = \step -> do- stmt <- lift $ getStatementCached query- liftIO $ S.reset stmt >> bind stmt vals- let iter = checkContinue0 $ \loop k -> do- x <- liftIO $ do- x <- S.step stmt- case x of- S.Done -> return Nothing- S.Row -> do- fmap (Just . map pFromSql) $ S.unsafeColumns stmt (map typeToSqlite types)- maybe (continue k) (\row -> k (Chunks [row]) >>== loop) x- Iteratee (runIteratee (iter step))- typeToSqlite :: DbType -> Maybe S.ColumnType typeToSqlite DbString = Just S.TextColumn typeToSqlite DbInt32 = Just S.IntegerColumn@@ -788,21 +457,18 @@ typeToSqlite DbDay = Nothing typeToSqlite DbTime = Nothing typeToSqlite DbDayTime = Nothing+typeToSqlite DbDayTimeZoned = Nothing typeToSqlite DbBlob = Just S.BlobColumn typeToSqlite (DbMaybe _) = Nothing-typeToSqlite (DbList _) = Just S.IntegerColumn-typeToSqlite (DbTuple _ _) = Just S.IntegerColumn-typeToSqlite (DbEntity _) = Just S.IntegerColumn--getConstructorTypes :: ConstructorDef -> [DbType]-getConstructorTypes = map (getType.snd) . constrParams--firstRow :: Monad m => RowPopper m -> m (Maybe [PersistValue])-firstRow pop = pop >>= return+typeToSqlite (DbList _ _) = Just S.IntegerColumn+typeToSqlite (DbEntity Nothing _) = Just S.IntegerColumn+typeToSqlite t = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t -mapAllRows :: Monad m => ([PersistValue] -> m a) -> RowPopper m -> m [a]-mapAllRows f pop = go where- go = pop >>= maybe (return []) (f >=> \a -> liftM (a:) go)+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+ t -> t:acc pFromSql :: S.SQLData -> PersistValue pFromSql (S.SQLInteger i) = PersistInt64 i@@ -815,14 +481,89 @@ escape :: String -> String escape s = '\"' : s ++ "\"" -renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> RenderS-renderCond' = renderCond escape constrId renderEquals renderNotEquals where- renderEquals :: (String -> String) -> Expr v c a -> Expr v c a -> RenderS- renderEquals esc a b = renderExpr esc a <> ((" IS " ++), id) <> renderExpr esc b+escapeS :: Utf8 -> Utf8+escapeS a = let q = fromChar '"' in q <> a <> q - renderNotEquals :: (String -> String) -> Expr v c a -> Expr v c a -> RenderS- renderNotEquals esc a b = renderExpr esc a <> ((" IS NOT " ++), id) <> renderExpr esc b+renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> Maybe (RenderS Utf8)+renderCond' = renderCond proxy escapeS renderEquals renderNotEquals where+ renderEquals a b = a <> " IS " <> b+ renderNotEquals a b = a <> " IS NOT " <> b -isSimple :: [ConstructorDef] -> Bool-isSimple [_] = True-isSimple _ = False+defaultPriority :: Int+defaultPriority = 0++triggerPriority :: Int+triggerPriority = 1++proxy :: Proxy Sqlite+proxy = error "Proxy Sqlite"++delim' :: Utf8+delim' = fromChar delim++toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Sqlite m [PersistValue]+toEntityPersistValues' = liftM ($ []) . toEntityPersistValues++compareColumns :: Column Affinity -> Column DbType -> Bool+compareColumns (Column name1 isNull1 aff1 def1) (Column name2 isNull2 type2 def2) =+ aff1 == dbTypeAffinity type2 && name1 == name2 && isNull1 == isNull2 && def1 == def2++compareUniqs :: UniqueDef' -> UniqueDef' -> Bool+compareUniqs (UniqueDef' _ cols1) (UniqueDef' _ cols2) = haveSameElems (==) cols1 cols2++compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool+compareRefs (_, (tbl1, pairs1)) (_, (tbl2, pairs2)) = unescape tbl1 == unescape tbl2 && haveSameElems (==) pairs1 pairs2 where+ unescape name = if head name == '"' && last name == '"' then tail $ init name else name++mainTableId :: String+mainTableId = "id"++showAlterDb :: AlterDB Affinity -> SingleMigration+showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]+showAlterDb (AlterTable table createTable (TableInfo oldId oldCols _ _) (TableInfo newId newCols _ _) alts) | not (all isSupported alts) = (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 compareColumns oldCols newCols+ columnsTmp = intercalate "," $ map escape $ maybeToList (newId >> oldId) ++ map (colName . snd) commonColumns+ columnsNew = intercalate "," $ map escape $ maybeToList (oldId >> newId) ++ map (colName . snd) commonColumns+ isSupported (AlterColumn (_, Add _)) = True+ isSupported (AlterColumn (_, UpdateValue _)) = True+ isSupported _ = False+showAlterDb (AlterTable t _ _ _ alts) = Right $ map (showAlterTable t) alts+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")]+showAlterDb alt = error $ "showAlterDb: does not support " ++ show alt++showAlterTable :: String -> AlterTable -> (Bool, Int, String)+showAlterTable table (AlterColumn alt) = showAlterColumn table alt+showAlterTable table alt = error $ "showAlterTable: does not support " ++ show alt ++ " (table " ++ table ++ ")"++showAlterColumn :: String -> AlterColumn' -> (Bool, Int, String)+showAlterColumn table (_, Add col) = (False, defaultPriority, concat+ [ "ALTER TABLE "+ , escape table+ , " ADD COLUMN "+ , showColumn col+ ])+showAlterColumn table (n, UpdateValue s) = (False, defaultPriority, concat+ [ "UPDATE "+ , escape table+ , " SET "+ , escape n+ , "="+ , s+ , " WHERE "+ , escape n+ , " IS NULL"+ ])+showAlterColumn table alt = error $ "showAlterColumn: does not support " ++ show alt ++ " (table " ++ table ++ ")"
Database/Sqlite.hs view
@@ -165,9 +165,9 @@ foreign import ccall "sqlite3_prepare_v2" prepareC :: Ptr () -> CString -> Int -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> IO Int-prepareError :: Database -> String -> IO (Either Statement Error)+prepareError :: Database -> BS.ByteString -> IO (Either Statement Error) prepareError db@(Database database) text = do- BS.useAsCString (UTF8.fromString text)+ BS.useAsCString text (\textC -> do alloca (\statementC -> do err <- prepareC database textC (-1) statementC nullPtr@@ -176,7 +176,7 @@ statement <- peek statementC return $ Left $ Statement statement db else return $ Right err))-prepare :: Database -> String -> IO Statement+prepare :: Database -> BS.ByteString -> IO Statement prepare database text = do statementOrError <- prepareError database text case statementOrError of@@ -345,18 +345,10 @@ typedColumn :: ColumnType -> Statement -> Int -> IO SQLData typedColumn theType statement columnIndex = do case theType of- IntegerColumn -> do- int64 <- columnInt64 statement columnIndex- return $ SQLInteger int64- FloatColumn -> do- double <- columnDouble statement columnIndex- return $ SQLFloat double- TextColumn -> do- text <- columnText statement columnIndex- return $ SQLText text- BlobColumn -> do- byteString <- columnBlob statement columnIndex- return $ SQLBlob byteString+ IntegerColumn -> fmap SQLInteger $ columnInt64 statement columnIndex+ FloatColumn -> fmap SQLFloat $ columnDouble statement columnIndex+ TextColumn -> fmap SQLText $ columnText statement columnIndex+ BlobColumn -> fmap SQLBlob $ columnBlob statement columnIndex NullColumn -> return SQLNull columns :: Statement -> IO [SQLData]@@ -367,8 +359,10 @@ unsafeColumns :: Statement -> [Maybe ColumnType] -> IO [SQLData] unsafeColumns statement types = go 0 types where go :: Int -> [Maybe ColumnType] -> IO [SQLData]- go _ [] = return []+ go n [] = n `seq` return [] go n (t:ts) = do- c <- (maybe column typedColumn t) statement n+ c <- case t of+ Nothing -> column statement n+ Just t' -> typedColumn t' statement n cs <- go (n + 1) ts return (c:cs)
cbits/sqlite3.c view
file too large to diff
groundhog-sqlite.cabal view
@@ -1,14 +1,14 @@ name: groundhog-sqlite-version: 0.0.1.1+version: 0.1.0 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com> maintainer: Boris Lykah <lykahb@gmail.com>-synopsis: Backend for the groundhog library using sqlite3.+synopsis: Sqlite3 backend for the groundhog library description: This package includes a thin sqlite3 wrapper based on the direct-sqlite package, as well as the entire C library, so there are no system dependencies. category: Database stability: Non-stable-cabal-version: >= 1.10+cabal-version: >= 1.6 build-type: Simple flag systemlib@@ -18,18 +18,23 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1 && < 0.10- , transformers >= 0.2.1 && < 0.3- , groundhog >= 0.0.1 && < 0.1- , monad-control >= 0.2 && < 0.3+ , transformers >= 0.2.1 && < 0.4+ , groundhog >= 0.1.0 && < 0.2.0+ , monad-control >= 0.3 && < 0.4 , containers >= 0.2 && < 0.5- , enumerator >= 0.4.9 && < 0.5 , utf8-string >= 0.3.4 && < 0.4- , pool >= 0.1 && < 0.2+ , blaze-builder >= 0.3.0.0 && < 0.4+ , pool-conduit >= 0.1 && < 0.2+ , 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 else c-sources: cbits/sqlite3.c- default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/lykahb/groundhog.git