{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- A function to wait until a suitable time to delete a SQLite database file,
-- and a function to delete a SQLite database file, which isn't as
-- straightforward as it sounds.

module Cardano.DB.Sqlite.Delete
    ( -- * Removing files with retry
      deleteSqliteDatabase
    , deleteSqliteDatabase'
    , deleteSqliteDatabaseRetryPolicy
    , DeleteSqliteDatabaseLog (..)
    -- * Ref-counting open databases
    , RefCount
    , newRefCount
    , withRef
    , waitForFree
    , waitForFree'
    , waitForFreeRetryPolicy
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Control.Retry
    ( RetryPolicy
    , RetryStatus (..)
    , capDelay
    , fibonacciBackoff
    , limitRetries
    , limitRetriesByCumulativeDelay
    , retryPolicy
    , retrying
    )
import Control.Tracer
    ( Tracer, traceWith )
import Data.Aeson
    ( ToJSON )
import Data.Function
    ( (&) )
import Data.Map.Strict
    ( Map )
import Data.Maybe
    ( fromMaybe, isJust )
import Data.Text.Class
    ( ToText (..) )
import GHC.Generics
    ( Generic )
import System.Directory
    ( removePathForcibly )
import UnliftIO.Exception
    ( bracket_ )
import UnliftIO.MVar
    ( MVar, modifyMVar, modifyMVar_, newMVar, readMVar )

#if defined(mingw32_HOST_OS)
import Control.Retry
    ( logRetries, recovering )
import System.IO.Error
    ( isPermissionError )
#else
#endif

import qualified Data.Map.Strict as Map
import qualified Data.Text as T

{-------------------------------------------------------------------------------
                           Removing files with retry
-------------------------------------------------------------------------------}

-- | Remove a SQLite database file.
--
-- If <https://www.sqlite.org/tempfiles.html SQLite temporary files> are present
-- (@-wal@ and @-shm@), we remove them as well. Normally, they would be removed
-- when the SQLite connection is closed. But we attempt to remove them anyway,
-- in case cardano-wallet was unable to close the SQLite connection.
--
-- Additionally, on Windows, the deletion operations will be retried for a short
-- time if they fail.  The reason for this is that a FileDelete command just
-- marks a file for deletion. The file is really only removed when the last
-- handle to the file is closed. Unfortunately there are a lot of system
-- services that can have a file temporarily opened using a shared read-only
-- lock, such as the built in AV and search indexer.
--
-- We can't really guarantee that these are all off, so what we can do is
-- whenever after an rm the file still exists to try again and wait a bit.
--
-- See <https://github.com/haskell/directory/issues/96> for more information
-- about this issue.
deleteSqliteDatabase :: Tracer IO DeleteSqliteDatabaseLog -> FilePath -> IO ()
deleteSqliteDatabase :: Tracer IO DeleteSqliteDatabaseLog -> FilePath -> IO ()
deleteSqliteDatabase Tracer IO DeleteSqliteDatabaseLog
tr =
    Tracer IO DeleteSqliteDatabaseLog
-> RetryPolicy -> FilePath -> IO ()
deleteSqliteDatabase' Tracer IO DeleteSqliteDatabaseLog
tr RetryPolicy
deleteSqliteDatabaseRetryPolicy

-- | A variant of 'deleteSqliteDatabase' where the caller can specify the
-- 'RetryPolicy'.
deleteSqliteDatabase'
    :: Tracer IO DeleteSqliteDatabaseLog
    -> RetryPolicy
    -> FilePath
    -> IO ()
deleteSqliteDatabase' :: Tracer IO DeleteSqliteDatabaseLog
-> RetryPolicy -> FilePath -> IO ()
deleteSqliteDatabase' Tracer IO DeleteSqliteDatabaseLog
tr RetryPolicy
pol FilePath
db = (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
delete [FilePath]
files
  where
    files :: [FilePath]
files = [ FilePath
db, FilePath
db FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-wal", FilePath
db FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-shm" ]
    delete :: FilePath -> IO ()
delete = Tracer IO DeleteSqliteDatabaseLog -> RetryPolicy -> IO () -> IO ()
handleErrors Tracer IO DeleteSqliteDatabaseLog
tr RetryPolicy
pol (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removePathForcibly

handleErrors
    :: Tracer IO DeleteSqliteDatabaseLog
    -> RetryPolicy
    -> IO ()
    -> IO ()
#if defined(mingw32_HOST_OS)
handleErrors tr policy = recovering policy [check] . const
  where
    check = logRetries (pure . isPermissionError) logRetry
    logRetry True _ st = traceWith tr $ MsgRetryDelete $ rsIterNumber st
    logRetry False e _ = traceWith tr $ MsgGaveUpDelete $ show e
#else
handleErrors :: Tracer IO DeleteSqliteDatabaseLog -> RetryPolicy -> IO () -> IO ()
handleErrors Tracer IO DeleteSqliteDatabaseLog
_ RetryPolicy
_ = IO () -> IO ()
forall a. a -> a
id
#endif

-- | Retry policy where delay increases linearly from base with each retry.
-- (as <https://www.sqlite.org/src/info/89f1848d7f implemented by SQLite>)
linearBackoff
    :: Int
    -- ^ Base delay in microseconds
    -> RetryPolicy
linearBackoff :: Int -> RetryPolicy
linearBackoff Int
base = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy ((RetryStatus -> Maybe Int) -> RetryPolicyM m)
-> (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } ->
  Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n

-- | Recommended retry policy for 'deleteSqliteDatabase'.
deleteSqliteDatabaseRetryPolicy :: RetryPolicy
deleteSqliteDatabaseRetryPolicy :: RetryPolicyM m
deleteSqliteDatabaseRetryPolicy = Int -> RetryPolicy
linearBackoff Int
25000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10

-- | Log messages that may arise from 'deleteSqliteDatabase'.
data DeleteSqliteDatabaseLog
    = MsgRetryDelete Int
    | MsgGaveUpDelete String
    deriving ((forall x.
 DeleteSqliteDatabaseLog -> Rep DeleteSqliteDatabaseLog x)
-> (forall x.
    Rep DeleteSqliteDatabaseLog x -> DeleteSqliteDatabaseLog)
-> Generic DeleteSqliteDatabaseLog
forall x. Rep DeleteSqliteDatabaseLog x -> DeleteSqliteDatabaseLog
forall x. DeleteSqliteDatabaseLog -> Rep DeleteSqliteDatabaseLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeleteSqliteDatabaseLog x -> DeleteSqliteDatabaseLog
$cfrom :: forall x. DeleteSqliteDatabaseLog -> Rep DeleteSqliteDatabaseLog x
Generic, Int -> DeleteSqliteDatabaseLog -> FilePath -> FilePath
[DeleteSqliteDatabaseLog] -> FilePath -> FilePath
DeleteSqliteDatabaseLog -> FilePath
(Int -> DeleteSqliteDatabaseLog -> FilePath -> FilePath)
-> (DeleteSqliteDatabaseLog -> FilePath)
-> ([DeleteSqliteDatabaseLog] -> FilePath -> FilePath)
-> Show DeleteSqliteDatabaseLog
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DeleteSqliteDatabaseLog] -> FilePath -> FilePath
$cshowList :: [DeleteSqliteDatabaseLog] -> FilePath -> FilePath
show :: DeleteSqliteDatabaseLog -> FilePath
$cshow :: DeleteSqliteDatabaseLog -> FilePath
showsPrec :: Int -> DeleteSqliteDatabaseLog -> FilePath -> FilePath
$cshowsPrec :: Int -> DeleteSqliteDatabaseLog -> FilePath -> FilePath
Show, DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool
(DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool)
-> (DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool)
-> Eq DeleteSqliteDatabaseLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool
$c/= :: DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool
== :: DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool
$c== :: DeleteSqliteDatabaseLog -> DeleteSqliteDatabaseLog -> Bool
Eq, [DeleteSqliteDatabaseLog] -> Encoding
[DeleteSqliteDatabaseLog] -> Value
DeleteSqliteDatabaseLog -> Encoding
DeleteSqliteDatabaseLog -> Value
(DeleteSqliteDatabaseLog -> Value)
-> (DeleteSqliteDatabaseLog -> Encoding)
-> ([DeleteSqliteDatabaseLog] -> Value)
-> ([DeleteSqliteDatabaseLog] -> Encoding)
-> ToJSON DeleteSqliteDatabaseLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [DeleteSqliteDatabaseLog] -> Encoding
$ctoEncodingList :: [DeleteSqliteDatabaseLog] -> Encoding
toJSONList :: [DeleteSqliteDatabaseLog] -> Value
$ctoJSONList :: [DeleteSqliteDatabaseLog] -> Value
toEncoding :: DeleteSqliteDatabaseLog -> Encoding
$ctoEncoding :: DeleteSqliteDatabaseLog -> Encoding
toJSON :: DeleteSqliteDatabaseLog -> Value
$ctoJSON :: DeleteSqliteDatabaseLog -> Value
ToJSON)

instance ToText DeleteSqliteDatabaseLog where
    toText :: DeleteSqliteDatabaseLog -> Text
toText DeleteSqliteDatabaseLog
msg = case DeleteSqliteDatabaseLog
msg of
        MsgRetryDelete Int
retryNum ->
            Text
"retry " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
retryNum) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for lock/sharing violation - probably due to antivirus software"
        MsgGaveUpDelete FilePath
e ->
            Text
"gave up on delete due to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
e

instance HasPrivacyAnnotation DeleteSqliteDatabaseLog
instance HasSeverityAnnotation DeleteSqliteDatabaseLog where
    getSeverityAnnotation :: DeleteSqliteDatabaseLog -> Severity
getSeverityAnnotation DeleteSqliteDatabaseLog
msg = case DeleteSqliteDatabaseLog
msg of
        MsgRetryDelete Int
_ -> Severity
Warning
        MsgGaveUpDelete FilePath
_ -> Severity
Error

{-------------------------------------------------------------------------------
                          Ref-counting open databases
-------------------------------------------------------------------------------}

-- | Mutable variable containing reference counts to IDs of type @ix@.
data RefCount ix = RefCount
    { RefCount ix -> MVar (Map ix Int)
_refCount :: MVar (Map ix Int) -- ^ number of references to each index
    , RefCount ix -> MVar ()
_takeLock :: MVar () -- ^ lock on incrementing references
    }

-- | Construct a 'RefCount' with zero references.
newRefCount :: Ord ix => IO (RefCount ix)
newRefCount :: IO (RefCount ix)
newRefCount = MVar (Map ix Int) -> MVar () -> RefCount ix
forall ix. MVar (Map ix Int) -> MVar () -> RefCount ix
RefCount (MVar (Map ix Int) -> MVar () -> RefCount ix)
-> IO (MVar (Map ix Int)) -> IO (MVar () -> RefCount ix)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ix Int -> IO (MVar (Map ix Int))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map ix Int
forall a. Monoid a => a
mempty IO (MVar () -> RefCount ix) -> IO (MVar ()) -> IO (RefCount ix)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()

-- | Acquire a reference to the given identifier, perform the given action, then
-- release the reference. Multiple 'withRef' calls can take references at the
-- same time.
withRef :: Ord ix => RefCount ix -> ix -> IO a -> IO a
withRef :: RefCount ix -> ix -> IO a -> IO a
withRef (RefCount MVar (Map ix Int)
mvar MVar ()
lock) ix
ix =
    IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (MVar () -> (() -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Map ix Int -> Map ix Int) -> IO ()
forall (m :: * -> *).
MonadUnliftIO m =>
(Map ix Int -> Map ix Int) -> m ()
modify Map ix Int -> Map ix Int
inc) ((Map ix Int -> Map ix Int) -> IO ()
forall (m :: * -> *).
MonadUnliftIO m =>
(Map ix Int -> Map ix Int) -> m ()
modify Map ix Int -> Map ix Int
dec)
  where
    modify :: (Map ix Int -> Map ix Int) -> m ()
modify Map ix Int -> Map ix Int
f = MVar (Map ix Int) -> (Map ix Int -> m (Map ix Int)) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Map ix Int)
mvar (Map ix Int -> m (Map ix Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ix Int -> m (Map ix Int))
-> (Map ix Int -> Map ix Int) -> Map ix Int -> m (Map ix Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ix Int -> Map ix Int
f)
    inc :: Map ix Int -> Map ix Int
inc = (Int -> Int -> Int) -> ix -> Int -> Map ix Int -> Map ix Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ix
ix Int
1
    dec :: Map ix Int -> Map ix Int
dec = (Int -> Maybe Int) -> ix -> Map ix Int -> Map ix Int
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (\Int
n -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Maybe Int
forall a. Maybe a
Nothing) ix
ix

-- | Attempt to wait until all 'withRef' calls for the given identifier have
-- completed, then perform an action.
--
-- This will block for up to 2 minutes before running the action. The action is
-- passed the reference count, which should be @0@ under normal conditions.
--
-- No new references can be taken using 'withRef' while the action is running.
waitForFree
    :: Ord ix
    => Tracer IO (Maybe Int)
    -- ^ Logging of current number of references
    -> RefCount ix
    -- ^ Mutable variable containing reference counts
    -> ix
    -- ^ Identifier
    -> (Int -> IO a)
    -- ^ Action to run, passed number of references in use
    -> IO a
waitForFree :: Tracer IO (Maybe Int) -> RefCount ix -> ix -> (Int -> IO a) -> IO a
waitForFree Tracer IO (Maybe Int)
tr = Tracer IO (Maybe Int)
-> RetryPolicy -> RefCount ix -> ix -> (Int -> IO a) -> IO a
forall ix a.
Ord ix =>
Tracer IO (Maybe Int)
-> RetryPolicy -> RefCount ix -> ix -> (Int -> IO a) -> IO a
waitForFree' Tracer IO (Maybe Int)
tr RetryPolicy
waitForFreeRetryPolicy

-- | A variant of 'waitForFree' where the caller can specify the 'RetryPolicy'.
waitForFree'
    :: Ord ix
    => Tracer IO (Maybe Int)
    -- ^ Logging of current number of references
    -> RetryPolicy
    -- ^ How and when to poll the 'RefCount'
    -> RefCount ix
    -- ^ Mutable variable containing reference counts
    -> ix
    -- ^ Identifier
    -> (Int -> IO a)
    -- ^ Action to run, passed number of references in use
    -> IO a
waitForFree' :: Tracer IO (Maybe Int)
-> RetryPolicy -> RefCount ix -> ix -> (Int -> IO a) -> IO a
waitForFree' Tracer IO (Maybe Int)
tr RetryPolicy
pol (RefCount MVar (Map ix Int)
mvar MVar ()
lock) ix
ix Int -> IO a
action = MVar () -> (() -> IO ((), a)) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar ()
lock ((() -> IO ((), a)) -> IO a) -> (() -> IO ((), a)) -> IO a
forall a b. (a -> b) -> a -> b
$ IO ((), a) -> () -> IO ((), a)
forall a b. a -> b -> a
const (IO ((), a) -> () -> IO ((), a)) -> IO ((), a) -> () -> IO ((), a)
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int
res <- RetryPolicyM IO
-> (RetryStatus -> Maybe Int -> IO Bool)
-> (RetryStatus -> IO (Maybe Int))
-> IO (Maybe Int)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM IO
RetryPolicy
pol ((Maybe Int -> IO Bool) -> RetryStatus -> Maybe Int -> IO Bool
forall a b. a -> b -> a
const ((Maybe Int -> IO Bool) -> RetryStatus -> Maybe Int -> IO Bool)
-> (Maybe Int -> IO Bool) -> RetryStatus -> Maybe Int -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Maybe Int -> Bool) -> Maybe Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust) (IO (Maybe Int) -> RetryStatus -> IO (Maybe Int)
forall a b. a -> b -> a
const IO (Maybe Int)
check)
    ((), ) (a -> ((), a)) -> IO a -> IO ((), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO a
action (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
res)
  where
    check :: IO (Maybe Int)
check = do
        Maybe Int
refs <- ix -> Map ix Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ix
ix (Map ix Int -> Maybe Int) -> IO (Map ix Int) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map ix Int) -> IO (Map ix Int)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Map ix Int)
mvar
        Tracer IO (Maybe Int) -> Maybe Int -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (Maybe Int)
tr Maybe Int
refs
        Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
refs

-- | Recommended retry schedule for polling the 'RefCount'. It will poll for up
-- to 2 minutes.
waitForFreeRetryPolicy :: RetryPolicy
waitForFreeRetryPolicy :: RetryPolicyM m
waitForFreeRetryPolicy = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
fibonacciBackoff Int
50_000 RetryPolicyM m
-> (RetryPolicyM m -> RetryPolicyM m) -> RetryPolicyM m
forall a b. a -> (a -> b) -> b
& Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
5_000_000
    RetryPolicyM m
-> (RetryPolicyM m -> RetryPolicyM m) -> RetryPolicyM m
forall a b. a -> (a -> b) -> b
& Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
120_000_000