packages feed

groundhog-sqlite 0.11.0 → 0.12.0

raw patch · 2 files changed

+346/−272 lines, 2 filesdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

Database/Groundhog/Sqlite.hs view
@@ -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
groundhog-sqlite.cabal view
@@ -1,5 +1,5 @@ name:            groundhog-sqlite-version:         0.11.0+version:         0.12.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -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