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