Parser.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_HADDOCK prune #-}

-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0

module Cardano.Address.Script.Parser
    (
    -- ** Script Parser
      scriptFromString
    , scriptToText
    , scriptParser

    -- Internal
    , requireSignatureOfParser
    , requireAllOfParser
    , requireAnyOfParser
    , requireAtLeastOfParser
    , requireCosignerOfParser
    ) where

import Prelude

import Cardano.Address.KeyHash
    ( KeyHash, keyHashFromText, prettyErrKeyHashFromText )
import Cardano.Address.Script
    ( Cosigner (..), ErrValidateScript (..), Script (..) )
import Data.Char
    ( isDigit, isLetter )
import Data.Text
    ( Text )
import Data.Word
    ( Word8 )
import Numeric.Natural
    ( Natural )
import Text.ParserCombinators.ReadP
    ( ReadP, readP_to_S, (<++) )

import qualified Data.Text as T
import qualified Text.ParserCombinators.ReadP as P

-- | Run 'scriptParser' on string input.
--
-- @since 3.0.0
scriptFromString
    :: ReadP (Script a)
    -> String
    -> Either ErrValidateScript (Script a)
scriptFromString parser str =
    case readP_to_S (scriptParser parser) str of
         [(script, "")] -> pure script
         _ -> Left Malformed

-- | Defines canonical string output for script that is
-- consistent with 'scriptFromString'.
--
-- @since 3.10.0
scriptToText
    :: Show a
    => Script a
    -> Text
scriptToText (RequireSignatureOf object) = T.pack $ show object
scriptToText (RequireAllOf contents) =
    "all [" <>  T.intercalate "," (map scriptToText contents) <> "]"
scriptToText (RequireAnyOf contents) =
    "any [" <>  T.intercalate "," (map scriptToText contents) <> "]"
scriptToText (RequireSomeOf m contents) =
    "at_least "<> T.pack (show m) <>
    " [" <>  T.intercalate "," (map scriptToText contents) <> "]"
scriptToText (ActiveFromSlot s) =
    "active_from " <> T.pack (show s)
scriptToText (ActiveUntilSlot s) =
    "active_until " <> T.pack (show s)


-- | The script embodies combination of signing keys that need to be met to make
-- it valid. We assume here that the script could
-- delivered from standard input. The examples below are self-explanatory:
--
-- 1. requiring signature
-- 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe
--
-- 2. 'any' for signature required
-- any [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
--
-- 3. 'all' signatures required
-- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
--
-- 4. 'at_least' 1 signature required
-- at_least 1 [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
--
-- 5. Nested script are supported
-- at_least 1 [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]]
-- 6. 1 signature required after slot number 120
-- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_from 120]
-- 7. 1 signature required until slot number 150
-- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_until 150]
-- 8. 1 signature required in slot interval <145, 150)
-- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_from 145, active_until 150]
--
-- Parser is insensitive to whitespaces.
--
-- @since 3.0.0
scriptParser :: ReadP (Script a) -> ReadP (Script a)
scriptParser parser =
    requireAllOfParser parser <++
    requireAnyOfParser parser <++
    requireAtLeastOfParser parser <++
    parser <++
    activeFromSlotParser <++
    activeUntilSlotParser

requireSignatureOfParser :: ReadP (Script KeyHash)
requireSignatureOfParser = do
    P.skipSpaces
    verKeyStr <- P.munch1 (\c -> isDigit c || isLetter c || c == '_')
    case keyHashFromText (T.pack verKeyStr) of
        Left e  -> fail (prettyErrKeyHashFromText e)
        Right h -> pure (RequireSignatureOf h)

requireCosignerOfParser :: ReadP (Script Cosigner)
requireCosignerOfParser = do
    P.skipSpaces
    _identifier <- P.string "cosigner#"
    cosignerid <- fromInteger . read <$> P.munch1 isDigit
    pure $ RequireSignatureOf $ Cosigner cosignerid

requireAllOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAllOfParser parser = do
    P.skipSpaces
    _identifier <- P.string "all"
    RequireAllOf <$> commonPart parser

requireAnyOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAnyOfParser parser = do
    P.skipSpaces
    _identifier <- P.string "any"
    RequireAnyOf <$> commonPart parser

requireAtLeastOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAtLeastOfParser parser = do
    P.skipSpaces
    _identifier <- P.string "at_least"
    RequireSomeOf <$> naturalParser <*> commonPart parser

activeFromSlotParser :: ReadP (Script a)
activeFromSlotParser = do
    P.skipSpaces
    _identifier <- P.string "active_from"
    ActiveFromSlot <$> slotParser

activeUntilSlotParser :: ReadP (Script a)
activeUntilSlotParser = do
    P.skipSpaces
    _identifier <- P.string "active_until"
    ActiveUntilSlot <$> slotParser

naturalParser :: ReadP Word8
naturalParser = do
    P.skipSpaces
    fromInteger . read <$> P.munch1 isDigit

slotParser :: ReadP Natural
slotParser = do
    P.skipSpaces
    fromInteger . read <$> P.munch1 isDigit

commonPart :: ReadP (Script a) -> ReadP [Script a]
commonPart parser = do
    P.skipSpaces
    _open <- P.string "["
    P.skipSpaces
    content <- P.sepBy (scriptParser parser) (P.string ",")
    P.skipSpaces
    _close <- P.string "]"
    P.skipSpaces
    return content