{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Singular.Registry.Blueprint.Schema
Description : CIP-57 blueprint schema types, JSON parsing and validation
License     : Apache-2.0

The CIP-57 schema model behind 'Singular.Registry.Blueprint': the
'Blueprint', 'Validator', 'Schema' and 'Constructor' types with their
Aeson parsers, and 'validateData' for checking 'PlutusCore.Data.Data'
values against a declared schema.

This is the schema-and-validation owner extracted from
@Singular.Registry.Blueprint@; the public module re-exports it and is
its only intended consumer surface.
-}
module Singular.Registry.Blueprint.Schema
    ( -- * Schema types
      Blueprint (..)
    , Validator (..)
    , Schema (..)
    , Constructor (..)

      -- * Validation
    , validateData
    ) where

import Data.Aeson
    ( FromJSON (..)
    , Value
    , withObject
    , (.:)
    , (.:?)
    )
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (Parser)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import PlutusCore.Data (Data (..))

-- | A single constructor alternative in a schema.
data Constructor = Constructor
    { Constructor -> Integer
conIndex :: Integer
    -- ^ Constructor tag (matches Aiken's Constr index)
    , Constructor -> [Schema]
conFields :: [Schema]
    -- ^ Schemas for each positional field
    }
    deriving stock (Int -> Constructor -> ShowS
[Constructor] -> ShowS
Constructor -> String
(Int -> Constructor -> ShowS)
-> (Constructor -> String)
-> ([Constructor] -> ShowS)
-> Show Constructor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Constructor -> ShowS
showsPrec :: Int -> Constructor -> ShowS
$cshow :: Constructor -> String
show :: Constructor -> String
$cshowList :: [Constructor] -> ShowS
showList :: [Constructor] -> ShowS
Show, Constructor -> Constructor -> Bool
(Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool) -> Eq Constructor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Constructor -> Constructor -> Bool
== :: Constructor -> Constructor -> Bool
$c/= :: Constructor -> Constructor -> Bool
/= :: Constructor -> Constructor -> Bool
Eq)

-- | CIP-57 schema for a Plutus data type.
data Schema
    = -- | @{"dataType": "bytes"}@
      SBytes
    | -- | @{"dataType": "integer"}@
      SInteger
    | {- | @{"dataType": "list", "items": <one schema>}@ — a
      homogeneous list of any length.
      -}
      SList Schema
    | {- | @{"dataType": "list", "items": [<schema>, ...]}@ — Aiken's
      FIXED TUPLE (#157 request-destination-binding): an ARRAY of positional item
      schemas. On the wire it is a Plutus @List@ of exactly that
      arity, each element of its own declared type, which is what
      distinguishes it from 'SList' and why it cannot share that
      case: a homogeneous rule would accept a three-element pair.
      -}
      STuple [Schema]
    | -- | @{"anyOf": [...constructors...]}@
      SConstructors [Constructor]
    | -- | @{"$ref": "#/definitions/..."}@
      SRef Text
    deriving stock (Int -> Schema -> ShowS
[Schema] -> ShowS
Schema -> String
(Int -> Schema -> ShowS)
-> (Schema -> String) -> ([Schema] -> ShowS) -> Show Schema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Schema -> ShowS
showsPrec :: Int -> Schema -> ShowS
$cshow :: Schema -> String
show :: Schema -> String
$cshowList :: [Schema] -> ShowS
showList :: [Schema] -> ShowS
Show, Schema -> Schema -> Bool
(Schema -> Schema -> Bool)
-> (Schema -> Schema -> Bool) -> Eq Schema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Schema -> Schema -> Bool
== :: Schema -> Schema -> Bool
$c/= :: Schema -> Schema -> Bool
/= :: Schema -> Schema -> Bool
Eq)

-- | A validator entry in the blueprint.
data Validator = Validator
    { Validator -> Text
vTitle :: Text
    -- ^ Human-readable validator name
    , Validator -> Maybe Schema
vDatum :: Maybe Schema
    -- ^ Datum schema, absent for minting validators
    , Validator -> Schema
vRedeemer :: Schema
    -- ^ Redeemer schema
    , Validator -> Text
vHash :: Text
    -- ^ Hex-encoded script hash (28 bytes)
    , Validator -> Maybe Text
vCompiledCode :: Maybe Text
    -- ^ Hex-encoded double-CBOR PlutusV3 script
    , Validator -> Int
vParameters :: Int
    {- ^ How many parameters this validator applies. A blueprint omits
    the array entirely for a parameterless validator, so an absent
    `parameters` key reads as zero. This is what makes a
    parameterless policy's compiled hash its policy id, with no
    applied hash to derive, so a consumer that wants to state it
    should READ it here rather than write the number down.
    -}
    }
    deriving stock (Int -> Validator -> ShowS
[Validator] -> ShowS
Validator -> String
(Int -> Validator -> ShowS)
-> (Validator -> String)
-> ([Validator] -> ShowS)
-> Show Validator
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validator -> ShowS
showsPrec :: Int -> Validator -> ShowS
$cshow :: Validator -> String
show :: Validator -> String
$cshowList :: [Validator] -> ShowS
showList :: [Validator] -> ShowS
Show, Validator -> Validator -> Bool
(Validator -> Validator -> Bool)
-> (Validator -> Validator -> Bool) -> Eq Validator
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Validator -> Validator -> Bool
== :: Validator -> Validator -> Bool
$c/= :: Validator -> Validator -> Bool
/= :: Validator -> Validator -> Bool
Eq)

-- | A parsed CIP-57 blueprint.
data Blueprint = Blueprint
    { Blueprint -> [Validator]
validators :: [Validator]
    -- ^ All validator entries in the blueprint
    , Blueprint -> Map Text Schema
definitions :: Map Text Schema
    -- ^ Named type definitions referenced by @$ref@
    }
    deriving stock (Int -> Blueprint -> ShowS
[Blueprint] -> ShowS
Blueprint -> String
(Int -> Blueprint -> ShowS)
-> (Blueprint -> String)
-> ([Blueprint] -> ShowS)
-> Show Blueprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Blueprint -> ShowS
showsPrec :: Int -> Blueprint -> ShowS
$cshow :: Blueprint -> String
show :: Blueprint -> String
$cshowList :: [Blueprint] -> ShowS
showList :: [Blueprint] -> ShowS
Show, Blueprint -> Blueprint -> Bool
(Blueprint -> Blueprint -> Bool)
-> (Blueprint -> Blueprint -> Bool) -> Eq Blueprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Blueprint -> Blueprint -> Bool
== :: Blueprint -> Blueprint -> Bool
$c/= :: Blueprint -> Blueprint -> Bool
/= :: Blueprint -> Blueprint -> Bool
Eq)

-- ---------------------------------------------------------
-- JSON parsing
-- ---------------------------------------------------------

instance FromJSON Constructor where
    parseJSON :: Value -> Parser Constructor
parseJSON = String
-> (Object -> Parser Constructor) -> Value -> Parser Constructor
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Constructor" ((Object -> Parser Constructor) -> Value -> Parser Constructor)
-> (Object -> Parser Constructor) -> Value -> Parser Constructor
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        idx <- Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"index"
        fields <- o .: "fields"
        pure
            Constructor
                { conIndex = idx
                , conFields = fields
                }

instance FromJSON Schema where
    parseJSON :: Value -> Parser Schema
parseJSON = String -> (Object -> Parser Schema) -> Value -> Parser Schema
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Schema" ((Object -> Parser Schema) -> Value -> Parser Schema)
-> (Object -> Parser Schema) -> Value -> Parser Schema
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        mRef <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"$ref"
        case mRef of
            Just Text
ref -> Schema -> Parser Schema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> Parser Schema) -> Schema -> Parser Schema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
SRef (Text -> Text
parseRef Text
ref)
            Maybe Text
Nothing -> do
                mAnyOf <- Object
o Object -> Key -> Parser (Maybe [Constructor])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"anyOf"
                case mAnyOf of
                    Just [Constructor]
cs ->
                        Schema -> Parser Schema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> Parser Schema) -> Schema -> Parser Schema
