Merge pull request #31 from frenetic-lang/qc

Update and expand quickcheck subpackage

_oasis

@@ -39,7 +39,8 @@ Library quickcheck
     packet,
     quickcheck
   Modules:
-    Packet_Arbitrary
+    Arbitrary_Base,
+    Arbitrary_Packet
 
 Executable testtool
   Path: test

quickcheck/Arbitrary_Base.ml

@@ -0,0 +1,65 @@
+open QuickCheck
+module Gen = QuickCheck_gen
+
+(* arbitrary instance for usigned integers, using `int` type. *)
+let arbitrary_uint = Gen.sized (fun n -> Gen.choose_int (0, n))
+
+(* arbitrary instance for unsigned int4, using the `int` type. *)
+let arbitrary_uint4 = Gen.choose_int (0, 0xf)
+
+(* arbitrary instance for unsigned int8, using the `int` type. *)
+let arbitrary_uint8 = Gen.choose_int (0, 0xff)
+
+(* arbitrary instance for unsigned int12, using the `int` type. *)
+let arbitrary_uint12 = Gen.choose_int (0, 0xfff)
+
+(* arbitrary instance for unsigned int16, using the `int` type. *)
+let arbitrary_uint16 = Gen.choose_int (0, 0xffff)
+
+(* arbitrary instance for unsigned int32, using the `int32` type. *)
+let arbitrary_uint32 =
+  let open Gen in
+  arbitrary_uint16 >>= fun a ->
+  arbitrary_uint16 >>= fun b ->
+    let open Int32 in
+    let hi = shift_left (of_int a) 16 in
+    let lo = of_int b in
+    ret_gen (logor hi lo)
+
+(* arbitrary first `b` bits set in an Int32 *)
+let arbitrary_uint32_bits b =
+  Gen.choose_int32 (Int32.zero, Int32.of_int ((0x1 lsl b) - 1) )
+
+(* arbitrary instance for unsigned int48, using the `int64` type. *)
+let arbitrary_uint48 =
+  let open Gen in
+  arbitrary_uint16 >>= fun a ->
+  arbitrary_uint16 >>= fun b ->
+  arbitrary_uint16 >>= fun c ->
+    let open Int64 in
+    let hi = shift_left (of_int a) 32 in
+    let mid = shift_left (of_int b) 16 in
+    let lo = of_int c in
+    ret_gen Int64.(logor (logor hi mid) lo)
+
+(* arbitrary instance for unsigned int48, using the `int64` type. *)
+let arbitrary_uint64 =
+  let open Gen in
+  arbitrary_uint16 >>= fun a ->
+  arbitrary_uint16 >>= fun b ->
+  arbitrary_uint16 >>= fun c ->
+  arbitrary_uint16 >>= fun d ->
+    let open Int64 in
+    let hi = shift_left (of_int a) 48 in
+    let mid1 = shift_left (of_int b) 32 in
+    let mid2 = shift_left (of_int c) 16 in
+    let lo = of_int d in
+    ret_gen Int64.(logor (logor hi (logor mid1 mid2)) lo)
+
+
+(* arbitrary instance for option type, favoring `Some` rather than `None` *)
+let arbitrary_option arb =
+  let open Gen in
+  frequency [
+      (1, ret_gen None);
+      (3, arb >>= fun e -> ret_gen (Some e)) ]

quickcheck/Arbitrary_Base.mli

@@ -0,0 +1,31 @@
+open QuickCheck
+
+(* arbitrary instance for usigned integers. Still uses the `int` type. *)
+val arbitrary_uint : int arbitrary
+
+(* arbitrary instance for unsigned int4, using the `int` type. *)
+val arbitrary_uint4 : int arbitrary 
+
+(* arbitrary instance for unsigned int8, using the `int` type. *)
+val arbitrary_uint8 : int arbitrary
+
+(* arbitrary instance for unsigned int12, using the `int` type. *)
+val arbitrary_uint12 : int arbitrary
+
+(* arbitrary instance for unsigned int16, using the `int` type. *)
+val arbitrary_uint16 : int arbitrary
+
+(* arbitrary instance for unsigned int32, using the `int32` type. *)
+val arbitrary_uint32 : int32 arbitrary
+
+(* arbitrary first [b] bits for unsigned int32 type. [b] must be less than 32. *)
+val arbitrary_uint32_bits : int -> int32 arbitrary
+
+(* arbitrary instance for unsigned int48, using the `int64` type. *)
+val arbitrary_uint48 : int64 arbitrary
+
+(* arbitrary instance for unsigned int64, using the `int64` type. *)
+val arbitrary_uint64 : int64 arbitrary
+
+(* arbitrary instance for option type, favoring `Some` rather than `None` *)
+val arbitrary_option : 'a arbitrary -> 'a option arbitrary

