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

{-# OPTIONS_HADDOCK prune #-}

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

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

import Prelude

import Cardano.Address.Script
    ( Cosigner (..)
    , ErrValidateScript (..)
    , KeyHash
    , Script (..)
    , keyHashFromText
    , prettyErrKeyHashFromText
    )
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 :: ReadP (Script a) -> String -> Either ErrValidateScript (Script a)
scriptFromString ReadP (Script a)
parser String
str =
    case ReadP (Script a) -> ReadS (Script a)
forall a. ReadP a -> ReadS a
readP_to_S (ReadP (Script a) -> ReadP (Script a)
forall a. ReadP (Script a) -> ReadP (Script a)
scriptParser ReadP (Script a)
parser) String
str of
         [(Script a
script, String
"")] -> Script a -> Either ErrValidateScript (Script a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Script a
script
         [(Script a, String)]
_ -> ErrValidateScript -> Either ErrValidateScript (Script a)
forall a b. a -> Either a b
Left ErrValidateScript
Malformed

-- | Defines canonical string output for script that is
-- consistent with 'scriptFromString'.
--
-- @since 3.10.0
scriptToText
    :: Show a
    => Script a
    -> Text
scriptToText :: Script a -> Text
scriptToText (RequireSignatureOf a
object) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
object
scriptToText (RequireAllOf [Script a]
contents) =
    Text
"all [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text -> [Text] -> Text
T.intercalate Text
"," ((Script a -> Text) -> [Script a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Script a -> Text
forall a. Show a => Script a -> Text
scriptToText [Script a]
contents) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
scriptToText (RequireAnyOf [Script a]
contents) =
    Text
"any [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text -> [Text] -> Text
T.intercalate Text
"," ((Script a -> Text) -> [Script a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Script a -> Text
forall a. Show a => Script a -> Text
scriptToText [Script a]
contents) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
scriptToText (RequireSomeOf Word8
m [Script a]
contents) =
    Text
"at_least "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word8 -> String
forall a. Show a => a -> String
show Word8
m) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text -> [Text] -> Text
T.intercalate Text
"," ((Script a -> Text) -> [Script a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Script a -> Text
forall a. Show a => Script a -> Text
scriptToText [Script a]
contents) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
scriptToText (ActiveFromSlot Natural
s) =
    Text
"active_from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Natural -> String
forall a. Show a => a -> String
show Natural
s)
scriptToText (ActiveUntilSlot Natural
s) =
    Text
"active_until " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Natural -> String
forall a. Show a => a -> String
show Natural
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 :: ReadP (Script a) -> ReadP (Script a)
scriptParser ReadP (Script a)
parser =
    ReadP (Script a) -> ReadP (Script a)
forall a. ReadP (Script a) -> ReadP (Script a)
requireAllOfParser ReadP (Script a)
parser ReadP (Script a) -> ReadP (Script a) -> ReadP (Script a)
forall a. ReadP a -> ReadP a -> ReadP a
<++
    ReadP (Script a) -> ReadP (Script a)
forall a. ReadP (Script a) -> ReadP (Script a)
requireAnyOfParser ReadP (Script a)
parser ReadP (Script a) -> ReadP (Script a) -> ReadP (Script a)
forall a. ReadP a -> ReadP a -> ReadP a
<++
    ReadP (Script a) -> ReadP (Script a)
forall a. ReadP (Script a) -> ReadP (Script a)
requireAtLeastOfParser ReadP (Script a)
parser ReadP (Script a) -> ReadP (Script a) -> ReadP (Script a)
forall a. ReadP a -> ReadP a -> ReadP a
<++
    ReadP (Script a)
parser ReadP (Script a) -> ReadP (Script a) -> ReadP (Script a)
forall a. ReadP a -> ReadP a -> ReadP a
<++
    ReadP (Script a)
forall a. ReadP (Script a)
activeFromSlotParser ReadP (Script a) -> ReadP (Script a) -> ReadP (Script a)
forall a. ReadP a -> ReadP a -> ReadP a
<++
    ReadP (Script a)
forall a. ReadP (Script a)
activeUntilSlotParser

requireSignatureOfParser :: ReadP (Script KeyHash)
requireSignatureOfParser :: ReadP (Script KeyHash)
requireSignatureOfParser = do
    ReadP ()
P.skipSpaces
    String
verKeyStr <- (Char -> Bool) -> ReadP String
P.munch1 (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
    case Text -> Either ErrKeyHashFromText KeyHash
keyHashFromText (String -> Text
T.pack String
verKeyStr) of
        Left ErrKeyHashFromText
e  -> String -> ReadP (Script KeyHash)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ErrKeyHashFromText -> String
prettyErrKeyHashFromText ErrKeyHashFromText
e)
        Right KeyHash
h -> Script KeyHash -> ReadP (Script KeyHash)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash -> Script KeyHash
forall elem. elem -> Script elem
RequireSignatureOf KeyHash
h)

requireCosignerOfParser :: ReadP (Script Cosigner)
requireCosignerOfParser :: ReadP (Script Cosigner)
requireCosignerOfParser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"cosigner#"
    Word8
cosignerid <- Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer -> Word8) -> (String -> Integer) -> String -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read (String -> Word8) -> ReadP String -> ReadP Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit
    Script Cosigner -> ReadP (Script Cosigner)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script Cosigner -> ReadP (Script Cosigner))
