diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist/Sqlite.hs b/Database/Persist/Sqlite.hs --- a/Database/Persist/Sqlite.hs +++ b/Database/Persist/Sqlite.hs @@ -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 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.11.0.0 +version: 2.11.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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)