{-# LANGUAGE OverloadedStrings #-}
module Ouroboros.Consensus.Node.Recovery
  ( createMarkerOnCleanShutdown
  , hasCleanShutdownMarker
  , createCleanShutdownMarker
  , removeCleanShutdownMarker
  ) where

import           Control.Monad (unless, when)

import           Ouroboros.Consensus.Node.Exit (ExitReason (..), toExitReason)
import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.Storage.FS.API (HasFS, doesFileExist,
                     removeFile, withFile)
import           Ouroboros.Consensus.Storage.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"]

-- | When the given action terminates with a /clean/ exception, create the
-- /clean shutdown marker file/.
--
-- NOTE: we assume the action (i.e., the node itself) never terminates without
-- an exception.
--
-- A /clean/ exception is an exception for 'exceptionRequiresRecovery' returns
-- 'False'.
createMarkerOnCleanShutdown
  :: IOLike m
  => HasFS m h
  -> m a  -- ^ Action to run
  -> m a
createMarkerOnCleanShutdown :: HasFS m h -> m a -> m a
createMarkerOnCleanShutdown HasFS m h
mp = (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
. SomeException -> Bool
exceptionRequiresRecovery)
    (HasFS m h -> m ()
forall (m :: * -> *) h. IOLike m => HasFS m h -> m ()
createCleanShutdownMarker HasFS m h
mp)

-- | Return 'True' when 'cleanShutdownMarkerFile' exists.
hasCleanShutdownMarker
  :: HasFS m h
  -> m Bool
hasCleanShutdownMarker :: HasFS m h -> m Bool
hasCleanShutdownMarker HasFS m h
hasFS =
    HasFS m h -> 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 :: 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 (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 :: HasFS m h -> m ()
removeCleanShutdownMarker HasFS m h
hasFS =
    HasFS m h -> 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 :: SomeException -> Bool
exceptionRequiresRecovery :: SomeException -> Bool
exceptionRequiresRecovery SomeException
e = case SomeException -> ExitReason
toExitReason SomeException
e of
    ExitReason
DatabaseCorruption -> Bool
True
    ExitReason
_                  -> Bool
False

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

onExceptionIf
  :: (IOLike m, Exception e)
  => (e -> Bool)  -- ^ Predicate to selection exceptions
  -> m ()         -- ^ Exception handler
  -> m a
  -> m a
onExceptionIf :: (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 (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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e