{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Pantry.SQLite
  ( Storage (..)
  , initStorage
  ) where

import           Control.Concurrent.Companion
                   ( Companion, onCompanionDone, withCompanion )
import           Database.Persist.Sqlite
import           Pantry.Types
                   ( PantryException (MigrationFailure), 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 -- ^ Database description, for lock messages.

  -> Migration -- ^ Initial migration.

  -> Path Abs File -- ^ SQLite database file.

  -> (Storage -> RIO env a) -- ^ What to do with the initialised 'Storage'.

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