{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module PlutusCore.Executable.Blueprint
  ( BlueprintValidator (..)
  , readBlueprint
  , writeBlueprint
  ) where

import PlutusCore.Executable.AstIO (decodeUplcHex, encodeUplcHex)
import PlutusCore.Executable.Types
import PlutusLedgerApi.Common

import Data.Aeson (Value (..))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString.Lazy qualified as BSL
import Data.Either
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Vector qualified as V

-- | A validator in a blueprint.
data BlueprintValidator = BlueprintValidator
  { BlueprintValidator -> Text
bvTitle :: Text
  , BlueprintValidator -> UplcProg ()
bvCode :: UplcProg ()
  }

-- | Reads a blueprint file, extracts the validators, and returns (validators, entire json).
readBlueprint :: Input -> IO ([BlueprintValidator], Value)
readBlueprint :: Input -> IO ([BlueprintValidator], Value)
readBlueprint Input
inp = do
  ByteString
bytes <- case Input
inp of
    FileInput [Char]
file -> [Char] -> IO ByteString
BSL.readFile [Char]
file
    Input
StdInput -> IO ByteString
BSL.getContents
  case ByteString -> Either [Char] Value
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode ByteString
bytes of
    Left [Char]
err -> [Char] -> IO ([BlueprintValidator], Value)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ([BlueprintValidator], Value))
-> [Char] -> IO ([BlueprintValidator], Value)
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse blueprint: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
    Right Value
val -> ([BlueprintValidator], Value) -> IO ([BlueprintValidator], Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> [BlueprintValidator]
extractValidators Value
val, Value
val)

extractValidators :: Value -> [BlueprintValidator]
extractValidators :: Value -> [BlueprintValidator]
extractValidators (Object Object
obj) =
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"validators" Object
obj of
    Just (Array Array
arr) -> (Value -> BlueprintValidator) -> [Value] -> [BlueprintValidator]
forall a b. (a -> b) -> [a] -> [b]
map Value -> BlueprintValidator
parseValidator (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr)
    Just Value
_ -> [Char] -> [BlueprintValidator]
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: 'validators' field is not an array"
    Maybe Value
Nothing -> []
extractValidators Value
_ = [Char] -> [BlueprintValidator]
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: top-level value is not an object"

parseValidator :: Value -> BlueprintValidator
parseValidator :: Value -> BlueprintValidator
parseValidator (Object Object
obj) =
  BlueprintValidator
    { bvTitle :: Text
bvTitle = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
"title") Object
obj of
        Just (String Text
t) -> Text
t
        Maybe Value
_ -> Text
"<untitled>"
    , bvCode :: UplcProg ()
bvCode = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
"compiledCode") Object
obj of
        Just (String Text
hex) -> Text -> UplcProg ()
decodeUplcHex Text
hex
        Maybe Value
