{- |
Module      : Singular.Registry.Deployment.Mirror
Description : The proof mirror a deployment carries beside its manifest
License     : Apache-2.0

One owner for the deployment's one non-chain dependency: the proof
mirror written beside a manifest, per registry token, as the four
hex-encoded key\/value maps an in-memory MPF database is. Reading and
writing the file live here; loading one never queries a node, and the
caller — not this module — compares a loaded trie's root against the
chain's after attaching.

This module is an internal owner behind the 'Singular.Registry.Deployment'
facade: callers import the facade, which re-exports the unchanged public
surface. It reads 'mirrorPathFor', 'hex' and 'die' from
"Singular.Registry.Deployment.Manifest", so the mirror's path has one
owner.
-}
module Singular.Registry.Deployment.Mirror
    ( -- * The proof mirror
      Mirror (..)
    , MirrorTrie (..)
    , loadMirror
    , saveMirror
    , replaceDurably
    ) where

import Control.Exception (bracket)
import Data.Aeson
    ( FromJSON (..)
    , ToJSON (..)
    , eitherDecodeFileStrict'
    )
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Short qualified as SBS
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import System.Directory (doesFileExist)
import System.FilePath (takeDirectory)
import System.Posix.Files (rename)
import System.Posix.IO
    ( OpenFileFlags (..)
    , OpenMode (..)
    , closeFd
    , defaultFileFlags
    , openFd
    )
import System.Posix.IO.ByteString (fdWrite)
import System.Posix.Unistd (fileSynchronise)

import MPF.Backend.Pure (MPFInMemoryDB (..))

import Singular.Registry.Deployment.Manifest (die, hex, mirrorPathFor)
import Singular.Registry.Ledger (AssetName (..), TokenId (..))

-- ---------------------------------------------------------
-- The proof mirror
-- ---------------------------------------------------------

{- | The tries a run needs, as the file beside the manifest carries
them: per registry token, the four key/value maps an in-memory MPF
database is, hex-encoded so the file stays diffable.
-}
newtype Mirror = Mirror {Mirror -> [MirrorTrie]
mirrorTries :: [MirrorTrie]}
    deriving (Mirror -> Mirror -> Bool
(Mirror -> Mirror -> Bool)
-> (Mirror -> Mirror -> Bool) -> Eq Mirror
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mirror -> Mirror -> Bool
== :: Mirror -> Mirror -> Bool
$c/= :: Mirror -> Mirror -> Bool
/= :: Mirror -> Mirror -> Bool
Eq, Int -> Mirror -> ShowS
[Mirror] -> ShowS
Mirror -> String
(Int -> Mirror -> ShowS)
-> (Mirror -> String) -> ([Mirror] -> ShowS) -> Show Mirror
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mirror -> ShowS
showsPrec :: Int -> Mirror -> ShowS
$cshow :: Mirror -> String
show :: Mirror -> String
$cshowList :: [Mirror] -> ShowS
showList :: [Mirror] -> ShowS
Show, (forall x. Mirror -> Rep Mirror x)
-> (forall x. Rep Mirror x -> Mirror) -> Generic Mirror
forall x. Rep Mirror x -> Mirror
forall x. Mirror -> Rep Mirror x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Mirror -> Rep Mirror x
from :: forall x. Mirror -> Rep Mirror x
$cto :: forall x. Rep Mirror x -> Mirror
to :: forall x. Rep Mirror x -> Mirror
Generic)

instance ToJSON Mirror where
    toJSON :: Mirror -> Value
toJSON = Options -> Mirror -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
Aeson.defaultOptions
instance FromJSON Mirror where
    parseJSON :: Value -> Parser Mirror
parseJSON = Options -> Value -> Parser Mirror
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
Aeson.defaultOptions

