to/from json instances for script

command-line/lib/Command/Key/Hash.hs

@@ -14,10 +14,10 @@ module Command.Key.Hash
 import Prelude hiding
     ( mod )
 
+import Cardano.Address.Script
+    ( KeyHash (..) )
 import Cardano.Address.Style.Shelley
     ( hashKey, liftXPub )
-import Cardano.Script
-    ( KeyHash (..) )
 import Codec.Binary.Bech32.TH
     ( humanReadablePart )
 import Options.Applicative

command-line/lib/Command/Script/Hash.hs

@@ -12,7 +12,7 @@ module Command.Script.Hash
 
     ) where
 
-import Cardano.Script
+import Cardano.Address.Script
     ( Script (..)
     , ScriptHash (..)
     , prettyErrValidateScript
@@ -60,7 +60,7 @@ mod liftCmd = command "hash" $
             ])
   where
     parser = Cmd
-        <$> encodingOpt [humanReadablePart|script_hash|]
+        <$> encodingOpt [humanReadablePart|script|]
         <*> scriptArg
 
 run :: Cmd -> IO ()

command-line/lib/Options/Applicative/Script.hs

@@ -22,18 +22,18 @@ import Prelude
 
 import Cardano.Address.Derivation
     ( Depth (..) )
-import Cardano.Address.Style.Shelley
-    ( Credential (..), liftXPub )
-import Cardano.Script
+import Cardano.Address.Script
     ( ErrValidateScript
     , Script (..)
     , ScriptHash
     , prettyErrValidateScript
     , scriptHashFromBytes
     , validateScript
     )
-import Cardano.Script.Parser
+import Cardano.Address.Script.Parser
     ( scriptFromString )
+import Cardano.Address.Style.Shelley
+    ( Credential (..), liftXPub )
 import Control.Applicative
     ( (<|>) )
 import Control.Arrow

command-line/lib/System/IO/Extra.hs

@@ -28,10 +28,10 @@ import Prelude
 
 import Cardano.Address.Derivation
     ( XPrv, XPub, xprvFromBytes, xpubFromBytes )
+import Cardano.Address.Script
+    ( ScriptHash, scriptHashFromBytes )
 import Cardano.Mnemonic
     ( MkSomeMnemonicError (..), SomeMnemonic, mkSomeMnemonic )
