{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{- HLINT ignore "Redundant flip" -}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- An implementation of the DBLayer which uses Persistent and SQLite.

module Cardano.DB.Sqlite
    ( SqliteContext (..)
    , newSqliteContext
    , newInMemorySqliteContext
    , ForeignKeysSetting (..)

    -- * ConnectionPool
    , ConnectionPool
    , withConnectionPool

    -- * Helpers
    , chunkSize
    , dbChunked
    , dbChunkedFor
    , dbChunked'
    , handleConstraint

    -- * Manual Migration
    , ManualMigration (..)
    , MigrationError (..)
    , DBField (..)
    , tableName
    , fieldName
    , fieldType

    -- * Logging
    , DBLog (..)
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Wallet.Logging
    ( BracketLog, bracketTracer )
import Control.Monad
    ( join, void, when )
import Control.Monad.IO.Unlift
    ( MonadUnliftIO (..) )
import Control.Monad.Logger
    ( LogLevel (..) )
import Control.Retry
    ( RetryStatus (..)
    , constantDelay
    , limitRetriesByCumulativeDelay
    , logRetries
    , recovering
    )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Data.Aeson
    ( ToJSON (..) )
import Data.Function
    ( (&) )
import Data.Functor
    ( (<&>) )
import Data.List
    ( isInfixOf )
import Data.List.Split
    ( chunksOf )
import Data.Pool
    ( Pool, createPool, destroyAllResources, withResource )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( NominalDiffTime )
import Database.Persist.EntityDef
    ( getEntityDBName, getEntityFields )
import Database.Persist.Names
    ( EntityNameDB (..), unFieldNameDB )
import Database.Persist.Sql
    ( EntityField
    , LogFunc
    , Migration
    , PersistEntity (..)
    , PersistException
    , SqlPersistT
    , SqlType (..)
    , close'
    , fieldDB
    , fieldSqlType
    , runMigrationUnsafeQuiet
    , runSqlConn
    )
import Database.Persist.Sqlite
    ( SqlBackend, wrapConnection )
import Database.Sqlite
    ( Error (ErrorConstraint), SqliteException (SqliteException) )
import Fmt
    ( fmt, ordinalF, (+|), (+||), (|+), (||+) )
import GHC.Generics
    ( Generic )
import System.Environment
    ( lookupEnv )
import System.Log.FastLogger
    ( fromLogStr )
import UnliftIO.Compat
    ( handleIf )
import UnliftIO.Exception
    ( Exception, bracket, bracket_, handleJust, tryJust )
import UnliftIO.MVar
    ( newMVar, withMVarMasked )

import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Database.Persist.Sql as Persist
import qualified Database.Sqlite as Sqlite

{-------------------------------------------------------------------------------
                            Sqlite connection set up
-------------------------------------------------------------------------------}

-- | 'SqliteContext' is a function to execute queries.
newtype SqliteContext = SqliteContext
    { SqliteContext -> forall a. SqlPersistT IO a -> IO a
runQuery :: forall a. SqlPersistT IO a -> IO a
    -- ^ Run a query with a connection from the pool.
    }

type ConnectionPool = Pool (SqlBackend, Sqlite.Connection)

-- | Run an action, and convert any Sqlite constraints exception into the given
-- error result. No other exceptions are handled.
handleConstraint :: MonadUnliftIO m => e -> m a -> m (Either e a)
handleConstraint :: e -> m a -> m (Either e a)
handleConstraint e
e = (SqliteException -> Maybe ())
-> (() -> m (Either e a)) -> m (Either e a) -> m (Either e a)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust SqliteException -> Maybe ()
select () -> m (Either e a)
handler (m (Either e a) -> m (Either e a))
-> (m a -> m (Either e a)) -> m a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right
  where
    select :: SqliteException -> Maybe ()
select (SqliteException Error
ErrorConstraint Text
_ Text
_) = () -> Maybe ()
forall a. a -> Maybe a
Just ()
    select SqliteException
_ = Maybe ()
forall a. Maybe a
Nothing
    handler :: () -> m (Either e a)
handler = m (Either e a) -> () -> m (Either e a)
forall a b. a -> b -> a
const (m (Either e a) -> () -> m (Either e a))
-> (e -> m (Either e a)) -> e -> () -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure  (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left (e -> () -> m (Either e a)) -> e -> () -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ e
e

{-------------------------------------------------------------------------------
                           Internal / Database Setup
-------------------------------------------------------------------------------}

newInMemorySqliteContext
    :: Tracer IO DBLog
    -> [ManualMigration]
    -> Migration
    -> ForeignKeysSetting
    -> IO (IO (), SqliteContext)
newInMemorySqliteContext :: Tracer IO DBLog
-> [ManualMigration]
-> Migration
-> ForeignKeysSetting
-> IO (IO (), SqliteContext)
newInMemorySqliteContext Tracer IO DBLog
tr [ManualMigration]
manualMigrations Migration
autoMigration ForeignKeysSetting
disableFK = do
    Connection
conn <- Text -> IO Connection
Sqlite.open Text
":memory:"
    (ManualMigration -> IO ()) -> [ManualMigration] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ManualMigration -> Connection -> IO ()
`executeManualMigration` Connection
conn) [ManualMigration]
manualMigrations
    SqlBackend
unsafeBackend <- Connection -> LogFunc -> IO SqlBackend
wrapConnection Connection
conn (Tracer IO DBLog -> LogFunc
queryLogFunc Tracer IO DBLog
tr)
    IO [Text] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Text] -> IO ()) -> IO [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend IO [Text] -> SqlBackend -> IO [Text]
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn (Migration -> ReaderT SqlBackend IO [Text]
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafeQuiet Migration
autoMigration) SqlBackend
unsafeBackend

    let observe :: forall a. IO a -> IO a
        observe :: IO a -> IO a
observe = Tracer IO BracketLog -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Tracer m BracketLog -> m a -> m a
bracketTracer ((BracketLog -> DBLog) -> Tracer IO DBLog -> Tracer IO BracketLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap BracketLog -> DBLog
MsgRun Tracer IO DBLog
tr)

    -- We still use a lock with the in-memory database to protect it from
    -- concurrent accesses and ensure database integrity in case where multiple
    -- threads would be reading/writing from/to it.
    MVar SqlBackend
lock <- SqlBackend -> IO (MVar SqlBackend)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar SqlBackend
unsafeBackend
    let useForeignKeys :: IO a -> IO a
        useForeignKeys :: IO a -> IO a
useForeignKeys
            | ForeignKeysSetting
disableFK ForeignKeysSetting -> ForeignKeysSetting -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignKeysSetting
ForeignKeysDisabled = Tracer IO DBLog -> Connection -> IO a -> IO a
forall a. Tracer IO DBLog -> Connection -> IO a -> IO a
withForeignKeysDisabled Tracer IO DBLog
tr Connection
conn
            | Bool
otherwise = IO a -> IO a
forall a. a -> a
id
        runQuery :: forall a. SqlPersistT IO a -> IO a
        runQuery :: SqlPersistT IO a -> IO a
runQuery SqlPersistT IO a
cmd = MVar SqlBackend -> (SqlBackend -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked MVar SqlBackend
lock
            (IO a -> IO a
forall a. IO a -> IO a
observe (IO a -> IO a) -> (SqlBackend -> IO a) -> SqlBackend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
useForeignKeys (IO a -> IO a) -> (SqlBackend -> IO a) -> SqlBackend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlPersistT IO a -> SqlBackend -> IO a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn SqlPersistT IO a
cmd)

    (IO (), SqliteContext) -> IO (IO (), SqliteContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (SqlBackend -> IO ()
forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' SqlBackend
unsafeBackend, SqliteContext :: (forall a. SqlPersistT IO a -> IO a) -> SqliteContext
SqliteContext { forall a. SqlPersistT IO a -> IO a
runQuery :: forall a. SqlPersistT IO a -> IO a
$sel:runQuery:SqliteContext :: forall a. SqlPersistT IO a -> IO a
runQuery })

-- | Sets up query logging and timing, runs schema migrations if necessary and
-- provide a safe 'SqliteContext' for interacting with the database.
newSqliteContext
    :: Tracer IO DBLog
    -> ConnectionPool
    -> [ManualMigration]
    -> Migration
    -> IO (Either MigrationError SqliteContext)
newSqliteContext :: Tracer IO DBLog
-> ConnectionPool
-> [ManualMigration]
-> Migration
-> IO (Either MigrationError SqliteContext)
newSqliteContext Tracer IO DBLog
tr ConnectionPool
pool [ManualMigration]
manualMigrations Migration
autoMigration = do
    Either MigrationError [Text]
migrationResult <- ConnectionPool
-> ((SqlBackend, Connection) -> IO (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
forall a r. Pool a -> (a -> IO r) -> IO r
withResource ConnectionPool
pool (((SqlBackend, Connection) -> IO (Either MigrationError [Text]))
 -> IO (Either MigrationError [Text]))
-> ((SqlBackend, Connection) -> IO (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
forall a b. (a -> b) -> a -> b
$ \(SqlBackend
backend, Connection
conn) -> do
        let executeAutoMigration :: IO [Text]
executeAutoMigration = ReaderT SqlBackend IO [Text] -> SqlBackend -> IO [Text]
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn
                (Migration -> ReaderT SqlBackend IO [Text]
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafeQuiet Migration
autoMigration)
                SqlBackend
backend
        Either MigrationError [Text]
migrationResult <- Tracer IO DBLog
-> Connection
-> IO (Either MigrationError [Text])
-> IO (Either MigrationError [Text])
forall a. Tracer IO DBLog -> Connection -> IO a -> IO a
withForeignKeysDisabled Tracer IO DBLog
tr Connection
conn (IO (Either MigrationError [Text])
 -> IO (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
-> IO (Either MigrationError [Text])
forall a b. (a -> b) -> a -> b
$ do
            (ManualMigration -> IO ()) -> [ManualMigration] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ManualMigration -> Connection -> IO ()
`executeManualMigration` Connection
conn) [ManualMigration]
manualMigrations
            IO [Text]
executeAutoMigration
                IO [Text]
-> (IO [Text] -> IO (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
forall a b. a -> (a -> b) -> b
& (PersistException -> Maybe MigrationError)
-> IO [Text] -> IO (Either MigrationError [Text])
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (MatchMigrationError PersistException =>
PersistException -> Maybe MigrationError
forall e. MatchMigrationError e => e -> Maybe MigrationError
matchMigrationError @PersistException)
                IO (Either MigrationError [Text])
-> (IO (Either MigrationError [Text])
    -> IO (Either MigrationError (Either MigrationError [Text])))
-> IO (Either MigrationError (Either MigrationError [Text]))
forall a b. a -> (a -> b) -> b
& (SqliteException -> Maybe MigrationError)
-> IO (Either MigrationError [Text])
-> IO (Either MigrationError (Either MigrationError [Text]))
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (MatchMigrationError SqliteException =>
SqliteException -> Maybe MigrationError
forall e. MatchMigrationError e => e -> Maybe MigrationError
matchMigrationError @SqliteException)
                IO (Either MigrationError (Either MigrationError [Text]))
-> (IO (Either MigrationError (Either MigrationError [Text]))
    -> IO (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
forall a b. a -> (a -> b) -> b
& (Either MigrationError (Either MigrationError [Text])
 -> Either MigrationError [Text])
-> IO (Either MigrationError (Either MigrationError [Text]))
-> IO (Either MigrationError [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either MigrationError (Either MigrationError [Text])
-> Either MigrationError [Text]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
        Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Either MigrationError Int -> DBLog
MsgMigrations (Either MigrationError Int -> DBLog)
-> Either MigrationError Int -> DBLog
forall a b. (a -> b) -> a -> b
$ ([Text] -> Int)
-> Either MigrationError [Text] -> Either MigrationError Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Either MigrationError [Text]
migrationResult
        Either MigrationError [Text] -> IO (Either MigrationError [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Either MigrationError [Text]
migrationResult
    Either MigrationError SqliteContext
-> IO (Either MigrationError SqliteContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MigrationError SqliteContext
 -> IO (Either MigrationError SqliteContext))
-> Either MigrationError SqliteContext
-> IO (Either MigrationError SqliteContext)
forall a b. (a -> b) -> a -> b
$ case Either MigrationError [Text]
migrationResult of
        Left MigrationError
e  -> MigrationError -> Either MigrationError SqliteContext
forall a b. a -> Either a b
Left MigrationError
e
        Right{} ->
            let observe :: IO a -> IO a
                observe :: IO a -> IO a
observe = Tracer IO BracketLog -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Tracer m BracketLog -> m a -> m a
bracketTracer ((BracketLog -> DBLog) -> Tracer IO DBLog -> Tracer IO BracketLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap BracketLog -> DBLog
MsgRun Tracer IO DBLog
tr)

               -- Note that `withResource` does already mask async exception but
               -- only for dealing with the pool resource acquisition. The action
               -- is then ran unmasked with the acquired resource. If an
               -- asynchronous exception occurs (or actually any exception), the
               -- resource is NOT placed back in the pool.
                runQuery :: SqlPersistT IO a -> IO a
                runQuery :: SqlPersistT IO a -> IO a
runQuery SqlPersistT IO a
cmd = ConnectionPool -> ((SqlBackend, Connection) -> IO a) -> IO a
forall a r. Pool a -> (a -> IO r) -> IO r
withResource ConnectionPool
pool (((SqlBackend, Connection) -> IO a) -> IO a)
-> ((SqlBackend, Connection) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
                    IO a -> IO a
forall a. IO a -> IO a
observe
                    (IO a -> IO a)
-> ((SqlBackend, Connection) -> IO a)
-> (SqlBackend, Connection)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO DBLog -> NominalDiffTime -> IO a -> IO a
forall a. Tracer IO DBLog -> NominalDiffTime -> IO a -> IO a
retryOnBusy Tracer IO DBLog
tr NominalDiffTime
retryOnBusyTimeout
                    (IO a -> IO a)
-> ((SqlBackend, Connection) -> IO a)
-> (SqlBackend, Connection)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlPersistT IO a -> SqlBackend -> IO a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn SqlPersistT IO a
cmd (SqlBackend -> IO a)
-> ((SqlBackend, Connection) -> SqlBackend)
-> (SqlBackend, Connection)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlBackend, Connection) -> SqlBackend
forall a b. (a, b) -> a
fst

            in SqliteContext -> Either MigrationError SqliteContext
forall a b. b -> Either a b
Right (SqliteContext -> Either MigrationError SqliteContext)
-> SqliteContext -> Either MigrationError SqliteContext
forall a b. (a -> b) -> a -> b
$ SqliteContext :: (forall a. SqlPersistT IO a -> IO a) -> SqliteContext
SqliteContext { forall a. SqlPersistT IO a -> IO a
runQuery :: forall a. SqlPersistT IO a -> IO a
$sel:runQuery:SqliteContext :: forall a. SqlPersistT IO a -> IO a
runQuery }

-- | Finalize database statements and close the database connection.
--
-- If the database connection is still in use, it will retry for up to a minute,
-- to let other threads finish up.
--
-- This function is idempotent: if the database connection has already been
-- closed, calling this function will exit without doing anything.
destroySqliteBackend
    :: Tracer IO DBLog
    -> SqlBackend
    -> FilePath
    -> IO ()
destroySqliteBackend :: Tracer IO DBLog -> SqlBackend -> FilePath -> IO ()
destroySqliteBackend Tracer IO DBLog
tr SqlBackend
sqlBackend FilePath
dbFile = do
    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (FilePath -> DBLog
MsgCloseSingleConnection FilePath
dbFile)

    -- Hack for ADP-827: timeout earlier in integration tests.
    --
    -- There seem to be some concurrency problem causing persistent-sqlite to
    -- leak unfinalized statements, causing SQLITE_BUSY when we try to close the
    -- connection. In this case, retrying 2 or 60 seconds would have no
    -- difference.
    --
    -- But in production, the longer timeout isn't as much of a problem, and
    -- might be needed for windows.
    NominalDiffTime
timeoutSec <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CARDANO_WALLET_TEST_INTEGRATION" IO (Maybe FilePath)
-> (Maybe FilePath -> NominalDiffTime) -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Just FilePath
_ -> NominalDiffTime
2
            Maybe FilePath
Nothing -> NominalDiffTime
retryOnBusyTimeout

    Tracer IO DBLog -> NominalDiffTime -> IO () -> IO ()
forall a. Tracer IO DBLog -> NominalDiffTime -> IO a -> IO a
retryOnBusy Tracer IO DBLog
tr NominalDiffTime
timeoutSec (SqlBackend -> IO ()
forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' SqlBackend
sqlBackend)
        IO () -> (IO () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& (SqliteException -> Bool)
-> (SqliteException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> Bool) -> (e -> m a) -> m a -> m a
handleIf SqliteException -> Bool
isAlreadyClosed
            (Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ())
-> (SqliteException -> DBLog) -> SqliteException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DBLog
MsgIsAlreadyClosed (Text -> DBLog)
-> (SqliteException -> Text) -> SqliteException -> DBLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteException -> Text
forall a. Show a => a -> Text
showT)
        IO () -> (IO () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& (PersistentSqlException -> Bool)
-> (PersistentSqlException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> Bool) -> (e -> m a) -> m a -> m a
handleIf PersistentSqlException -> Bool
statementAlreadyFinalized
            (Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ())
-> (PersistentSqlException -> DBLog)
-> PersistentSqlException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DBLog
MsgStatementAlreadyFinalized (Text -> DBLog)
-> (PersistentSqlException -> Text)
-> PersistentSqlException
-> DBLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentSqlException -> Text
forall a. Show a => a -> Text
showT)
  where
    isAlreadyClosed :: SqliteException -> Bool
isAlreadyClosed = \case
        -- Thrown when an attempt is made to close a connection that is already
        -- in the closed state:
        Sqlite.SqliteException Error
Sqlite.ErrorMisuse Text
_ Text
_ -> Bool
True
        Sqlite.SqliteException {}                     -> Bool
False

    statementAlreadyFinalized :: PersistentSqlException -> Bool
statementAlreadyFinalized = \case
        -- Thrown
        Persist.StatementAlreadyFinalized{} -> Bool
True
        Persist.Couldn'tGetSQLConnection{}  -> Bool
False

    showT :: Show a => a -> Text
    showT :: a -> Text
showT = FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

-- | Default timeout for `retryOnBusy`
retryOnBusyTimeout :: NominalDiffTime
retryOnBusyTimeout :: NominalDiffTime
retryOnBusyTimeout = NominalDiffTime
60

-- | Retry an action if the database yields an 'SQLITE_BUSY' error.
--
-- From <https://www.sqlite.org/rescode.html#busy>
--
--     The SQLITE_BUSY result code indicates that the database file could not be
--     written (or in some cases read) because of concurrent activity by some
--     other database connection, usually a database connection in a separate
--     process.
--
--     For example, if process A is in the middle of a large write transaction
--     and at the same time process B attempts to start a new write transaction,
--     process B will get back an SQLITE_BUSY result because SQLite only supports
--     one writer at a time. Process B will need to wait for process A to finish
--     its transaction before starting a new transaction. The sqlite3_busy_timeout()
--     and sqlite3_busy_handler() interfaces and the busy_timeout pragma are
--     available to process B to help it deal with SQLITE_BUSY errors.
--
retryOnBusy
    :: Tracer IO DBLog -- ^ Logging
    -> NominalDiffTime -- ^ Timeout
    -> IO a -- ^ Action to retry
    -> IO a
retryOnBusy :: Tracer IO DBLog -> NominalDiffTime -> IO a -> IO a
retryOnBusy Tracer IO DBLog
tr NominalDiffTime
timeout IO a
action = RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO a)
-> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicyM IO
policy
    [(SqliteException -> IO Bool)
-> (Bool -> SqliteException -> RetryStatus -> IO ())
-> RetryStatus
-> Handler IO Bool
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> m Bool)
-> (Bool -> e -> RetryStatus -> m ())
-> RetryStatus
-> Handler m Bool
logRetries SqliteException -> IO Bool
forall (f :: * -> *). Applicative f => SqliteException -> f Bool
isBusy Bool -> SqliteException -> RetryStatus -> IO ()
traceRetries]
    (\RetryStatus
st -> IO a
action IO a -> IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RetryLog -> RetryStatus -> IO ()
trace RetryLog
MsgRetryDone RetryStatus
st)
  where
    policy :: RetryPolicyM IO
policy = Int -> RetryPolicyM IO -> RetryPolicyM IO
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
usTimeout (RetryPolicyM IO -> RetryPolicyM IO)
-> RetryPolicyM IO -> RetryPolicyM IO
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM IO
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay (Int
25Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
ms)
    usTimeout :: Int
usTimeout = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate (NominalDiffTime
timeout NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1_000_000)
    ms :: Int
ms = Int
1000 -- microseconds in a millisecond

    isBusy :: SqliteException -> f Bool
isBusy (SqliteException Error
name Text
_ Text
_) = Bool -> f Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error
name Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
Sqlite.ErrorBusy)

    traceRetries :: Bool -> SqliteException -> RetryStatus -> IO ()
traceRetries Bool
retr SqliteException
_ = RetryLog -> RetryStatus -> IO ()
trace (RetryLog -> RetryStatus -> IO ())
-> RetryLog -> RetryStatus -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
retr then RetryLog
MsgRetry else RetryLog
MsgRetryGaveUp

    trace :: RetryLog -> RetryStatus -> IO ()
trace RetryLog
m RetryStatus{Int
rsIterNumber :: RetryStatus -> Int
rsIterNumber :: Int
rsIterNumber} = Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$
        Int -> RetryLog -> DBLog
MsgRetryOnBusy Int
rsIterNumber RetryLog
m

-- | Run the given task in a context where foreign key constraints are
--   /temporarily disabled/, before re-enabling them.
--
withForeignKeysDisabled
    :: Tracer IO DBLog
    -> Sqlite.Connection
    -> IO a
    -> IO a
withForeignKeysDisabled :: Tracer IO DBLog -> Connection -> IO a -> IO a
withForeignKeysDisabled Tracer IO DBLog
t Connection
c =
    IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_
        (Tracer IO DBLog -> Connection -> ForeignKeysSetting -> IO ()
updateForeignKeysSetting Tracer IO DBLog
t Connection
c ForeignKeysSetting
ForeignKeysDisabled)
        (Tracer IO DBLog -> Connection -> ForeignKeysSetting -> IO ()
updateForeignKeysSetting Tracer IO DBLog
t Connection
c ForeignKeysSetting
ForeignKeysEnabled)

-- | Specifies whether or not foreign key constraints are enabled, equivalent
--   to the Sqlite 'foreign_keys' setting.
--
-- When foreign key constraints are /enabled/, the database will enforce
-- referential integrity, and cascading deletes are enabled.
--
-- When foreign keys constraints are /disabled/, the database will not enforce
-- referential integrity, and cascading deletes are disabled.
--
-- See the following resource for more information:
-- https://www.sqlite.org/foreignkeys.html#fk_enable
--
data ForeignKeysSetting
    = ForeignKeysEnabled
        -- ^ Foreign key constraints are /enabled/.
    | ForeignKeysDisabled
        -- ^ Foreign key constraints are /disabled/.
    deriving (ForeignKeysSetting -> ForeignKeysSetting -> Bool
(ForeignKeysSetting -> ForeignKeysSetting -> Bool)
-> (ForeignKeysSetting -> ForeignKeysSetting -> Bool)
-> Eq ForeignKeysSetting
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForeignKeysSetting -> ForeignKeysSetting -> Bool
$c/= :: ForeignKeysSetting -> ForeignKeysSetting -> Bool
== :: ForeignKeysSetting -> ForeignKeysSetting -> Bool
$c== :: ForeignKeysSetting -> ForeignKeysSetting -> Bool
Eq, (forall x. ForeignKeysSetting -> Rep ForeignKeysSetting x)
-> (forall x. Rep ForeignKeysSetting x -> ForeignKeysSetting)
-> Generic ForeignKeysSetting
forall x. Rep ForeignKeysSetting x -> ForeignKeysSetting
forall x. ForeignKeysSetting -> Rep ForeignKeysSetting x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ForeignKeysSetting x -> ForeignKeysSetting
$cfrom :: forall x. ForeignKeysSetting -> Rep ForeignKeysSetting x
Generic, [ForeignKeysSetting] -> Encoding
[ForeignKeysSetting] -> Value
ForeignKeysSetting -> Encoding
ForeignKeysSetting -> Value
(ForeignKeysSetting -> Value)
-> (ForeignKeysSetting -> Encoding)
-> ([ForeignKeysSetting] -> Value)
-> ([ForeignKeysSetting] -> Encoding)
-> ToJSON ForeignKeysSetting
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ForeignKeysSetting] -> Encoding
$ctoEncodingList :: [ForeignKeysSetting] -> Encoding
toJSONList :: [ForeignKeysSetting] -> Value
$ctoJSONList :: [ForeignKeysSetting] -> Value
toEncoding :: ForeignKeysSetting -> Encoding
$ctoEncoding :: ForeignKeysSetting -> Encoding
toJSON :: ForeignKeysSetting -> Value
$ctoJSON :: ForeignKeysSetting -> Value
ToJSON, Int -> ForeignKeysSetting -> ShowS
[ForeignKeysSetting] -> ShowS
ForeignKeysSetting -> FilePath
(Int -> ForeignKeysSetting -> ShowS)
-> (ForeignKeysSetting -> FilePath)
-> ([ForeignKeysSetting] -> ShowS)
-> Show ForeignKeysSetting
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ForeignKeysSetting] -> ShowS
$cshowList :: [ForeignKeysSetting] -> ShowS
show :: ForeignKeysSetting -> FilePath
$cshow :: ForeignKeysSetting -> FilePath
showsPrec :: Int -> ForeignKeysSetting -> ShowS
$cshowsPrec :: Int -> ForeignKeysSetting -> ShowS
Show)

-- | Read the current value of the Sqlite 'foreign_keys' setting.
--
readForeignKeysSetting :: Sqlite.Connection -> IO ForeignKeysSetting
readForeignKeysSetting :: Connection -> IO ForeignKeysSetting
readForeignKeysSetting Connection
connection = do
    Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
connection Text
"PRAGMA foreign_keys"
    [PersistValue]
state <- Statement -> IO StepResult
Sqlite.step Statement
query IO StepResult -> IO [PersistValue] -> IO [PersistValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Statement -> IO [PersistValue]
Sqlite.columns Statement
query
    Statement -> IO ()
Sqlite.finalize Statement
query
    case [PersistValue]
state of
        [Persist.PersistInt64 Int64
0] -> ForeignKeysSetting -> IO ForeignKeysSetting
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignKeysSetting
ForeignKeysDisabled
        [Persist.PersistInt64 Int64
1] -> ForeignKeysSetting -> IO ForeignKeysSetting
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignKeysSetting
ForeignKeysEnabled
        [PersistValue]
unexpectedValue -> FilePath -> IO ForeignKeysSetting
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ForeignKeysSetting)
-> FilePath -> IO ForeignKeysSetting
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat
            [ FilePath
"Unexpected result when querying the current value of "
            , FilePath
"the Sqlite 'foreign_keys' setting: "
            , [PersistValue] -> FilePath
forall a. Show a => a -> FilePath
show [PersistValue]
unexpectedValue
            , FilePath
"."
            ]

-- | Update the current value of the Sqlite 'foreign_keys' setting.
--
updateForeignKeysSetting
    :: Tracer IO DBLog
    -> Sqlite.Connection
    -> ForeignKeysSetting
    -> IO ()
updateForeignKeysSetting :: Tracer IO DBLog -> Connection -> ForeignKeysSetting -> IO ()
updateForeignKeysSetting Tracer IO DBLog
trace Connection
connection ForeignKeysSetting
desiredValue = do
    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
trace (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignKeysSetting -> DBLog
MsgUpdatingForeignKeysSetting ForeignKeysSetting
desiredValue
    Statement
query <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
connection (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$
        Text
"PRAGMA foreign_keys = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valueToWrite Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
    StepResult
_ <- Statement -> IO StepResult
Sqlite.step Statement
query
    Statement -> IO ()
Sqlite.finalize Statement
query
    ForeignKeysSetting
finalValue <- Connection -> IO ForeignKeysSetting
readForeignKeysSetting Connection
connection
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ForeignKeysSetting
desiredValue ForeignKeysSetting -> ForeignKeysSetting -> Bool
forall a. Eq a => a -> a -> Bool
/= ForeignKeysSetting
finalValue) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat
        [ FilePath
"Unexpected error when updating the value of the Sqlite "
        , FilePath
"'foreign_keys' setting. Attempted to write the value "
        , ForeignKeysSetting -> FilePath
forall a. Show a => a -> FilePath
show ForeignKeysSetting
desiredValue
        , FilePath
" but retrieved the final value "
        , ForeignKeysSetting -> FilePath
forall a. Show a => a -> FilePath
show ForeignKeysSetting
finalValue
        , FilePath
"."
        ]
  where
    valueToWrite :: Text
valueToWrite = case ForeignKeysSetting
desiredValue of
        ForeignKeysSetting
ForeignKeysEnabled  -> Text
"ON"
        ForeignKeysSetting
ForeignKeysDisabled -> Text
"OFF"

withConnectionPool
    :: Tracer IO DBLog
    -> FilePath
    -> (ConnectionPool -> IO a)
    -> IO a
withConnectionPool :: Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a
withConnectionPool Tracer IO DBLog
tr FilePath
fp =
    IO ConnectionPool
-> (ConnectionPool -> IO ()) -> (ConnectionPool -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Tracer IO DBLog -> FilePath -> IO ConnectionPool
newConnectionPool Tracer IO DBLog
tr FilePath
fp) (Tracer IO DBLog -> FilePath -> ConnectionPool -> IO ()
forall a. Tracer IO DBLog -> FilePath -> Pool a -> IO ()
destroyConnectionPool Tracer IO DBLog
tr FilePath
fp)

newConnectionPool
    :: Tracer IO DBLog
    -> FilePath
    -> IO ConnectionPool
newConnectionPool :: Tracer IO DBLog -> FilePath -> IO ConnectionPool
newConnectionPool Tracer IO DBLog
tr FilePath
fp = do
    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (DBLog -> IO ()) -> DBLog -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> DBLog
MsgStartConnectionPool FilePath
fp

    let acquireConnection :: IO (SqlBackend, Connection)
acquireConnection = do
            Connection
conn <- Text -> IO Connection
Sqlite.open (FilePath -> Text
T.pack FilePath
fp)
            (,Connection
conn) (SqlBackend -> (SqlBackend, Connection))
-> IO SqlBackend -> IO (SqlBackend, Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> LogFunc -> IO SqlBackend
wrapConnection Connection
conn (Tracer IO DBLog -> LogFunc
queryLogFunc Tracer IO DBLog
tr)

    let releaseConnection :: (SqlBackend, Connection) -> IO ()
releaseConnection = \(SqlBackend
backend, Connection
_) -> do
            Tracer IO DBLog -> SqlBackend -> FilePath -> IO ()
destroySqliteBackend Tracer IO DBLog
tr SqlBackend
backend FilePath
fp

    IO (SqlBackend, Connection)
-> ((SqlBackend, Connection) -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO ConnectionPool
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool
        IO (SqlBackend, Connection)
acquireConnection
        (SqlBackend, Connection) -> IO ()
releaseConnection
        Int
numberOfStripes
        NominalDiffTime
timeToLive
        Int
maximumConnections
  where
    numberOfStripes :: Int
numberOfStripes = Int
1
    maximumConnections :: Int
maximumConnections = Int
10
    timeToLive :: NominalDiffTime
timeToLive = NominalDiffTime
600 {- 10 minutes -} :: NominalDiffTime

destroyConnectionPool :: Tracer IO DBLog -> FilePath -> Pool a -> IO ()
destroyConnectionPool :: Tracer IO DBLog -> FilePath -> Pool a -> IO ()
destroyConnectionPool Tracer IO DBLog
tr FilePath
fp Pool a
pool = do
    Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (FilePath -> DBLog
MsgStopConnectionPool FilePath
fp)
    Pool a -> IO ()
forall a. Pool a -> IO ()
destroyAllResources Pool a
pool

{-------------------------------------------------------------------------------
                                    Migrations
-------------------------------------------------------------------------------}

-- | Error type for when migrations go wrong after opening a database.
newtype MigrationError = MigrationError
    { MigrationError -> Text
getMigrationErrorMessage :: Text }
    deriving (Int -> MigrationError -> ShowS
[MigrationError] -> ShowS
MigrationError -> FilePath
(Int -> MigrationError -> ShowS)
-> (MigrationError -> FilePath)
-> ([MigrationError] -> ShowS)
-> Show MigrationError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MigrationError] -> ShowS
$cshowList :: [MigrationError] -> ShowS
show :: MigrationError -> FilePath
$cshow :: MigrationError -> FilePath
showsPrec :: Int -> MigrationError -> ShowS
$cshowsPrec :: Int -> MigrationError -> ShowS
Show, MigrationError -> MigrationError -> Bool
(MigrationError -> MigrationError -> Bool)
-> (MigrationError -> MigrationError -> Bool) -> Eq MigrationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationError -> MigrationError -> Bool
$c/= :: MigrationError -> MigrationError -> Bool
== :: MigrationError -> MigrationError -> Bool
$c== :: MigrationError -> MigrationError -> Bool
Eq, (forall x. MigrationError -> Rep MigrationError x)
-> (forall x. Rep MigrationError x -> MigrationError)
-> Generic MigrationError
forall x. Rep MigrationError x -> MigrationError
forall x. MigrationError -> Rep MigrationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MigrationError x -> MigrationError
$cfrom :: forall x. MigrationError -> Rep MigrationError x
Generic, [MigrationError] -> Encoding
[MigrationError] -> Value
MigrationError -> Encoding
MigrationError -> Value
(MigrationError -> Value)
-> (MigrationError -> Encoding)
-> ([MigrationError] -> Value)
-> ([MigrationError] -> Encoding)
-> ToJSON MigrationError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MigrationError] -> Encoding
$ctoEncodingList :: [MigrationError] -> Encoding
toJSONList :: [MigrationError] -> Value
$ctoJSONList :: [MigrationError] -> Value
toEncoding :: MigrationError -> Encoding
$ctoEncoding :: MigrationError -> Encoding
toJSON :: MigrationError -> Value
$ctoJSON :: MigrationError -> Value
ToJSON)

instance Exception MigrationError

class Exception e => MatchMigrationError e where
    -- | Exception predicate for migration errors.
    matchMigrationError :: e -> Maybe MigrationError

instance MatchMigrationError PersistException where
    matchMigrationError :: PersistException -> Maybe MigrationError
matchMigrationError PersistException
e
        | FilePath
mark FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
msg = MigrationError -> Maybe MigrationError
forall a. a -> Maybe a
Just (MigrationError -> Maybe MigrationError)
-> MigrationError -> Maybe MigrationError
forall a b. (a -> b) -> a -> b
$ Text -> MigrationError
MigrationError (Text -> MigrationError) -> Text -> MigrationError
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
msg
        | Bool
otherwise = Maybe MigrationError
forall a. Maybe a
Nothing
      where
        msg :: FilePath
msg = PersistException -> FilePath
forall a. Show a => a -> FilePath
show PersistException
e
        mark :: FilePath
mark = FilePath
"Database migration: manual intervention required."

instance MatchMigrationError SqliteException where
    matchMigrationError :: SqliteException -> Maybe MigrationError
matchMigrationError (SqliteException Error
ErrorConstraint Text
_ Text
msg) =
        MigrationError -> Maybe MigrationError
forall a. a -> Maybe a
Just (MigrationError -> Maybe MigrationError)
-> MigrationError -> Maybe MigrationError
forall a b. (a -> b) -> a -> b
$ Text -> MigrationError
MigrationError Text
msg
    matchMigrationError SqliteException
_ =
        Maybe MigrationError
forall a. Maybe a
Nothing

-- | Encapsulates a manual migration action (or sequence of actions) to be
--   performed immediately after an SQL connection is initiated.
--
newtype ManualMigration = ManualMigration
    { ManualMigration -> Connection -> IO ()
executeManualMigration :: Sqlite.Connection -> IO () }

data DBField where
    DBField
        :: forall record typ. (PersistEntity record)
        => EntityField record typ
        -> DBField

tableName :: DBField -> Text
tableName :: DBField -> Text
tableName (DBField (EntityField record typ
_ :: EntityField record typ)) =
    EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName (EntityDef -> EntityNameDB) -> EntityDef -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ Proxy record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Proxy record
forall k (t :: k). Proxy t
Proxy @record)

fieldName :: DBField -> Text
fieldName :: DBField -> Text
fieldName (DBField EntityField record typ
field) =
    FieldNameDB -> Text
unFieldNameDB (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB (FieldDef -> FieldNameDB) -> FieldDef -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ EntityField record typ -> FieldDef
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
field

fieldType :: DBField -> Text
fieldType :: DBField -> Text
fieldType (DBField EntityField record typ
field) =
    SqlType -> Text
showSqlType (SqlType -> Text) -> SqlType -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> SqlType
fieldSqlType (FieldDef -> SqlType) -> FieldDef -> SqlType
forall a b. (a -> b) -> a -> b
$ EntityField record typ -> FieldDef
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
field

showSqlType :: SqlType -> Text
showSqlType :: SqlType -> Text
showSqlType = \case
    SqlType
SqlString  -> Text
"VARCHAR"
    SqlType
SqlInt32   -> Text
"INTEGER"
    SqlType
SqlInt64   -> Text
"INTEGER"
    SqlType
SqlReal    -> Text
"REAL"
    SqlType
SqlDay     -> Text
"DATE"
    SqlType
SqlTime    -> Text
"TIME"
    SqlType
SqlDayTime -> Text
"TIMESTAMP"
    SqlType
SqlBlob    -> Text
"BLOB"
    SqlType
SqlBool    -> Text
"BOOLEAN"
    SqlOther Text
t -> Text
t
    SqlNumeric Word32
precision Word32
scale -> [Text] -> Text
T.concat
        [ Text
"NUMERIC("
        , FilePath -> Text
T.pack (Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
precision)
        , Text
","
        , FilePath -> Text
T.pack (Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
scale), Text
")"
        ]

instance Show DBField where
    show :: DBField -> FilePath
show DBField
field = Text -> FilePath
T.unpack (DBField -> Text
tableName DBField
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBField -> Text
fieldName DBField
field)

instance Eq DBField where
    DBField
field0 == :: DBField -> DBField -> Bool
== DBField
field1 = DBField -> FilePath
forall a. Show a => a -> FilePath
show DBField
field0 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== DBField -> FilePath
forall a. Show a => a -> FilePath
show DBField
field1

instance ToJSON DBField where
    toJSON :: DBField -> Value
toJSON = Text -> Value
Aeson.String (Text -> Value) -> (DBField -> Text) -> DBField -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (DBField -> FilePath) -> DBField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBField -> FilePath
forall a. Show a => a -> FilePath
show

{-------------------------------------------------------------------------------
                                    Logging
-------------------------------------------------------------------------------}

data DBLog
    = MsgMigrations (Either MigrationError Int)
    | MsgQuery Text Severity
    | MsgRun BracketLog
    | MsgCloseSingleConnection FilePath
    | MsgStartConnectionPool FilePath
    | MsgStopConnectionPool FilePath
    | MsgDatabaseReset
    | MsgIsAlreadyClosed Text
    | MsgStatementAlreadyFinalized Text
    | MsgManualMigrationNeeded DBField Text
    | MsgExpectedMigration DBLog
    | MsgManualMigrationNotNeeded DBField
    | MsgUpdatingForeignKeysSetting ForeignKeysSetting
    | MsgRetryOnBusy Int RetryLog
    deriving ((forall x. DBLog -> Rep DBLog x)
-> (forall x. Rep DBLog x -> DBLog) -> Generic DBLog
forall x. Rep DBLog x -> DBLog
forall x. DBLog -> Rep DBLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DBLog x -> DBLog
$cfrom :: forall x. DBLog -> Rep DBLog x
Generic, Int -> DBLog -> ShowS
[DBLog] -> ShowS
DBLog -> FilePath
(Int -> DBLog -> ShowS)
-> (DBLog -> FilePath) -> ([DBLog] -> ShowS) -> Show DBLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DBLog] -> ShowS
$cshowList :: [DBLog] -> ShowS
show :: DBLog -> FilePath
$cshow :: DBLog -> FilePath
showsPrec :: Int -> DBLog -> ShowS
$cshowsPrec :: Int -> DBLog -> ShowS
Show, DBLog -> DBLog -> Bool
(DBLog -> DBLog -> Bool) -> (DBLog -> DBLog -> Bool) -> Eq DBLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DBLog -> DBLog -> Bool
$c/= :: DBLog -> DBLog -> Bool
== :: DBLog -> DBLog -> Bool
$c== :: DBLog -> DBLog -> Bool
Eq, [DBLog] -> Encoding
[DBLog] -> Value
DBLog -> Encoding
DBLog -> Value
(DBLog -> Value)
-> (DBLog -> Encoding)
-> ([DBLog] -> Value)
-> ([DBLog] -> Encoding)
-> ToJSON DBLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [DBLog] -> Encoding
$ctoEncodingList :: [DBLog] -> Encoding
toJSONList :: [DBLog] -> Value
$ctoJSONList :: [DBLog] -> Value
toEncoding :: DBLog -> Encoding
$ctoEncoding :: DBLog -> Encoding
toJSON :: DBLog -> Value
$ctoJSON :: DBLog -> Value
ToJSON)

data RetryLog = MsgRetry | MsgRetryGaveUp | MsgRetryDone
    deriving ((forall x. RetryLog -> Rep RetryLog x)
-> (forall x. Rep RetryLog x -> RetryLog) -> Generic RetryLog
forall x. Rep RetryLog x -> RetryLog
forall x. RetryLog -> Rep RetryLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RetryLog x -> RetryLog
$cfrom :: forall x. RetryLog -> Rep RetryLog x
Generic, Int -> RetryLog -> ShowS
[RetryLog] -> ShowS
RetryLog -> FilePath
(Int -> RetryLog -> ShowS)
-> (RetryLog -> FilePath) -> ([RetryLog] -> ShowS) -> Show RetryLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RetryLog] -> ShowS
$cshowList :: [RetryLog] -> ShowS
show :: RetryLog -> FilePath
$cshow :: RetryLog -> FilePath
showsPrec :: Int -> RetryLog -> ShowS
$cshowsPrec :: Int -> RetryLog -> ShowS
Show, RetryLog -> RetryLog -> Bool
(RetryLog -> RetryLog -> Bool)
-> (RetryLog -> RetryLog -> Bool) -> Eq RetryLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RetryLog -> RetryLog -> Bool
$c/= :: RetryLog -> RetryLog -> Bool
== :: RetryLog -> RetryLog -> Bool
$c== :: RetryLog -> RetryLog -> Bool
Eq, [RetryLog] -> Encoding
[RetryLog] -> Value
RetryLog -> Encoding
RetryLog -> Value
(RetryLog -> Value)
-> (RetryLog -> Encoding)
-> ([RetryLog] -> Value)
-> ([RetryLog] -> Encoding)
-> ToJSON RetryLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RetryLog] -> Encoding
$ctoEncodingList :: [RetryLog] -> Encoding
toJSONList :: [RetryLog] -> Value
$ctoJSONList :: [RetryLog] -> Value
toEncoding :: RetryLog -> Encoding
$ctoEncoding :: RetryLog -> Encoding
toJSON :: RetryLog -> Value
$ctoJSON :: RetryLog -> Value
ToJSON)

instance HasPrivacyAnnotation DBLog
instance HasSeverityAnnotation DBLog where
    getSeverityAnnotation :: DBLog -> Severity
getSeverityAnnotation DBLog
ev = case DBLog
ev of
        MsgMigrations (Right Int
0) -> Severity
Debug
        MsgMigrations (Right Int
_) -> Severity
Notice
        MsgMigrations (Left MigrationError
_) -> Severity
Error
        MsgQuery Text
_ Severity
sev -> Severity
sev
        MsgRun BracketLog
_ -> Severity
Debug
        MsgCloseSingleConnection FilePath
_ -> Severity
Info
        MsgStartConnectionPool FilePath
_ -> Severity
Info
        MsgStopConnectionPool FilePath
_ -> Severity
Info
        MsgExpectedMigration DBLog
_ -> Severity
Debug
        DBLog
MsgDatabaseReset -> Severity
Notice
        MsgIsAlreadyClosed Text
_ -> Severity
Warning
        MsgStatementAlreadyFinalized Text
_ -> Severity
Warning
        MsgManualMigrationNeeded{} -> Severity
Notice
        MsgManualMigrationNotNeeded{} -> Severity
Debug
        MsgUpdatingForeignKeysSetting{} -> Severity
Debug
        MsgRetryOnBusy Int
n RetryLog
_
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 -> Severity
Debug
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 -> Severity
Notice
            | Bool
otherwise -> Severity
Warning

instance ToText DBLog where
    toText :: DBLog -> Text
toText = \case
        MsgMigrations (Right Int
0) ->
            Text
"No database migrations were necessary."
        MsgMigrations (Right Int
n) ->
            Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
""Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+||Int
nInt -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+Builder
" migrations were applied to the database."
        MsgMigrations (Left MigrationError
err) ->
            Text
"Failed to migrate the database: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MigrationError -> Text
getMigrationErrorMessage MigrationError
err
        MsgQuery Text
stmt Severity
_ -> Text
stmt
        MsgRun BracketLog
b ->
            Text
"Running database action - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BracketLog -> Text
forall a. ToText a => a -> Text
toText BracketLog
b
        MsgStartConnectionPool FilePath
fp ->
            Text
"Starting connection pool for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp
        MsgStopConnectionPool FilePath
fp ->
            Text
"Stopping database connection pool " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp
        DBLog
MsgDatabaseReset ->
            Text
"Non backward compatible database found. Removing old database \
            \and re-creating it from scratch. Ignore the previous error."
        MsgCloseSingleConnection FilePath
fp ->
            Builder
"Closing single database connection ("Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|FilePath
fpFilePath -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
")"
        MsgIsAlreadyClosed Text
msg ->
            Text
"Attempted to close an already closed connection: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
        MsgStatementAlreadyFinalized Text
msg ->
            Text
"Statement already finalized: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
        MsgExpectedMigration DBLog
msg -> Text
"Expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBLog -> Text
forall a. ToText a => a -> Text
toText DBLog
msg
        MsgManualMigrationNeeded DBField
field Text
value -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ DBField -> Text
tableName DBField
field
            , Text
" table does not contain required field '"
            , DBField -> Text
fieldName DBField
field
            , Text
"'. "
            , Text
"Adding this field with a default value of "
            , Text
value
            , Text
"."
            ]
        MsgManualMigrationNotNeeded DBField
field -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ DBField -> Text
tableName DBField
field
            , Text
" table already contains required field '"
            , DBField -> Text
fieldName DBField
field
            , Text
"'."
            ]
        MsgUpdatingForeignKeysSetting ForeignKeysSetting
value -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Updating the foreign keys setting to: "
            , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ForeignKeysSetting -> FilePath
forall a. Show a => a -> FilePath
show ForeignKeysSetting
value
            , Text
"."
            ]
        MsgRetryOnBusy Int
n RetryLog
msg -> case RetryLog
msg of
            RetryLog
MsgRetry
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10 ->
                    Builder
"Retrying db query because db was busy " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                    Builder
"for the " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int -> Builder
forall a. (Buildable a, Integral a) => a -> Builder
ordinalF Int
n Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" time."
                | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 ->
                    Text
"No more logs until it finishes..."
                | Bool
otherwise -> Text
""
            RetryLog
MsgRetryGaveUp -> Text
"Gave up on retrying the db query."
            RetryLog
MsgRetryDone
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 -> Builder
"DB query succeeded after " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
n Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" attempts."
                | Bool
otherwise -> Text
""

-- | Produce a persistent 'LogFunc' backed by 'Tracer IO DBLog'
queryLogFunc :: Tracer IO DBLog -> LogFunc
queryLogFunc :: Tracer IO DBLog -> LogFunc
queryLogFunc Tracer IO DBLog
tr Loc
_loc Text
_source LogLevel
level LogStr
str = Tracer IO DBLog -> DBLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBLog
tr (Text -> Severity -> DBLog
MsgQuery Text
msg Severity
sev)
  where
    -- Filter out parameters which appear after the statement semicolon.
    -- They will contain sensitive material that we don't want in the log.
    stmt :: ByteString
stmt = (Char -> Bool) -> ByteString -> ByteString
B8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
fromLogStr LogStr
str
    msg :: Text
msg = ByteString -> Text
T.decodeUtf8 ByteString
stmt
    sev :: Severity
sev = case LogLevel
level of
        LogLevel
LevelDebug -> Severity
Debug
        LogLevel
LevelInfo -> Severity
Info
        LogLevel
LevelWarn -> Severity
Warning
        LogLevel
LevelError -> Severity
Error
        LevelOther Text
_ -> Severity
Warning

{-------------------------------------------------------------------------------
                               Extra DB Helpers
-------------------------------------------------------------------------------}

-- | Convert a single DB "updateMany" (or similar) query into multiple
-- updateMany queries with smaller lists of values.
--
-- This is to prevent too many variables appearing in the SQL statement.
-- SQLITE_MAX_VARIABLE_NUMBER is 999 by default, and we will get a
-- "too many SQL variables" exception if that is exceeded.
--
-- We choose a conservative value 'chunkSize' << 999 because there can be
-- multiple variables per row updated.
dbChunked
    :: forall record b. PersistEntity record
    => ([record] -> SqlPersistT IO b)
    -> [record]
    -> SqlPersistT IO ()
dbChunked :: ([record] -> SqlPersistT IO b) -> [record] -> SqlPersistT IO ()
dbChunked = forall a b.
PersistEntity record =>
([a] -> SqlPersistT IO b) -> [a] -> SqlPersistT IO ()
forall record a b.
PersistEntity record =>
([a] -> SqlPersistT IO b) -> [a] -> SqlPersistT IO ()
dbChunkedFor @record

-- | Like 'dbChunked', but generalized for the case where the input list is not
-- the same type as the record.
dbChunkedFor
    :: forall record a b. PersistEntity record
    => ([a] -> SqlPersistT IO b)
    -> [a]
    -> SqlPersistT IO ()
dbChunkedFor :: ([a] -> SqlPersistT IO b) -> [a] -> SqlPersistT IO ()
dbChunkedFor = Int -> ([a] -> SqlPersistT IO b) -> [a] -> SqlPersistT IO ()
forall (m :: * -> *) a b.
Monad m =>
Int -> ([a] -> m b) -> [a] -> m ()
chunkedM (PersistEntity record => Int
forall record. PersistEntity record => Int
chunkSizeFor @record)

-- | Like 'dbChunked', but allows bundling elements with a 'Key'. Useful when
-- used with 'repsertMany'.
dbChunked'
    :: forall record b. PersistEntity record
    => ([(Key record, record)] -> SqlPersistT IO b)
    -> [(Key record, record)]
    -> SqlPersistT IO ()
dbChunked' :: ([(Key record, record)] -> SqlPersistT IO b)
-> [(Key record, record)] -> SqlPersistT IO ()
dbChunked' = Int
-> ([(Key record, record)] -> SqlPersistT IO b)
-> [(Key record, record)]
-> SqlPersistT IO ()
forall (m :: * -> *) a b.
Monad m =>
Int -> ([a] -> m b) -> [a] -> m ()
chunkedM (PersistEntity record => Int
forall record. PersistEntity record => Int
chunkSizeFor @record)

-- | Given an action which takes a list of items, and a list of items, run that
-- action multiple times with the input list cut into chunks.
chunkedM
    :: Monad m
    => Int -- ^ Chunk size
    -> ([a] -> m b) -- ^ Action to run on values
    -> [a] -- ^ The values
    -> m ()
chunkedM :: Int -> ([a] -> m b) -> [a] -> m ()
chunkedM Int
n [a] -> m b
f = ([a] -> m b) -> [[a]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [a] -> m b
f ([[a]] -> m ()) -> ([a] -> [[a]]) -> [a] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [[a]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
n

-- | Maximum number of variables allowed in a single SQL statement
--
-- See also 'dbChunked'.
chunkSize :: Int
chunkSize :: Int
chunkSize = Int
999


-- | Size of chunks when inserting, updating or deleting many rows at once.
-- Worst-case is when all columns of a particular table gets updated / inserted,
-- thus to be safe we must ensure that we do not act on more than `chunkSize /
-- cols` variables.
--
-- See also 'dbChunked'.
chunkSizeFor :: forall record. PersistEntity record => Int
chunkSizeFor :: Int
chunkSizeFor = Int
chunkSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cols
  where
    cols :: Int
cols = [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FieldDef] -> Int) -> [FieldDef] -> Int
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields (EntityDef -> [FieldDef]) -> EntityDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ Proxy record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Proxy record
forall k (t :: k). Proxy t
Proxy @record)
    -- TODO: Does getEntityFields differ from the past entityFields?