-- | One registry's trie.
data MirrorTrie = MirrorTrie
    { MirrorTrie -> Text
mtToken :: Text
    -- ^ Hex asset name of the registry this trie belongs to
    , MirrorTrie -> [(Text, Text)]
mtMpf :: [(Text, Text)]
    , MirrorTrie -> [(Text, Text)]
mtKv :: [(Text, Text)]
    , MirrorTrie -> [(Text, Text)]
mtJournal :: [(Text, Text)]
    , MirrorTrie -> [(Text, Text)]
mtMetrics :: [(Text, Text)]
    }
    deriving (MirrorTrie -> MirrorTrie -> Bool
(MirrorTrie -> MirrorTrie -> Bool)
-> (MirrorTrie -> MirrorTrie -> Bool) -> Eq MirrorTrie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorTrie -> MirrorTrie -> Bool
== :: MirrorTrie -> MirrorTrie -> Bool
$c/= :: MirrorTrie -> MirrorTrie -> Bool
/= :: MirrorTrie -> MirrorTrie -> Bool
Eq, Int -> MirrorTrie -> ShowS
[MirrorTrie] -> ShowS
MirrorTrie -> String
(Int -> MirrorTrie -> ShowS)
-> (MirrorTrie -> String)
-> ([MirrorTrie] -> ShowS)
-> Show MirrorTrie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorTrie -> ShowS
showsPrec :: Int -> MirrorTrie -> ShowS
$cshow :: MirrorTrie -> String
show :: MirrorTrie -> String
$cshowList :: [MirrorTrie] -> ShowS
showList :: [MirrorTrie] -> ShowS
Show, (forall x. MirrorTrie -> Rep MirrorTrie x)
-> (forall x. Rep MirrorTrie x -> MirrorTrie) -> Generic MirrorTrie
forall x. Rep MirrorTrie x -> MirrorTrie
forall x. MirrorTrie -> Rep MirrorTrie x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MirrorTrie -> Rep MirrorTrie x
from :: forall x. MirrorTrie -> Rep MirrorTrie x
$cto :: forall x. Rep MirrorTrie x -> MirrorTrie
to :: forall x. Rep MirrorTrie x -> MirrorTrie
Generic)

instance ToJSON MirrorTrie where
    toJSON :: MirrorTrie -> Value
toJSON = Options -> MirrorTrie -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
Aeson.defaultOptions
instance FromJSON MirrorTrie where
    parseJSON :: Value -> Parser MirrorTrie
parseJSON = Options -> Value -> Parser MirrorTrie
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
Aeson.defaultOptions

{- | Read the mirror beside a manifest. A missing file is the empty
mirror, which is what a registry booted a moment ago actually has —
the caller that attaches compares the loaded root with the chain's, so
an empty mirror against a registry that has grown is refused by that
comparison rather than assumed.
-}
loadMirror :: FilePath -> IO (Map.Map TokenId MPFInMemoryDB)
loadMirror :: String -> IO (Map TokenId MPFInMemoryDB)
loadMirror String
manifest = do
    let path :: String
path = ShowS
mirrorPathFor String
manifest
    there <- String -> IO Bool
doesFileExist String
path
    if not there
        then pure Map.empty
        else do
            parsed <- eitherDecodeFileStrict' path
            case parsed of
                Left String
