Enable foreign key constraints by default for Sqlite backend.

persistent-sqlite/ChangeLog.md

@@ -1,3 +1,8 @@
+## 2.6.1.0
+
+* Removed the behaviour of toggling write-ahead log (WAL) based on a prefix in the connection string, in favour of using a record.
+* Turned on foreign key constraints [#646](https://github.com/yesodweb/persistent/issues/646)
+
 ## 2.6
 
 Compatibility for backend-specific upsert functionality.

persistent-sqlite/Database/Persist/Sqlite.hs

@@ -4,20 +4,22 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TemplateHaskell #-}
 -- | A sqlite backend for persistent.
---
--- Note: If you prepend @WAL=off @ to your connection string, it will disable
--- the write-ahead log. For more information, see
--- <https://github.com/yesodweb/persistent/issues/363>.
 module Database.Persist.Sqlite
     ( withSqlitePool
     , withSqliteConn
     , createSqlitePool
     , module Database.Persist.Sql
     , SqliteConf (..)
+    , SqliteConnectionInfo
+    , mkSqliteConnectionInfo
+    , sqlConnectionStr
+    , walEnabled
+    , fkEnabled
     , runSqlite
     , wrapConnection
+    , wrapConnection'
     , mockMigration
     ) where
 
@@ -49,61 +51,64 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT)
 import Control.Monad (when)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Control.Monad.Trans.Writer (runWriterT)
+import Lens.Micro.TH (makeLenses)
 
 -- | Create a pool of SQLite connections.
 --
 -- Note that this should not be used with the @:memory:@ connection string, as
 -- the pool will regularly remove connections, destroying your database.
 -- Instead, use 'withSqliteConn'.
 createSqlitePool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)
-                 => Text -> Int -> m (Pool backend)
-createSqlitePool s = createSqlPool $ open' s
+                 => SqliteConnectionInfo -> Int -> m (Pool backend)
+createSqlitePool connInfo = createSqlPool $ open' connInfo
 
 -- | Run the given action with a connection pool.
 --
 -- Like 'createSqlitePool', this should not be used with @:memory:@.
 withSqlitePool :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend)
-               => Text
+               => SqliteConnectionInfo
                -> Int -- ^ number of connections to open
                -> (Pool backend -> m a) -> m a
-withSqlitePool s = withSqlPool $ open' s
+withSqlitePool connInfo = withSqlPool $ open' connInfo
 
 withSqliteConn :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend)
-               => Text -> (backend -> m a) -> m a
+               => SqliteConnectionInfo -> (backend -> m a) -> m a
 withSqliteConn = withSqlConn . open'
 
