Create Cardano.Api.MultiSig module

cardano-api/cardano-api.cabal

@@ -18,8 +18,10 @@ library
   exposed-modules:      Cardano.API
                         Cardano.Api.Byron
                         Cardano.Api.Crypto.Ed25519Bip32
+                        Cardano.Api.Eras
                         Cardano.Api.LocalChainSync
                         Cardano.Api.MetaData
+                        Cardano.Api.MultiSig
                         Cardano.Api.Protocol
                         Cardano.Api.Protocol.Byron
                         Cardano.Api.Protocol.Cardano

cardano-api/src/Cardano/Api/Eras.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- The Shelley ledger uses promoted data kinds which we have to use, but we do
+-- not export any from this API. We also use them unticked as nature intended.
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+
+module Cardano.Api.Eras
+  ( -- * Eras
+    Byron
+  , Shelley
+  , Allegra
+  , Mary
+  , HasTypeProxy(..)
+  , AsType (AsPaymentKey)
+  , AsType (AsHash)
+
+    -- ** Hashes
+    -- | In Cardano most keys are identified by their hash, and hashes are
+    -- used in many other places.
+  , Hash(PaymentKeyHash)
+
+  , PaymentKey
+  , PaymentExtendedKey
+  , GenesisKey
+  , GenesisUTxOKey
+  , GenesisDelegateKey
+  , StakeKey
+  , StakePoolKey
+
+    -- ** Raw binary
+    -- | Some types have a natural raw binary format.
+  , SerialiseAsRawBytes
+  , serialiseToRawBytes
+  , deserialiseFromRawBytes
+  , serialiseToRawBytesHex
+  , deserialiseFromRawBytesHex
+  ) where
+
+import           Cardano.Prelude
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as Base16
+import           Data.Proxy (Proxy (..))
+
+import           Ouroboros.Consensus.Shelley.Eras (StandardShelley)
+import qualified Shelley.Spec.Ledger.Keys as Shelley
+
+import qualified Cardano.Crypto.Hash.Class as Crypto
+
+class HasTypeProxy t where
+  -- | A family of singleton types used in this API to indicate which type to
+  -- use where it would otherwise be ambiguous or merely unclear.
+  --
+  -- Values of this type are passed to
+  --
+  data AsType t
+
+  proxyToAsType :: Proxy t -> AsType t
+
+-- ----------------------------------------------------------------------------
+-- Raw binary serialisation
+--
+
+class HasTypeProxy a => SerialiseAsRawBytes a where
+
+  serialiseToRawBytes :: a -> ByteString
+
+  deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a
+
+-- ----------------------------------------------------------------------------
+-- Cardano eras, sometimes we have to distinguish them
+--
+
+-- | A type used as a tag to distinguish the Byron era.
+data Byron
+
+-- | A type used as a tag to distinguish the Shelley era.
+data Shelley
+
+-- | A type used as a tag to distinguish the Allegra era.
+data Allegra
+
+  -- | A type used as a tag to distinguish the Mary era.
+data Mary
+
+data family Hash keyrole :: *
+
+instance HasTypeProxy a => HasTypeProxy (Hash a) where
+    data AsType (Hash a) = AsHash (AsType a)
+    proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a))
+
+newtype instance Hash PaymentKey =
+    PaymentKeyHash (Shelley.KeyHash Shelley.Payment StandardShelley)
+  deriving (Eq, Ord, Show)
+
+instance SerialiseAsRawBytes (Hash PaymentKey) where
+    serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) =
+      Crypto.hashToBytes vkh
+
+    deserialiseFromRawBytes (AsHash AsPaymentKey) bs =
+      PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs
+
+-- | Map the various Shelley key role types into corresponding 'Shelley.KeyRole'
+-- types.
+--
+type family ShelleyKeyRole (keyrole :: *) :: Shelley.KeyRole
+
+data PaymentKey
+data PaymentExtendedKey
+
+instance HasTypeProxy PaymentKey where
+    data AsType PaymentKey = AsPaymentKey
+    proxyToAsType _ = AsPaymentKey
+
+data GenesisKey
+data GenesisUTxOKey
+data GenesisDelegateKey
+data StakeKey
+data StakePoolKey
+
+type instance ShelleyKeyRole PaymentKey         = Shelley.Payment
+type instance ShelleyKeyRole GenesisKey         = Shelley.Genesis
+type instance ShelleyKeyRole GenesisUTxOKey     = Shelley.Payment
+type instance ShelleyKeyRole GenesisDelegateKey = Shelley.GenesisDelegate
+type instance ShelleyKeyRole StakeKey           = Shelley.Staking
+type instance ShelleyKeyRole StakePoolKey       = Shelley.StakePool
+
+
+serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString
+serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes
+
+deserialiseFromRawBytesHex :: SerialiseAsRawBytes a
+                           => AsType a -> ByteString -> Maybe a
+deserialiseFromRawBytesHex proxy hex =
+  case Base16.decode hex of
+    (raw, trailing)
+      | BS.null trailing -> deserialiseFromRawBytes proxy raw
+      | otherwise        -> Nothing

