Add hyperlane-encode-token-message native

src/Crypto/Hash/HyperlaneNatives.hs

@@ -22,6 +22,7 @@ module Crypto.Hash.HyperlaneNatives
     -- Implementation of natives
   , hyperlaneMessageId
   , hyperlaneDecodeTokenMessage
+  , hyperlaneEncodeTokenMessage
   ) where
 
 import Control.Lens ((^?), at, _Just, Prism', _1)
@@ -30,6 +31,7 @@ import Control.Monad.Except (throwError)
 import Data.Bifunctor (first)
 import Data.Binary.Get (Get)
 import Data.Binary.Get qualified as Bin
+import Data.Binary.Put qualified as Bin
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Base16 qualified as Base16
@@ -45,16 +47,17 @@ import Data.Ratio ((%))
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Text.Read qualified as Text
 import Data.WideWord.Word256 (Word256(..))
 import Data.Word (Word8, Word32)
 import Ethereum.Misc (keccak256, _getKeccak256Hash, _getBytesN)
 import Pact.JSON.Decode qualified as J
 import Pact.Types.Exp (Literal(..))
 import Pact.Types.PactValue (PactValue(PGuard), fromPactValue)
 import Pact.Types.Pretty (Doc, pretty)
-import Pact.Types.Runtime (Object(..), ObjectMap(..), FieldKey, Name, Type(TyAny), _TLiteral, _LInteger, _LString, toTObject, ChainId(..))
+import Pact.Types.Runtime (Object(..), ObjectMap(..), FieldKey, Name, Type(TyAny), _TLiteral, _LInteger, _LString, toTObject, ChainId(..), _LDecimal)
 import Pact.Types.Term (Term(..), toTerm)
-import Pact.Types.Util (decodeBase64UrlUnpadded)
+import Pact.Types.Util (decodeBase64UrlUnpadded, encodeBase64UrlUnpadded)
 
 ----------------------------------------------
 --               Primitives                 --
@@ -85,6 +88,13 @@ hyperlaneDecodeTokenMessage i = do
         pure tm
   tokenMessageToTerm tm
 
+hyperlaneEncodeTokenMessage :: Object Name -> Either Doc Text
+hyperlaneEncodeTokenMessage o = do
+  tm <- first displayHyperlaneMessageIdError $ do
+    decodeHyperlaneTokenMessageObject o
+  let encoded = Text.decodeUtf8 $ encodeBase64UrlUnpadded $ BL.toStrict $ Bin.runPut (Bin.putBuilder $ packTokenMessageERC20 tm)
+  return encoded
+
 ----------------------------------------------
 --              Error Types                 --
 ----------------------------------------------
@@ -103,6 +113,7 @@ data HyperlaneMessageIdError
     -- ^ Invalid base64 text field.
   | HyperlaneMessageIdIncorrectSize FieldKey Int Int
     -- ^ Invalid Hex. We discard error messages from base16-bytestring to
+  | HyperlaneMessageIdErrorInvalidChainId Text
 
 displayHyperlaneMessageIdError :: HyperlaneMessageIdError -> Doc
 displayHyperlaneMessageIdError = \case
@@ -113,6 +124,7 @@ displayHyperlaneMessageIdError = \case
   HyperlaneMessageIdInvalidBase64 key -> "Invalid base64 encoding on field " <> pretty key
   HyperlaneMessageIdIncorrectSize key expected actual ->
     "Incorrect binary data size " <> pretty key <> ". Expected: " <> pretty expected <> ", but got " <> pretty actual
+  HyperlaneMessageIdErrorInvalidChainId msg -> "Failed to decode chainId " <> pretty msg
 
 data HyperlaneDecodeError
   = HyperlaneDecodeErrorBase64
@@ -269,9 +281,17 @@ decodeBase64AndValidate key expected s = do
 
   return decoded
 
-----------------------------------------------
---      Hyperlane Pact Object Decoding      --
-----------------------------------------------
+parseChainId :: Text -> Either HyperlaneMessageIdError Word256
+parseChainId s = do
+  cid <- first (HyperlaneMessageIdErrorInvalidChainId . Text.pack) $ Text.decimal s
+
+  unless (fst cid >= 0) $ throwError $ HyperlaneMessageIdErrorInvalidChainId "ChainId can't be negative"
+  return $ fst cid
+
+
+------------------------------------------------------
+--      Hyperlane Message Pact Object Decoding      --
+------------------------------------------------------
 
 decodeHyperlaneMessageObject :: Object Name -> Either HyperlaneMessageIdError HyperlaneMessage
 decodeHyperlaneMessageObject o = do
@@ -287,13 +307,30 @@ decodeHyperlaneMessageObject o = do
 
   pure HyperlaneMessage{..}
 
+------------------------------------------------------------
+--      Hyperlane Token Message Pact Object Decoding      --
+------------------------------------------------------------
+
+decodeHyperlaneTokenMessageObject :: Object Name -> Either HyperlaneMessageIdError TokenMessageERC20
+decodeHyperlaneTokenMessageObject o = do
+  let om = _objectMap (_oObject o)
+
+  tmRecipient <- grabField om "recipient" _LString
+  tmAmount    <- decimalToWord <$> grabField om "amount" _LDecimal
+  tmChainId   <- parseChainId =<< grabField om "chainId" _LString
+
+  pure TokenMessageERC20{..}
+
 ----------------------------------------------
 --                Utilities                 --
 ----------------------------------------------
 
 wordToDecimal :: Word256 -> Decimal
 wordToDecimal w = fromRational (toInteger w % ethInWei)
 
+decimalToWord :: Decimal -> Word256
+decimalToWord d = round $ d * ethInWei
+
 ethInWei :: Num a => a
 ethInWei = 1_000_000_000_000_000_000 -- 1e18
 {-# inline ethInWei #-}

src/Pact/Gas/Table.hs

@@ -58,6 +58,7 @@ data GasCostConfig = GasCostConfig
   , _gasCostConfig_poseidonHashHackAChainLinearGasFactor :: Gas
   , _gasCostConfig_hyperlaneMessageIdGasPerRecipientOneHundredBytes :: MilliGas
   , _gasCostConfig_hyperlaneDecodeTokenMessageGasPerOneHundredBytes :: MilliGas
+  , _gasCostConfig_hyperlaneEncodeTokenMessageGasPerOneHundredBytes :: MilliGas
   , _gasCostConfig_keccak256GasPerOneHundredBytes :: MilliGas
   , _gasCostConfig_keccak256GasPerChunk :: MilliGas
   }
@@ -88,6 +89,7 @@ defaultGasConfig = GasCostConfig
   , _gasCostConfig_poseidonHashHackAChainQuadraticGasFactor = 38
   , _gasCostConfig_hyperlaneMessageIdGasPerRecipientOneHundredBytes = MilliGas 47
   , _gasCostConfig_hyperlaneDecodeTokenMessageGasPerOneHundredBytes = MilliGas 50
+  , _gasCostConfig_hyperlaneEncodeTokenMessageGasPerOneHundredBytes = MilliGas 50
   , _gasCostConfig_keccak256GasPerOneHundredBytes = MilliGas 146
   , _gasCostConfig_keccak256GasPerChunk = MilliGas 2_120
   }