-open' :: (IsSqlBackend backend) => Text -> LogFunc -> IO backend
-open' connStr logFunc = do
-    let (connStr', enableWal) = case () of
-          ()
-            | Just cs <- T.stripPrefix "WAL=on "  connStr -> (cs, True)
-            | Just cs <- T.stripPrefix "WAL=off " connStr -> (cs, False)
-            | otherwise                                   -> (connStr, True)
-
-    conn <- Sqlite.open connStr'
-    wrapConnectionWal enableWal conn logFunc
+open' :: (IsSqlBackend backend) => SqliteConnectionInfo -> LogFunc -> IO backend
+open' connInfo logFunc = do
+    conn <- Sqlite.open $ _sqlConnectionStr connInfo
+    wrapConnection' connInfo conn logFunc
 
 -- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL 'Connection'.
 --
 -- Since 1.1.5
 wrapConnection :: (IsSqlBackend backend) => Sqlite.Connection -> LogFunc -> IO backend
-wrapConnection = wrapConnectionWal True
+wrapConnection = wrapConnection' (mkSqliteConnectionInfo "")
 
--- | Allow control of WAL settings when wrapping
-wrapConnectionWal :: (IsSqlBackend backend)
-                  => Bool -- ^ enable WAL?
+-- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL 'Connection', allowing full control over WAL and FK constraints.
+wrapConnection' :: (IsSqlBackend backend)
+                  => SqliteConnectionInfo
                   -> Sqlite.Connection
                   -> LogFunc
                   -> IO backend
-wrapConnectionWal enableWal conn logFunc = do
-    when enableWal $ do
+wrapConnection' connInfo conn logFunc = do
+    when (_walEnabled connInfo) $ do
         -- Turn on the write-ahead log
         -- https://github.com/yesodweb/persistent/issues/363
         turnOnWal <- Sqlite.prepare conn "PRAGMA journal_mode=WAL;"
         _ <- Sqlite.step turnOnWal
         Sqlite.reset conn turnOnWal
         Sqlite.finalize turnOnWal
 
+    when (_fkEnabled connInfo) $ do
+        -- Turn on foreign key constraints
+        -- https://github.com/yesodweb/persistent/issues/646
+        turnOnFK <- Sqlite.prepare conn "PRAGMA foreign_keys = on;"
+        _ <- Sqlite.step turnOnFK
+        Sqlite.reset conn turnOnFK
+        Sqlite.finalize turnOnFK
+
     smap <- newIORef $ Map.empty
     return . mkPersistBackend $ SqlBackend
         { connPrepare = prepare' conn
@@ -135,7 +140,7 @@ wrapConnectionWal enableWal conn logFunc = do
 --
 -- Since 1.1.4
 runSqlite :: (MonadBaseControl IO m, MonadIO m, IsSqlBackend backend)
-          => Text -- ^ connection string
+          => SqliteConnectionInfo
           -> ReaderT backend (NoLoggingT (ResourceT m)) a -- ^ database action
           -> m a
 runSqlite connstr = runResourceT
@@ -426,9 +431,9 @@ escape (DBName s) =
     go '"' = "\"\""
     go c = T.singleton c
 
--- | Information required to connect to a sqlite database
+-- | Information required to setup a connection pool.
 data SqliteConf = SqliteConf
-    { sqlDatabase :: Text
+    { sqlConnInfo :: SqliteConnectionInfo
     , sqlPoolSize :: Int
     } deriving Show
 
@@ -452,3 +457,21 @@ finally a sequel = control $ \runInIO ->
                      E.finally (runInIO a)
                                (runInIO sequel)
 {-# INLINABLE finally #-}
+-- | Creates a SqliteConnectionInfo from a connection string, with the default settings.
+mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo
+mkSqliteConnectionInfo fp = SqliteConnectionInfo fp True True
+
+-- | Information required to connect to a sqlite database. We export lenses instead of fields to avoid being limited to the current implementation.
+data SqliteConnectionInfo = SqliteConnectionInfo
+    { _sqlConnectionStr :: Text -- ^ connection string for the database. Use @:memory:@ for an in-memory database.
+    , _walEnabled :: Bool -- ^ if the write-ahead log is enabled - see https://github.com/yesodweb/persistent/issues/363.
+    , _fkEnabled :: Bool -- ^ if foreign-key constraints are enabled.
+    } deriving Show
+makeLenses ''SqliteConnectionInfo
+
+instance FromJSON SqliteConnectionInfo where
+    parseJSON v = modifyFailure ("Persistent: error loading SqliteConnectionInfo: " ++) $
+      flip (withObject "SqliteConnectionInfo") v $ \o -> SqliteConnectionInfo
+        <$> o .: "connectionString"
+        <*> o .: "walEnabled"
+        <*> o .: "fkEnabled"

persistent-sqlite/persistent-sqlite.cabal

@@ -1,5 +1,5 @@
 name:            persistent-sqlite
-version:         2.6
+version:         2.6.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -32,6 +32,7 @@ library
                    , aeson                   >= 0.6.2
                    , conduit                 >= 0.5.3
                    , monad-logger            >= 0.2.4
+                   , microlens-th            >= 0.4.1.1
                    , resourcet               >= 1.1
                    , time
                    , old-locale

persistent-sqlite/test/Spec.hs

@@ -27,12 +27,12 @@ asIO = id
 
 main :: IO ()
 main = hspec $ do
-    it "issue #328" $ asIO $ runSqlite ":memory:" $ do
+    it "issue #328" $ asIO $ runSqlite (mkSqliteConnectionInfo ":memory:") $ do
         runMigration migrateAll
         insert . Test $ read "2014-11-30 05:15:25.123"
         [Single x] <- rawSql "select strftime('%s%f',time) from test" []
         liftIO $ x `shouldBe` Just ("141732452525.123" :: String)
-    it "issue #339" $ asIO $ runSqlite ":memory:" $ do
+    it "issue #339" $ asIO $ runSqlite (mkSqliteConnectionInfo ":memory:") $ do
         runMigration migrateAll
         now <- liftIO getCurrentTime
         tid <- insert $ Test now

persistent-test/persistent-test.cabal

@@ -96,7 +96,7 @@ library
                    , lifted-base              >= 0.1
                    , network
                    , path-pieces              >= 0.1
-                   , http-api-data            >= 0.2       && < 0.3
+                   , http-api-data            >= 0.2       && < 0.4
                    , text                     >= 0.8
                    , transformers             >= 0.2.1
                    , monad-control            >= 0.3
@@ -136,7 +136,7 @@ library
      cpp-options: -DNO_OVERLAP
 
    if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper)
-      build-depends: persistent-sqlite
+      build-depends: persistent-sqlite     >= 2.6.1.0
      cpp-options: -DWITH_SQLITE -DDEBUG
 
    if flag(postgresql)

persistent-test/src/Init.hs

@@ -26,6 +26,7 @@ module Init (
 #else
   , db
   , sqlite_database
+  , sqlite_database_file
 #endif
   , BackendKey(..)
   , generateKey
@@ -220,9 +221,17 @@ instance Arbitrary PersistValue where
 persistSettings :: MkPersistSettings
 persistSettings = sqlSettings { mpsGeneric = True }
 type BackendMonad = SqlBackend
-sqlite_database :: Text
-sqlite_database = "test/testdb.sqlite3"
--- sqlite_database = ":memory:"
+#  ifdef WITH_SQLITE
+sqlite_database_file :: Text
+sqlite_database_file = "test/testdb.sqlite3"
+sqlite_database :: SqliteConnectionInfo
+sqlite_database = mkSqliteConnectionInfo sqlite_database_file
+#  else
+sqlite_database_file :: Text
+sqlite_database_file = error "Sqlite tests disabled"
+sqlite_database :: ()
+sqlite_database = error "Sqlite tests disabled"
+#  endif
 runConn :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT (LoggingT m) t -> m ()
 runConn f = do
   travis <- liftIO isTravis

persistent-test/test/main.hs

@@ -47,8 +47,10 @@ toExitCode False = ExitFailure 1
 main :: IO ()
 main = do
 #ifndef WITH_NOSQL
+#  ifdef WITH_SQLITE
   handle (\(_ :: IOException) -> return ())
-    $ removeFile $ fromText sqlite_database
+    $ removeFile $ fromText sqlite_database_file
+#  endif
 
   runConn $ do
     mapM_ setup

stack-docker.yaml

@@ -18,6 +18,7 @@ extra-deps:
   - attoparsec-0.13.0.1
   - http-api-data-0.2
   - time-parsers-0.1.0.0
+  - microlens-th-0.4.1.1
 
 docker:
   enable: true

stack.yaml

@@ -21,6 +21,7 @@ extra-deps:
   - base-compat-0.9.1
   - scientific-0.3.4.9
   - semigroups-0.18.2
+  - microlens-th-0.4.1.1
 
 flags:
   semigroups: