Activate foreign key checking in Sqlite

[WARNING] Yesod Cookbook has moved to a new place. Please contribute there.

Updated for the Yesod 1.4.3.3 scaffolding

In SQLite, foreign keys checks are not enabled by default. Instead, they must be enabled on a per-connection basis by issuing a PRAGMA command, like so:

PRAGMA foreign_keys = ON;

The command to issue foreign keys is a noop if done inside of a transaction, so it is necessary to enable them outside of one. Persistent functions like runSqlPersistMPool wrap your statements inside of a transaction, necessitating dropping down to the underlying Database.Sqlite package to enable foreign keys. To do this, add the following imports and functions to Application.hs:

import qualified Database.Sqlite as Sqlite
import Database.Persist.Sqlite              (createSqlPool, wrapConnection)

rawConnection :: Text -> IO Sqlite.Connection
rawConnection t = Sqlite.open t

disableForeignKeys :: Sqlite.Connection -> IO ()
disableForeignKeys conn = Sqlite.prepare conn "PRAGMA foreign_keys = ON;" >>= void . Sqlite.step

Then, in the makeFoundation function, replace this code:

-- Create the database connection pool
pool <- flip runLoggingT logFunc $ createSqlitePool
    (sqlDatabase $ appDatabaseConf appSettings)
    (sqlPoolSize $ appDatabaseConf appSettings)

with this:

sqliteConn <- rawConnection (sqlDatabase $ appDatabaseConf appSettings)    
disableForeignKeys sqliteConn

pool <- flip runLoggingT logFunc $ createSqlPool 
        (wrapConnection sqliteConn) 
        (sqlPoolSize $ appDatabaseConf appSettings)

You can then verify that foreign keys are enabled by sending PRAGMA foreign_keys to SQLite:

import Database.Persist.Sql  (SqlBackend, rawSql, unSingle)

fksEnabled :: MonadIO m => ReaderT SqlBackend m Bool
fksEnabled = do
    fkStatus <- rawSql "PRAGMA foreign_keys" []
    return $ (map unSingle fkStatus) == ["1" :: Text]

You can then call this function from a Handler or a test, like so:

fkStatus <- runDB $ fksEnabled
traceM $ "Foreign keys enabled = " ++ show fkStatus