Add new modules for Eras, Keys, Serialisation and HasTypeProxy

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

@@ -0,0 +1,24 @@
+
+module Cardano.Api.Eras
+  ( -- * Eras
+    Byron
+  , Shelley
+  , Allegra
+  , Mary
+  ) where
+
+-- ----------------------------------------------------------------------------
+-- 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

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Api.HasTypeProxy
+  ( HasTypeProxy(AsType, proxyToAsType)
+  ) where
+
+import           Data.Proxy (Proxy (..))
+
+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

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

@@ -0,0 +1,76 @@
+{-# 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.Key
+  ( AsType (AsPaymentKey, 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
+  ) where
+
+import           Cardano.Prelude
+
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
+import qualified Shelley.Spec.Ledger.Keys as Shelley
+
+import           Cardano.Api.HasTypeProxy (HasTypeProxy (..))
+import           Cardano.Api.Serialisation
+import qualified Cardano.Crypto.Hash.Class as Crypto
+
+data family Hash keyrole :: Type
+
+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 StandardCrypto)
+  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 :: Type) :: 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
+

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

@@ -0,0 +1,256 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Api.Serialisation
+  ( -- ** Raw binary
+    -- | Some types have a natural raw binary format.
+    SerialiseAsRawBytes,
+    serialiseToRawBytes,
+    deserialiseFromRawBytes,
+    serialiseToRawBytesHex,
+    deserialiseFromRawBytesHex,
+
+    -- ** Text envelope
+    -- | Support for a envelope file format with text headers and a hex-encoded
+    -- binary payload.
+    HasTextEnvelope(..),
+    TextEnvelope,
+    TextEnvelopeType,
+    TextEnvelopeDescr,
+    TextEnvelopeError,
+    serialiseToTextEnvelope,
+    deserialiseFromTextEnvelope,
+    readFileTextEnvelope,
+    writeFileTextEnvelope,
+    readTextEnvelopeFromFile,
+    readTextEnvelopeOfTypeFromFile,
+    -- *** Reading one of several key types
+    FromSomeType(..),
+    deserialiseFromTextEnvelopeAnyOf,
+    readFileTextEnvelopeAnyOf,
+
+    -- ** CBOR
+    SerialiseAsCBOR,
+    ToCBOR,
+    FromCBOR,
+    serialiseToCBOR,
+    deserialiseFromCBOR,
+
+    -- * Errors
+    Error(..),
+    throwErrorAsException,
+    FileError(..),
+  ) where
+
+import           Cardano.Prelude hiding (show)
+import           Prelude (String, show)
+
+import           Control.Monad.Trans.Except.Extra
+import qualified Data.Aeson as Aeson
+import           Data.Aeson.Encode.Pretty (encodePretty')
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List as List
+import qualified Data.Text as Text
+
+import           Cardano.Api.HasTypeProxy (HasTypeProxy (AsType, proxyToAsType))
+import qualified Cardano.Api.TextView as TextView
+
+import           Cardano.Binary (FromCBOR, ToCBOR)
+import qualified Cardano.Binary as CBOR
+
+-- ----------------------------------------------------------------------------
+-- Raw binary serialisation
+--
+
+class HasTypeProxy a => SerialiseAsRawBytes a where
+
+  serialiseToRawBytes :: a -> ByteString
+
+  deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a
+
+
+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
+    Left _ -> Nothing
+    Right raw -> deserialiseFromRawBytes proxy raw
+
+-- ----------------------------------------------------------------------------
+-- TextEnvelope Serialisation
+--
+
+type TextEnvelope = TextView.TextView
+type TextEnvelopeType = TextView.TextViewType
+type TextEnvelopeDescr = TextView.TextViewDescription
+
+class SerialiseAsCBOR a => HasTextEnvelope a where
+    textEnvelopeType :: AsType a -> TextEnvelopeType
+
+    textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr
+    textEnvelopeDefaultDescr _ = ""
+
+type TextEnvelopeError = TextView.TextViewError
+
+data FileError e = FileError   FilePath e
+                 | FileIOError FilePath IOException
+  deriving Show
+
+instance Error e => Error (FileError e) where
+  displayError (FileIOError path ioe) =
+    path ++ ": " ++ displayException ioe
+  displayError (FileError path e) =
+    path ++ ": " ++ displayError e
+
+instance Error TextView.TextViewError where
+  displayError = Text.unpack . TextView.renderTextViewError
+
+serialiseToTextEnvelope :: forall a. HasTextEnvelope a
+                        => Maybe TextEnvelopeDescr -> a -> TextEnvelope
+serialiseToTextEnvelope mbDescr a =
+    TextView.TextView {
+      TextView.tvType    = textEnvelopeType ttoken
+    , TextView.tvDescription   = fromMaybe (textEnvelopeDefaultDescr a) mbDescr
+    , TextView.tvRawCBOR = serialiseToCBOR a
+    }
+  where
+    ttoken :: AsType a
+    ttoken = proxyToAsType Proxy
+
+
+deserialiseFromTextEnvelope :: HasTextEnvelope a
+                            => AsType a
+                            -> TextEnvelope
+                            -> Either TextEnvelopeError a
+deserialiseFromTextEnvelope ttoken te = do
+    TextView.expectTextViewOfType (textEnvelopeType ttoken) te
+    first TextView.TextViewDecodeError $
+      deserialiseFromCBOR ttoken (TextView.tvRawCBOR te) --TODO: You have switched from CBOR to JSON
+
+data FromSomeType (c :: Type -> Constraint) b where
+     FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b
+
+
+deserialiseFromTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
+                                 -> TextEnvelope
+                                 -> Either TextEnvelopeError b
+deserialiseFromTextEnvelopeAnyOf types te =
+    case List.find matching types of
+      Nothing ->
+        Left (TextView.TextViewTypeError expectedTypes actualType)
+
+      Just (FromSomeType ttoken f) ->
+        first TextView.TextViewDecodeError $
+          f <$> deserialiseFromCBOR ttoken (TextView.tvRawCBOR te)
+  where
+    actualType    = TextView.tvType te
+    expectedTypes = [ textEnvelopeType ttoken
+                    | FromSomeType ttoken _f <- types ]
+
+    matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken
+
+
+writeFileTextEnvelope :: HasTextEnvelope a
+                      => FilePath
+                      -> Maybe TextEnvelopeDescr
+                      -> a
+                      -> IO (Either (FileError ()) ())
+writeFileTextEnvelope path mbDescr a =
+    runExceptT $ do
+      handleIOExceptT (FileIOError path) $ BS.writeFile path content
+  where
+    content = LBS.toStrict $ encodePretty' TextView.textViewJSONConfig (serialiseToTextEnvelope mbDescr a) <> "\n"
+
+readFileTextEnvelope :: HasTextEnvelope a
+                     => AsType a
+                     -> FilePath
+                     -> IO (Either (FileError TextEnvelopeError) a)
+readFileTextEnvelope ttoken path =
+    runExceptT $ do
+      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
+      firstExceptT (FileError path) $ hoistEither $ do
+        te <- first TextView.TextViewAesonDecodeError $ Aeson.eitherDecodeStrict' content
+        deserialiseFromTextEnvelope ttoken te
+
+
+readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
+                          -> FilePath
+                          -> IO (Either (FileError TextEnvelopeError) b)
+readFileTextEnvelopeAnyOf types path =
+    runExceptT $ do
+      content <- handleIOExceptT (FileIOError path) $ BS.readFile path
+      firstExceptT (FileError path) $ hoistEither $ do
+        te <- first TextView.TextViewAesonDecodeError $ Aeson.eitherDecodeStrict' content
+        deserialiseFromTextEnvelopeAnyOf types te
+
+readTextEnvelopeFromFile :: FilePath
+                         -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
+readTextEnvelopeFromFile path =
+  runExceptT $ do
+    bs <- handleIOExceptT (FileIOError path) $
+            BS.readFile path
+    firstExceptT (FileError path . TextView.TextViewAesonDecodeError)
+      . hoistEither $ Aeson.eitherDecodeStrict' bs
+
+readTextEnvelopeOfTypeFromFile
+  :: TextEnvelopeType
+  -> FilePath
+  -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
+readTextEnvelopeOfTypeFromFile expectedType path =
+  runExceptT $ do
+    te <- ExceptT (readTextEnvelopeFromFile path)
+    firstExceptT (FileError path) $ hoistEither $
+      TextView.expectTextViewOfType expectedType te
+    return te
+
+-- ----------------------------------------------------------------------------
+-- CBOR serialisation
+--
+
+class HasTypeProxy a => SerialiseAsCBOR a where
+    serialiseToCBOR :: a -> ByteString
+    deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a
+
+    default serialiseToCBOR :: ToCBOR a => a -> ByteString
+    serialiseToCBOR = CBOR.serialize'
+
+    default deserialiseFromCBOR :: FromCBOR a
+                                => AsType a
+                                -> ByteString
+                                -> Either CBOR.DecoderError a
+    deserialiseFromCBOR _proxy = CBOR.decodeFull'
+
+-- ----------------------------------------------------------------------------
+-- Error reporting
+--
+
+class Show e => Error e where
+
+    displayError :: e -> String
+
+instance Error () where
+    displayError () = ""
+
+-- | The preferred approach is to use 'Except' or 'ExceptT', but you can if
+-- necessary use IO exceptions.
+--
+throwErrorAsException :: Error e => e -> IO a
+throwErrorAsException e = throwIO (ErrorAsException e)
+
+data ErrorAsException where
+     ErrorAsException :: Error e => e -> ErrorAsException
+
+instance Show ErrorAsException where
+    show (ErrorAsException e) = show e
+
+instance Exception ErrorAsException where
+    displayException (ErrorAsException e) = displayError e