forall a b. (a -> b) -> a -> b
$ [Constructor] -> Schema
SConstructors [Constructor]
cs
                    Maybe [Constructor]
Nothing -> do
                        mDataType <-
                            Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dataType"
                                :: Parser
                                    (Maybe Text)
                        case mDataType of
                            Just Text
"bytes" ->
                                Schema -> Parser Schema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
SBytes
                            Just Text
"integer" ->
                                Schema -> Parser Schema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
SInteger
                            Just Text
"list" -> do
                                -- The JSON itself says which one this
                                -- is: an ARRAY of item schemas is
                                -- Aiken's fixed tuple, anything else is
                                -- a homogeneous list. Branching on the
                                -- shape rather than trying one and
                                -- falling back keeps both cases exact —
                                -- a malformed tuple stays an error
                                -- instead of silently becoming a list.
                                items <-
                                    Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"items"
                                        :: Parser Aeson.Value
                                case items of
                                    Aeson.Array Array
_ ->
                                        [Schema] -> Schema
STuple ([Schema] -> Schema) -> Parser [Schema] -> Parser Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [Schema]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
items
                                    Value
_ -> Schema -> Schema
SList (Schema -> Schema) -> Parser Schema -> Parser Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Schema
forall a. FromJSON a => Value -> Parser a
parseJSON Value
items
                            Just Text
"constructor" -> do
                                idx <- Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"index"
                                fields <-
                                    o .: "fields"
                                pure $
                                    SConstructors
                                        [ Constructor
                                            idx
                                            fields
                                        ]
                            Maybe Text