quickcheck/Packet_Arbitrary.ml → quickcheck/Arbitrary_Packet.ml

@@ -2,44 +2,10 @@ open Packet
 open QuickCheck
 module Gen = QuickCheck_gen
 
-(* arbitrary first `b` bits set in an Int32 *)
-let arbitrary_uint32_bits b =
-  Gen.choose_int32 (Int32.zero, Int32.of_int ((0x1 lsl b) - 1) )
+open Arbitrary_Base
 
-(* arbitrary instance for uint3, using the `int32` type. *)
-let arbitrary_uint4 = arbitrary_uint32_bits 4
-
-(* arbitrary instance for uint8, using the `int32` type. *)
-let arbitrary_uint8 = arbitrary_uint32_bits 8
-
-(* arbitrary instance for uint12, using the `int32` type. *)
-let arbitrary_uint12 = arbitrary_uint32_bits 12
-
-(* arbitrary instance for uint16, using the `int32` type. *)
-let arbitrary_uint16 = arbitrary_uint32_bits 16
-
-(* arbitrary instance for uint32, using the `int32` type. *)
-let arbitrary_uint32 =
-  let open Gen in
-  arbitrary_uint16 >>= fun w16_1 ->
-  arbitrary_uint16 >>= fun w16_2 ->
-    ret_gen Int32.(logor (shift_left w16_1 16) w16_2)
-
-let choose_int64 = Gen.lift_gen QuickCheck_util.Random.int64_range
-
-(* arbitrary instance for uint48, using the `int64` type. *)
-let arbitrary_int48 =
-  choose_int64 (Int64.zero, 0xffffffffffL)
-
-(* arbitrary instance for option type, favoring `Some` rather than `None` *)
-let arbitrary_option arb =
-  let open Gen in
-  frequency [
-      (1, ret_gen None);
-      (3, arb >>= fun e -> ret_gen (Some e)) ]
-
-let arbitrary_dlAddr = arbitrary_int48
-let arbitrary_nwAddr = arbitrary_int32
+let arbitrary_dlAddr = arbitrary_uint48
+let arbitrary_dlTyp = arbitrary_uint16
 
 let arbitrary_dlVlan =
   let open Gen in
@@ -49,9 +15,15 @@ let arbitrary_dlVlan =
     | Some w16 ->
       arbitrary_uint32_bits 3 >>= fun w4 ->
       arbitrary_bool >>=  fun b ->
-          ret_gen (Some (Int32.to_int w16), b, Int32.to_int w4)
+          ret_gen (Some w16, b, Int32.to_int w4)
   end
 
+
+let arbitrary_nwAddr = arbitrary_uint32
+let arbitrary_nwTos = arbitrary_uint8
+let arbitrary_nwProto = arbitrary_uint8
+let arbitrary_tpPort = Arbitrary_Base.arbitrary_uint16
+
 let arbitrary_dl_unparsable_len l =
   let li = Int32.to_int l in
   Gen.ret_gen (Unparsable(li, Cstruct.create li))
@@ -122,21 +94,19 @@ let arbitrary_ip arbitrary_tp =
   arbitrary_nwAddr >>= fun nwDst ->
   arbitrary_tp >>= fun tp ->
     ret_gen {
-        tos = Int32.to_int tos
-      ; ident = Int32.to_int ident
+        tos = tos
+      ; ident = ident
       ; flags = flags
       ; frag = Int32.to_int frag
-      ; ttl = Int32.to_int ttl
+      ; ttl = ttl
       (* Dummy checksum, as the library currently does not verify it *)
-      ; chksum = Int32.to_int chksum
+      ; chksum = chksum
       ; src = nwSrc
       ; dst = nwDst
       ; tp = tp
       ; options = empty_bytes
     }
 