err -> String -> IO (Map TokenId MPFInMemoryDB)
forall a. String -> IO a
die (String
"proof mirror " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)
                Right (Mirror [MirrorTrie]
tries) ->
                    [(TokenId, MPFInMemoryDB)] -> Map TokenId MPFInMemoryDB
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TokenId, MPFInMemoryDB)] -> Map TokenId MPFInMemoryDB)
-> IO [(TokenId, MPFInMemoryDB)] -> IO (Map TokenId MPFInMemoryDB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MirrorTrie -> IO (TokenId, MPFInMemoryDB))
-> [MirrorTrie] -> IO [(TokenId, MPFInMemoryDB)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM MirrorTrie -> IO (TokenId, MPFInMemoryDB)
one [MirrorTrie]
tries
  where
    one :: MirrorTrie -> IO (TokenId, MPFInMemoryDB)
one MirrorTrie
mt = do
        name <- Text -> IO ByteString
unhex (MirrorTrie -> Text
mtToken MirrorTrie
mt)
        db <-
            MPFInMemoryDB
                <$> pairs (mtMpf mt)
                <*> pairs (mtKv mt)
                <*> pairs (mtJournal mt)
                <*> pairs (mtMetrics mt)
                <*> pure Map.empty
        pure (TokenId (AssetName (SBS.toShort name)), db)
    pairs :: [(Text, Text)] -> IO (Map ByteString ByteString)
pairs [(Text, Text)]
kvs = [(ByteString, ByteString)] -> Map ByteString ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ByteString, ByteString)] -> Map ByteString ByteString)
-> IO [(ByteString, ByteString)] -> IO (Map ByteString ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Text) -> IO (ByteString, ByteString))
-> [(Text, Text)] -> IO [(ByteString, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Text
k, Text
v) -> (,) (ByteString -> ByteString -> (ByteString, ByteString))
-> IO ByteString -> IO (ByteString -> (ByteString, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO ByteString
unhex Text
k IO (ByteString -> (ByteString, ByteString))
-> IO ByteString -> IO (ByteString, ByteString)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> IO ByteString
unhex Text
v) [(Text, Text)]
kvs
    unhex :: Text -> IO ByteString
unhex Text
t = case ByteString -> Either String ByteString
B16.decode (String -> ByteString
BC.pack (Text -> String
T.unpack Text
t)) of
        Right ByteString
b -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b
        Left String
_ -> String -> IO ByteString
forall a. String -> IO a
die (String
"proof mirror: not hex: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

{- | Write the mirror beside a manifest, replacing what was there whole
or not at all ('replaceDurably').
-}
saveMirror :: FilePath -> Map.Map TokenId MPFInMemoryDB -> IO ()
saveMirror :: String -> Map TokenId MPFInMemoryDB -> IO ()
saveMirror String
manifest Map TokenId MPFInMemoryDB
tries =
    String -> ByteString -> IO ()
replaceDurably
        (ShowS
mirrorPathFor String
manifest)
        ( LazyByteString -> ByteString
BL.toStrict
            (Mirror -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encodePretty ([MirrorTrie] -> Mirror
Mirror (((TokenId, MPFInMemoryDB) -> MirrorTrie)
-> [(TokenId, MPFInMemoryDB)] -> [MirrorTrie]
forall a b. (a -> b) -> [a] -> [b]
map (TokenId, MPFInMemoryDB) -> MirrorTrie
one (Map TokenId MPFInMemoryDB -> [(TokenId, MPFInMemoryDB)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TokenId MPFInMemoryDB
tries))) LazyByteString -> LazyByteString -> LazyByteString
forall a. Semigroup a => a -> a -> a
<> LazyByteString
"\n")
        )
  where
    one :: (TokenId, MPFInMemoryDB) -> MirrorTrie
one (TokenId (AssetName ShortByteString
n), MPFInMemoryDB
db) =
        MirrorTrie
            { mtToken :: Text
mtToken = String -> Text
T.pack (ByteString -> String
hex (ShortByteString -> ByteString
SBS.fromShort ShortByteString
n))
            , mtMpf :: [(Text, Text)]
mtMpf = Map ByteString ByteString -> [(Text, Text)]
pairs (MPFInMemoryDB -> Map ByteString ByteString
mpfInMemoryMPF MPFInMemoryDB
db)
            , mtKv :: [(Text, Text)]
mtKv = Map ByteString ByteString -> [(Text, Text)]
pairs (MPFInMemoryDB -> Map ByteString ByteString
mpfInMemoryKV MPFInMemoryDB
db)
            , mtJournal :: [(Text, Text)]
mtJournal = Map ByteString ByteString -> [(Text, Text)]
pairs (MPFInMemoryDB -> Map ByteString ByteString
mpfInMemoryJournal MPFInMemoryDB
db)
            , mtMetrics :: [(Text, Text)]
mtMetrics = Map ByteString ByteString -> [(Text, Text)]
pairs (MPFInMemoryDB -> Map ByteString ByteString
mpfInMemoryMetrics MPFInMemoryDB
db)
            }
    pairs :: Map ByteString ByteString -> [(Text, Text)]
pairs =
        ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k, ByteString
v) -> (String -> Text
T.pack (ByteString -> String
hex ByteString
k), String -> Text
T.pack (ByteString -> String
hex ByteString
v))) ([(ByteString, ByteString)] -> [(Text, Text)])
-> (Map ByteString ByteString -> [(ByteString, ByteString)])
-> Map ByteString ByteString
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString ByteString -> [(ByteString, ByteString)]
forall k a. Map k a -> [(k, a)]
Map.toList

{- | Replace a file whole, durably: the bytes go to a sibling
@PATH.partial@, synchronised to disk, which is then renamed over @PATH@,
and the directory is synchronised. A process killed at any point leaves
@PATH@ holding either its previous bytes or the new ones, never a
prefix; a killed replacement may leave the @.partial@ sibling, which the
next replacement overwrites.
-}
replaceDurably :: FilePath -> BS.ByteString -> IO ()
replaceDurably :: String -> ByteString -> IO ()
replaceDurably String
path ByteString
bytes = do
    let partial :: String
partial = String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".partial"
    IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        ( String -> OpenMode -> OpenFileFlags -> IO Fd
openFd
            String
partial
            OpenMode
WriteOnly
            OpenFileFlags
defaultFileFlags{trunc = True, creat = Just 0o644}
        )
        Fd -> IO ()
closeFd
        (\Fd
fd -> Fd -> ByteString -> IO ()
writeAll Fd
fd ByteString
bytes IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
fileSynchronise Fd
fd)
    String -> String -> IO ()
rename String
partial String
path
    IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (String -> OpenMode -> OpenFileFlags -> IO Fd
openFd (ShowS
takeDirectory String
path) OpenMode
ReadOnly OpenFileFlags
defaultFileFlags)
        Fd -> IO ()
closeFd
        Fd -> IO ()
fileSynchronise
  where
    writeAll :: Fd -> ByteString -> IO ()
writeAll Fd
fd ByteString
b
        | ByteString -> Bool
BS.null ByteString
b = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            n <- Fd -> ByteString -> IO ByteCount
fdWrite Fd
fd ByteString
b
            writeAll fd (BS.drop (fromIntegral n) b)