{- |
Module      : Singular.Registry.Blueprint.Load
Description : blueprint loading, code selection and registry naming codes
License     : Apache-2.0

Loads a @plutus.json@ blueprint produced by the Aiken compiler,
selects validators by title prefix ('extractScriptHash',
'extractCompiledCode'), and reads the registry partition's own
compiled codes ('NamingCodes', 'loadRegistryCodesFromEnv').

This is the loading-and-code-selection owner extracted from
@Singular.Registry.Blueprint@; the public module re-exports it and is
its only intended consumer surface.
-}
module Singular.Registry.Blueprint.Load
    ( -- * Loading
      loadBlueprint

      -- * The compiled codes the four registry pins derive from
    , NamingCodes (..)

      -- * The registry partition's own compiled code (#173 A173-BOOT)
    , loadRegistryCodesFromEnv

      -- * Script hash extraction
    , extractScriptHash

      -- * Compiled code extraction
    , extractCompiledCode
    ) where

import Control.Exception (ErrorCall (..), throwIO)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Short qualified as SBS
import Data.Char (isDigit)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word8)
import Singular.Registry.Blueprint.Schema
    ( Blueprint (..)
    , Validator (..)
    )
import System.Environment (lookupEnv)

-- ---------------------------------------------------------
-- Loading
-- ---------------------------------------------------------

{- | Load and parse a CIP-57 blueprint from a file
path.
-}
loadBlueprint
    :: FilePath
    -- ^ Path to the @plutus.json@ file
    -> IO (Either String Blueprint)
loadBlueprint :: String -> IO (Either String Blueprint)
loadBlueprint String
path = do
    bs <- String -> IO ByteString
BS.readFile String
path
    pure $ Aeson.eitherDecodeStrict' bs

-- ---------------------------------------------------------
-- Script hash extraction
-- ---------------------------------------------------------

{- | Find the first validator whose title starts with
the given prefix and return its hash.
-}
extractScriptHash
    :: Text
    -- ^ Title prefix to match
    -> Blueprint
    -- ^ Blueprint to search
    -> Maybe Text
extractScriptHash :: Text -> Blueprint -> Maybe Text
extractScriptHash Text
prefix Blueprint
bp =
    case (Validator -> Bool) -> [Validator] -> [Validator]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (Text -> Text -> Bool
T.isPrefixOf Text
prefix (Text -> Bool) -> (Validator -> Text) -> Validator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator -> Text
vTitle)
        (Blueprint -> [Validator]
validators Blueprint
bp) of
        (Validator
v : [Validator]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Validator -> Text
vHash Validator
v)
        [] -> Maybe Text
forall a. Maybe a
Nothing

-- ---------------------------------------------------------
-- Compiled code extraction
-- ---------------------------------------------------------

{- | Find the first validator whose title starts with
the given prefix and return its compiled script
bytes as a 'ShortByteString'. The hex-encoded
@compiledCode@ is decoded to raw bytes suitable
for 'PlutusBinary'.
-}
extractCompiledCode
    :: Text
    -- ^ Title prefix to match
    -> Blueprint
    -- ^ Blueprint to search
    -> Maybe SBS.ShortByteString
extractCompiledCode :: Text -> Blueprint -> Maybe ShortByteString
extractCompiledCode Text
prefix Blueprint
bp = do
    v <-
        case (Validator -> Bool) -> [Validator] -> [Validator]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (Text -> Text -> Bool
T.isPrefixOf Text
prefix (Text -> Bool) -> (Validator -> Text) -> Validator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator -> Text
vTitle)
            (Blueprint -> [Validator]
validators Blueprint
bp) of
            (Validator
x : [Validator]
_) -> Validator -> Maybe Validator
forall a. a -> Maybe a
Just Validator
x
            [] -> Maybe Validator
forall a. Maybe a
Nothing
    hex <- vCompiledCode v
    SBS.toShort <$> decodeHex hex

{- | Decode a hex 'Text' to 'ByteString'.
Returns 'Nothing' on invalid input.
-}
decodeHex :: Text -> Maybe BS.ByteString
decodeHex :: Text -> Maybe ByteString
decodeHex Text
t
    | Int -> Bool
