Make AnnotatedSignature type more strictly-typed

- AnnotatedSignature now uses cardano-crypto types rather than Text.

cabal.project

@@ -27,4 +27,34 @@ package metadata-store-postgres
 
 tests: False
 
-test-show-details: direct
+test-show-details: direct
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/cardano-base
+  tag: b364d925e0a72689ecba40dd1f4899f76170b894
+  --sha256: 0igb4gnzlwxy1h40vy5s1aysmaa04wypxn7sn67qy6din7ysmad3
+  subdir:
+    binary
+    binary/test
+    cardano-crypto-class
+    cardano-crypto-praos
+    cardano-crypto-tests
+    slotting
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/cardano-prelude
+  tag: 116087dbcebb88aafdc7d3d0577477ba36129b41
+  --sha256: 0kxk5vcywsl19qc65y8mkc0npv5qz9fm23avs247xnb0zq17wcrd
+  subdir:
+    cardano-prelude
+    cardano-prelude-test
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/cardano-crypto
+  tag: 2547ad1e80aeabca2899951601079408becbc92c
+  --sha256: 1p2kg2w02q5w1cvqzhfhqmxviy4xrzada3mmb096j2n6hfr20kri
+
+allow-newer: github:base16-bytestring

metadata-lib/metadata-lib.cabal

@@ -32,6 +32,8 @@ library
                      , base
                      , base64-bytestring
                      , bytestring
+                     , cardano-crypto
+                     , cardano-crypto-class
                      , casing
                      , containers
                      , deepseq
@@ -82,6 +84,7 @@ test-suite unit-tests
                 , base >=4.12 && <5
                 , base64-bytestring
                 , bytestring
+                , cardano-crypto-class
                 , containers
                 , hedgehog
                 , hspec

metadata-lib/src/Cardano/Metadata/Types/Common.hs

@@ -7,20 +7,26 @@
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Cardano.Metadata.Types.Common where
 
 import           Control.DeepSeq              (NFData)
 import           Data.Maybe (fromMaybe)
 import           Data.Aeson                   (FromJSON, FromJSONKey, ToJSON,
                                                ToJSONKey, (.:), (.:?))
+import qualified Data.Aeson                   as Aeson
 import           Data.Aeson.TH                (deriveJSON)
 import qualified Data.Aeson.Types             as Aeson
 import           Data.ByteArray.Encoding      (Base (Base16, Base64),
                                                convertFromBase, convertToBase)
 import           Data.ByteString              (ByteString)
+import qualified Data.ByteString.Char8 as     BC
+import qualified Data.ByteString.Lazy as BSL
 import           Data.Hashable                (Hashable)
 import qualified Data.HashMap.Strict          as HM
+import qualified Data.ByteString.Short as Short
 import           Data.String                  (IsString)
 import           Data.Text                    (Text)
 import qualified Data.Text                    as T
@@ -33,6 +39,9 @@ import           Text.Read                    (readEither, readPrec)
 import qualified Text.Read                    as Read (lift)
 import           Web.HttpApiData              (FromHttpApiData, ToHttpApiData)
 
