diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-sqlite +## 2.13.0.0 + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13` changes for SqlBackend being made internal. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/Database/Persist/Sqlite.hs b/Database/Persist/Sqlite.hs --- a/Database/Persist/Sqlite.hs +++ b/Database/Persist/Sqlite.hs @@ -11,12 +11,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} + -- Strictly, this could go as low as GHC 8.6.1, which is when DerivingVia was -- introduced - this base version requires 8.6.5+ #if MIN_VERSION_base(4,12,0) {-# LANGUAGE DerivingVia #-} {-# LANGUAGE UndecidableInstances #-} #endif + -- | A sqlite backend for persistent. -- -- Note: If you prepend @WAL=off @ to your connection string, it will disable @@ -78,18 +80,19 @@ import Data.Int (Int64) import Data.IORef import qualified Data.Map as Map -import Data.Monoid ((<>)) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO import Lens.Micro.TH (makeLenses) import UnliftIO.Resource (ResourceT, runResourceT) +import Data.Foldable (toList) #if MIN_VERSION_base(4,12,0) import Database.Persist.Compatible #endif import Database.Persist.Sql +import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util import qualified Database.Sqlite as Sqlite @@ -267,28 +270,27 @@ Sqlite.finalize stmt smap <- newIORef $ Map.empty - return $ SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connUpsertSql = Nothing - , connPutManySql = Just putManySql - , connInsertManySql = Nothing - , connClose = Sqlite.close conn - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = logFunc - , connMaxParams = Just 999 - , connRepsertManySql = Just repsertManySql - } + return $ + setConnMaxParams 999 $ + setConnPutManySql putManySql $ + setConnRepsertManySql repsertManySql $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = Sqlite.close conn + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . getEntityDBName + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = logFunc + } where helper t getter = do stmt <- getter t @@ -336,31 +338,31 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = - case entityPrimary ent of - Just _ -> + case getEntityId ent of + EntityIdNaturalKey _ -> ISRManyKeys sql vals where sql = T.concat [ "INSERT INTO " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , "(" , T.intercalate "," $ map (escapeF . fieldDB) cols , ") VALUES(" , T.intercalate "," (map (const "?") cols) , ")" ] - Nothing -> + EntityIdField fd -> ISRInsertGet ins sel where sel = T.concat [ "SELECT " - , escapeF $ fieldDB (entityId ent) + , escapeF $ fieldDB fd , " FROM " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , " WHERE _ROWID_=last_insert_rowid()" ] ins = T.concat [ "INSERT INTO " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , if null cols then " VALUES(null)" else T.concat @@ -375,7 +377,7 @@ notGenerated = isNothing . fieldGenerated cols = - filter notGenerated $ entityFields ent + filter notGenerated $ getEntityFields ent execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do @@ -441,7 +443,7 @@ return $ Right sql where def = val - table = entityDB def + table = getEntityDBName def go = do x <- CL.head case x of @@ -454,44 +456,42 @@ -- with the difference that an actual database isn't needed for it. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend - { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - } - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Nothing - , connClose = undefined - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = undefined - , connUpsertSql = undefined - , connPutManySql = undefined - , connMaxParams = Just 999 - , connRepsertManySql = Nothing - } - result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend - mapM_ TIO.putStrLn $ map snd $ snd resp - where - helper t getter = do - stmt <- getter t - _ <- stmtExecute stmt [] - stmtReset stmt - ignoreExceptions = E.handle (\(_ :: E.SomeException) -> return ()) + smap <- newIORef $ Map.empty + let sqlbackend = + setConnMaxParams 999 $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = undefined + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . getEntityDBName + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = undefined + } + result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend + mapM_ TIO.putStrLn $ map snd $ snd resp + where + helper t getter = do + stmt <- getter t + _ <- stmtExecute stmt [] + stmtReset stmt + ignoreExceptions = + E.handle (\(_ :: E.SomeException) -> return ()) -- | Check if a column name is listed as the "safe to remove" in the entity -- list. @@ -499,7 +499,7 @@ safeToRemove def (FieldNameDB colName) = any (elem FieldAttrSafeToRemove . fieldAttrs) $ filter ((== FieldNameDB colName) . fieldDB) - $ entityFields def + $ getEntityFieldsDatabase def getCopyTable :: [EntityDef] -> (Text -> IO Statement) @@ -527,12 +527,12 @@ names <- getCols return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y - table = entityDB def + table = getEntityDBName def tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" (cols, uniqs, fdef) = sqliteMkColumns allDefs def cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs, fdef) - tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols', uniqs, []) + tmpSql = mkCreateTable True (setEntityDBName tableTmp def) (cols', uniqs, []) dropTmp = "DROP TABLE " <> escapeE tableTmp dropOld = "DROP TABLE " <> escapeE table copyToTemp common = T.concat @@ -562,7 +562,7 @@ [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE " - , escapeE $ entityDB entity + , escapeE $ getEntityDBName entity , "(" ] @@ -572,25 +572,25 @@ , ")" ] - columns = case entityPrimary entity of - Just pdef -> + columns = case getEntityId entity of + EntityIdNaturalKey pdef -> [ T.drop 1 $ T.concat $ map (sqlColumn isTemp) cols , ", PRIMARY KEY " , "(" - , T.intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef + , T.intercalate "," $ map (escapeF . fieldDB) $ toList $ compositeFields pdef , ")" ] - Nothing -> - [ escapeF $ fieldDB (entityId entity) + EntityIdField fd -> + [ escapeF $ fieldDB fd , " " - , showSqlType $ fieldSqlType $ entityId entity + , showSqlType $ fieldSqlType fd , " PRIMARY KEY" - , mayDefault $ defaultAttribute $ fieldAttrs $ entityId entity + , mayDefault $ defaultAttribute $ fieldAttrs fd , T.concat $ map (sqlColumn isTemp) nonIdCols ] - nonIdCols = filter (\c -> cName c /= fieldDB (entityId entity)) cols + nonIdCols = filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity)) cols mayDefault :: Maybe Text -> Text mayDefault def = case def of @@ -652,7 +652,7 @@ [ ",CONSTRAINT " , escapeC cname , " UNIQUE (" - , T.intercalate "," $ map (escapeF . snd) cols + , T.intercalate "," $ map (escapeF . snd) $ toList cols , ")" ] @@ -674,16 +674,16 @@ go c = T.singleton c putManySql :: EntityDef -> Int -> Text -putManySql ent n = putManySql' conflictColumns fields ent n +putManySql ent n = putManySql' conflictColumns (toList fields) ent n where - fields = entityFields ent - conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (entityUniques ent) + fields = getEntityFieldsDatabase ent + conflictColumns = concatMap (map (escapeF . snd) . toList . uniqueFields) (getEntityUniques ent) repsertManySql :: EntityDef -> Int -> Text -repsertManySql ent n = putManySql' conflictColumns fields ent n +repsertManySql ent n = putManySql' conflictColumns (toList fields) ent n where fields = keyAndEntityFields ent - conflictColumns = escapeF . fieldDB <$> entityKeyFields ent + conflictColumns = escapeF . fieldDB <$> toList (getEntityKeyFields ent) putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns fields ent n = q @@ -691,7 +691,7 @@ fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escapeE . entityDB $ ent + table = escapeE . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-sqlite.cabal b/persistent-sqlite.cabal --- a/persistent-sqlite.cabal +++ b/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -44,7 +44,7 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , bytestring >= 0.10 , conduit >= 1.2.12 @@ -114,7 +114,9 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: SqliteInit + other-modules: + SqliteInit + Database.Persist.Sqlite.CompositeSpec ghc-options: -Wall build-depends: base >= 4.9 && < 5 diff --git a/test/Database/Persist/Sqlite/CompositeSpec.hs b/test/Database/Persist/Sqlite/CompositeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/Sqlite/CompositeSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Database.Persist.Sqlite.CompositeSpec where + +import SqliteInit + +import Control.Monad.Reader (MonadReader) +import Control.Monad.Trans.Resource (MonadResource) +import qualified Data.Conduit.List as CL +import Conduit +import Database.Persist.Sqlite +import System.IO (hClose) +import Control.Exception (handle, IOException, throwIO) +import System.IO.Temp (withSystemTempFile) +import qualified Data.Text as T +import qualified Lens.Micro as Lens + +share [mkPersist sqlSettings, mkMigrate "compositeSetup"] [persistLowerCase| +SimpleComposite + int Int + text Text + Primary text int + deriving Show Eq + +SimpleCompositeReference + int Int + text Text + label Text + Foreign SimpleComposite fk_simple_composite text int + deriving Show Eq +|] + +share [mkPersist sqlSettings, mkMigrate "compositeMigrateTest"] [persistLowerCase| +SimpleComposite2 sql=simple_composite + int Int + text Text + new Int default=0 + Primary text int + deriving Show Eq + +SimpleCompositeReference2 sql=simple_composite_reference + int Int + text Text + label Text + Foreign SimpleComposite2 fk_simple_composite text int + deriving Show Eq +|] + +spec :: Spec +spec = describe "CompositeSpec" $ do + it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent compositeSetup + void $ runMigrationSilent compositeMigrateTest + pure () + it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do + hClose h + let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) + + runSqliteInfo connInfo $ do + void $ runMigrationSilent compositeSetup + forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do + let key = SimpleCompositeKey strKey intKey + insertKey key (SimpleComposite intKey strKey) + insert (SimpleCompositeReference intKey strKey "test") + + validateForeignKeys + + runSqliteInfo connInfo $ do + void $ runMigrationSilent compositeMigrateTest + validateForeignKeys + + +validateForeignKeys + :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) + => m () +validateForeignKeys = do + violations <- map (T.pack . show) <$> runConduit (checkForeignKeys .| CL.consume) + unless (null violations) . liftIO . throwIO $ + PersistForeignConstraintUnmet (T.unlines violations) diff --git a/test/SqliteInit.hs b/test/SqliteInit.hs --- a/test/SqliteInit.hs +++ b/test/SqliteInit.hs @@ -84,21 +84,24 @@ persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } + type BackendMonad = SqlBackend sqlite_database_file :: Text sqlite_database_file = "testdb.sqlite3" + sqlite_database :: SqliteConnectionInfo sqlite_database = mkSqliteConnectionInfo sqlite_database_file + runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () runConn f = do - travis <- liftIO isTravis - let debugPrint = not travis && _debugOn - let printDebug = if debugPrint then print . fromLogStr else void . return - flip runLoggingT (\_ _ _ s -> printDebug s) $ do - _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f - return () + travis <- liftIO isTravis + let debugPrint = not travis && _debugOn + let printDebug = if debugPrint then print . fromLogStr else void . return + void $ flip runLoggingT (\_ _ _ s -> printDebug s) $ do + withSqlitePoolInfo sqlite_database 1 $ runSqlPool f db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do - runResourceT $ runConn $ actions >> transactionUndo + runResourceT $ runConn $ actions >> transactionUndo + diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -70,6 +70,7 @@ import qualified Database.Sqlite as Sqlite import PersistentTestModels +import qualified Database.Persist.Sqlite.CompositeSpec as CompositeSpec import qualified MigrationTest type Tuple = (,) @@ -93,37 +94,6 @@ utc UTCTime |] -share [mkPersist sqlSettings, mkMigrate "compositeSetup"] [persistLowerCase| -SimpleComposite - int Int - text Text - Primary text int - deriving Show Eq - -SimpleCompositeReference - int Int - text Text - label Text - Foreign SimpleComposite fk_simple_composite text int - deriving Show Eq -|] - -share [mkPersist sqlSettings, mkMigrate "compositeMigrateTest"] [persistLowerCase| -SimpleComposite2 sql=simple_composite - int Int - text Text - new Int default=0 - Primary text int - deriving Show Eq - -SimpleCompositeReference2 sql=simple_composite_reference - int Int - text Text - label Text - Foreign SimpleComposite2 fk_simple_composite text int - deriving Show Eq -|] - share [mkPersist sqlSettings, mkMigrate "idSetup"] [persistLowerCase| Simple text Text @@ -176,165 +146,123 @@ main :: IO () main = do - handle (\(_ :: IOException) -> return ()) - $ removeFile $ fromText sqlite_database_file + handle (\(_ :: IOException) -> return ()) + $ removeFile $ fromText sqlite_database_file - runConn $ do - mapM_ setup - [ ForeignKey.compositeMigrate - , PersistentTest.testMigrate - , PersistentTest.noPrefixMigrate - , PersistentTest.customPrefixMigrate - , EmbedTest.embedMigrate - , EmbedOrderTest.embedOrderMigrate - , LargeNumberTest.numberMigrate - , UniqueTest.uniqueMigrate - , MaxLenTest.maxlenMigrate - , Recursive.recursiveMigrate - , CompositeTest.compositeMigrate - , MigrationTest.migrationMigrate - , PersistUniqueTest.migration - , RenameTest.migration - , CustomPersistFieldTest.customFieldMigrate - , PrimaryTest.migration - , CustomPrimaryKeyReferenceTest.migration - , MigrationColumnLengthTest.migration - , TransactionLevelTest.migration - , LongIdentifierTest.migration - ] - PersistentTest.cleanDB - ForeignKey.cleanDB + runConn $ do + mapM_ setup + [ ForeignKey.compositeMigrate + , PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate + , MigrationTest.migrationMigrate + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate + , PrimaryTest.migration + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + , TransactionLevelTest.migration + , LongIdentifierTest.migration + ] + PersistentTest.cleanDB + ForeignKey.cleanDB - hspec $ do - RenameTest.specsWith db - DataTypeTest.specsWith - db - (Just (runMigrationSilent dataTypeMigrate)) - [ TestFn "text" dataTypeTableText - , TestFn "textMaxLen" dataTypeTableTextMaxLen - , TestFn "bytes" dataTypeTableBytes - , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple - , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen - , TestFn "int" dataTypeTableInt - , TestFn "intList" dataTypeTableIntList - , TestFn "intMap" dataTypeTableIntMap - , TestFn "bool" dataTypeTableBool - , TestFn "day" dataTypeTableDay - , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) - , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) - ] - [ ("pico", dataTypeTablePico) ] - dataTypeTableDouble - HtmlTest.specsWith - db - (Just (runMigrationSilent HtmlTest.htmlMigrate)) - EmbedTest.specsWith db - EmbedOrderTest.specsWith db - LargeNumberTest.specsWith db - UniqueTest.specsWith db - MaxLenTest.specsWith db - Recursive.specsWith db - SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationOnlyTest.specsWith db - (Just - $ runMigrationSilent MigrationOnlyTest.migrateAll1 - >> runMigrationSilent MigrationOnlyTest.migrateAll2 - ) - PersistentTest.specsWith db - PersistentTest.filterOrSpecs db - ReadWriteTest.specsWith db - RawSqlTest.specsWith db - UpsertTest.specsWith - db - UpsertTest.Don'tUpdateNull - UpsertTest.UpsertPreserveOldKey - MpsNoPrefixTest.specsWith db - MpsCustomPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith db - PersistUniqueTest.specsWith db - PrimaryTest.specsWith db - CustomPersistFieldTest.specsWith db - CustomPrimaryKeyReferenceTest.specsWith db - MigrationColumnLengthTest.specsWith db - EquivalentTypeTest.specsWith db - ForeignKey.specsWith db - TransactionLevelTest.specsWith db - MigrationTest.specsWith db - LongIdentifierTest.specsWith db - GeneratedColumnTestSQL.specsWith db - - it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - insert_ . Test $ read "2014-11-30 05:15:25.123Z" - [Single x] <- rawSql "select strftime('%s%f',time) from test" [] - liftIO $ x `shouldBe` Just ("141732452525.123" :: String) - it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - now <- liftIO getCurrentTime - tid <- insert $ Test now - Just (Test now') <- get tid - liftIO $ now' `shouldBe` now - it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - conn <- Sqlite.open (T.pack fp) - Sqlite.close conn - return () - it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z") - - it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent compositeSetup - void $ runMigrationSilent compositeMigrateTest - pure () - - it "test migrating sparse primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) - runSqliteInfo connInfo $ do - void $ runMigrationSilent idSetup - forM_ (map toSqlKey [1,3]) $ \key -> do - insertKey key (Simple "foo") - insert (SimpleReference key "test") - - validateForeignKeys - - runSqliteInfo connInfo $ do - void $ runMigrationSilent idMigrateTest - validateForeignKeys - - it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) - - runSqliteInfo connInfo $ do - void $ runMigrationSilent compositeSetup - forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do - let key = SimpleCompositeKey strKey intKey - insertKey key (SimpleComposite intKey strKey) - insert (SimpleCompositeReference intKey strKey "test") - - validateForeignKeys + hspec $ do + describe "Database" $ describe "Persist" $ describe "Sqlite" $ do + CompositeSpec.spec + RenameTest.specsWith db + DataTypeTest.specsWith + db + (Just (runMigrationSilent dataTypeMigrate)) + [ TestFn "text" dataTypeTableText + , TestFn "textMaxLen" dataTypeTableTextMaxLen + , TestFn "bytes" dataTypeTableBytes + , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple + , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen + , TestFn "int" dataTypeTableInt + , TestFn "intList" dataTypeTableIntList + , TestFn "intMap" dataTypeTableIntMap + , TestFn "bool" dataTypeTableBool + , TestFn "day" dataTypeTableDay + , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) + , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) + ] + [ ("pico", dataTypeTablePico) ] + dataTypeTableDouble + HtmlTest.specsWith + db + (Just (runMigrationSilent HtmlTest.htmlMigrate)) + EmbedTest.specsWith db + EmbedOrderTest.specsWith db + LargeNumberTest.specsWith db + UniqueTest.specsWith db + MaxLenTest.specsWith db + Recursive.specsWith db + SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) + MigrationOnlyTest.specsWith db + (Just + $ runMigrationSilent MigrationOnlyTest.migrateAll1 + >> runMigrationSilent MigrationOnlyTest.migrateAll2 + ) + PersistentTest.specsWith db + PersistentTest.filterOrSpecs db + ReadWriteTest.specsWith db + RawSqlTest.specsWith db + UpsertTest.specsWith + db + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey - runSqliteInfo connInfo $ do - void $ runMigrationSilent compositeMigrateTest - validateForeignKeys + MpsNoPrefixTest.specsWith db + MpsCustomPrefixTest.specsWith db + EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith db + PersistUniqueTest.specsWith db + PrimaryTest.specsWith db + CustomPersistFieldTest.specsWith db + CustomPrimaryKeyReferenceTest.specsWith db + MigrationColumnLengthTest.specsWith db + EquivalentTypeTest.specsWith db + ForeignKey.specsWith db + TransactionLevelTest.specsWith db + MigrationTest.specsWith db + LongIdentifierTest.specsWith db + GeneratedColumnTestSQL.specsWith db - it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent testMigrate - let catcher :: forall m. Monad m => SomeException -> m () - catcher _ = return () - insert_ $ Person "A" 0 Nothing - insert_ (Person "A" 1 Nothing) `catch` catcher - insert_ $ Person "B" 0 Nothing - return () + it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + insert_ . Test $ read "2014-11-30 05:15:25.123Z" + [Single x] <- rawSql "select strftime('%s%f',time) from test" [] + liftIO $ x `shouldBe` Just ("141732452525.123" :: String) + it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + now <- liftIO getCurrentTime + tid <- insert $ Test now + Just (Test now') <- get tid + liftIO $ now' `shouldBe` now + it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do + hClose h + conn <- Sqlite.open (T.pack fp) + Sqlite.close conn + return () + it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z") -validateForeignKeys - :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) - => m () -validateForeignKeys = do - violations <- map (T.pack . show) <$> runConduit (checkForeignKeys .| CL.consume) - unless (null violations) . liftIO . throwIO $ - PersistForeignConstraintUnmet (T.unlines violations) + it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent testMigrate + let catcher :: forall m. Monad m => SomeException -> m () + catcher _ = return () + insert_ $ Person "A" 0 Nothing + insert_ (Person "A" 1 Nothing) `catch` catcher + insert_ $ Person "B" 0 Nothing + return ()