stable encoding

pact-core.cabal

@@ -51,6 +51,7 @@ common pact-core-common
     , exceptions
     , array
     , pact-json
+    , scientific
 
   ghc-options: -Wall -Werror -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
   ghc-prof-options: -fprof-auto -fprof-auto-calls
@@ -108,6 +109,7 @@ library
     Pact.Core.Interpreter
     Pact.Core.ChainData
     Pact.Core.Environment
+    Pact.Core.StableEncoding
 
      -- Syntax modules
     Pact.Core.Syntax.ParseTree

pact-core/Pact/Core/IR/Eval/CEK.hs

@@ -40,6 +40,7 @@ import Data.List.NonEmpty(NonEmpty(..))
 import Data.Foldable(find, foldl')
 import qualified Data.RAList as RAList
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Data.Vector as V
 import qualified Data.Set as S
 import qualified Data.Map.Strict as M
@@ -58,6 +59,7 @@ import Pact.Core.ModRefs
 import Pact.Core.Environment
 import Pact.Core.Persistence
 import Pact.Core.Hash
+import Pact.Core.StableEncoding
 
 import Pact.Core.IR.Term hiding (PactStep)
 import Pact.Core.IR.Eval.Runtime
@@ -255,9 +257,12 @@ initPact i pc cont handler cenv = do
       applyPact i pc pStep cont handler cenv' mempty
     Just ps ->
       let
-        npId = mkNestedPactId pc (_psPactId ps)
+        PactId p = _psPactId ps
+        npId = hashToPactId (pactHash (T.encodeUtf8 p <> ":" <> encodeStable pc))
         pStep = PactStep (_psStep ps) (_psRollback ps) npId Nothing
       in applyNestedPact i pc pStep cont handler cenv
+  where
+    hashToPactId = PactId . hashToText
 
 applyPact
   :: MonadEval b i m

pact-core/Pact/Core/Pacts/Types.hs

@@ -12,18 +12,13 @@ module Pact.Core.Pacts.Types
  , peStepCount, peYield, peStep, peContinuation, peStepHasRollback, pePactId
  , peNestedPactExec
  , Yield(..)
- , hashToPactId
- , mkNestedPactId
  , Provenance(..)
  ) where
 
 -- Todo: yield
 import Data.Text(Text)
 import Control.Lens
 import Data.Map.Strict (Map)
-import qualified Data.Text.Encoding as T
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as BS8
 
 import Pact.Core.PactValue
 import Pact.Core.Names
@@ -35,9 +30,6 @@ newtype PactId
   = PactId Text
   deriving (Eq,Ord,Show,Pretty)
 
-hashToPactId :: Hash -> PactId
-hashToPactId = PactId . hashToText
-
 data PactContinuation name v
   = PactContinuation
   { _pcName :: name
@@ -56,14 +48,6 @@ data Provenance = Provenance
     -- ^ a hash of current containing module
   } deriving (Eq, Show)
 
-encodePactContinuation :: PactContinuation FullyQualifiedName PactValue -> ByteString
-encodePactContinuation = BS8.pack . show
-
-mkNestedPactId :: PactContinuation FullyQualifiedName PactValue -> PactId -> PactId
-mkNestedPactId pc (PactId parent) =
-  hashToPactId (pactHash (T.encodeUtf8 parent <> ":" <> encodePactContinuation pc)) -- TODO add pc
-
-
 
 -- | `Yield` representing an object
 data Yield
@@ -95,4 +79,3 @@ data PactStep = PactStep
   } deriving Show
 
 makeLenses ''PactStep
-

pact-core/Pact/Core/StableEncoding.hs

@@ -0,0 +1,189 @@
+{-# LANGUAGE TypeApplications #-}
+
+-- |
+--
+-- Stable encoding which matches Pacts StableEncoding.
+--
+
+module Pact.Core.StableEncoding
+  (encodeStable)
+where
+
+import Pact.Core.PactValue
+import Pact.Core.Literal
+import Pact.Core.Guards
+import Pact.Core.Names
+import Pact.Core.ModRefs
+import Pact.Core.Hash
+import Pact.Core.Pacts.Types
+import Pact.Time
+
+import Data.Decimal (DecimalRaw(..))
+
+import qualified Data.Text as T
+import Data.Scientific (Scientific)
+import qualified Pact.JSON.Encode as J
+import qualified Data.Set as Set
+import Data.Map.Strict (Map)
+import Pact.JSON.Legacy.Utils
+import Data.Ratio ((%), denominator)
+import Data.ByteString (ByteString)
+
+encodeStable :: J.Encode (StableEncoding a) => a -> ByteString
+encodeStable = J.encodeStrict . StableEncoding
+
+newtype StableEncoding a = StableEncoding a
+  deriving (Ord, Eq)
+
+
+-- | Stable encoding of `Literal`
+--
+-- `isSafeInteger` checks for the Javascript maximum/minimum numbers.
+-- Details can be found here: https://github.com/kadena-io/pact/blob/e72d86749f5d65ac8d6e07a7652dd2ffb468607b/src/Pact/Types/Codec.hs#L44
+instance J.Encode (StableEncoding Literal) where
+  build (StableEncoding lit) = case lit of
+    LString t -> J.build t
+    LInteger i -> encodeInteger i
+    LDecimal d -> encodeDecimal d
+    LUnit -> encodeUnit
+    LBool b -> J.build b
+    where
+      encodeInteger i
+        | isSafeInteger i = J.object [ "int" J..= J.Aeson i ]
+        | otherwise = J.object [ "int" J..= T.pack (show i) ]
+      encodeDecimal d@(Decimal _ mantissa)
+        | isSafeInteger mantissa = J.build $ J.Aeson @Scientific $ fromRational $ toRational d
+        | otherwise = J.object [ "decimal" J..= T.pack (show d) ]
+      encodeUnit = J.object ["unit" J..= T.empty] -- TODO: Discuss?
+      isSafeInteger i = i >= -9007199254740991 && i <= 9007199254740991
+  {-# INLINABLE build #-}
+
+
+-- | Stable encoding of `Guard FullyQualifiedName PactValue`
+instance J.Encode (StableEncoding (Guard FullyQualifiedName PactValue)) where
+  build (StableEncoding g) = case g of
+    GKeyset ks -> J.build (StableEncoding ks)
+    GKeySetRef ksn -> J.object ["keysetref" J..= StableEncoding ksn]
+    GUserGuard ug -> J.build (StableEncoding ug)
+    GCapabilityGuard cg -> J.build (StableEncoding cg)
+    GModuleGuard mg -> J.build (StableEncoding mg)
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `CapabilityGuard FullyQualifiedName PactValue`
+instance J.Encode (StableEncoding (CapabilityGuard FullyQualifiedName PactValue)) where
+  build (StableEncoding (CapabilityGuard name args)) = J.object
+    [ "cgPactId" J..=  (error "a" :: T.Text) -- TODO: Check availability
+    , "cgArgs" J..= J.Array (StableEncoding <$> args)
+    , "cgName" J..= StableEncoding name
+    ]
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `FullyQualifiedName`
+instance J.Encode (StableEncoding FullyQualifiedName) where
+  build (StableEncoding (FullyQualifiedName (ModuleName mn mns) n (ModuleHash mh))) = J.build t
+    where
+      t = maybe "" ((<> ".") . _namespaceName) mns <> mn <> "." <> n <> ".{" <> hashToText mh <> "}"
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `ModuleGuard`
+instance J.Encode (StableEncoding ModuleGuard) where
+  build (StableEncoding (ModuleGuard m name)) = J.object
+    [ "moduleName" J..= _mnName m
+    , "name" J..= name
+    ]
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `UserGuard FullyQualifiedName PactValue`
+instance J.Encode (StableEncoding (UserGuard FullyQualifiedName PactValue)) where
+  build (StableEncoding (UserGuard fun args)) = J.object
+    [ "args" J..= J.array (StableEncoding <$> args)
+    , "fun" J..= StableEncoding fun
+    ]
+  {-# INLINABLE build #-}
+
+-- TODO: KeySetName is namespaced (maybe)
+-- | Stable encoding of `KeySetName`
+instance J.Encode (StableEncoding KeySetName) where
+  build (StableEncoding (KeySetName ksn)) = J.build ksn
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `KeySet FullyQualifiedName`
+instance J.Encode (StableEncoding (KeySet FullyQualifiedName)) where
+  build (StableEncoding (KeySet keys predFun)) =J.object
+    [ "pred" J..= StableEncoding predFun
+    , "keys" J..= J.Array (Set.map StableEncoding keys) -- TODO: is this valid?
+    ]
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `Map Field PactValue`
+instance J.Encode (StableEncoding (Map Field PactValue)) where
+  build (StableEncoding o) = J.build (legacyMap _field (StableEncoding <$> o))
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `KSPredicate FullyQualifiedName`
+instance J.Encode (StableEncoding (KSPredicate FullyQualifiedName)) where
+  build (StableEncoding ksp) = case ksp of
+    KeysAll -> J.build ("keys-all" :: T.Text)
+    Keys2 -> J.build ("keys-2" :: T.Text)
+    KeysAny -> J.build ("keys-any" :: T.Text)
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `PublicKeyText`
+instance J.Encode (StableEncoding PublicKeyText) where
+  build (StableEncoding (PublicKeyText pkt)) = J.build pkt
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `NamespaceName`
+instance J.Encode (StableEncoding NamespaceName) where
+  build (StableEncoding (NamespaceName ns)) = J.build ns
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `ModuleName`
+instance J.Encode (StableEncoding ModuleName) where
+  build (StableEncoding (ModuleName mn ns)) = J.object
+    [ "namespace" J..= (StableEncoding <$> ns)
+    , "name" J..= mn
+    ]
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `ModRef`
+instance J.Encode (StableEncoding ModRef) where
+  build (StableEncoding (ModRef mn imp _ref)) = J.object
+    [ "refSpec" J..= J.Array (StableEncoding <$> imp)
+--    , "refInfo" J..= _modRefInfo o
+    , "refName" J..= StableEncoding mn
+    ]
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `UTCTime`
+--
+-- See https://github.com/kadena-io/pact/blob/e72d86749f5d65ac8d6e07a7652dd2ffb468607b/src/Pact/Types/Codec.hs#L150
+-- for further details
+instance J.Encode (StableEncoding UTCTime) where
+  build (StableEncoding utc)
+    | denom utc == 1 = J.object [ "time" J..= T.pack (formatTime "%Y-%m-%dT%H:%M:%SZ" utc) ]
+    | otherwise = J.object [ "timep" J..= T.pack (formatTime "%Y-%m-%dT%H:%M:%S.%vZ" utc) ]
+    where
+      denom :: UTCTime -> Integer
+      denom = denominator . (% 1000) . fromIntegral . toPosixTimestampMicros
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `PactValue`
+instance J.Encode (StableEncoding PactValue) where
+  build (StableEncoding pv) = case pv of
+    PLiteral lit  -> J.build (StableEncoding lit)
+    PList l -> J.build (J.Array (StableEncoding <$> l))
+    PGuard g -> J.build (StableEncoding g)
+    PObject o -> J.build (StableEncoding o)
+    PModRef mr -> J.build (StableEncoding mr)
+    PCapToken _ct -> error "not implemented"
+    PTime pt -> J.build (StableEncoding pt)
+  {-# INLINABLE build #-}
+
+-- | Stable encoding of `PactContinuation FullyQualifiedName PactValue`
+instance J.Encode (StableEncoding (PactContinuation FullyQualifiedName PactValue)) where
+  build (StableEncoding (PactContinuation name args))= J.object
+    [ "args" J..= J.Array (StableEncoding <$> args)
+    , "def" J..= J.build (StableEncoding name)
+    ]
+  {-# INLINABLE build #-}