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

      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
      forM_ migrates $ \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...

      withSqliteConnInfo (sqinfo False) $ \SqlBackend
    conn0 -> do
        connVar <- SqlBackend -> RIO env (MVar SqlBackend)
    forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
    newMVar SqlBackend
    conn0
        inner $ 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_ = \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_ = 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
        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 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