diff --git a/tests/feedback.ml b/tests/feedback.ml index bfeaf206..5d9851d8 100644 --- a/tests/feedback.ml +++ b/tests/feedback.ml @@ -1,4 +1,68 @@ +module Flow = struct + + let rewrap_st = function (`S _, st) -> `S st | (`C _, st) -> `C st + + let unwrap_st = function `S st -> st | `C st -> st + + let can_send_appdata st = + Tls.Flow.can_send_appdata (unwrap_st st) + + let send_application_data state data = + match Tls.Flow.send_application_data (unwrap_st state) data with + | None -> None + | Some (st', cs) -> Some (rewrap_st (state, st'), cs) + + let handle_tls ~tag state msg = + let (handler, descr) = match state with + | `S st -> (Tls.Server.handle_tls st, "server") + | `C st -> (Tls.Client.handle_tls st, "client") in + match handler msg with + | `Fail _ -> + failwith @@ Printf.sprintf "[%s] error in %s" tag descr + | `Ok (st', ans, appdata) -> (rewrap_st (state, st'), ans, appdata) +end + +let loop_chatter ~cert ~loops ~size = + + Printf.eprintf "Looping %d times, %d bytes.\n%!" loops size; + + let message = Nocrypto.Rng.generate size + and server = Tls.Server.new_connection ~cert () + and (client, init) = + Tls.Client.new_connection ~validator:Tls.X509.Validator.null () + in + Testlib.time @@ fun () -> + + let rec handshake srv cli cli_msg = + let tag = "handshake" in + let (srv, ans, _) = Flow.handle_tls ~tag srv cli_msg in + let (cli, ans, _) = Flow.handle_tls ~tag cli ans in + if Flow.can_send_appdata cli then (srv, cli) + else handshake srv cli ans + + and chat srv cli data = function + | 0 -> data + | n -> + let tag = "chat" in + let simplex sender recv data = + match Flow.send_application_data sender [data] with + | None -> failwith @@ "can't send" + | Some (sender', msg) -> + match Flow.handle_tls ~tag recv msg with + | (recv', _, Some data') -> (sender', recv', data') + | (_, _, None) -> failwith "expected data" + in + let (cli, srv, data1) = simplex cli srv data in + let (srv, cli, data2) = simplex srv cli data1 in + chat srv cli data2 (pred n) + in + let (srv, cli) = handshake (`S server) (`C client) init in + let message' = chat srv cli message loops in + if Tls.Utils.Cs.equal message message' then () + else failwith @@ "the message got corrupted :(" + + let cs_mmap file = Unix_cstruct.of_fd Unix.(openfile file [O_RDONLY] 0) @@ -14,5 +78,5 @@ let _ = try int_of_string Sys.argv.(2) with _ -> 1024 and cert = load_priv () in - Testlib.loop_chatter ~cert ~loops ~size + loop_chatter ~cert ~loops ~size diff --git a/tests/readertests.ml b/tests/readertests.ml index 94bfd066..f422705e 100644 --- a/tests/readertests.ml +++ b/tests/readertests.ml @@ -1,27 +1,7 @@ open OUnit2 open Tls -open Utils - -let (<>) = Cs.(<>) - -let list_to_cstruct xs = - let open Cstruct in - let buf = create (List.length xs) in - List.iteri (set_uint8 buf) xs ; - buf - -let uint16_to_cstruct i = - let open Cstruct in - let buf = create 2 in - BE.set_uint16 buf 0 i; - buf - -let assert_cs_eq ?msg cs1 cs2 = - assert_equal - ~cmp:Utils.Cs.equal - ~printer:Utils.hexdump_to_str - ?msg - cs1 cs2 +open Testlib + let rec assert_lists_eq comparison a b = match a, b with diff --git a/tests/testlib.ml b/tests/testlib.ml index 570f94c4..d4f5cebf 100644 --- a/tests/testlib.ml +++ b/tests/testlib.ml @@ -1,70 +1,29 @@ +open OUnit2 + let time f = let t1 = Sys.time () in let r = f () in let t2 = Sys.time () in ( Printf.eprintf "[time] %f.04 s\n%!" (t2 -. t1) ; r ) -module Flow = struct - - let rewrap_st = function (`S _, st) -> `S st | (`C _, st) -> `C st - - let unwrap_st = function `S st -> st | `C st -> st - - let can_send_appdata st = - Tls.Flow.can_send_appdata (unwrap_st st) - - let send_application_data state data = - match Tls.Flow.send_application_data (unwrap_st state) data with - | None -> None - | Some (st', cs) -> Some (rewrap_st (state, st'), cs) - - let handle_tls ~tag state msg = - let (handler, descr) = match state with - | `S st -> (Tls.Server.handle_tls st, "server") - | `C st -> (Tls.Client.handle_tls st, "client") in - match handler msg with - | `Fail _ -> - failwith @@ Printf.sprintf "[%s] error in %s" tag descr - | `Ok (st', ans, appdata) -> (rewrap_st (state, st'), ans, appdata) -end - -let loop_chatter ~cert ~loops ~size = - - Printf.eprintf "Looping %d times, %d bytes.\n%!" loops size; - - let message = Nocrypto.Rng.generate size - and server = Tls.Server.new_connection ~cert () - and (client, init) = - Tls.Client.new_connection ~validator:Tls.X509.Validator.null () - in - time @@ fun () -> - - let rec handshake srv cli cli_msg = - let tag = "handshake" in - let (srv, ans, _) = Flow.handle_tls ~tag srv cli_msg in - let (cli, ans, _) = Flow.handle_tls ~tag cli ans in - if Flow.can_send_appdata cli then (srv, cli) - else handshake srv cli ans - - and chat srv cli data = function - | 0 -> data - | n -> - let tag = "chat" in - let simplex sender recv data = - match Flow.send_application_data sender [data] with - | None -> failwith @@ "can't send" - | Some (sender', msg) -> - match Flow.handle_tls ~tag recv msg with - | (recv', _, Some data') -> (sender', recv', data') - | (_, _, None) -> failwith "expected data" - in - let (cli, srv, data1) = simplex cli srv data in - let (srv, cli, data2) = simplex srv cli data1 in - chat srv cli data2 (pred n) - in - let (srv, cli) = handshake (`S server) (`C client) init in - let message' = chat srv cli message loops in - if Tls.Utils.Cs.equal message message' then () - else failwith @@ "the message got corrupted :(" - +let (<>) = Tls.Utils.Cs.(<>) + +let list_to_cstruct xs = + let open Cstruct in + let buf = create (List.length xs) in + List.iteri (set_uint8 buf) xs ; + buf + +let uint16_to_cstruct i = + let open Cstruct in + let buf = create 2 in + BE.set_uint16 buf 0 i; + buf + +let assert_cs_eq ?msg cs1 cs2 = + assert_equal + ~cmp:Tls.Utils.Cs.equal + ~printer:Tls.Utils.hexdump_to_str + ?msg + cs1 cs2