@@ -247,6 +249,7 @@ defaultGasTable =
   ,("poseidon-hash-hack-a-chain", 124)
   ,("hyperlane-message-id", 2)
   ,("hyperlane-decode-token-message", 2)
+  ,("hyperlane-encode-token-message", 2)
   ,("hash-keccak256",1)
   ]
 
@@ -351,6 +354,9 @@ tableGasModel gasConfig =
         GHyperlaneDecodeTokenMessage len ->
           let MilliGas costPerOneHundredBytes = _gasCostConfig_hyperlaneDecodeTokenMessageGasPerOneHundredBytes gasConfig
           in MilliGas (costPerOneHundredBytes * div (fromIntegral len) 100)
+        GHyperlaneEncodeTokenMessage len ->
+          let MilliGas costPerOneHundredBytes = _gasCostConfig_hyperlaneEncodeTokenMessageGasPerOneHundredBytes gasConfig
+          in MilliGas (costPerOneHundredBytes * div (fromIntegral len) 100)
         GKeccak256 chunkBytes ->
           let MilliGas costPerOneHundredBytes = _gasCostConfig_keccak256GasPerOneHundredBytes gasConfig
               MilliGas costPerChunk = _gasCostConfig_keccak256GasPerChunk gasConfig

src/Pact/Interpreter.hs

@@ -282,7 +282,7 @@ pact411Natives :: [Text]
 pact411Natives = ["enforce-verifier", "hyperlane-message-id", "hyperlane-decode-token-message"]
 
 pact412Natives :: [Text]
-pact412Natives = ["hash-keccak256"]
+pact412Natives = ["hash-keccak256", "hyperlane-encode-token-message"]
 
 initRefStore :: RefStore
 initRefStore = RefStore nativeDefs

src/Pact/Native.hs

@@ -110,7 +110,7 @@ import Pact.Types.Version
 import Pact.Types.Namespace
 import Crypto.Hash.Keccak256Native (Keccak256Error(..), keccak256)
 import Crypto.Hash.PoseidonNative (poseidon)
-import Crypto.Hash.HyperlaneNatives (hyperlaneMessageId, hyperlaneDecodeTokenMessage)
+import Crypto.Hash.HyperlaneNatives (hyperlaneMessageId, hyperlaneDecodeTokenMessage, hyperlaneEncodeTokenMessage)
 
 import qualified Pact.JSON.Encode as J
 