-> Script Cosigner -> ReadP (Script Cosigner)
forall a b. (a -> b) -> a -> b
$ Cosigner -> Script Cosigner
forall elem. elem -> Script elem
RequireSignatureOf (Cosigner -> Script Cosigner) -> Cosigner -> Script Cosigner
forall a b. (a -> b) -> a -> b
$ Word8 -> Cosigner
Cosigner Word8
cosignerid

requireAllOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAllOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAllOfParser ReadP (Script a)
parser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"all"
    [Script a] -> Script a
forall elem. [Script elem] -> Script elem
RequireAllOf ([Script a] -> Script a) -> ReadP [Script a] -> ReadP (Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP (Script a) -> ReadP [Script a]
forall a. ReadP (Script a) -> ReadP [Script a]
commonPart ReadP (Script a)
parser

requireAnyOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAnyOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAnyOfParser ReadP (Script a)
parser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"any"
    [Script a] -> Script a
forall elem. [Script elem] -> Script elem
RequireAnyOf ([Script a] -> Script a) -> ReadP [Script a] -> ReadP (Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP (Script a) -> ReadP [Script a]
forall a. ReadP (Script a) -> ReadP [Script a]
commonPart ReadP (Script a)
parser

requireAtLeastOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAtLeastOfParser :: ReadP (Script a) -> ReadP (Script a)
requireAtLeastOfParser ReadP (Script a)
parser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"at_least"
    Word8 -> [Script a] -> Script a
forall elem. Word8 -> [Script elem] -> Script elem
RequireSomeOf (Word8 -> [Script a] -> Script a)
-> ReadP Word8 -> ReadP ([Script a] -> Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Word8
naturalParser ReadP ([Script a] -> Script a)
-> ReadP [Script a] -> ReadP (Script a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP (Script a) -> ReadP [Script a]
forall a. ReadP (Script a) -> ReadP [Script a]
commonPart ReadP (Script a)
parser

activeFromSlotParser :: ReadP (Script a)
activeFromSlotParser :: ReadP (Script a)
activeFromSlotParser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"active_from"
    Natural -> Script a
forall elem. Natural -> Script elem
ActiveFromSlot (Natural -> Script a) -> ReadP Natural -> ReadP (Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Natural
slotParser

activeUntilSlotParser :: ReadP (Script a)
activeUntilSlotParser :: ReadP (Script a)
activeUntilSlotParser = do
    ReadP ()
P.skipSpaces
    String
_identifier <- String -> ReadP String
P.string String
"active_until"
    Natural -> Script a
forall elem. Natural -> Script elem
ActiveUntilSlot (Natural -> Script a) -> ReadP Natural -> ReadP (Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Natural
slotParser

naturalParser :: ReadP Word8
naturalParser :: ReadP Word8
naturalParser = do
    ReadP ()
P.skipSpaces
    Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer -> Word8) -> (String -> Integer) -> String -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read (String -> Word8) -> ReadP String -> ReadP Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit

slotParser :: ReadP Natural
slotParser :: ReadP Natural
slotParser = do
    ReadP ()
P.skipSpaces
    Integer -> Natural
forall a. Num a => Integer -> a
fromInteger (Integer -> Natural) -> (String -> Integer) -> String -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read (String -> Natural) -> ReadP String -> ReadP Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit

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