{-# 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 :: 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 :: (forall env a.
 HasLogFunc env =>
 ReaderT SqlBackend (RIO env) a -> RIO env a)
-> (forall env a. HasLogFunc env => RIO env a -> RIO env a)
-> Storage
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_ = 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 :: 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 (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 (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