{-# 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
  -> MountPoint
     -- ^ Database directory. Should be the mount point of the @HasFS@. Used
     -- in error messages.
  -> 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
      FilePath         -- ^ The full path to the 'dbMarkerFile'
      NetworkMagic  -- ^ Actual
      NetworkMagic  -- ^ Expected

    -- | 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
      FilePath         -- ^ The full path to the 'dbMarkerFile'

    -- | The database folder contained a 'dbMarkerFile' that could not
    -- be read. The file has been tampered with or it was corrupted somehow.
  | CorruptDbMarker
      FilePath         -- ^ The full path to the 'dbMarkerFile'
  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