{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
module Cardano.Address.Script.Parser
(
scriptFromString
, scriptToText
, scriptParser
, 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
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
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)
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