    {-# 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 description :: Text
    description migration :: Migration
    migration fp :: Path Abs File
    fp inner :: 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, MonadLogger 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 (m :: * -> *) backend 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
    $ \mig :: 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
    $ "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, MonadLogger 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
    $ \conn0 :: 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_ = \action :: 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
    $ \conn :: 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 (m :: * -> *) backend 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 isMigration :: 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 ["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 desc :: Utf8Builder
    desc dbFile :: Path Abs File
    dbFile inner :: 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]
    ++ ".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
    $ \run :: 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 res :: a
    res -> a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    res
          Nothing -> do
            let complainer :: Companion IO
                complainer :: Companion IO
    complainer delay :: 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
    $ 5 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 1000 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 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
    $ "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
    <> " 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 (60 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 1000 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 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 ("Acquired the " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> Utf8Builder
    desc Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> " database write lock")
                    Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logWarn ("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
    <> " 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
    $ \stopComplaining :: 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