forall a. Integral a => a -> Bool
odd (Text -> Int
T.length Text
t) = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise =
        [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Maybe [Word8] -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [Word8]
go (Text -> String
T.unpack Text
t)
  where
    go :: String -> Maybe [Word8]
go [] = [Word8] -> Maybe [Word8]
forall a. a -> Maybe a
Just []
    go (Char
a : Char
b : String
rest) = do
        hi <- Char -> Maybe Word8
hexDigit Char
a
        lo <- hexDigit b
        (hi * 16 + lo :) <$> go rest
    go String
_ = Maybe [Word8]
forall a. Maybe a
Nothing

    hexDigit :: Char -> Maybe Word8
    hexDigit :: Char -> Maybe Word8
hexDigit Char
c
        | Char -> Bool
isDigit Char
c =
            Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$
                Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0')
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' =
            Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$
                Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    ( Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a'
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
                    )
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' =
            Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$
                Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                    ( Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A'
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
                    )
        | Bool
otherwise = Maybe Word8
forall a. Maybe a
Nothing

{- | The compiled codes the four registry pins derive from: the
application whose mint arm certifies an edge, and the witness policy the
three token kinds are derived from.

The four policy pins of a registry are derived from these two, so every
consumer of the application — the conformance rows, the devnet end-to-end and the
bounded journey — binds to one source and moves together.

#173 I2: for the OPEN registry both now come from the registry
partition's own blueprint. The record keeps its name because every
consumer names its fields; renaming it is a sweep this ticket does not
need.
-}
data NamingCodes = NamingCodes
    { NamingCodes -> ShortByteString
ncApplication :: SBS.ShortByteString
    , NamingCodes -> ShortByteString
ncWitness :: SBS.ShortByteString
    }

{- | #173 A173-BOOT: the four pins of an OPEN registry, read from the
registry partition's own blueprint and nothing else.

The open registry's application is @open.open@ — parameterless, so its
compiled hash IS its policy id, with no applied hash to derive (A-001
row 1; Lean @openPolicyParameters = []@). Its three token witnesses are
@witness.witness@ in the SAME blueprint, which moved here from the
naming partition in this ticket (I2). A boot therefore consults
@REGISTRY_BLUEPRINT@ alone: no naming blueprint participates, and
@NAMING_BLUEPRINT@ need not be set at all.

Both codes are read from the SAME blueprint, so a consumer cannot
silently pair an open application from one build with witnesses from
another.
-}
loadRegistryCodesFromEnv :: IO NamingCodes
loadRegistryCodesFromEnv :: IO NamingCodes
loadRegistryCodesFromEnv = do
    mPath <- String -> IO (Maybe String)
lookupEnv String
"REGISTRY_BLUEPRINT"
    path <- case mPath of
        Just String
p | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p) -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p
        Maybe String
_ -> String -> IO String
forall a. String -> IO a
die String
"REGISTRY_BLUEPRINT is not set"
    ebp <- loadBlueprint path
    bp <- case ebp of
        Left String
err -> String -> IO Blueprint
forall a. String -> IO a
die (String
"registry blueprint does not parse: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err)
        Right Blueprint
bp -> Blueprint -> IO Blueprint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blueprint
bp
    case ( extractCompiledCode "open.open" bp
         , extractCompiledCode "witness.witness" bp
         ) of
        (Just ShortByteString
openCode, Just ShortByteString
witnessCode) ->
            NamingCodes -> IO NamingCodes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamingCodes{ncApplication :: ShortByteString
ncApplication = ShortByteString
openCode, ncWitness :: ShortByteString
ncWitness = ShortByteString
witnessCode}
        (Maybe ShortByteString
Nothing, Maybe ShortByteString
_) ->
            String -> IO NamingCodes
forall a. String -> IO a
die
                String
"registry blueprint has no open.open code: the open \
                \application is not in the registry partition (#173 I1)"
        (Maybe ShortByteString
_, Maybe ShortByteString
Nothing) ->
            String -> IO NamingCodes
forall a. String -> IO a
die
                String
"registry blueprint has no witness.witness code: the three \
                \witness policies have not moved here (#173 I2)"
  where
    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