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

-- | Special file we store in the DB dir to avoid unintended deletions
module Ouroboros.Consensus.Node.DbMarker
  ( DbMarkerError (..)
  , checkDbMarker

    -- * For the benefit of testing only
  , dbMarkerContents
  , dbMarkerFile
  , dbMarkerParse
  ) where

import Control.Monad (void, when)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS.Char8
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Word
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Magic (NetworkMagic (..))
import System.FS.API.Lazy
import Text.Read (readMaybe)

{-------------------------------------------------------------------------------
  Check proper
-------------------------------------------------------------------------------}

-- | Check database marker
--
-- The database folder will contain folders for the ImmutableDB (@immutable@),
-- the VolatileDB (@volatile@), and the LedgerDB (@ledger@). All three
-- subdatabases can delete files from these folders, e.g., outdated files or
-- files that are deemed invalid.
--
-- For example, when starting a node that will connect to a testnet with a
-- database folder containing mainnet blocks, these blocks will be deemed
-- invalid and will be deleted. This would throw away a perfectly good chain,
-- possibly consisting of gigabytes of data that will have to be synched
-- again.
--
-- To protect us from unwanted deletion of valid files, we first check whether
-- we have been given the path to the right database folder. We do this by
-- reading the 'NetworkMagic' of the net from a file stored in the root of
-- the database folder. This file's name is defined in 'dbMarkerFile'.
--
-- * If the 'NetworkMagic' from the file matches that of the net, we have
--   the right database folder.
-- * If not, we are opening the wrong database folder and abort by throwing a
--   'DbMarkerError'.
-- * If there is no such file and the folder is empty, we create it and store
--   the net's 'NetworkMagic' in it.
-- * If there is no such file, but the folder is not empty, we throw a
--   'DbMarkerError', because we have likely been given the wrong path,
--   maybe to a folder containing user or system files. This includes the case
--   that the 'dbMarkerFile' has been deleted.
-- * If there is such a 'dbMarkerFile', but it could not be read or its
--   contents could not be parsed, we also throw a 'DbMarkerError'.
--
-- Note that an 'FsError' can also be thrown.
checkDbMarker ::
  forall m h.
  MonadThrow m =>
  HasFS m h ->
  -- | Database directory. Should be the mount point of the @HasFS@. Used
  -- in error messages.
  MountPoint ->
  NetworkMagic ->
  m (Either DbMarkerError ())
checkDbMarker :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h
-> MountPoint -> NetworkMagic -> m (Either DbMarkerError ())
checkDbMarker HasFS m h
hasFS MountPoint
mountPoint NetworkMagic
networkMagic = ExceptT DbMarkerError m () -> m (Either DbMarkerError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DbMarkerError m () -> m (Either DbMarkerError ()))
-> ExceptT DbMarkerError m () -> m (Either DbMarkerError ())
forall a b. (a -> b) -> a -> b
$ do
  fileExists <- m Bool -> ExceptT DbMarkerError m Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT DbMarkerError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT DbMarkerError m Bool)
-> m Bool -> ExceptT DbMarkerError m Bool
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
pFile
  if fileExists
    then do
      actualNetworkMagic <- readNetworkMagicFile
      when (actualNetworkMagic /= networkMagic) $
        throwError $
          NetworkMagicMismatch
            fullPath
            actualNetworkMagic
            networkMagic
    else do
      lift $ createDirectoryIfMissing hasFS False root
      isEmpty <- lift $ Set.null <$> listDirectory hasFS root
      if isEmpty
        then
          createNetworkMagicFile
        else
          throwError $ NoDbMarkerAndNotEmpty fullPath
 where
  root :: FsPath
root = [FilePath] -> FsPath
mkFsPath []
  pFile :: FsPath
pFile = [Text] -> FsPath
fsPathFromList [Text
dbMarkerFile]
  fullPath :: FilePath
