Refactor CBORTerm representation and introduce mkCBORTerm helper function (#176)

Author: joaosreis

mempack-scls/mempack-1.0/Data/MemPack/Extra.hs

@@ -17,7 +17,8 @@ module Data.MemPack.Extra (
   Entry (..),
   ByteStringSized (..),
   SomeByteStringSized (..),
-  CBORTerm (..),
+  CBORTerm (getRawTerm),
+  mkCBORTerm,
   RawBytes (..),
   Unpack',
   hPutBuffer,
@@ -212,15 +213,18 @@ instance (KnownNat n) => MemPack (ByteStringSized n) where
     pure (ByteStringSized bs)
 
 -- | Helper to store CBOR terms directly as entries.
-newtype CBORTerm = CBORTerm CBOR.Term
+data CBORTerm = CBORTerm {getRawTerm :: !CBOR.Term, getEncodedBytes :: ByteString}
   deriving (Eq, Ord, Show)
 
+mkCBORTerm :: CBOR.Term -> CBORTerm
+mkCBORTerm t = CBORTerm t (CBOR.toStrictByteString (CBOR.encodeTerm t))
+
 instance MemPack CBORTerm where
-  packedByteCount (CBORTerm t) =
-    BS.length (CBOR.toStrictByteString (CBOR.encodeTerm t))
+  packedByteCount (CBORTerm _ bs) =
+    BS.length bs
 
-  packM (CBORTerm t) =
-    packByteStringM (CBOR.toStrictByteString (CBOR.encodeTerm t))
+  packM (CBORTerm _ bs) =
+    packByteStringM bs
 
   unpackM = do
     start <- gets fromIntegral
@@ -229,7 +233,7 @@ instance MemPack CBORTerm where
       Left err -> failUnpack $ TextError $ "CBOR term deserialisation failed: " <> T.pack (show err)
       Right (_rest, bytesRead, term) -> do
         put (start + fromIntegral bytesRead)
-        pure (CBORTerm term)
+        pure (CBORTerm term bytes)
 
 hPutBuffer :: (Buffer u) => Handle -> u -> IO ()
 hPutBuffer handle u =

mempack-scls/mempack-2.0/Data/MemPack/Extra.hs

@@ -17,7 +17,8 @@ module Data.MemPack.Extra (
   Entry (..),
   ByteStringSized (..),
   SomeByteStringSized (..),
-  CBORTerm (..),
+  CBORTerm (getRawTerm),
+  mkCBORTerm,
   RawBytes (..),
   Unpack',
   hPutBuffer,
@@ -217,15 +218,18 @@ instance (KnownNat n) => MemPack (ByteStringSized n) where
     pure (ByteStringSized bs)
 
 -- | Helper to store CBOR terms directly as entries.
-newtype CBORTerm = CBORTerm CBOR.Term
+data CBORTerm = CBORTerm {getRawTerm :: !CBOR.Term, getEncodedBytes :: ByteString}
   deriving (Eq, Ord, Show)
 
+mkCBORTerm :: CBOR.Term -> CBORTerm
+mkCBORTerm t = CBORTerm t (CBOR.toStrictByteString (CBOR.encodeTerm t))
+
 instance MemPack CBORTerm where
-  packedByteCount (CBORTerm t) =
-    BS.length (CBOR.toStrictByteString (CBOR.encodeTerm t))
+  packedByteCount (CBORTerm _ bs) =
+    BS.length bs
 
-  packM (CBORTerm t) =
-    packByteStringM (CBOR.toStrictByteString (CBOR.encodeTerm t))
+  packM (CBORTerm _ bs) =
+    packByteStringM bs
 
   unpackM = do
     start <- gets fromIntegral
@@ -234,7 +238,7 @@ instance MemPack CBORTerm where
       Left err -> failUnpack $ TextError $ "CBOR term deserialisation failed: " <> T.pack (show err)
       Right (_rest, bytesRead, term) -> do
         put (start + fromIntegral bytesRead)
-        pure (CBORTerm term)
+        pure (CBORTerm term bytes)
 
 hPutBuffer :: (Buffer u) => Handle -> u -> IO ()
 hPutBuffer handle u =

scls-format/test/Roundtrip.hs

@@ -111,7 +111,7 @@ mkRoundtripTestsFor groupName serialize =
                 key <- uniformByteStringM (fromIntegral kSize) globalStdGen
                 term <- applyAtomicGen (generateCBORTerm' mt (Name (T.pack "record_entry") mempty)) globalStdGen
                 Right (_, canonicalTerm) <- pure $ deserialiseFromBytes decodeTerm $ toLazyByteString (encodeTerm term)
-                pure $! SomeCBOREntry (GenericCBOREntry $ ChunkEntry (ByteStringSized @n key) (CBORTerm canonicalTerm))
+                pure $! SomeCBOREntry (GenericCBOREntry $ ChunkEntry (ByteStringSized @n key) (mkCBORTerm canonicalTerm))
         mEntries <-
           replicateM 1024 $ do
             MetadataEntry

scls-util/src/Cardano/SCLS/Util/Check.hs

@@ -231,29 +231,29 @@ validateChunk cddlTrees Chunk{..} = do
       }
 
 validateAgainst :: forall n. CTreeRoot' Identity MonoRef -> (Int, GenericCBOREntry n) -> Maybe CheckError
-validateAgainst t v@(i, GenericCBOREntry (ChunkEntry _ (CBORTerm term))) =
+validateAgainst t v@(i, GenericCBOREntry (ChunkEntry _ cTerm)) =
   case validateCDDLAgainst t v of
     Just e -> Just e
     Nothing -> case checkCanonical of
       Nothing -> Nothing
-      Just expected -> Just (CBORIsNotCanonicalError i expected term)
+      Just expected -> Just (CBORIsNotCanonicalError i expected (getRawTerm cTerm))
  where
   checkCanonical =
-    let encodedData = toLazyByteString (getRawEncoding $ toCanonicalCBOR Proxy term)
+    let encodedData = toLazyByteString (getRawEncoding $ toCanonicalCBOR Proxy $ getRawTerm cTerm)
      in case deserialiseFromBytes (decodeTerm) encodedData of
           Right (_, decodedAsTerm) ->
-            if term == decodedAsTerm
+            if getRawTerm cTerm == decodedAsTerm
               then Nothing
               else Just decodedAsTerm
           _ -> Nothing
 
 validateCDDLAgainst :: CTreeRoot' Identity MonoRef -> (Int, GenericCBOREntry n) -> Maybe CheckError
-validateCDDLAgainst cddl@(CTreeRoot cddlTree) (seqNum, GenericCBOREntry (ChunkEntry _key (CBORTerm term))) =
+validateCDDLAgainst cddl@(CTreeRoot cddlTree) (seqNum, GenericCBOREntry (ChunkEntry _key cTerm)) =
   let name = Name (T.pack "record_entry") mempty
    in case Map.lookup name cddlTree of
         Nothing -> Nothing
         Just rule ->
-          case runReader (validateTerm term (runIdentity rule)) cddl of
+          case runReader (validateTerm (getRawTerm cTerm) (runIdentity rule)) cddl of
             CBORTermResult _term Valid{} -> Nothing
             CBORTermResult bad_term problem -> Just (CDDLValidationError seqNum problem bad_term)
 

scls-util/src/Cardano/SCLS/Util/Debug.hs

@@ -76,7 +76,7 @@ generateNamespaceEntries count spec = replicateM_ count do
   let size = fromSNat @n SNat
   keyIn <- liftIO $ uniformByteStringM (fromIntegral size) globalStdGen
   term <- liftIO $ applyAtomicGen (generateCBORTerm' spec (Name (T.pack "record_entry") mempty)) globalStdGen
-  S.yield $ GenericCBOREntry $ ChunkEntry (ByteStringSized @n keyIn) (CBORTerm term)
+  S.yield $ GenericCBOREntry $ ChunkEntry (ByteStringSized @n keyIn) (mkCBORTerm term)
 
 printHexEntries :: FilePath -> T.Text -> Int -> IO Result
 printHexEntries filePath ns_name@(Namespace.fromText -> ns) entryNo = do