+import Cardano.Crypto.DSIGN
+import Cardano.Crypto.Hash
+
 -- | The metadata subject, the on-chain identifier
 newtype Subject = Subject { unSubject :: Text }
   deriving (Generic, Eq, Ord, FromHttpApiData, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
@@ -59,11 +68,28 @@ type Description = Property Text
 -- | A pair of a public key, and a signature of the metadata entry by
 -- that public key.
 data AnnotatedSignature =
-  AnnotatedSignature { asSignature :: Text
-                     , asPublicKey :: Text
+  AnnotatedSignature { asAttestationSignature :: SigDSIGN Ed25519DSIGN
+                     , asPublicKey            :: VerKeyDSIGN Ed25519DSIGN
                      }
   deriving (Eq, Show)
 
+mkAnnotatedSignature :: forall val . ToJSON val => SignKeyDSIGN Ed25519DSIGN -> Subject -> PropertyName -> val -> AnnotatedSignature
+mkAnnotatedSignature skey subj propName propVal =
+  let
+    hashSubj     = hashWith (T.encodeUtf8 . unSubject) subj :: Hash Blake2b_256 Subject
+    hashPropName = hashWith (T.encodeUtf8 . unPropertyName) propName :: Hash Blake2b_256 PropertyName
+    hashPropVal  = hashWith (BSL.toStrict . Aeson.encode) propVal :: Hash Blake2b_256 val
+
+    h = hashWith id
+      (  hashToBytes hashSubj
+      <> hashToBytes hashPropName
+      <> hashToBytes hashPropVal
+      ) :: Hash Blake2b_256 ByteString
+    publicKey = deriveVerKeyDSIGN skey
+    sig       = signDSIGN () (hashToBytes h) skey
+  in
+    AnnotatedSignature sig publicKey
+
 -- | Hash functions supported by 'PreImage'.
 data HashFn = Blake2b256
             | Blake2b224
@@ -139,6 +165,54 @@ instance FromJSON value => FromJSON (Property value) where
       <$> obj .: "value"
       <*> (fromMaybe [] <$> obj .:? "anSignatures")
 
-$(deriveJSON Aeson.defaultOptions{ Aeson.fieldLabelModifier = toCamel . fromHumps . drop 2 } ''AnnotatedSignature)
+instance ToJSON AnnotatedSignature where
+  toJSON (AnnotatedSignature sig pubKey) = Aeson.Object . HM.fromList $
+    [ ("signature", Aeson.String $ T.decodeUtf8 $ convertToBase Base16 $ rawSerialiseSigDSIGN sig)
+    , ("publicKey", Aeson.String $ T.decodeUtf8 $ convertToBase Base16 $ rawSerialiseVerKeyDSIGN pubKey)
+    ]
+
+deserialiseBase16 :: Text -> Either Text ByteString
+deserialiseBase16 t =
+  case (convertFromBase Base16 . T.encodeUtf8 $ t) of
+    Left err -> Left . T.pack $ "Failed to deserialise Base16 bytestring from text: '" <> T.unpack t <> "', error was: " <> err
+    Right x  -> pure x
+
+deserialiseAttestationSignature :: ByteString -> Either Text (SigDSIGN Ed25519DSIGN)
+deserialiseAttestationSignature t =
+  case rawDeserialiseSigDSIGN t of
+    Nothing -> Left . T.pack $ "Failed to parse Ed25519DSIGN signature from '" <> BC.unpack t <> "'."
+    Just x  -> pure x
+
+deserialisePublicKey :: ByteString -> Either Text (VerKeyDSIGN Ed25519DSIGN)
+deserialisePublicKey t =
+  case rawDeserialiseVerKeyDSIGN t of
+    Nothing -> Left . T.pack $ "Failed to parse Ed25519DSIGN verification key from '" <> BC.unpack t <> "'."
+    Just x  -> pure x
+
+instance FromJSON AnnotatedSignature where
+  parseJSON = Aeson.withObject "AnnotatedSignature" $ \obj -> do
+    AnnotatedSignature
+    <$> (deserialiseSigDSIGN =<< deserialiseBase16 =<< obj .: "signature")
+    <*> (deserialiseVerKeyDSIGN =<< deserialiseBase16 =<< obj .: "publicKey")
+
+    where
+      deserialiseBase16 :: Text -> Aeson.Parser ByteString
+      deserialiseBase16 t =
+        case (convertFromBase Base16 . T.encodeUtf8 $ t) of
+          Left err -> fail $ "Failed to deserialise Base16 bytestring from text: '" <> T.unpack t <> "', error was: " <> err
+          Right x  -> pure x
+
+      deserialiseSigDSIGN :: ByteString -> Aeson.Parser (SigDSIGN Ed25519DSIGN)
+      deserialiseSigDSIGN t =
+        case rawDeserialiseSigDSIGN t of
+          Nothing -> fail $ "Failed to parse Ed25519DSIGN signature from '" <> BC.unpack t <> "'."
+          Just x  -> pure x
+
+      deserialiseVerKeyDSIGN :: ByteString -> Aeson.Parser (VerKeyDSIGN Ed25519DSIGN)
+      deserialiseVerKeyDSIGN t =
+        case rawDeserialiseVerKeyDSIGN t of
+          Nothing -> fail $ "Failed to parse Ed25519DSIGN verification key from '" <> BC.unpack t <> "'."
+          Just x  -> pure x
+
 $(deriveJSON Aeson.defaultOptions{ Aeson.fieldLabelModifier = toCamel . fromHumps . drop 3 } ''Owner)
 $(deriveJSON Aeson.defaultOptions{ Aeson.fieldLabelModifier = toCamel . fromHumps . drop 2 } ''PreImage)

metadata-lib/src/Test/Cardano/Helpers.hs

@@ -1,12 +1,14 @@
 module Test.Cardano.Helpers where
 
 import           Data.Aeson          (FromJSON, ToJSON)
+import           Control.Monad.IO.Class (MonadIO)
 import qualified Data.Aeson          as Aeson
 import qualified Data.HashMap.Strict as HM
 import           Data.List           (sort)
 import           Data.Text           (Text)
 import           Hedgehog            (Gen, MonadTest, failure, footnote, forAll,
-                                      property, tripping, (===))
+                                      property, tripping, (===), toGenT, MonadGen, GenT)
+import Hedgehog.Internal.Property (forAllT)
 import qualified Hedgehog            as H (Property)
 import           Text.Read           (readEither)
 
@@ -16,9 +18,9 @@ prop_read_show_roundtrips gen = property $ do
 
   tripping a show readEither
 
-prop_json_roundtrips :: (Show a, Eq a, ToJSON a, FromJSON a) => Gen a -> H.Property
+prop_json_roundtrips :: (Show a, Eq a, ToJSON a, FromJSON a) => GenT IO a -> H.Property
 prop_json_roundtrips gen = property $ do
-  a <- forAll gen
+  a <- forAllT (toGenT gen)
 
   tripping a Aeson.toJSON Aeson.fromJSON
 

metadata-lib/src/Test/Cardano/Metadata/Generators.hs

@@ -26,6 +26,9 @@ import qualified Hedgehog.Range                as Range
 import           Network.URI                   (URI (URI), URIAuth (URIAuth))
 import           Test.Tasty                    (TestTree, testGroup)
 import           Test.Tasty.Hedgehog
+import qualified Cardano.Crypto.DSIGN.Class as Crypto
+import qualified Cardano.Crypto.Seed as Crypto
+import qualified Cardano.Crypto.Hash as Crypto
 
 import           Cardano.Metadata.Server.Types (BatchRequest (BatchRequest),
                                                 BatchResponse (BatchResponse))
@@ -37,7 +40,7 @@ import           Cardano.Metadata.Types.Common (AnnotatedSignature (AnnotatedSig
                                                 PreImage (PreImage),
                                                 Property (Property),
                                                 PropertyName (PropertyName),
-                                                Subject (Subject), unSubject)
+                                                Subject (Subject), unSubject, mkAnnotatedSignature)
 import qualified Cardano.Metadata.Types.Wallet as Wallet
 import qualified Cardano.Metadata.Types.Weakly as Weakly
 
@@ -72,8 +75,20 @@ publicKey = Gen.text (Range.linear 0 64) Gen.hexit
 sig :: MonadGen m => m Text
 sig = Gen.text (Range.linear 0 128) Gen.hexit
 
-annotatedSignature :: MonadGen m => m AnnotatedSignature
-annotatedSignature = AnnotatedSignature <$> publicKey <*> sig
+annotatedSignature :: (MonadGen m, MonadIO m, Aeson.ToJSON val) => Subject -> PropertyName -> val -> m AnnotatedSignature
+annotatedSignature subj propName val = do
+  sKey <- liftIO $ do
+    seed <- Crypto.readSeedFromSystemEntropy 32
+    pure $ Crypto.genKeyDSIGN seed
+
+  pure $ mkAnnotatedSignature sKey subj propName val
+
+annotatedSignature' :: (MonadGen m, MonadIO m) => m AnnotatedSignature
+annotatedSignature' = do
+  subj  <- subject
+  pName <- propertyName
+  val   <- propertyValue
+  annotatedSignature subj pName val
 
 propName :: MonadGen m => m PropertyName
 propName = Gen.choice [ pure $ PropertyName "description"
@@ -93,15 +108,26 @@ preImage = PreImage <$> metadataValue <*> hashFn
 owner :: MonadGen m => m Owner
 owner = Owner <$> publicKey <*> sig
 
-stronglyTypedProperty :: MonadGen m => m a -> m (Property a)
-stronglyTypedProperty genA =
-  Property <$> genA <*> Gen.list (Range.linear 0 5) annotatedSignature
+stronglyTypedProperty :: (MonadIO m, MonadGen m, Aeson.ToJSON a) => Subject -> PropertyName -> m a -> m (Property a)
+stronglyTypedProperty subject propName genA = do
+  a <- genA
+  Property <$> pure a <*> Gen.list (Range.linear 0 5) (annotatedSignature subject propName a)
+
+name :: (MonadIO m, MonadGen m) => Subject -> m Name
+name subj = stronglyTypedProperty subj "name" (Gen.text (Range.linear 1 256) Gen.unicodeAll)
+
+name' :: (MonadIO m, MonadGen m) => m Name
+name' = do
+  subj <- subject
+  name subj
 
-name :: MonadGen m => m Name
-name = stronglyTypedProperty (Gen.text (Range.linear 1 256) Gen.unicodeAll)
+description :: (MonadIO m, MonadGen m) => Subject -> m Description
+description subj = stronglyTypedProperty subj "description" (Gen.text (Range.linear 1 256) Gen.unicodeAll)
 
-description :: MonadGen m => m Description
-description = stronglyTypedProperty (Gen.text (Range.linear 1 256) Gen.unicodeAll)
+description' :: (MonadIO m, MonadGen m) => m Description
+description' = do
+  subj <- subject
+  description subj
 
 httpsURI :: MonadGen m => m URI
 httpsURI = (URI <$> pure "https:" <*> (Just <$> uriAuthority) <*> (T.unpack <$> uriPath) <*> pure mempty <*> pure mempty)
@@ -137,16 +163,25 @@ assetUnit = Wallet.AssetUnit
   <$> Gen.text (Range.linear 1 30) Gen.unicodeAll
   <*> Gen.integral (Range.linear 1 19)
 
-walletMetadata :: MonadGen m => m Wallet.Metadata
-walletMetadata = Wallet.Metadata
-  <$> subject
-  <*> stronglyTypedProperty (Gen.text (Range.linear 1 50) Gen.unicodeAll)
-  <*> description
-  <*> Gen.maybe (stronglyTypedProperty assetUnit)
-  <*> Gen.maybe (stronglyTypedProperty assetLogo)
-  <*> Gen.maybe (stronglyTypedProperty assetURL)
-  <*> Gen.maybe (stronglyTypedProperty ticker)
-  <*> (fmap HM.fromList $ Gen.list (Range.linear 1 5) ((,) <$> propertyName <*> weaklyTypedProperty))
+walletMetadata :: (MonadIO m, MonadGen m) => m Wallet.Metadata
+walletMetadata = do
+  subj <- subject
+
+  let
+    weakProp = do
+      pName <- propertyName 
+      prop  <- weaklyTypedProperty subj pName
+      pure (pName, prop)
+
+  name    <- stronglyTypedProperty subj "name" (Gen.text (Range.linear 1 50) Gen.unicodeAll)
+  desc    <- description subj
+  unit    <- Gen.maybe (stronglyTypedProperty subj "unit" assetUnit)
+  logo    <- Gen.maybe (stronglyTypedProperty subj "logo" assetLogo)
+  url     <- Gen.maybe (stronglyTypedProperty subj "url" assetURL)
+  ticker  <- Gen.maybe (stronglyTypedProperty subj "ticker" ticker)
+  rest    <- (fmap HM.fromList $ Gen.list (Range.linear 1 5) weakProp)
+
+  pure $ Wallet.Metadata subj name desc unit logo url ticker rest
 
 batchRequest :: MonadGen m => m BatchRequest
 batchRequest =
@@ -160,7 +195,7 @@ batchRequestFor subjects = do
   props <- Gen.maybe $ Gen.list (Range.linear 0 20) propName
   pure $ BatchRequest subjs props
 
-batchResponse :: MonadGen m => m BatchResponse
+batchResponse :: (MonadIO m, MonadGen m) => m BatchResponse
 batchResponse = BatchResponse <$> Gen.list (Range.linear 0 20) weaklyTypedMetadata
 
 key :: MonadGen m => m Word8
@@ -173,14 +208,27 @@ keyVals :: MonadGen m => m [(Word8, Word8)]
 keyVals = do
   Gen.list (Range.linear 0 20) ((,) <$> key <*> val)
 
-weaklyTypedProperty :: MonadGen m => m Weakly.Property
-weaklyTypedProperty = Property <$> propertyValue <*> Gen.list (Range.linear 0 5) annotatedSignature
-
-weaklyTypedMetadata :: MonadGen m => m Weakly.Metadata
-weaklyTypedMetadata =
-  Weakly.Metadata
-  <$> subject
-  <*> (fmap HM.fromList $ Gen.list (Range.linear 0 20) ((,) <$> propertyName <*> weaklyTypedProperty))
+weaklyTypedProperty :: (MonadIO m, MonadGen m) => Subject -> PropertyName -> m Weakly.Property
+weaklyTypedProperty subj pName = do
+  val <- propertyValue
+  Property <$> pure val <*> Gen.list (Range.linear 0 5) (annotatedSignature subj pName val)
+
+weaklyTypedProperty' :: (MonadIO m, MonadGen m) => m Weakly.Property
+weaklyTypedProperty' = do
+  subj  <- subject
+  pName <- propertyName
+  weaklyTypedProperty subj pName
+
+weaklyTypedMetadata :: (MonadIO m, MonadGen m) => m Weakly.Metadata
+weaklyTypedMetadata = do
+  s <- subject
+  let
+    weakProp = do
+      pName <- propertyName
+      prop  <- weaklyTypedProperty s pName
+      pure (pName, prop)
+
+  Weakly.Metadata s <$> (fmap HM.fromList $ Gen.list (Range.linear 0 20) weakProp)
 
 propertyName :: MonadGen m => m PropertyName
 propertyName = PropertyName <$> Gen.text (Range.linear 1 64) Gen.unicodeAll