_ -> [Char] -> UplcProg ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: validator missing `compiledCode'"
    }
parseValidator Value
_ = [Char] -> BlueprintValidator
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: validator entry is not an object"

readPlutusVersion :: Text -> PlutusLedgerLanguage
readPlutusVersion :: Text -> PlutusLedgerLanguage
readPlutusVersion = \case
  Text
"v1" -> PlutusLedgerLanguage
PlutusV1
  Text
"v2" -> PlutusLedgerLanguage
PlutusV2
  Text
"v3" -> PlutusLedgerLanguage
PlutusV3
  Text
other -> [Char] -> PlutusLedgerLanguage
forall a. HasCallStack => [Char] -> a
error ([Char] -> PlutusLedgerLanguage) -> [Char] -> PlutusLedgerLanguage
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown plutusVersion in blueprint: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
other

getPlutusVersion :: Value -> PlutusLedgerLanguage
getPlutusVersion :: Value -> PlutusLedgerLanguage
getPlutusVersion (Object Object
obj) =
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
"preamble") Object
obj of
    Just (Object Object
preamble) ->
      case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
"plutusVersion") Object
preamble of
        Just (String Text
v) -> Text -> PlutusLedgerLanguage
readPlutusVersion Text
v
        Maybe Value
_ -> [Char] -> PlutusLedgerLanguage
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: preamble missing 'plutusVersion'"
    Maybe Value
_ -> [Char] -> PlutusLedgerLanguage
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: missing 'preamble' object"
getPlutusVersion Value
_ = [Char] -> PlutusLedgerLanguage
forall a. HasCallStack => [Char] -> a
error [Char]
"Blueprint: top-level value is not an object"

writeBlueprint :: Output -> Value -> [UplcProg ann] -> IO ()
writeBlueprint :: forall ann. Output -> Value -> [UplcProg ann] -> IO ()
writeBlueprint Output
outp Value
original [UplcProg ann]
optimisedProgs =
  let updated :: Value
updated = Value -> [UplcProg ann] -> Value
forall ann. Value -> [UplcProg ann] -> Value
updateValidators Value
original [UplcProg ann]
optimisedProgs
   in case Output
outp of
        FileOutput [Char]
file -> [Char] -> ByteString -> IO ()
BSL.writeFile [Char]
file (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Value
updated)
        Output
StdOutput -> ByteString -> IO ()
BSL.putStr (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Value
updated)
        Output
NoOutput -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

updateValidators :: Value -> [UplcProg ann] -> Value
updateValidators :: forall ann. Value -> [UplcProg ann] -> Value
updateValidators top :: Value
top@(Object Object
obj) [UplcProg ann]
optimisedProgs =
  let key :: Key
key = Text -> Key
Key.fromText Text
"validators"
      ver :: PlutusLedgerLanguage
ver = Value -> PlutusLedgerLanguage
getPlutusVersion Value
top
   in case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
key Object
obj of
        Just Value
arr -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
key (PlutusLedgerLanguage -> Value -> Value
updateArr PlutusLedgerLanguage
ver Value
arr) Object
obj
        Maybe Value
Nothing -> Object -> Value
Object Object
obj -- no validator in blueprint
  where
    updateArr :: PlutusLedgerLanguage -> Value -> Value
updateArr PlutusLedgerLanguage
ver (Array Array
arr)
      | Array -> Int
forall a. Vector a -> Int
V.length Array
arr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [UplcProg ann] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UplcProg ann]
optimisedProgs =
          Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> UplcProg ann -> Value)
-> Array -> Vector (UplcProg ann) -> Array
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith (PlutusLedgerLanguage -> Value -> UplcProg ann -> Value
forall {ann}.
PlutusLedgerLanguage
-> Value -> Program Name DefaultUni DefaultFun ann -> Value
updateOne PlutusLedgerLanguage
ver) Array
arr ([UplcProg ann] -> Vector (UplcProg ann)
forall a. [a] -> Vector a
V.fromList [UplcProg ann]
optimisedProgs)
      | Bool
otherwise =
          [Char] -> Value
forall a. HasCallStack => [Char] -> a
error ([Char] -> Value) -> [Char] -> Value
forall a b. (a -> b) -> a -> b
$
            [Char]
"Blueprint: mismatch between number of validators ("
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Array -> Int
forall a. Vector a -> Int
V.length Array
arr)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") and optimised programs ("
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([UplcProg ann] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UplcProg ann]
optimisedProgs)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    updateArr PlutusLedgerLanguage
_ Value
other = Value
other
    updateOne :: PlutusLedgerLanguage
-> Value -> Program Name DefaultUni DefaultFun ann -> Value
updateOne PlutusLedgerLanguage
ver (Object Object
oldValidatorObj) Program Name DefaultUni DefaultFun ann
optimisedProg =
      let hex :: Text
hex = Program Name DefaultUni DefaultFun ann -> Text
forall ann. UplcProg ann -> Text
encodeUplcHex Program Name DefaultUni DefaultFun ann
optimisedProg
          hash :: ByteString
hash =
            ByteString -> Either [Char] ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight ([Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid validator in blueprint: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
hex) (Either [Char] ByteString -> ByteString)
-> Either [Char] ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
              PlutusLedgerLanguage -> ByteString -> Either [Char] ByteString
hashScriptHex PlutusLedgerLanguage
ver (Text -> ByteString
T.encodeUtf8 Text
hex)
       in Object -> Value
Object
            (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
Key.fromText Text
"compiledCode") (Text -> Value
String Text
hex)
            (Object -> Object) -> (Object -> Object) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
Key.fromText Text
"hash") (Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
hash)
            (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
oldValidatorObj
    updateOne PlutusLedgerLanguage
_ Value
other Program Name DefaultUni DefaultFun ann
_ = Value
other
updateValidators Value
other [UplcProg ann]
_ = Value
other