{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Pantry.SQLite
( Storage (..)
, initStorage
) where
import RIO hiding (FilePath)
import Database.Persist.Sqlite
import RIO.Orphans ()
import Path (Path, Abs, File, toFilePath, parent)
import Path.IO (ensureDir)
import Pantry.Types (PantryException (MigrationFailure), Storage (..))
import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..))
import Pantry.Internal.Companion
initStorage
:: HasLogFunc env
=> Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
initStorage :: forall env a.
HasLogFunc env =>
Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
initStorage Text
description Migration
migration Path Abs File
fp Storage -> RIO env a
inner = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
fp
[Text]
migrates <- forall env a.
HasLogFunc env =>
Utf8Builder -> Path Abs File -> RIO env a -> RIO env a
withWriteLock (forall a. Display a => a -> Utf8Builder
display Text
description) Path Abs File
fp forall a b. (a -> b) -> a -> b
$ forall {a}. RIO env a -> RIO env a
wrapMigrationFailure forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo (Bool -> SqliteConnectionInfo
sqinfo Bool
True) forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationSilent Migration
migration
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
migrates forall a b. (a -> b) -> a -> b
$ \Text
mig -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Migration executed: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
mig
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo (Bool -> SqliteConnectionInfo
sqinfo Bool
False) forall a b. (a -> b) -> a -> b
$ \SqlBackend
conn0 -> do
MVar SqlBackend
connVar <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar SqlBackend
conn0
Storage -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Storage
{ withStorage_ :: forall env a.
HasLogFunc env =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage_ = \ReaderT SqlBackend (RIO env) a
action -> forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar SqlBackend
connVar forall a b. (a -> b) -> a -> b
$ \SqlBackend
conn ->
forall env a.
HasLogFunc env =>
Utf8Builder -> Path Abs File -> RIO env a -> RIO env a
withWriteLock (forall a. Display a => a -> Utf8Builder
display Text
description) Path Abs File
fp forall a b. (a -> b) -> a -> b
$
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn ReaderT SqlBackend (RIO env) a
action SqlBackend
conn
, withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ = forall a. a -> a
id
}
where
wrapMigrationFailure :: RIO env a -> RIO env a
wrapMigrationFailure = forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Path Abs File -> SomeException -> PantryException
MigrationFailure Text
description Path Abs File
fp)
sqinfo :: Bool -> SqliteConnectionInfo
sqinfo Bool
isMigration
= forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SqliteConnectionInfo [Text]
extraPragmas [Text
"PRAGMA busy_timeout=2000;"]
forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SqliteConnectionInfo Bool
walEnabled Bool
False
forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SqliteConnectionInfo Bool
fkEnabled (Bool -> Bool
not Bool
isMigration)
forall a b. (a -> b) -> a -> b
$ Text -> SqliteConnectionInfo
mkSqliteConnectionInfo (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
fp)
withWriteLock
:: HasLogFunc env
=> Utf8Builder
-> Path Abs File
-> RIO env a
-> RIO env a
withWriteLock :: forall env a.
HasLogFunc env =>
Utf8Builder -> Path Abs File -> RIO env a -> RIO env a
withWriteLock Utf8Builder
desc Path Abs File
dbFile RIO env a
inner = do
let lockFile :: String
lockFile = forall b t. Path b t -> String
toFilePath Path Abs File
dbFile forall a. [a] -> [a] -> [a]
++ String
".pantry-write-lock"
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> do
Maybe a
mres <- forall a.
String -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)
withTryFileLock String
lockFile SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. RIO env a -> IO a
run RIO env a
inner
case Maybe a
mres of
Just a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
Maybe a
Nothing -> do
let complainer :: Companion IO
complainer :: Companion IO
complainer Delay
delay = forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ do
Delay
delay forall a b. (a -> b) -> a -> b
$ Int
5 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Unable to get a write lock on the " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
desc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" database, waiting..."
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Delay
delay (Int
60 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000)
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
`onCompanionDone` forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Acquired the " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
desc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" database write lock")
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Still waiting on the " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
desc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" database write lock...")
forall (m :: * -> *) a.
MonadUnliftIO m =>
Companion m -> (StopCompanion m -> m a) -> m a
withCompanion Companion IO
complainer forall a b. (a -> b) -> a -> b
$ \IO ()
stopComplaining ->
forall a. String -> SharedExclusive -> (FileLock -> IO a) -> IO a
withFileLock String
lockFile SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
IO ()
stopComplaining
forall a. RIO env a -> IO a
run RIO env a
inner