-import Cardano.Script
-    ( ScriptHash, scriptHashFromBytes )
 import Codec.Binary.Encoding
     ( AbstractEncoding (..)
     , Encoding

command-line/test/Command/ScriptSpec.hs

@@ -7,7 +7,7 @@ module Command.ScriptSpec
 
 import Prelude
 
-import Cardano.Script
+import Cardano.Address.Script
     ( ErrValidateScript (..), prettyErrValidateScript )
 import Data.String.Interpolate
     ( iii )

core/cardano-addresses.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 7230b06b321453c9af8eb4c5f2800263125c54f14a33d152661f9d8189b904a0
+-- hash: d031c987a04a14f86cdbbc2cae6c846d9b47c0ea9754ff29a51efaeeb84ccaab
 
 name:           cardano-addresses
 version:        2.1.0
@@ -34,14 +34,14 @@ library
       Cardano.Address
       Cardano.Address.Derivation
       Cardano.Address.Errors
+      Cardano.Address.Script
+      Cardano.Address.Script.Parser
       Cardano.Address.Style.Byron
       Cardano.Address.Style.Icarus
       Cardano.Address.Style.Jormungandr
       Cardano.Address.Style.Shelley
       Cardano.Codec.Cbor
       Cardano.Mnemonic
-      Cardano.Script
-      Cardano.Script.Parser
       Codec.Binary.Encoding
       Data.Word7
   other-modules:
@@ -79,15 +79,15 @@ test-suite unit
   main-is: Main.hs
   other-modules:
       Cardano.Address.DerivationSpec
+      Cardano.Address.Script.ParserSpec
+      Cardano.Address.ScriptSpec
       Cardano.Address.Style.ByronSpec
       Cardano.Address.Style.IcarusSpec
       Cardano.Address.Style.JormungandrSpec
       Cardano.Address.Style.ShelleySpec
       Cardano.AddressSpec
       Cardano.Codec.CborSpec
       Cardano.MnemonicSpec
-      Cardano.Script.ParserSpec
-      Cardano.ScriptSpec
       Codec.Binary.EncodingSpec
       Data.Word7Spec
       Test.Arbitrary
@@ -100,6 +100,7 @@ test-suite unit
       hspec-discover:hspec-discover
   build-depends:
       QuickCheck
+    , aeson
     , base >=4.7 && <5
     , bech32
     , binary

core/lib/Cardano/Script.hs → core/lib/Cardano/Address/Script.hs

@@ -1,19 +1,22 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Cardano.Script
+module Cardano.Address.Script
     (
     -- * Script
       Script (..)
     , validateScript
     , ErrValidateScript (..)
     , prettyErrValidateScript
+    , bech32
 
     -- * Hashing
     , serialize
@@ -24,13 +27,18 @@ module Cardano.Script
 
     , KeyHash (..)
     , keyHashFromBytes
+    , keyHashFromText
 
     -- * Internal
     , hashSize
     ) where
 
 import Prelude
 
+import Codec.Binary.Encoding
+    ( AbstractEncoding (..), detectEncoding, encode, fromBase16 )
+import Control.Applicative
+    ( (<|>) )
 import Control.DeepSeq
     ( NFData )
 import Control.Monad
@@ -41,22 +49,41 @@ import Crypto.Hash.Algorithms
     ( Blake2b_224 (..) )
 import Crypto.Hash.IO
     ( HashAlgorithm (hashDigestSize) )
+import Data.Aeson
+    ( FromJSON (..)
+    , ToJSON (..)
+    , Value (..)
+    , object
+    , withObject
+    , withText
+    , (.:)
+    , (.=)
+    )
 import Data.ByteString
     ( ByteString )
+import Data.Either.Combinators
+    ( maybeToRight )
 import Data.Foldable
     ( foldl', traverse_ )
 import Data.Maybe
     ( isNothing )
+import Data.Text
+    ( Text )
 import Data.Word
     ( Word8 )
 import GHC.Generics
     ( Generic )
 
 import qualified Cardano.Codec.Cbor as CBOR
+import qualified Codec.Binary.Bech32 as Bech32
+import qualified Codec.Binary.Bech32.TH as Bech32
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString as BS
 import qualified Data.List as L
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
 
 -- | A 'Script' type represents multi signature script. The script embodies conditions
 -- that need to be satisfied to make it valid.
@@ -66,7 +93,7 @@ data Script
     = RequireSignatureOf !KeyHash
     | RequireAllOf ![Script]
     | RequireAnyOf ![Script]
-    | RequireMOf Word8 ![Script]
+    | RequireSomeOf Word8 ![Script]
     deriving stock (Generic, Show, Eq)
 instance NFData Script
 
@@ -88,7 +115,7 @@ validateScript = \case
         when (hasDuplicate script) $ Left DuplicateSignatures
         traverse_ validateScript script
 
-    RequireMOf m script -> do
+    RequireSomeOf m script -> do
         when (m == 0) $ Left MZero
         when (length script < fromIntegral m) $ Left ListTooSmall
         when (hasDuplicate script) $ Left DuplicateSignatures
@@ -143,7 +170,7 @@ serialize script =
             encodeMultiscriptCtr 1 2 <> encodeFoldable toCBOR contents
         RequireAnyOf contents ->
             encodeMultiscriptCtr 2 2 <> encodeFoldable toCBOR contents
-        RequireMOf m contents -> mconcat
+        RequireSomeOf m contents -> mconcat
             [ encodeMultiscriptCtr 3 3
             , CBOR.encodeInt (fromInteger $ toInteger m)
             , encodeFoldable toCBOR contents
@@ -154,10 +181,10 @@ serialize script =
         CBOR.encodeListLen listLen <> CBOR.encodeWord ctrIndex
 
     encodeFoldable :: (Foldable f) => (a -> CBOR.Encoding) -> f a -> CBOR.Encoding
-    encodeFoldable encode xs = wrapArray len contents
+    encodeFoldable encode' xs = wrapArray len contents
       where
         (len, contents) = foldl' go (0, mempty) xs
-        go (!l, !enc) next = (l + 1, enc <> encode next)
+        go (!l, !enc) next = (l + 1, enc <> encode' next)
 
         wrapArray :: Word -> CBOR.Encoding -> CBOR.Encoding
         wrapArray len' contents'
@@ -172,7 +199,7 @@ toScriptHash = ScriptHash . blake2b224 . serialize
 -- 28-byte.
 --
 -- @since 3.0.0
-newtype ScriptHash = ScriptHash ByteString
+newtype ScriptHash = ScriptHash { unScriptHash :: ByteString }
     deriving (Generic, Show, Eq)
 instance NFData ScriptHash
 
@@ -188,7 +215,7 @@ scriptHashFromBytes bytes
 -- multi-signature script. The hash is expected to have size of 28-byte.
 --
 -- @since 3.0.0
-newtype KeyHash = KeyHash ByteString
+newtype KeyHash = KeyHash { unKeyHash :: ByteString }
     deriving (Generic, Show, Eq)
 instance NFData KeyHash
 
@@ -200,6 +227,61 @@ keyHashFromBytes bytes
     | BS.length bytes /= hashSize = Nothing
     | otherwise = Just $ KeyHash bytes
 
+data ErrorKeyHashFromText =
+      ErrorKeyHashFromTextInvalidString (AbstractEncoding ())
+    | ErrorKeyHashFromTextWrongEncoding
+    | ErrorKeyHashFromTextWrongPayload
+    | ErrorKeyHashFromTextWrongHrp
+    | ErrorKeyHashFromTextWrongDataPart
+    deriving (Show, Eq)
+
+showErr :: ErrorKeyHashFromText -> String
+showErr (ErrorKeyHashFromTextInvalidString EBase16) =
+    "Invalid Base16-encoded string."
+showErr (ErrorKeyHashFromTextInvalidString EBech32{}) =
+    "Invalid Bech32-encoded string."
+showErr (ErrorKeyHashFromTextInvalidString EBase58) =
+    "Verification key hash must be must be encoded as \
+    \base16 or bech32."
+showErr ErrorKeyHashFromTextWrongEncoding =
+    "Verification key hash must be must be encoded as \
+    \base16 or bech32."
+showErr ErrorKeyHashFromTextWrongPayload =
+    "Verification key hash must contain exactly 28 bytes."
+showErr ErrorKeyHashFromTextWrongHrp =
+    "Verification key hash must have 'script_vkh' hrp when Bech32-encoded."
+showErr ErrorKeyHashFromTextWrongDataPart =
+    "Verification key hash is Bech32-encoded but has wrong data part."
+
+-- | Construct a 'KeyHash' from 'Text'. Either hex encoded text or
+-- Bech32 encoded text with `script_vkh` hrp is expected. Also
+-- binary payload is expected to be composed of 28 bytes.
+--
+-- @since 3.0.0
+keyHashFromText :: Text -> Either ErrorKeyHashFromText KeyHash
+keyHashFromText txt =  case detectEncoding str of
+        Just EBase16 -> case fromBase16 (toBytes str) of
+            Left _ -> Left $ ErrorKeyHashFromTextInvalidString EBase16
+            Right bytes -> checkPayload bytes
+        Just EBech32{} -> fromBech32
+        Just EBase58 -> Left ErrorKeyHashFromTextWrongEncoding
+        Nothing -> Left ErrorKeyHashFromTextWrongEncoding
+ where
+    str = T.unpack txt
+    toBytes = T.encodeUtf8 . T.pack
+    checkPayload bytes =
+        maybeToRight ErrorKeyHashFromTextWrongPayload (keyHashFromBytes bytes)
+    fromBech32 = do
+        (hrp, dp) <- either
+            (const $ Left $ ErrorKeyHashFromTextInvalidString $ EBech32 ())
+            Right (Bech32.decodeLenient txt)
+        case Bech32.humanReadablePartToText hrp of
+            "script_vkh" -> do
+                bytes <- maybeToRight
+                    ErrorKeyHashFromTextWrongDataPart (Bech32.dataPartToBytes dp)
+                checkPayload bytes
+            _ -> Left ErrorKeyHashFromTextWrongHrp
+
 --
 -- Internal
 --
@@ -212,3 +294,57 @@ blake2b224 =
 -- Size, in bytes, of a hash of public key (without the corresponding chain code)
 hashSize :: Int
 hashSize = hashDigestSize Blake2b_224
+
+-- | Encode a 'KeyHash' to bech32 'Text', using @script_vkh@ as a human readable prefix.
+--
+-- @since 3.0.0
+bech32 :: KeyHash -> Text
+bech32 (KeyHash keyHash) = T.decodeUtf8 $ encode (EBech32 hrp) keyHash
+  where
+    hrp = [Bech32.humanReadablePart|script_vkh|]
+
+-- Examples of Script jsons:
+--"e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735a"
+--{ "all" : [ "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735a"
+--          , "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735b"
+--          ]
+--}
+--{ "all" : [ "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735a"
+--          , {"any": [ "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735b"
+--                    , "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735c"
+--                    ]
+--            }
+--          ]
+--}
+--{ "all" : [ "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735a"
+--          , {"some": { "from" :[ "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735b"
+--                               , "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735c"
+--                               , "e09d36c79dec9bd1b3d9e152247701cd0bb860b5ebfd1de8abb6735d"
+--                               ]
+--                     , "at_least" : 2
+--                     }
+--            }
+--          ]
+--}
+
+instance ToJSON Script where
+    toJSON (RequireSignatureOf keyHash) = String $ bech32 keyHash
+    toJSON (RequireAllOf content) =
+        object ["all" .= fmap toJSON content]
+    toJSON (RequireAnyOf content) =
+        object ["any" .= fmap toJSON content]
+    toJSON (RequireSomeOf count scripts) =
+        object ["some" .= object ["at_least" .= count, "from" .= scripts]]
+
+instance FromJSON Script where
+    parseJSON v = parseKey v <|> parseAnyOf v  <|> parseAllOf v <|> parseAtLeast v
+      where
+        parseKey = withText "Script KeyHash" $
+            either (fail . showErr) (pure . RequireSignatureOf) . keyHashFromText
+        parseAnyOf = withObject "Script AnyOf" $ \o ->
+            RequireAnyOf <$> o .: "any"
+        parseAllOf = withObject "Script AllOf" $ \o ->
+            RequireAllOf <$> o .: "all"
+        parseAtLeast = withObject "Script SomeOf" $ \o -> do
+            some <- o .: "some"
+            RequireSomeOf <$> some .: "at_least" <*> some .: "from"