{- |
Module      : Singular.Registry.Deployment.Manifest
Description : The deployment manifest and the paths around it
License     : Apache-2.0

One owner for the deployment record as a file: the manifest and
reference-script values with their JSON instances, reading and writing
one, choosing one from a command line or the environment, the
@txid#index@ spelling and its parse, an address as the exact hex bytes
the ledger serialises, the byte-rendering helper 'hex' and the shared
error helper 'die' the deployment family shares. Nothing here queries
a node.

This module is an internal owner behind the 'Singular.Registry.Deployment'
facade: callers import the facade, which re-exports the unchanged public
surface. See the deployment ownership guide for the dependency direction
between the owners.
-}
module Singular.Registry.Deployment.Manifest
    ( -- * The manifest
      Deployment (..)
    , ReferenceScript (..)
    , readDeployment
    , writeDeployment

      -- * Choosing one
    , deploymentPathFromArgs
    , deploymentPathFromEnvironment

      -- * Output references
    , renderOutRef
    , parseOutRef
    , renderAddrBytes

      -- * The mirror's path
    , mirrorPathFor

      -- * Shared rendering, for the deployment family only
    , die
    , hex
    ) where

import Control.Exception (ErrorCall (..), throwIO)
import Data.Aeson
    ( FromJSON (..)
    , ToJSON (..)
    , eitherDecodeFileStrict'
    )
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString (ByteString)
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.List (isPrefixOf)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word16, Word32)
import GHC.Generics (Generic)
import System.Environment (getArgs, lookupEnv)
import System.FilePath (dropExtension, (<.>))
import Text.Read (readMaybe)

import Cardano.Crypto.Hash (hashFromBytes, hashToBytes)
import Cardano.Ledger.Address (Addr, serialiseAddr)
import Cardano.Ledger.Api.Tx.In (TxId (..), TxIn (..))
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Hashes (extractHash, unsafeMakeSafeHash)

-- ---------------------------------------------------------
-- The manifest
-- ---------------------------------------------------------

{- | One reference-script output: what it carries, where it is, and the
hash a node must agree it holds.
-}
data ReferenceScript = ReferenceScript
    { ReferenceScript -> Text
refRole :: Text
    -- ^ Which script this is (@state@, @request@, @application@, …)
    , ReferenceScript -> Text
refHash :: Text
    -- ^ Hex script hash the output must carry
    , ReferenceScript -> Text
refOutRef :: Text
    -- ^ @txid#index@ of the output
    , ReferenceScript -> Text
refAddress :: Text
    {- ^ Address the output sits at, in the bech32 form a person reads.
    Informational: refAddressBytes is what the code queries.
    -}
    , ReferenceScript -> Text
refAddressBytes :: Text
    {- ^ The same address as the hex bytes the ledger serialises, which
    round-trips exactly
    -}
    }
    deriving (ReferenceScript -> ReferenceScript -> Bool
(ReferenceScript -> ReferenceScript -> Bool)
-> (ReferenceScript -> ReferenceScript -> Bool)
-> Eq ReferenceScript
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReferenceScript -> ReferenceScript -> Bool
== :: ReferenceScript -> ReferenceScript -> Bool
$c/= :: ReferenceScript -> ReferenceScript -> Bool
/= :: ReferenceScript -> ReferenceScript -> Bool
Eq, Int -> ReferenceScript -> ShowS
[ReferenceScript] -> ShowS
ReferenceScript -> String
(Int -> ReferenceScript -> ShowS)
-> (ReferenceScript -> String)
-> ([ReferenceScript] -> ShowS)
-> Show ReferenceScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReferenceScript -> ShowS
showsPrec :: Int -> ReferenceScript -> ShowS
$cshow :: ReferenceScript -> String
show :: ReferenceScript -> String
$cshowList :: [ReferenceScript] -> ShowS
showList :: [ReferenceScript] -> ShowS
Show, (forall x. ReferenceScript -> Rep ReferenceScript x)
-> (forall x. Rep ReferenceScript x -> ReferenceScript)
-> Generic ReferenceScript
forall x. Rep ReferenceScript x -> ReferenceScript
forall x. ReferenceScript -> Rep ReferenceScript x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ReferenceScript -> Rep ReferenceScript x
from :: forall x. ReferenceScript -> Rep ReferenceScript x
$cto :: forall x. Rep ReferenceScript x -> ReferenceScript
to :: forall x. Rep ReferenceScript x -> ReferenceScript
Generic)

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

