[MLton-commit] r5933

Vesa Karvonen vesak at mlton.org
Thu Aug 23 02:29:56 PDT 2007


Enhanced pickling with a simple TypeHash based type-mismatch detection.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U   mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U   mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
U   mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml	2007-08-23 08:22:22 UTC (rev 5932)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml	2007-08-23 09:29:55 UTC (rev 5933)
@@ -23,7 +23,7 @@
    structure Open = WithEq          (Open) open Open structure Eq=Open
    structure Open = WithOrd         (Open) open Open
    structure Open = WithPretty      (Open) open Open
-   structure Open = WithTypeHash    (Open) open Open
+   structure Open = WithTypeHash    (Open) open Open structure TypeHash=Open
    structure Open = WithTypeInfo    (Open) open Open structure TypeInfo=Open
    structure Open = WithDataRecInfo (Open) open Open structure DataRecInfo=Open
 
@@ -36,8 +36,8 @@
    structure Open = WithArbitrary   (Open) open Open
 
    structure Open = struct
-      open TypeInfo Open
-      structure TypeInfo = Rep
+      open TypeHash TypeInfo Open
+      structure TypeHash = Rep and TypeInfo = Rep
    end
    structure Open = WithHash        (Open) open Open structure Hash=Open
 
@@ -48,8 +48,9 @@
    structure Open = WithSome        (Open) open Open structure Some=Open
 
    structure Open = struct
-      open Eq Hash TypeInfo DataRecInfo Some
-      structure Eq=Rep and Hash=Rep and TypeInfo=Rep and DataRecInfo=Rep
+      open DataRecInfo Eq Hash TypeHash TypeInfo Some
+      structure DataRecInfo = Rep and Eq = Rep and Hash = Rep and TypeHash = Rep
+            and TypeInfo = Rep
    end
    structure Open = WithPickle      (Open) open Open
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-08-23 08:22:22 UTC (rev 5932)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-08-23 09:29:55 UTC (rev 5933)
@@ -266,6 +266,8 @@
            (swap Word.isoInt)
    end
 
+   val word32 = bits false Word32.ops Iso.id
+
    (* Encodes fixed size int as a size followed by little endian bytes. *)
    fun mkFixedInt (fromLargeWordX, toLargeWord) =
        {rd = let
@@ -469,11 +471,30 @@
 
    open Pickle.This
 
-   fun pickler t =
-       O.run (HashMap.new {eq = Dyn.eq, hash = Dyn.hash}) (#wr (getT t))
-   fun unpickler t =
-       I.run (HashMap.new {eq = op =, hash = Word.fromInt}) (#rd (getT t))
+   structure Pickling = struct
+      exception TypeMismatch
+   end
 
+   fun pickler t = let
+      val key = Arg.typeHash t
+      val wr = #wr (getT t)
+      open O
+   in
+      run (HashMap.new {eq = Dyn.eq, hash = Dyn.hash})
+          (fn v => #wr word32 key >> wr v)
+   end
+   fun unpickler t = let
+      val key = Arg.typeHash t
+      val rd = #rd (getT t)
+      open I
+   in
+      run (HashMap.new {eq = op =, hash = Word.fromInt})
+          (#rd word32 >>= (fn key' =>
+           if key' <> key
+           then raise Pickling.TypeMismatch
+           else rd))
+   end
+
    fun pickle t = let
       val pA = pickler t (IOSMonad.fromPutter (uncurry Buffer.push))
    in
@@ -655,7 +676,7 @@
       val largeWord = mkFixedInt Iso.id
 
       val word8  = word8
-      val word32 = bits false Word32.ops Iso.id
+      val word32 = word32
       val word64 = bits false Word64.ops Iso.id)
 
    open Layered

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-08-23 08:22:22 UTC (rev 5932)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-08-23 09:29:55 UTC (rev 5933)
@@ -67,6 +67,9 @@
          public/value/data-rec-info.sig
          detail/value/data-rec-info.sml
 
+         public/value/type-hash.sig
+         detail/value/type-hash.sml
+
          public/value/some.sig
          detail/value/some.sml
 
@@ -109,9 +112,6 @@
 
          public/value/transform.sig
          detail/value/transform.sml
-
-         public/value/type-hash.sig
-         detail/value/type-hash.sml
       in
          public/export.sml
       end

Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig	2007-08-23 08:22:22 UTC (rev 5932)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig	2007-08-23 09:29:55 UTC (rev 5933)
@@ -7,9 +7,10 @@
 (**
  * Signature for a generic pickle/unpickle function.
  *
- * WARNING: The pickle format is neither versioned nor typed.  Pickling
- * with one type and unpickling with another either fails with an
- * exception or produces some value, which is usually not wanted.
+ * WARNING: The pickle format contains the {typeHash} of the pickled type.
+ * While this can help to detect accidental type mismatches (pickling with
+ * one type and then unpickling with another) it is not fool proof nor
+ * designed to be secure in any way.
  *
  * The pickle format is designed to be platform independent.  For example,
  * it is possible to pickle on a 32-bit big-endian platform and unpickle
@@ -30,6 +31,11 @@
 signature PICKLE = sig
    structure Pickle : OPEN_REP
 
+   structure Pickling : sig
+      exception TypeMismatch
+      (** Raised by unpickling functions when a type-mismatch is detected. *)
+   end
+
    (** == Stream Interface ==
     *
     * The {pickler} and {unpickler} functions support pickling directly to
@@ -58,6 +64,6 @@
 end
 
 signature WITH_PICKLE_DOM = sig
-   include OPEN_CASES DATA_REC_INFO EQ HASH SOME TYPE_INFO
-   sharing Rep = DataRecInfo = Eq = Hash = Some = TypeInfo
+   include OPEN_CASES DATA_REC_INFO EQ HASH SOME TYPE_HASH TYPE_INFO
+   sharing Rep = DataRecInfo = Eq = Hash = Some = TypeHash = TypeInfo
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml	2007-08-23 08:22:22 UTC (rev 5932)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml	2007-08-23 09:29:55 UTC (rev 5933)
@@ -21,6 +21,15 @@
                 in
                    verifyTrue (seq t (x, unpickle t p))
                 end)
+
+   fun testTypeMismatch t u =
+       test (fn () => let
+                   val p = pickle t (some t)
+                in
+                   verifyFailsWith
+                      (fn Pickling.TypeMismatch => true | _ => false)
+                      (fn () => unpickle u p)
+                end)
 in
    unitTests
       (title "Generic.Pickle")
@@ -36,5 +45,11 @@
       (testSeq (Graph.t int) Graph.intGraph1)
       (testSeq (array exn) ExnArray.exnArray1)
 
+      (title "Generic.Pickle.TypeMismatch")
+
+      (testTypeMismatch int word)
+      (testTypeMismatch (list char) (vector char))
+      (testTypeMismatch (array real) (option real))
+
       $
 end




More information about the MLton-commit mailing list