Fix path-dependent module hoisting

kadena-io · Oct 15, 2024 · 7b42421 · 7b42421
1 parent 82d7f76
commit 7b42421
Show file tree

Hide file tree

Showing 2 changed files with 13 additions and 16 deletions.
diff --git a/pact/Pact/Core/Hash.hs b/pact/Pact/Core/Hash.hs
@@ -31,16 +31,14 @@ module Pact.Core.Hash
 , moduleHashToText
 , parseHash
 , parseModuleHash
-  -- unsafe creating of a 'ModuleHash', only used in the
-  -- legacy translation process.
-, unsafeBsToModuleHash
+, hashToByteString
 ) where
 
 import Control.DeepSeq
 import Data.Aeson
 import Data.ByteString.Short (ShortByteString, fromShort, toShort)
 import Data.ByteString (ByteString)
-import Data.Hashable (Hashable)
+import Data.Hashable (Hashable, unhashed)
 import Data.Serialize (Serialize)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
@@ -109,12 +107,8 @@ pactHashLength = 32
 unsafeBsToPactHash :: ByteString -> Hash
 unsafeBsToPactHash = Hash . toShort
 
-
--- | Creates a 'ModuleHash' value directly from a 'ByteString' without using the hashing functions.
--- This function is unsafe because it bypasses the hashing process and assumes the provided 'ByteString'
--- is a valid hash.
-unsafeBsToModuleHash :: ByteString -> ModuleHash
-unsafeBsToModuleHash = ModuleHash . unsafeBsToPactHash
+hashToByteString :: Hash -> ByteString
+hashToByteString = fromShort . unHash
 
 parseHash :: Text -> Maybe Hash
 parseHash t = case decodeBase64UrlUnpadded (T.encodeUtf8 t) of

diff --git a/pact/Pact/Core/Serialise/LegacyPact.hs b/pact/Pact/Core/Serialise/LegacyPact.hs
@@ -72,7 +72,7 @@ type CoreTerm = EvalTerm CoreBuiltin ()
 type CorePreNormalizedTerm = Term (Name, DeBruijn) Type CoreBuiltin ()
 type CoreDef = EvalDef CoreBuiltin ()
 
-type TranslateState = [CoreDef]
+type TranslateState = [(FullyQualifiedName, CoreDef)]
 
 
 type TranslateM = ReaderT DeBruijn (StateT TranslateState (Except String))
@@ -96,7 +96,9 @@ fromLegacyModuleData (Legacy.ModuleData md mref mdeps) = do
       let mh = fromLegacyModuleHash (Legacy._mHash m)
       deps <- fromLegacyDeps mh mdeps
       m' <- fromLegacyModule mh m mref
-      pure (ModuleData m' deps)
+      rest <- get
+      let deps' = M.union deps (M.fromList rest)
+      pure (ModuleData m' deps')
     Legacy.MDInterface i -> do
       let ifn = fromLegacyModuleName (Legacy._interfaceName i)
       let mh = ModuleHash $ pactHash $ T.encodeUtf8 (renderModuleName ifn)
@@ -688,13 +690,14 @@ fromLegacyTerm mh = \case
   Legacy.TDef d@(Legacy.Def n mn _dt (Legacy.FunType _args _) _body _) -> do
     let mn' = fromLegacyModuleName mn
         dn  = Legacy._unDefName n
-        h = CBOR.encodeModuleName mn' <> T.encodeUtf8 dn <> CBOR.encodeModuleHash mh
-        newHash = unsafeBsToModuleHash h
+        h = CBOR.encodeModuleName mn' <> T.encodeUtf8 dn <> hashToByteString (_mhHash mh)
+        newHash = ModuleHash (pactHash h)
         nk = NTopLevel mn' newHash
         name = Name dn nk
+        newFqn = FullyQualifiedName mn' dn newHash
 
-    def <- fromLegacyDef mh d
-    modify' (def:)
+    def <- fromLegacyDef newHash d
+    modify' ((newFqn, def):)
     depth <- ask
     pure (Var (name, depth) ())