{- | A registry that exists, recorded well enough to find it again and
to refuse to use the wrong one.
-}
data Deployment = Deployment
    { Deployment -> Text
depRelease :: Text
    -- ^ Release tag or candidate commit the deployment was made from
    , Deployment -> Text
depLeanRevision :: Text
    -- ^ Revision of the model that release was built against
    , Deployment -> Word32
depNetworkMagic :: Word32
    -- ^ Network the deployment lives on
    , Deployment -> Text
depSeedOutRef :: Text
    -- ^ @txid#index@ the boot mint consumed; the registry's identity
    , Deployment -> Text
depCageToken :: Text
    -- ^ Hex asset name of the registry token (SHA-256 of the seed)
    , Deployment -> Text
depStatePolicy :: Text
    -- ^ Applied state script hash, which is the registry's policy id
    , Deployment -> Text
depRequestHash :: Text
    -- ^ Applied request validator hash
    , Deployment -> Text
depApplicationHash :: Text
    -- ^ Naming application validator hash
    , Deployment -> Text
depRepresentativePolicy :: Text
    {- ^ The registry-bound ACTIVE token policy: `witness(1, registry)`
    applied (#157 C5/C7). Renamed from the representative policy it
    became; the manifest key keeps its spelling so existing manifests
    and the attach check still read it.
    -}
    , Deployment -> Integer
depProcessTime :: Integer
    -- ^ Phase-1 window (ms) the registry was booted with
    , Deployment -> Integer
depRetractTime :: Integer
    -- ^ Phase-2 window (ms) the registry was booted with
    , Deployment -> Integer
depTip :: Integer
    -- ^ Oracle tip (lovelace) the registry was booted with
    , Deployment -> [ReferenceScript]
depReferenceScripts :: [ReferenceScript]
    -- ^ The outputs published once and reused by every later run
    , Deployment -> [Text]
depBootstrapTxs :: [Text]
    -- ^ Transaction ids that created all of the above, in order
    }
    deriving (Deployment -> Deployment -> Bool
(Deployment -> Deployment -> Bool)
-> (Deployment -> Deployment -> Bool) -> Eq Deployment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Deployment -> Deployment -> Bool
== :: Deployment -> Deployment -> Bool
$c/= :: Deployment -> Deployment -> Bool
/= :: Deployment -> Deployment -> Bool
Eq, Int -> Deployment -> ShowS
[Deployment] -> ShowS
Deployment -> String
(Int -> Deployment -> ShowS)
-> (Deployment -> String)
-> ([Deployment] -> ShowS)
-> Show Deployment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Deployment -> ShowS
showsPrec :: Int -> Deployment -> ShowS
$cshow :: Deployment -> String
show :: Deployment -> String
$cshowList :: [Deployment] -> ShowS
showList :: [Deployment] -> ShowS
Show, (forall x. Deployment -> Rep Deployment x)
-> (forall x. Rep Deployment x -> Deployment) -> Generic Deployment
forall x. Rep Deployment x -> Deployment
forall x. Deployment -> Rep Deployment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Deployment -> Rep Deployment x
from :: forall x. Deployment -> Rep Deployment x
$cto :: forall x. Rep Deployment x -> Deployment
to :: forall x. Rep Deployment x -> Deployment
Generic)

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

-- | Read a manifest, naming the file when it will not parse.
readDeployment :: FilePath -> IO Deployment
readDeployment :: String -> IO Deployment
readDeployment String
path = do
    parsed <- String -> IO (Either String Deployment)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' String
path
    case parsed of
        Right Deployment
d -> Deployment -> IO Deployment
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Deployment
d
        Left String
err -> String -> IO Deployment
forall a. String -> IO a
die (String
"deployment manifest " 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)

-- | Write a manifest, formatted for a person to read in review.
writeDeployment :: FilePath -> Deployment -> IO ()
writeDeployment :: String -> Deployment -> IO ()
writeDeployment String
path = String -> ByteString -> IO ()
BL.writeFile String
path (ByteString -> IO ())
-> (Deployment -> ByteString) -> Deployment -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") (ByteString -> ByteString)
-> (Deployment -> ByteString) -> Deployment -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deployment -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty

{- | Where the proof mirror for a manifest lives: the manifest's own
path with a @.mirror.json@ extension, so the two travel together and
neither is guessed from a separate flag.
-}
mirrorPathFor :: FilePath -> FilePath
mirrorPathFor :: ShowS
mirrorPathFor String
manifest = ShowS
dropExtension String
manifest String -> ShowS
<.> String
"mirror" String -> ShowS
<.> String
"json"

-- ---------------------------------------------------------
-- Choosing one
-- ---------------------------------------------------------

{- | The manifest a command line names, if any. @--deployment PATH@ and
@--deployment=PATH@ are both accepted; absent, the caller keeps its
existing behaviour of booting its own registry.
-}
deploymentPathFromArgs :: [String] -> Maybe FilePath
deploymentPathFromArgs :: [String] -> Maybe String
deploymentPathFromArgs = [String] -> Maybe String
go
  where
    name :: String
name = String
"--deployment"
    go :: [String] -> Maybe String
go (String
a : [String]
rest)
        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name = case [String]
rest of
            (String
v : [String]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
            [] -> Maybe String
forall a. Maybe a
Nothing
        | (String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"=") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
a = String -> Maybe String
forall a. a -> Maybe a
Just (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
a)
        | Bool
otherwise = [String] -> Maybe String
go [String]
rest
    go [] = Maybe String
forall a. Maybe a
Nothing

{- | 'deploymentPathFromArgs' for this process, falling back to
@SINGULAR_DEPLOYMENT@.
-}
deploymentPathFromEnvironment :: IO (Maybe FilePath)
deploymentPathFromEnvironment :: IO (Maybe String)
deploymentPathFromEnvironment = do
    args <- IO [String]
getArgs
    case deploymentPathFromArgs args of
        Just String
p -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
p)
        Maybe String
Nothing -> String -> IO (Maybe String)
lookupEnv String
"SINGULAR_DEPLOYMENT"

-- ---------------------------------------------------------
-- Output references
-- ---------------------------------------------------------

-- | @txid#index@, the spelling every Cardano tool prints.
renderOutRef :: TxIn -> Text
renderOutRef :: TxIn -> Text
renderOutRef (TxIn (TxId SafeHash EraIndependentTxBody
h) (TxIx Word16
i)) =
    String -> Text
T.pack (ByteString -> String
hex (Hash HASH EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentTxBody
h)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"#" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
i)

-- | Parse @txid#index@ back, naming what was wrong with it.
parseOutRef :: Text -> Either String TxIn
parseOutRef :: Text -> Either String TxIn
parseOutRef Text
t = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"#" Text
t of
    [Text
idT, Text
ixT] -> do
        raw <- case ByteString -> Either String ByteString
B16.decode (String -> ByteString
BC.pack (Text -> String
T.unpack Text
idT)) of
            Right ByteString
b -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
b
            Left String
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String
"transaction id is not hex: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
idT)
        h <- case hashFromBytes raw of
            Just Hash HASH EraIndependentTxBody