fullPath = MountPoint -> FsPath -> FilePath
fsToFilePath MountPoint
mountPoint FsPath
pFile

  readNetworkMagicFile :: ExceptT DbMarkerError m NetworkMagic
  readNetworkMagicFile :: ExceptT DbMarkerError m NetworkMagic
readNetworkMagicFile = m (Either DbMarkerError NetworkMagic)
-> ExceptT DbMarkerError m NetworkMagic
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either DbMarkerError NetworkMagic)
 -> ExceptT DbMarkerError m NetworkMagic)
-> m (Either DbMarkerError NetworkMagic)
-> ExceptT DbMarkerError m NetworkMagic
forall a b. (a -> b) -> a -> b
$
    HasFS m h
-> FsPath
-> OpenMode
-> (Handle h -> m (Either DbMarkerError NetworkMagic))
-> m (Either DbMarkerError NetworkMagic)
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
pFile OpenMode
ReadMode ((Handle h -> m (Either DbMarkerError NetworkMagic))
 -> m (Either DbMarkerError NetworkMagic))
-> (Handle h -> m (Either DbMarkerError NetworkMagic))
-> m (Either DbMarkerError NetworkMagic)
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> do
      bs <- LazyByteString -> StrictByteString
toStrict (LazyByteString -> StrictByteString)
-> m LazyByteString -> m StrictByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> Handle h -> m LazyByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m LazyByteString
hGetAll HasFS m h
hasFS Handle h
h
      runExceptT $ dbMarkerParse fullPath bs

  createNetworkMagicFile :: ExceptT DbMarkerError m ()
  createNetworkMagicFile :: ExceptT DbMarkerError m ()
createNetworkMagicFile = m () -> ExceptT DbMarkerError m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT DbMarkerError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT DbMarkerError m ())
-> m () -> ExceptT DbMarkerError 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
pFile (AllowExisting -> OpenMode
AppendMode AllowExisting
MustBeNew) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
      m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
        HasFS m h -> Handle h -> LazyByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> LazyByteString -> m Word64
hPutAll HasFS m h
hasFS Handle h
h (LazyByteString -> m Word64) -> LazyByteString -> m Word64
forall a b. (a -> b) -> a -> b
$
          StrictByteString -> LazyByteString
fromStrict (StrictByteString -> LazyByteString)
-> StrictByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$
            NetworkMagic -> StrictByteString
dbMarkerContents NetworkMagic
networkMagic

{-------------------------------------------------------------------------------
  Error
-------------------------------------------------------------------------------}

data DbMarkerError
  = -- | There was a 'dbMarkerFile' in the database folder, but it
    -- contained a different 'NetworkMagic' than the expected one. This
    -- indicates that this database folder corresponds to another net.
    NetworkMagicMismatch
      -- | The full path to the 'dbMarkerFile'
      FilePath
      -- | Actual
      NetworkMagic
      -- | Expected
      NetworkMagic
  | -- | The database folder contained no 'dbMarkerFile', but also
    -- contained some files. Either the given folder is a non-database folder
    -- or it is a database folder, but its 'dbMarkerFile' has been
    -- deleted.
    NoDbMarkerAndNotEmpty
      -- | The full path to the 'dbMarkerFile'
      FilePath
  | -- | The database folder contained a 'dbMarkerFile' that could not
    -- be read. The file has been tampered with or it was corrupted somehow.
    CorruptDbMarker
      -- | The full path to the 'dbMarkerFile'
      FilePath
  deriving (DbMarkerError -> DbMarkerError -> Bool
(DbMarkerError -> DbMarkerError -> Bool)
-> (DbMarkerError -> DbMarkerError -> Bool) -> Eq DbMarkerError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DbMarkerError -> DbMarkerError -> Bool
== :: DbMarkerError -> DbMarkerError -> Bool
$c/= :: DbMarkerError -> DbMarkerError -> Bool
/= :: DbMarkerError -> DbMarkerError -> Bool
Eq, Int -> DbMarkerError -> ShowS
[DbMarkerError] -> ShowS
DbMarkerError -> FilePath
(Int -> DbMarkerError -> ShowS)
-> (DbMarkerError -> FilePath)
-> ([DbMarkerError] -> ShowS)
-> Show DbMarkerError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DbMarkerError -> ShowS
showsPrec :: Int -> DbMarkerError -> ShowS
$cshow :: DbMarkerError -> FilePath
show :: DbMarkerError -> FilePath
$cshowList :: [DbMarkerError] -> ShowS
showList :: [DbMarkerError] -> ShowS
Show)

