{-# 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 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

  -- Make a single connection to the SQLite database and wrap it in an MVar for

  -- the entire execution context. Previously we used a resource pool of size

  -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird

  -- interaction with Docker on OS X where when resource-pool's reaper would

  -- trigger, it would somehow cause the Stack process inside the container to

  -- die with a SIGBUS. Definitely an interesting thing worth following up

  -- on...

  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
      -- NOTE: Currently, we take a write lock on every action. This is

      -- a bit heavyweight, but it avoids the SQLITE_BUSY errors

      -- reported in

      -- <https://github.com/commercialhaskell/stack/issues/4471>

      -- completely. We can investigate more elegant solutions in the

      -- future, such as separate read and write actions or introducing

      -- smarter retry logic.

      { 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

           -- When doing a migration, we want to disable foreign key

           -- checking, since the order in which tables are created by

           -- the migration scripts may not respect foreign keys. The

           -- rest of the time: enforce those foreign keys.

           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)

-- | Ensure that only one process is trying to write to the database

-- at a time. See

-- https://github.com/commercialhaskell/stack/issues/4471 and comments

-- above.

withWriteLock
  :: HasLogFunc env
  => Utf8Builder -- ^ database description, for lock messages

  -> Path Abs File -- ^ SQLite database 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
              -- Wait five seconds before giving the first message to

              -- avoid spamming the user for uninteresting file locks

              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 -- 5 seconds

              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..."

              -- Now loop printing a message every 1 minute

              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) -- 1 minute

                  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