@@ -1624,6 +1624,7 @@ hyperlaneDefs :: NativeModule
 hyperlaneDefs = ("Hyperlane",)
   [ hyperlaneMessageIdDef
   , hyperlaneDecodeTokenMessageDef
+  , hyperlaneEncodeTokenMessageDef
   ]
 
 hyperlaneMessageIdDef :: NativeDef
@@ -1672,3 +1673,31 @@ hyperlaneDecodeTokenMessageDef =
             Left err -> evalError' i err
             Right term -> pure term
       _ -> argsError i args
+
+hyperlaneEncodeTokenMessageDef :: NativeDef
+hyperlaneEncodeTokenMessageDef =
+  defGasRNative
+    "hyperlane-encode-token-message"
+    hyperlaneEncodeTokenMessageDef'
+    (funType tTyObjectAny [("x", tTyString)])
+    ["(hyperlane-encode-token-message {recipient:GUARD, amount:DECIMAL, chainId:STRING})"]
+    "Encode an object into a base-64-unpadded encoded Hyperlane Token Message `AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAGAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAewAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAGF7InByZWQiOiAia2V5cy1hbGwiLCAia2V5cyI6WyJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2Il19AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA`."
+  where
+    hyperlaneEncodeTokenMessageDef' :: RNativeFun e
+    hyperlaneEncodeTokenMessageDef' i args = case args of
+      [TObject o _] ->
+        computeGas' i (GHyperlaneEncodeTokenMessage (BS.length (getRecipient o))) $
+          case hyperlaneEncodeTokenMessage o of
+            Left err -> evalError' i err
+            Right msg -> pure $ toTerm $ msg
+      _ -> argsError i args
+
+    getRecipient :: Object n -> BS.ByteString
+    getRecipient o =
+      let mRecipient = do
+            let om = _objectMap (_oObject o)
+            om ^? at "recipient" . _Just . _TLiteral . _1 . _LString
+      in
+      case mRecipient of
+        Nothing -> error "couldn't find recipient"
+        Just t -> T.encodeUtf8 t

src/Pact/Types/Gas.hs

@@ -189,6 +189,9 @@ data GasArgs
   | GHyperlaneDecodeTokenMessage !Int
   -- ^ Cost of hyperlane-decode-token-message on this size (in bytes) of the
   --   hyperlane TokenMessage base64-encoded string.
+  | GHyperlaneEncodeTokenMessage !Int
+  -- ^ Cost of hyperlane-encode-token-message on this size (in bytes) of the
+  --   hyperlane TokenMessage base64-encoded string.
   | GKeccak256 !(V.Vector Int)
   -- ^ Cost of hash-keccak256 given the number of bytes in each chunk.
 
@@ -261,6 +264,7 @@ instance Pretty GasArgs where
     GPoseidonHashHackAChain len -> "GPoseidonHashHackAChain:" <> pretty len
     GHyperlaneMessageId len -> "GHyperlaneMessageId:" <> pretty len
     GHyperlaneDecodeTokenMessage len -> "GHyperlaneDecodeTokenMessage:" <> pretty len
+    GHyperlaneEncodeTokenMessage len -> "GHyperlaneEncodeTokenMessage:" <> pretty len
     GKeccak256 chunksBytes -> "GKeccak256:" <> pretty (V.toList chunksBytes)
 
 newtype GasLimit = GasLimit ParsedInteger

tests/GasModelSpec.hs

@@ -92,6 +92,7 @@ untestedNativesCheck = do
      , "list"
      , "continue"
      , "hyperlane-decode-token-message"
+     , "hyperlane-encode-token-message"
      ])
 
 allGasTestsAndGoldenShouldPass :: Spec

tests/pact/hyperlane.repl

@@ -35,3 +35,7 @@
 (env-gas 0)
 (hyperlane-decode-token-message "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAGAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAewAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABfwgIHsgInByZWQiOiAia2V5cy1hbnkiLCAia2V5cyI6IFsgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiLCAiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiIsICJkYTFhMzM5YmQ4MmQyYzJlOTE4MDYyNmEwMGRjMDQzMjc1ZGViM2FiYWJiMjdiNTczOGFiZjZiOWRjZWU4ZGI2IiwgImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiIF0gfQAAAAA")
 (expect "Decoding a message with about 2000 characters should cost 3 gas" 3 (env-gas))
+
+(env-gas 0)
+(hyperlane-encode-token-message {"amount": 599.0,"chainId": "1","recipient": "{\"pred\": \"keys-all\", \"keys\":[\"da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6\"]}"})
+(expect "Encoding a message with should cost 2 gas" 2 (env-gas))