[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