{-# 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
    Bool
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 Bool
fileExists then do
      NetworkMagic
actualNetworkMagic <- ExceptT DbMarkerError m NetworkMagic
readNetworkMagicFile
      Bool -> ExceptT DbMarkerError m () -> ExceptT DbMarkerError m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NetworkMagic
actualNetworkMagic NetworkMagic -> NetworkMagic -> Bool
forall a. Eq a => a -> a -> Bool
/= NetworkMagic
networkMagic) (ExceptT DbMarkerError m () -> ExceptT DbMarkerError m ())
-> ExceptT DbMarkerError m () -> ExceptT DbMarkerError m ()
forall a b. (a -> b) -> a -> b
$
        DbMarkerError -> ExceptT DbMarkerError m ()
forall a. DbMarkerError -> ExceptT DbMarkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DbMarkerError -> ExceptT DbMarkerError m ())
-> DbMarkerError -> ExceptT DbMarkerError m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> NetworkMagic -> NetworkMagic -> DbMarkerError
NetworkMagicMismatch
          FilePath
fullPath
          NetworkMagic
actualNetworkMagic
          NetworkMagic
networkMagic
    else do
      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 -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
False FsPath
root
      Bool
isEmpty <- 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
$ Set FilePath -> Bool
forall a. Set a -> Bool
Set.null (Set FilePath -> Bool) -> m (Set FilePath) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> HasCallStack => FsPath -> m (Set FilePath)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set FilePath)
listDirectory HasFS m h
hasFS FsPath
root
      if Bool
isEmpty then
        ExceptT DbMarkerError m ()
createNetworkMagicFile
      else
        DbMarkerError -> ExceptT DbMarkerError m ()
forall a. DbMarkerError -> ExceptT DbMarkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DbMarkerError -> ExceptT DbMarkerError m ())
-> DbMarkerError -> ExceptT DbMarkerError m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> DbMarkerError
NoDbMarkerAndNotEmpty FilePath
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
        ByteString
bs <- ByteString -> ByteString
toStrict (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> Handle h -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m ByteString
hGetAll HasFS m h
hasFS Handle h
h
        ExceptT DbMarkerError m NetworkMagic
-> m (Either DbMarkerError NetworkMagic)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DbMarkerError m NetworkMagic
 -> m (Either DbMarkerError NetworkMagic))
-> ExceptT DbMarkerError m NetworkMagic
-> m (Either DbMarkerError NetworkMagic)
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> ExceptT DbMarkerError m NetworkMagic
forall (m :: * -> *).
Monad m =>
FilePath -> ByteString -> ExceptT DbMarkerError m NetworkMagic
dbMarkerParse FilePath
fullPath ByteString
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 -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
hasFS Handle h
h (ByteString -> m Word64) -> ByteString -> m Word64
forall a b. (a -> b) -> a -> b
$
          ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ NetworkMagic -> ByteString
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 -> ByteString
dbMarkerContents (NetworkMagic (Word32
nm :: Word32)) =
    FilePath -> ByteString
BS.Char8.pack (FilePath -> ByteString) -> FilePath -> ByteString
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 -> ByteString -> ExceptT DbMarkerError m NetworkMagic
dbMarkerParse FilePath
fullPath ByteString
bs =
    case FilePath -> Maybe Word32
forall a. Read a => FilePath -> Maybe a
readMaybe (ByteString -> FilePath
BS.Char8.unpack ByteString
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