diff options
| -rw-r--r-- | subsystem/dune | 6 | ||||
| -rw-r--r-- | subsystem/karuta/Translator.ml | 116 | ||||
| -rw-r--r-- | test/dune | 2 | ||||
| -rw-r--r-- | test/test_rnt.ml | 1 | ||||
| -rw-r--r-- | test/unit/karuta/Translator.ml | 60 |
5 files changed, 184 insertions, 1 deletions
diff --git a/subsystem/dune b/subsystem/dune new file mode 100644 index 0000000..9ff6f50 --- /dev/null +++ b/subsystem/dune @@ -0,0 +1,6 @@ +(include_subdirs qualified) + +(library + (name subsystem) + (public_name rnt.subsystem) + (libraries rnt batteries)) diff --git a/subsystem/karuta/Translator.ml b/subsystem/karuta/Translator.ml new file mode 100644 index 0000000..1fbbd9d --- /dev/null +++ b/subsystem/karuta/Translator.ml @@ -0,0 +1,116 @@ +(* A tuple of an ephemeral relation as an Erlang term in the external + term format, for binary_to_term on the BEAM: {Type, #{Name => + Value}}, with the type, names and strings as binaries. And back, + from what term_to_binary writes for such a term. *) + +open Rnt + +module Error = struct + open Concepts.Condition + let malformed () = + Concepts.Condition.condition "malformed-beam-tuple" + "A term is not {Type, #{Name => Value}} of binaries, and integers that fit an int" + Concepts.Condition.empty +end + +let binary buffer s = + Buffer.add_uint8 buffer 109; + Buffer.add_int32_be buffer (Int32.of_int (String.length s)); + Buffer.add_string buffer s + +(* Every integer as a small big: a sign, then the bytes of the magnitude, + least significant first. binary_to_term gives back an ordinary + integer when it fits one, and lsr reads abs min_int as 2^62. *) +let integer buffer n = + let rec digits m = if m = 0 then [] else (m land 0xff) :: digits (m lsr 8) in + let digits = digits (abs n) in + Buffer.add_uint8 buffer 110; + Buffer.add_uint8 buffer (List.length digits); + Buffer.add_uint8 buffer (if n < 0 then 1 else 0); + List.iter (Buffer.add_uint8 buffer) digits + +let encode {Concepts.Tuple.type_; attributes} = + let buffer = Buffer.create 64 in + Buffer.add_uint8 buffer 131; + Buffer.add_uint8 buffer 104; + Buffer.add_uint8 buffer 2; + binary buffer type_; + Buffer.add_uint8 buffer 116; + Buffer.add_int32_be buffer (Int32.of_int (BatMap.String.cardinal attributes)); + BatMap.String.iter + (fun name value -> + binary buffer name; + match value with + | Concepts.Value.String s -> binary buffer s + | Concepts.Value.Integer n -> integer buffer n ) + attributes; + Buffer.contents buffer + +(* Decoding raises within and answers a result at the end. *) +exception Malformed + +let decode bytes = + let position = ref 0 in + let take n = + if !position + n > String.length bytes then raise Malformed; + let at = !position in + position := at + n; + at + in + let u8 () = String.get_uint8 bytes (take 1) in + let i32 () = Int32.to_int (String.get_int32_be bytes (take 4)) in + let u32 () = i32 () land 0xffff_ffff in + let expect byte = if u8 () <> byte then raise Malformed in + let binary () = + let n = u32 () in + String.sub bytes (take n) n + in + (* a sign, then at most 8 bytes of the magnitude, least significant + first; an int holds magnitudes up to 2^62 - 1, or 2^62 when + negative *) + let big n = + let negative = u8 () = 1 in + if n > 8 then raise Malformed; + let at = take n in + let rec magnitude i m = + if i < 0 then m + else + magnitude (i - 1) + (Int64.logor (Int64.shift_left m 8) (Int64.of_int (String.get_uint8 bytes (at + i)))) + in + let m = magnitude (n - 1) 0L in + let limit = if negative then Int64.neg (Int64.of_int min_int) else Int64.of_int max_int in + if Int64.compare m 0L < 0 || Int64.compare m limit > 0 then raise Malformed; + Int64.to_int (if negative then Int64.neg m else m) + in + (* term_to_binary writes an integer in the least of these that holds it *) + let value () = + match u8 () with + | 109 -> Concepts.Value.String (binary ()) + | 97 -> Concepts.Value.Integer (u8 ()) + | 98 -> Concepts.Value.Integer (i32 ()) + | 110 -> Concepts.Value.Integer (big (u8 ())) + | _ -> raise Malformed + in + let rec attributes n map = + if n = 0 then map + else begin + expect 109; + let name = binary () in + let value = value () in + attributes (n - 1) (BatMap.String.add name value map) + end + in + match + expect 131; + expect 104; + expect 2; + expect 109; + let type_ = binary () in + expect 116; + let attributes = attributes (u32 ()) BatMap.String.empty in + if !position <> String.length bytes then raise Malformed; + {Concepts.Tuple.type_; attributes} + with + | tuple -> Ok tuple + | exception Malformed -> Error (Error.malformed ()) @@ -2,4 +2,4 @@ (test (name test_rnt) - (libraries rnt alcotest qcheck-core qcheck-alcotest batteries)) + (libraries rnt subsystem alcotest qcheck-core qcheck-alcotest batteries)) diff --git a/test/test_rnt.ml b/test/test_rnt.ml index c6fcfd5..299c6ca 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -7,6 +7,7 @@ let all_suites = @ Unit.Kernel.Session.suites () @ Unit.Kernel.Branch.suites () @ Unit.Evaluators.FOL.suites () + @ Unit.Karuta.Translator.suites () @ Integration.Registration.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/karuta/Translator.ml b/test/unit/karuta/Translator.ml new file mode 100644 index 0000000..92bd57f --- /dev/null +++ b/test/unit/karuta/Translator.ml @@ -0,0 +1,60 @@ +open Rnt +module Translator = Subsystem.Karuta.Translator +module Gen = QCheck2.Gen + +let value = + Gen.oneof + [ Gen.map (fun s -> Concepts.Value.String s) Gen.string_small; + Gen.map + (fun n -> Concepts.Value.Integer n) + (Gen.oneof [Gen.int; Gen.oneofl [min_int; max_int]]) ] + +let tuple = + Gen.map2 + (fun type_ attributes -> {Concepts.Tuple.type_; attributes= BatMap.String.of_list attributes}) + Gen.string_small + (Gen.small_list (Gen.pair Gen.string_small value)) + +let print tuple = tuple.Concepts.Tuple.type_ ^ " " ^ Concepts.Tuple.to_string tuple + +let same (a : Concepts.Tuple.t) (b : Concepts.Tuple.t) = + a.type_ = b.type_ && BatMap.String.equal Concepts.Value.equal a.attributes b.attributes + +let decodes_to_itself = + QCheck2.Test.make ~name:"a tuple decodes to itself" ~print tuple (fun tuple -> + match Translator.decode (Translator.encode tuple) with + | Ok decoded -> same tuple decoded + | Error _ -> false ) + +let a_cut_term_is_refused = + QCheck2.Test.make ~name:"a cut term is refused" ~print tuple (fun tuple -> + let bytes = Translator.encode tuple in + List.init (String.length bytes) (fun n -> Translator.decode (String.sub bytes 0 n)) + |> List.for_all Result.is_error ) + +(* term_to_binary writes an integer that fits a byte as 97, and one that + fits 32 bits as 98, which encode never does *) +let erlang_integers_decode = + QCheck2.Test.make ~name:"an integer as term_to_binary writes it decodes to itself" + ~print:string_of_int + (Gen.oneof [Gen.int_range 0 255; Gen.int_range (-0x8000_0000) 0x7fff_ffff]) + (fun n -> + let term = Buffer.create 32 in + (* {<<"t">>, #{<<"n">> => n}} *) + Buffer.add_string term + "\131\104\002\109\000\000\000\001t\116\000\000\000\001\109\000\000\000\001n"; + if n >= 0 && n < 256 then begin + Buffer.add_uint8 term 97; Buffer.add_uint8 term n + end + else begin + Buffer.add_uint8 term 98; + Buffer.add_int32_be term (Int32.of_int n) + end; + match Translator.decode (Buffer.contents term) with + | Ok {attributes; _} -> BatMap.String.bindings attributes = ["n", Concepts.Value.Integer n] + | Error _ -> false ) + +let suites () = + [ ( "karuta/translator", + List.map QCheck_alcotest.to_alcotest + [decodes_to_itself; a_cut_term_is_refused; erlang_integers_decode] ) ] |