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

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

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

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

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

-- | 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 = 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
              -- Wait five seconds before giving the first message to

              -- avoid spamming the user for uninteresting file locks

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

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

              -- Now loop printing a message every 1 minute

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

                  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