persistent-sqlite 2.11.0.0 → 2.11.1.0
raw patch · 4 files changed
+143/−6 lines, 4 filesdep +microlensdep +mtldep ~conduit
Dependencies added: microlens, mtl
Dependency ranges changed: conduit
Files
- ChangeLog.md +7/−0
- Database/Persist/Sqlite.hs +44/−1
- persistent-sqlite.cabal +5/−1
- test/main.hs +87/−4
ChangeLog.md view
@@ -1,5 +1,12 @@ # Changelog for persistent-sqlite +## 2.11.1.0++* Add `checkForeignKeys` operation to verify no foreign key constraints are+ violated by the database contents.+* Fix the migration for primary keys that was broken in 2.11.0.0+ [#1184](https://github.com/yesodweb/persistent/issues/1184)+ ## 2.11.0.0 * Foreign Key improvements [#1121] (https://github.com/yesodweb/persistent/pull/1121)
Database/Persist/Sqlite.hs view
@@ -36,6 +36,8 @@ , mockMigration , retryOnBusy , waitForDatabase+ , ForeignKeyViolation(..)+ , checkForeignKeys , RawSqlite , persistentBackend , rawSqliteConnection@@ -51,6 +53,8 @@ import Control.Monad (forM_) import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, askRunInIO, withRunInIO, withUnliftIO, unliftIO, withRunInIO) import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLogger, logWarn, runLoggingT)+import Control.Monad.Reader (MonadReader)+import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) import Control.Monad.Trans.Writer (runWriterT) import Data.Acquire (Acquire, mkAcquire, with)@@ -58,6 +62,7 @@ import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.Conduit+import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as CL import qualified Data.HashMap.Lazy as HashMap import Data.Int (Int64)@@ -487,7 +492,7 @@ getCopyTable allDefs getter def = do stmt <- getter $ T.concat [ "PRAGMA table_info(", escape table, ")" ] oldCols' <- with (stmtQuery stmt []) (\src -> runConduit $ src .| getCols)- let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ?+ let oldCols = map DBName oldCols' let newCols = filter (not . safeToRemove def) $ map cName cols let common = filter (`elem` oldCols) newCols return [ (False, tmpSql)@@ -750,6 +755,44 @@ <*> o .: "walEnabled" <*> o .: "fkEnabled" <*> o .:? "extraPragmas" .!= []++-- | Data type for reporting foreign key violations using 'checkForeignKeys'.+--+-- @since 2.11.1+data ForeignKeyViolation = ForeignKeyViolation+ { foreignKeyTable :: Text -- ^ The table of the violated constraint+ , foreignKeyColumn :: Text -- ^ The column of the violated constraint+ , foreignKeyRowId :: Int64 -- ^ The ROWID of the row with the violated foreign key constraint+ } deriving (Eq, Ord, Show)++-- | Outputs all (if any) the violated foreign key constraints in the database.+--+-- The main use is to validate that no foreign key constraints were+-- broken/corrupted by anyone operating on the database with foreign keys+-- disabled. See 'fkEnabled'.+--+-- @since 2.11.1+checkForeignKeys+ :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)+ => ConduitM () ForeignKeyViolation m ()+checkForeignKeys = rawQuery query [] .| C.mapM parse+ where+ parse l = case l of+ [ PersistInt64 rowid , PersistText table , PersistText column ] ->+ return ForeignKeyViolation+ { foreignKeyTable = table+ , foreignKeyColumn = column+ , foreignKeyRowId = rowid+ }+ _ -> liftIO . E.throwIO . PersistMarshalError $ mconcat+ [ "Unexpected result from foreign key check:\n", T.pack (show l) ]++ query = "\+\ SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")\n\+\ FROM pragma_foreign_key_check() AS origin\n\+\ INNER JOIN pragma_foreign_key_list(origin.\"table\") AS foreignkeys\n\+\ ON origin.fkid = foreignkeys.id AND origin.parent = foreignkeys.\"table\"\n\+\ GROUP BY origin.rowid" -- | Like `withSqliteConnInfo`, but exposes the internal `Sqlite.Connection`. -- For power users who want to manually interact with SQLite's C API via
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 2.11.0.0+version: 2.11.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -51,6 +51,7 @@ , containers >= 0.5 , microlens-th >= 0.4.1.1 , monad-logger >= 0.3.25+ , mtl , resource-pool , resourcet >= 1.1.9 , text >= 1.2@@ -123,11 +124,14 @@ , persistent-test , bytestring , containers+ , conduit , exceptions , fast-logger , hspec >= 2.4 , HUnit+ , microlens , monad-logger+ , mtl , QuickCheck , resourcet , system-fileio
test/main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -46,16 +47,21 @@ import qualified UpsertTest import qualified LongIdentifierTest -import Control.Exception (handle, IOException)+import Control.Exception (handle, IOException, throwIO) import Control.Monad.Catch (catch) import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (MonadReader)+import Control.Monad.Trans.Resource (MonadResource) import qualified Data.ByteString as BS+import Data.Conduit ((.|), runConduit)+import qualified Data.Conduit.List as CL import Data.Fixed import Data.IntMap (IntMap) import qualified Data.Text as T import Data.Time import Filesystem (removeFile) import Filesystem.Path.CurrentOS (fromText)+import qualified Lens.Micro as Lens import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import System.IO (hClose) import System.IO.Temp (withSystemTempFile)@@ -88,22 +94,59 @@ |] share [mkPersist sqlSettings, mkMigrate "compositeSetup"] [persistLowerCase|-Simple+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|-Simple2 sql=simple+SimpleComposite2 sql=simple_composite int Int text Text- bool Bool+ 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+ deriving Show Eq++SimpleReference+ simpleCompositeId SimpleId+ text Text+ deriving Show Eq+|]++share [mkPersist sqlSettings, mkMigrate "idMigrateTest"] [persistLowerCase|+Simple2 sql=simple+ text Text+ int Int default=0+ deriving Show Eq++SimpleReference2 sql=simple_reference+ simpleCompositeId Simple2Id+ text Text+ deriving Show Eq+|]+ instance Arbitrary DataTypeTable where arbitrary = DataTypeTable <$> arbText -- text@@ -247,6 +290,38 @@ 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++ runSqliteInfo connInfo $ do+ void $ runMigrationSilent compositeMigrateTest+ validateForeignKeys+ it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do void $ runMigrationSilent testMigrate let catcher :: forall m. Monad m => SomeException -> m ()@@ -255,3 +330,11 @@ insert_ (Person "A" 1 Nothing) `catch` catcher insert_ $ Person "B" 0 Nothing return ()++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)