{-# 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 description migration fp inner = do
ensureDir $ parent fp
migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $
withSqliteConnInfo (sqinfo True) $ runSqlConn $
runMigrationSilent migration
forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig
withSqliteConnInfo (sqinfo False) $ \conn0 -> do
connVar <- newMVar conn0
inner $ Storage
{ withStorage_ = \action -> withMVar connVar $ \conn ->
withWriteLock (display description) fp $
runSqlConn action conn
, withWriteLock_ = id
}
where
wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp)
sqinfo isMigration
= set extraPragmas ["PRAGMA busy_timeout=2000;"]
$ set walEnabled False
$ set fkEnabled (not isMigration)
$ mkSqliteConnectionInfo (fromString $ toFilePath fp)
withWriteLock
:: HasLogFunc env
=> Utf8Builder
-> Path Abs File
-> RIO env a
-> RIO env a
withWriteLock desc dbFile inner = do
let lockFile = toFilePath dbFile ++ ".pantry-write-lock"
withRunInIO $ \run -> do
mres <- withTryFileLock lockFile Exclusive $ const $ run inner
case mres of
Just res -> pure res
Nothing -> do
let complainer :: Companion IO
complainer delay = run $ do
delay $ 5 * 1000 * 1000
logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..."
forever $ do
delay (60 * 1000 * 1000)
`onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock")
logWarn ("Still waiting on the " <> desc <> " database write lock...")
withCompanion complainer $ \stopComplaining ->
withFileLock lockFile Exclusive $ const $ do
stopComplaining
run inner