h -> Hash HASH EraIndependentTxBody
-> Either String (Hash HASH EraIndependentTxBody)
forall a b. b -> Either a b
Right Hash HASH EraIndependentTxBody
h
            Maybe (Hash HASH EraIndependentTxBody)
Nothing ->
                String -> Either String (Hash HASH EraIndependentTxBody)
forall a b. a -> Either a b
Left
                    ( String
"transaction id is not 32 bytes: "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
raw)
                    )
        ix <- case readMaybe (T.unpack ixT) :: Maybe Word16 of
            Just Word16
n -> Word16 -> Either String Word16
forall a b. b -> Either a b
Right Word16
n
            Maybe Word16
Nothing -> String -> Either String Word16
forall a b. a -> Either a b
Left (String
"output index is not a number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ixT)
        Right (TxIn (TxId (unsafeMakeSafeHash h)) (TxIx ix))
    [Text]
_ -> String -> Either String TxIn
forall a b. a -> Either a b
Left (String
"not a txid#index output reference: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

-- ---------------------------------------------------------
-- Small helpers
-- ---------------------------------------------------------

-- | An address as the manifest records it: exact bytes, in hex.
renderAddrBytes :: Addr -> Text
renderAddrBytes :: Addr -> Text
renderAddrBytes = String -> Text
T.pack (String -> Text) -> (Addr -> String) -> Addr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
hex (ByteString -> String) -> (Addr -> ByteString) -> Addr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> ByteString
serialiseAddr

die :: String -> IO a
die :: forall a. String -> IO a
die = ErrorCall -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ErrorCall -> IO a) -> (String -> ErrorCall) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall

hex :: ByteString -> String
hex :: ByteString -> String
hex = ByteString -> String
BC.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode