{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.Node.Recovery (
    LastShutDownWasClean (..)
  , createCleanShutdownMarker
  , hasCleanShutdownMarker
  , removeCleanShutdownMarker
  , runWithCheckedDB
  ) where

import           Control.Monad (unless, when)
import           Control.Tracer (Tracer, traceWith)
import           Data.Proxy (Proxy)
import           Data.Typeable (Typeable)
import           Ouroboros.Consensus.Block (StandardHash)
import           Ouroboros.Consensus.Node.Exit (ExitReason (..), toExitReason)
import           Ouroboros.Consensus.Storage.ChainDB
import           Ouroboros.Consensus.Util.IOLike
import           System.FS.API (HasFS, doesFileExist, removeFile, withFile)
import           System.FS.API.Types (AllowExisting (..), FsPath, OpenMode (..),
                     mkFsPath)

-- | The path to the /clean shutdown marker file/.
cleanShutdownMarkerFile :: FsPath
cleanShutdownMarkerFile :: FsPath
cleanShutdownMarkerFile = [String] -> FsPath
mkFsPath [String
"clean"]

-- | Did the ChainDB already have existing clean-shutdown marker on disk?
newtype LastShutDownWasClean = LastShutDownWasClean Bool
  deriving (LastShutDownWasClean -> LastShutDownWasClean -> Bool
(LastShutDownWasClean -> LastShutDownWasClean -> Bool)
-> (LastShutDownWasClean -> LastShutDownWasClean -> Bool)
-> Eq LastShutDownWasClean
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LastShutDownWasClean -> LastShutDownWasClean -> Bool
== :: LastShutDownWasClean -> LastShutDownWasClean -> Bool
$c/= :: LastShutDownWasClean -> LastShutDownWasClean -> Bool
/= :: LastShutDownWasClean -> LastShutDownWasClean -> Bool
Eq, Int -> LastShutDownWasClean -> ShowS
[LastShutDownWasClean] -> ShowS
LastShutDownWasClean -> String
(Int -> LastShutDownWasClean -> ShowS)
-> (LastShutDownWasClean -> String)
-> ([LastShutDownWasClean] -> ShowS)
-> Show LastShutDownWasClean
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LastShutDownWasClean -> ShowS
showsPrec :: Int -> LastShutDownWasClean -> ShowS
$cshow :: LastShutDownWasClean -> String
show :: LastShutDownWasClean -> String
$cshowList :: [LastShutDownWasClean] -> ShowS
showList :: [LastShutDownWasClean] -> ShowS
Show)

-- | Return 'True' when 'cleanShutdownMarkerFile' exists.
hasCleanShutdownMarker ::
     HasFS m h
  -> m Bool
hasCleanShutdownMarker :: forall (m :: * -> *) h. HasFS m h -> m Bool
hasCleanShutdownMarker HasFS m h
hasFS =
    HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
cleanShutdownMarkerFile

-- | Create the 'cleanShutdownMarkerFile'.
--
-- Idempotent.
createCleanShutdownMarker ::
     IOLike m
  => HasFS m h
  -> m ()
createCleanShutdownMarker :: forall (m :: * -> *) h. IOLike m => HasFS m h -> m ()
createCleanShutdownMarker HasFS m h
hasFS = do
    Bool
alreadyExists <- HasFS m h -> m Bool
forall (m :: * -> *) h. HasFS m h -> m Bool
hasCleanShutdownMarker HasFS m h
hasFS
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
cleanShutdownMarkerFile (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
_h ->
        () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Remove 'cleanShutdownMarkerFile'.
--
-- Will throw an 'FsResourceDoesNotExist' error when it does not exist.
removeCleanShutdownMarker ::
     HasFS m h
  -> m ()
removeCleanShutdownMarker :: forall (m :: * -> *) h. HasFS m h -> m ()
removeCleanShutdownMarker HasFS m h
hasFS =
    HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
hasFS FsPath
cleanShutdownMarkerFile

-- | Return 'True' if the given exception indicates that recovery of the
-- database is required on the next startup.
exceptionRequiresRecovery ::
     forall blk. (StandardHash blk, Typeable blk)
  => Proxy blk
  -> SomeException
  -> Bool
exceptionRequiresRecovery :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy blk -> SomeException -> Bool
exceptionRequiresRecovery Proxy blk
pb SomeException
e = case Proxy blk -> SomeException -> ExitReason
forall blk.
(Typeable blk, StandardHash blk) =>
Proxy blk -> SomeException -> ExitReason
toExitReason Proxy blk
pb SomeException
e of
    ExitReason
DatabaseCorruption -> Bool
True
    ExitReason
_                  -> Bool
False

-- | A bracket function that manages the clean-shutdown marker on disk.
--
-- - If the marker is missing on startup, then ChainDB initialization will
--   revalidate the database contents.
--
-- - If the OS kills the nodes, then we don't have the opportunity to write out
--   the marker file, which is fine, since we want the next startup to do
--   revalidation.
--
-- - If initialization was cleanly interrupted (eg SIGINT), then we leave the
--   marker the marker in the same state as it was at the beginning of said
--   initialization.
--
-- - At the end of a successful initialization, we remove the marker and install
--   a shutdown handler that writes the marker except for certain exceptions
--   (see 'exceptionRequiresRecovery') that indicate corruption, for which we
--   want the next startup to do revalidation.
runWithCheckedDB ::
     forall a m h blk. (IOLike m, StandardHash blk, Typeable blk)
  => Proxy blk
  -> Tracer m (TraceEvent blk)
  -> HasFS m h
  -> (LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
  -> m a
runWithCheckedDB :: forall a (m :: * -> *) h blk.
(IOLike m, StandardHash blk, Typeable blk) =>
Proxy blk
-> Tracer m (TraceEvent blk)
-> HasFS m h
-> (LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
-> m a
runWithCheckedDB Proxy blk
pb Tracer m (TraceEvent blk)
tracer HasFS m h
hasFS LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a
body = do
    -- When we shut down cleanly, we create a marker file so that the next
    -- time we start, we know we don't have to validate the contents of the
    -- whole ChainDB. When we shut down with an exception indicating
    -- corruption or something going wrong with the file system, we don't
    -- create this marker file so that the next time we start, we do a full
    -- validation.
    Bool
wasClean <- HasFS m h -> m Bool
forall (m :: * -> *) h. HasFS m h -> m Bool
hasCleanShutdownMarker HasFS m h
hasFS
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
wasClean (Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer TraceEvent blk
forall blk. TraceEvent blk
TraceLastShutdownUnclean)
    Bool -> m a -> m a
forall {a}. Bool -> m a -> m a
removeMarkerOnUncleanShutdown Bool
wasClean
      (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a
body
          (Bool -> LastShutDownWasClean
LastShutDownWasClean Bool
wasClean)
          (\ChainDB m blk
_cdb m a
runWithInitializedChainDB -> m a -> m a
forall {a}. m a -> m a
createMarkerOnCleanShutdown (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
            -- ChainDB initialization has finished by the time we reach this
            -- point. We remove the marker so that a SIGKILL will cause an unclean
            -- shutdown.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasClean (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> m ()
forall (m :: * -> *) h. HasFS m h -> m ()
removeCleanShutdownMarker HasFS m h
hasFS
            m a
runWithInitializedChainDB
          )
  where
    -- | If there is a unclean exception during ChainDB initialization, we want
    -- to remove the marker file, so we install this handler.
    --
    -- It is OK to also wrap this handler around code that runs after ChainDB
    -- initialization, because the condition on this handler is the opposite of
    -- the condition in the @createMarkerOnCleanShutdown@ handler.
    removeMarkerOnUncleanShutdown :: Bool -> m a -> m a
removeMarkerOnUncleanShutdown Bool
wasClean = if Bool -> Bool
not Bool
wasClean then m a -> m a
forall a. a -> a
id else (SomeException -> Bool) -> m () -> m a -> m a
forall (m :: * -> *) e a.
(IOLike m, Exception e) =>
(e -> Bool) -> m () -> m a -> m a
onExceptionIf
      (Proxy blk -> SomeException -> Bool
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy blk -> SomeException -> Bool
exceptionRequiresRecovery Proxy blk
pb)
      (HasFS m h -> m ()
forall (m :: * -> *) h. HasFS m h -> m ()
removeCleanShutdownMarker HasFS m h
hasFS)

    -- | If a clean exception terminates the running node after ChainDB
    -- initialization, we want to create the marker file.
    --
    -- NOTE: we assume the action (i.e., the node itself) never terminates without
    -- an exception.
    createMarkerOnCleanShutdown :: m a -> m a
createMarkerOnCleanShutdown = (SomeException -> Bool) -> m () -> m a -> m a
forall (m :: * -> *) e a.
(IOLike m, Exception e) =>
(e -> Bool) -> m () -> m a -> m a
onExceptionIf
      (Bool -> Bool
not (Bool -> Bool) -> (SomeException -> Bool) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy blk -> SomeException -> Bool
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy blk -> SomeException -> Bool
exceptionRequiresRecovery Proxy blk
pb)
      (HasFS m h -> m ()
forall (m :: * -> *) h. IOLike m => HasFS m h -> m ()
createCleanShutdownMarker HasFS m h
hasFS)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

onExceptionIf ::
     (IOLike m, Exception e)
  => (e -> Bool)  -- ^ Predicate to selection exceptions
  -> m ()         -- ^ Exception handler
  -> m a
  -> m a
onExceptionIf :: forall (m :: * -> *) e a.
(IOLike m, Exception e) =>
(e -> Bool) -> m () -> m a -> m a
onExceptionIf e -> Bool
p m ()
h m a
m = m a
m m a -> (e -> m a) -> m a
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e
e -> do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (e -> Bool
p e
e) m ()
h
    e -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e