_ -> Schema -> Parser Schema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
SBytes

instance FromJSON Validator where
    parseJSON :: Value -> Parser Validator
parseJSON = String -> (Object -> Parser Validator) -> Value -> Parser Validator
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Validator" ((Object -> Parser Validator) -> Value -> Parser Validator)
-> (Object -> Parser Validator) -> Value -> Parser Validator
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        title <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"title"
        datumObj <- o .:? "datum"
        datum <- case datumObj of
            Just Object
d -> do
                s <- Object
d Object -> Key -> Parser Schema
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"schema"
                pure (Just s)
            Maybe Object
Nothing -> Maybe Schema -> Parser (Maybe Schema)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Schema
forall a. Maybe a
Nothing
        redeemerObj <- o .: "redeemer"
        redeemer <- redeemerObj .: "schema"
        h <- o .: "hash"
        code <- o .:? "compiledCode"
        params <- o .:? "parameters"
        pure
            Validator
                { vTitle = title
                , vDatum = datum
                , vRedeemer = redeemer
                , vHash = h
                , vCompiledCode = code
                , vParameters = maybe 0 length (params :: Maybe [Value])
                }

instance FromJSON Blueprint where
    parseJSON :: Value -> Parser Blueprint
parseJSON = String -> (Object -> Parser Blueprint) -> Value -> Parser Blueprint
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Blueprint" ((Object -> Parser Blueprint) -> Value -> Parser Blueprint)
-> (Object -> Parser Blueprint) -> Value -> Parser Blueprint
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        vs <- Object
o Object -> Key -> Parser [Validator]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"validators"
        defs <- o .: "definitions"
        pure
            Blueprint
                { validators = vs
                , definitions = defs
                }

{- | Strip the @#/definitions/@ prefix and unescape
tilde-encoded slashes (@~1@ -> @/@).
-}
parseRef :: Text -> Text
parseRef :: Text -> Text
parseRef =
    HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~1" Text
"/"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~0" Text
"~"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
stripPrefix Text
"#/definitions/"

stripPrefix :: Text -> Text -> Text
stripPrefix :: Text -> Text -> Text
stripPrefix Text
pfx Text
t =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Text -> Maybe Text
T.stripPrefix Text
pfx Text
t)

-- ---------------------------------------------------------
-- Validation
-- ---------------------------------------------------------

{- | Validate a 'Data' value against a 'Schema',
resolving @$ref@ through the definitions map.
-}
validateData
    :: Map Text Schema
    -- ^ Named definitions for @$ref@ resolution
    -> Schema
    -- ^ Schema to validate against
    -> Data
    -- ^ Value to validate
    -> Bool
validateData :: Map Text Schema -> Schema -> Data -> Bool
validateData Map Text Schema
defs Schema
schema Data
d = case (Schema
schema, Data
d) of
    (Schema
SBytes, B ByteString
_) -> Bool
True
    (Schema
SInteger, I Integer
_) -> Bool
True
    (SList Schema
s, List [Data]
xs) ->
        (Data -> Bool) -> [Data] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Map Text Schema -> Schema -> Data -> Bool
validateData Map Text Schema
defs Schema
s) [Data]
xs
    -- A fixed tuple is a list of EXACTLY its declared arity, validated
    -- element by element against its own position's schema. Wrong
    -- arity and wrong element types both refuse.
    (STuple [Schema]
ss, List [Data]
xs) ->
        [Schema] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Schema]
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Data] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Data]
xs
            Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Schema -> Data -> Bool) -> [Schema] -> [Data] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Map Text Schema -> Schema -> Data -> Bool
validateData Map Text Schema
defs) [Schema]
ss [Data]
xs)
    (SRef Text
ref, Data
_) ->
        case Text -> Map Text Schema -> Maybe Schema
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ref Map Text Schema
defs of
            Just Schema
s -> Map Text Schema -> Schema -> Data -> Bool
validateData Map Text Schema
defs Schema
s Data
d
            Maybe Schema
Nothing -> Bool
False
    (SConstructors [Constructor]
cs, Constr Integer
ix [Data]
fields) ->
        (Constructor -> Bool) -> [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
            ( \Constructor
c ->
                Constructor -> Integer
conIndex Constructor
c
                    Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
ix
                    Bool -> Bool -> Bool
&& [Schema] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Constructor -> [Schema]
conFields Constructor
c)
                        Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Data] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Data]
fields
                    Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
                        ( (Schema -> Data -> Bool) -> [Schema] -> [Data] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                            (Map Text Schema -> Schema -> Data -> Bool
validateData Map Text Schema
defs)
                            (Constructor -> [Schema]
conFields Constructor
c)
                            [Data]
fields
                        )
            )
            [Constructor]
cs
    (Schema, Data)
_ -> Bool
False