-let arbitrary_tpPort = Gen.map_gen Int32.to_int arbitrary_uint16
-
 let arbitrary_tcp_flags =
   let open Gen in
   let open Tcp.Flags in
@@ -194,10 +164,10 @@ let arbitrary_tcp arbitrary_payload =
       ; dst = dst
       ; seq = seq
       ; ack = ack
-      ; offset = Int32.to_int offset
+      ; offset = offset
       ; flags = flags
-      ; window = Int32.to_int window
+      ; window = window
       ; chksum = 0
-      ; urgent = Int32.to_int urgent
+      ; urgent = urgent
       ; payload = payload
     }

quickcheck/Arbitrary_Packet.mli

@@ -0,0 +1,21 @@
+open QuickCheck
+
+val arbitrary_dlAddr : Packet.dlAddr arbitrary
+val arbitrary_dlTyp  : Packet.dlTyp arbitrary
+val arbitrary_dlVlan : (int option *  bool * int) arbitrary
+val arbitrary_nwAddr : Packet.nwAddr arbitrary
+val arbitrary_nwTos  : Packet.nwTos arbitrary
+val arbitrary_nwProto : Packet.nwProto arbitrary
+val arbitrary_tpPort : Packet.tpPort arbitrary
+
+val arbitrary_payload : int -> Packet.bytes arbitrary
+val arbitrary_arp : Packet.Arp.t arbitrary
+
+val arbitrary_udp : Packet.bytes arbitrary -> Packet.Udp.t arbitrary
+val arbitrary_tcp : Packet.bytes arbitrary -> Packet.Tcp.t arbitrary
+
+val arbitrary_ip_unparsable : Packet.Ip.tp arbitrary
+val arbitrary_ip : Packet.Ip.tp arbitrary -> Packet.Ip.t arbitrary
+
+val arbitrary_dl_unparsable  : Packet.nw arbitrary
+val arbitrary_packet : Packet.nw arbitrary -> Packet.packet arbitrary

quickcheck/quickcheck.mllib

@@ -1,4 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: efc75b648e29fe9a8789eaa30621aa1d)
-Packet_Arbitrary
+# DO NOT EDIT (digest: 330820d542742d1a91c67ac9e7db617c)
+Arbitrary_Base
+Arbitrary_Packet
 # OASIS_STOP

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.3.0 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 3daa6b2eb51a4ad4a3c363d15e290382) *)
+(* DO NOT EDIT (digest: b16821acf833b7560ee1257ce9b521a0) *)
 (*
    Regenerated by OASIS v0.4.1
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6752,14 +6752,7 @@ let setup_t =
           copyrights = [];
           maintainers = [];
           authors =
-            [
-               "Spiridon Eliopoulos";
-               "Andrew Ferguson";
-               "Nate Foster";
-               "Arjun Guha";
-               "Mark Reitblatt";
-               "and Cole Schlesinger"
-            ];
+            ["https://github.com/frenetic-lang/ocaml-packet/contributors"];
           homepage = None;
           synopsis =
             "Serialization for some common network packets, including\nethernet frames, IP, TCP, and ARP.";
@@ -6911,7 +6904,7 @@ let setup_t =
                       bs_nativeopt = [(OASISExpr.EBool true, [])]
                    },
                    {
-                      lib_modules = ["Packet_Arbitrary"];
+                      lib_modules = ["Arbitrary_Base"; "Arbitrary_Packet"];
                       lib_pack = false;
                       lib_internal_modules = [];
                       lib_findlib_parent = Some "packet";
@@ -6999,14 +6992,14 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.1";
-     oasis_digest = Some "\246\148\213{d\144\203\0220\1813c\017\138\142V";
+     oasis_digest = Some "p0\128\249\191\242\255\025\229\225]JG\128\199\224";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7011 "setup.ml"
+# 7004 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

test/Test.ml

@@ -12,7 +12,7 @@ let packet_quickCheck arbitrary pred =
       | Exhausted _ -> failwith "No exhaustion expected"
 
 module RoundTrip = struct
-  module Arb = Packet_Arbitrary
+  module Arb = Arbitrary_Packet
 
   let unparsable_eq (l1, b1) (l2, b2) =
     l1 = l2 && compare (Cstruct.to_string b1) (Cstruct.to_string b2) = 0