cardano-api/src/Cardano/Api/MultiSig.hs

@@ -0,0 +1,225 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Api.MultiSig
+  ( -- * Scripts
+    -- | Both 'PaymentCredential's and 'StakeCredential's can use scripts.
+    -- Shelley supports multi-signatures via scripts.
+    Script(..),
+    Hash(ScriptHash),
+    parseScript,
+    parseScriptAny,
+    parseScriptAll,
+    parseScriptAtLeast,
+    parseScriptSig,
+
+    -- ** Script addresses
+    -- | Making addresses from scripts.
+    scriptHash,
+
+    -- ** Multi-signature scripts
+    -- | Making multi-signature scripts.
+    MultiSigScript(..),
+    ScriptFeatureInEra(..),
+    makeMultiSigScriptShelley,
+  ) where
+
+import           Cardano.Prelude
+import           Prelude (error)
+
+import           Control.Monad (fail)
+import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.:), (.=))
+import qualified Data.Aeson.Types as Aeson
+import           Data.Scientific (toBoundedInteger)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import           Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import           Cardano.Api.Eras
+
+import           Cardano.Slotting.Slot (SlotNo (..))
+
+--
+-- Shelley imports
+--
+import           Ouroboros.Consensus.Shelley.Eras (StandardShelley)
+import qualified Shelley.Spec.Ledger.Keys as Shelley
+import qualified Shelley.Spec.Ledger.Scripts as Shelley
+
+--
+-- Common types, consensus, network
+--
+import           Cardano.Binary (ToCBOR)
+
+-- ----------------------------------------------------------------------------
+-- Scripts
+--
+
+newtype Script = Script (Shelley.Script StandardShelley)
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToCBOR)
+
+newtype instance Hash Script = ScriptHash (Shelley.ScriptHash StandardShelley)
+  deriving (Eq, Ord, Show)
+
+scriptHash :: Script -> Hash Script
+scriptHash (Script s) = ScriptHash (Shelley.hashAnyScript s)
+
+data MultiSigScript era where
+  RequireSignature  :: Hash PaymentKey
+                     -> ScriptFeatureInEra SignatureFeature era
+                     -> MultiSigScript era
+
+  RequireTimeBefore :: SlotNo
+                    -> ScriptFeatureInEra TimeLocksFeature era
+                    -> MultiSigScript era
+
+  RequireTimeAfter  :: SlotNo
+                    -> ScriptFeatureInEra TimeLocksFeature era
+                    -> MultiSigScript era
+
+  RequireAllOf      ::        [MultiSigScript era] -> MultiSigScript era
+  RequireAnyOf      ::        [MultiSigScript era] -> MultiSigScript era
+  RequireMOf        :: Int -> [MultiSigScript era] -> MultiSigScript era
+
+-- Needed for roundtripping tests
+deriving instance Eq (MultiSigScript Shelley)
+deriving instance Show (MultiSigScript Shelley)
+
+-- | Script Features
+-- These are used within 'ScriptFeatureInEra' in conjunction with the era
+-- (e.g 'Shelley', 'Allegra' etc) to specify which script features are
+-- enabled in a particular era.
+data SignatureFeature
+data TimeLocksFeature
+
+
+data ScriptFeatureInEra sfeat era where
+     SignaturesInShelleyEra  :: ScriptFeatureInEra SignatureFeature Shelley
+     SignaturesInAllegraEra  :: ScriptFeatureInEra SignatureFeature Allegra
+     SignaturesInMaryEra     :: ScriptFeatureInEra SignatureFeature Mary
+
+     TimeLocksInAllegraEra   :: ScriptFeatureInEra TimeLocksFeature Allegra
+     TimeLocksInMaryEra      :: ScriptFeatureInEra TimeLocksFeature Mary
+
+deriving instance Eq (ScriptFeatureInEra SignatureFeature Shelley)
+deriving instance Show (ScriptFeatureInEra SignatureFeature Shelley)
+
+deriving instance Eq (ScriptFeatureInEra SignatureFeature Allegra)
+deriving instance Show (ScriptFeatureInEra SignatureFeature Allegra)
+
+deriving instance Eq (ScriptFeatureInEra SignatureFeature Mary)
+deriving instance Show (ScriptFeatureInEra SignatureFeature Mary)
+
+deriving instance Eq (ScriptFeatureInEra TimeLocksFeature Allegra)
+deriving instance Show (ScriptFeatureInEra TimeLocksFeature Allegra)
+
+deriving instance Eq (ScriptFeatureInEra TimeLocksFeature Mary)
+deriving instance Show (ScriptFeatureInEra TimeLocksFeature Mary)
+
+-- Needed for roundtripping tests
+deriving instance Eq (ScriptFeatureInEra TimeLocksFeature Shelley)
+deriving instance Show (ScriptFeatureInEra TimeLocksFeature Shelley)
+
+makeMultiSigScriptShelley :: MultiSigScript Shelley -> Script
+makeMultiSigScriptShelley = Script . Shelley.MultiSigScript . go
+  where
+    go :: MultiSigScript Shelley -> Shelley.MultiSig StandardShelley
+    go (RequireSignature (PaymentKeyHash kh) SignaturesInShelleyEra)
+                        = Shelley.RequireSignature (Shelley.coerceKeyRole kh)
+    go (RequireAllOf s) = Shelley.RequireAllOf (map go s)
+    go (RequireAnyOf s) = Shelley.RequireAnyOf (map go s)
+    go (RequireMOf m s) = Shelley.RequireMOf m (map go s)
+    go (RequireTimeBefore _ _) = error "Timelocks not available in Shelley era"
+    go (RequireTimeAfter _ _) = error "Timelocks not available in Shelley era"
+
+-- TODO: Distinguish different instances for Shelley vs Allegra etc
+instance ToJSON (MultiSigScript Shelley) where
+  toJSON (RequireSignature pKeyHash SignaturesInShelleyEra) =
+    object [ "keyHash" .= String (Text.decodeUtf8 . serialiseToRawBytesHex $ pKeyHash)
+           , "type" .= String "sig"
+           ]
+  toJSON (RequireAnyOf reqScripts) =
+    object [ "type" .= String "any", "scripts" .= map toJSON reqScripts ]
+  toJSON (RequireAllOf reqScripts) =
+    object [ "type" .= String "all", "scripts" .= map toJSON reqScripts ]
+  toJSON (RequireMOf reqNum reqScripts) =
+    object [ "type" .= String "atLeast"
+           , "required" .= reqNum
+           , "scripts" .= map toJSON reqScripts
+           ]
+  toJSON (RequireTimeBefore _ _) =
+    error "Timelocks not available in Shelley era multi signature scripts"
+  toJSON (RequireTimeAfter _ _) =
+    error "Timelocks not available in Shelley era multi signature scripts"
+
+-- TODO: Distinguish different instances for Shelley vs Allegra etc
+instance FromJSON (MultiSigScript Shelley) where
+  parseJSON = parseScript
+
+parseScript :: Value -> Aeson.Parser (MultiSigScript Shelley)
+parseScript v = parseScriptSig v
+                  <|> parseScriptAny v
+                  <|> parseScriptAll v
+                  <|> parseScriptAtLeast v
+
+parseScriptAny :: Value -> Aeson.Parser (MultiSigScript Shelley)
+parseScriptAny = Aeson.withObject "any" $ \obj -> do
+  t <- obj .: "type"
+  case t :: Text of
+    "any" -> do s <- obj .: "scripts"
+                RequireAnyOf <$> gatherMultiSigScripts s
+    _ -> fail "\"any\" multi-signature script value not found"
+
+parseScriptAll :: Value -> Aeson.Parser (MultiSigScript Shelley)
+parseScriptAll = Aeson.withObject "all" $ \obj -> do
+  t <- obj .: "type"
+  case t :: Text of
+    "all" -> do s <- obj .: "scripts"
+                RequireAllOf <$> gatherMultiSigScripts s
+    _ -> fail "\"all\" multi-signature script value not found"
+
+parseScriptAtLeast :: Value -> Aeson.Parser (MultiSigScript Shelley)
+parseScriptAtLeast = Aeson.withObject "atLeast" $ \obj -> do
+  v <- obj .: "type"
+  case v :: Text of
+    "atLeast" -> do
+      r <- obj .: "required"
+      s <- obj .: "scripts"
+      case r of
+        Number sci ->
+          case toBoundedInteger sci of
+            Just reqInt ->
+              do msigscripts <- gatherMultiSigScripts s
+                 let numScripts = length msigscripts
+                 when
+                   (reqInt > numScripts)
+                   (fail $ "Required number of script signatures exceeds the number of scripts."
+                         <> " Required number: " <> show reqInt
+                         <> " Number of scripts: " <> show numScripts)
+                 return $ RequireMOf reqInt msigscripts
+            Nothing -> fail $ "Error in multi-signature \"required\" key: "
+                            <> show sci <> " is not a valid Int"
+        _ -> fail "\"required\" value should be an integer"
+    _        -> fail "\"atLeast\" multi-signature script value not found"
+
+parseScriptSig :: Value -> Aeson.Parser (MultiSigScript Shelley)
+parseScriptSig = Aeson.withObject "sig" $ \obj -> do
+  v <- obj .: "type"
+  case v :: Text of
+    "sig" -> do k <- obj .: "keyHash"
+                flip RequireSignature SignaturesInShelleyEra <$> convertToHash k
+    _     -> fail "\"sig\" multi-signature script value not found"
+
+convertToHash :: Text -> Aeson.Parser (Hash PaymentKey)
+convertToHash txt = case deserialiseFromRawBytesHex (AsHash AsPaymentKey) $ Text.encodeUtf8 txt of
+                      Just payKeyHash -> return payKeyHash
+                      Nothing -> fail $ "Error deserialising payment key hash: " <> Text.unpack txt
+
+gatherMultiSigScripts :: Vector Value -> Aeson.Parser [MultiSigScript Shelley]
+gatherMultiSigScripts vs = sequence . Vector.toList $ Vector.map parseScript vs