instance Exception DbMarkerError where
  displayException :: DbMarkerError -> FilePath
displayException DbMarkerError
e = case DbMarkerError
e of
    NetworkMagicMismatch FilePath
f NetworkMagic
actual NetworkMagic
expected ->
      FilePath
"Wrong NetworkMagic in \""
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
f
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\": "
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> NetworkMagic -> FilePath
forall a. Show a => a -> FilePath
show NetworkMagic
actual
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", but expected: "
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> NetworkMagic -> FilePath
forall a. Show a => a -> FilePath
show NetworkMagic
expected
    NoDbMarkerAndNotEmpty FilePath
f ->
      FilePath
"Missing \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
f FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\" but the folder was not empty"
    CorruptDbMarker FilePath
f ->
      FilePath
"Corrupt or unreadable \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
f FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""

{-------------------------------------------------------------------------------
  Configuration (filename, file format)
-------------------------------------------------------------------------------}

-- | For legacy reasons it was using 'ProtocolMagicId' not 'NetworkMagic'
-- which are really the same thing.
dbMarkerFile :: Text
dbMarkerFile :: Text
dbMarkerFile = Text
"protocolMagicId"

-- Contents of the DB marker file
--
-- We show the protocol magic ID as a human readable (decimal) number.
--
-- Type annotation on @pmid@ is here so that /if/ the type changes, this
-- code will fail to build. This is important, because if we change the
-- type, we must consider how this affects existing DB deployments.
dbMarkerContents :: NetworkMagic -> ByteString
dbMarkerContents :: NetworkMagic -> StrictByteString
dbMarkerContents (NetworkMagic (Word32
nm :: Word32)) =
  FilePath -> StrictByteString
BS.Char8.pack (FilePath -> StrictByteString) -> FilePath -> StrictByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
nm

-- | Parse contents of the DB marker file
--
-- Must be inverse to 'dbMarkerContents'
dbMarkerParse ::
  Monad m =>
  FilePath ->
  ByteString ->
  ExceptT DbMarkerError m NetworkMagic
dbMarkerParse :: forall (m :: * -> *).
Monad m =>
FilePath
-> StrictByteString -> ExceptT DbMarkerError m NetworkMagic
dbMarkerParse FilePath
fullPath StrictByteString
bs =
  case FilePath -> Maybe Word32
forall a. Read a => FilePath -> Maybe a
readMaybe (StrictByteString -> FilePath
BS.Char8.unpack StrictByteString
bs) of
    Just Word32
nm -> NetworkMagic -> ExceptT DbMarkerError m NetworkMagic
forall a. a -> ExceptT DbMarkerError m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NetworkMagic -> ExceptT DbMarkerError m NetworkMagic)
-> NetworkMagic -> ExceptT DbMarkerError m NetworkMagic
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
nm
    Maybe Word32
Nothing -> DbMarkerError -> ExceptT DbMarkerError m NetworkMagic
forall a. DbMarkerError -> ExceptT DbMarkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DbMarkerError -> ExceptT DbMarkerError m NetworkMagic)
-> DbMarkerError -> ExceptT DbMarkerError m NetworkMagic
forall a b. (a -> b) -> a -> b
$ FilePath -> DbMarkerError
CorruptDbMarker FilePath
fullPath