-
Notifications
You must be signed in to change notification settings - Fork 15
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
CP-47001: [xapi-fdcaps-test]: add generate module
Signed-off-by: Edwin Török <[email protected]>
- Loading branch information
1 parent
a7bb4e9
commit 20c69ea
Showing
2 changed files
with
189 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,114 @@ | ||
(* | ||
* Copyright (C) 2023 Cloud Software Group | ||
* | ||
* This program is free software; you can redistribute it and/or modify | ||
* it under the terms of the GNU Lesser General Public License as published | ||
* by the Free Software Foundation; version 2.1 only. with the special | ||
* exception on linking described in file LICENSE. | ||
* | ||
* This program is distributed in the hope that it will be useful, | ||
* but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
* GNU Lesser General Public License for more details. | ||
*) | ||
|
||
open Xapi_fdcaps | ||
open Operations | ||
open Observations | ||
|
||
type t = { | ||
size: int | ||
; delay_read: Delay.t option | ||
; delay_write: Delay.t option | ||
; kind: Unix.file_kind | ||
} | ||
|
||
let make ~size ~delay_read ~delay_write kind = | ||
{size; delay_read; delay_write; kind} | ||
|
||
open QCheck2 | ||
|
||
let file_kind = | ||
( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|] | ||
, Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string | ||
) | ||
|
||
(* also coincidentally the pipe buffer size on Linux *) | ||
let ocaml_unix_buffer_size = 65536 | ||
|
||
let sizes = | ||
Gen.oneofa | ||
[| | ||
0 | ||
; 1 | ||
; 100 | ||
; 4096 | ||
; ocaml_unix_buffer_size - 1 | ||
; ocaml_unix_buffer_size | ||
; ocaml_unix_buffer_size + 1 | ||
; 2 * ocaml_unix_buffer_size | ||
; (10 * ocaml_unix_buffer_size) + 3 | ||
|] | ||
|
||
(* some may exceed length of test, but that is what the timeout is for *) | ||
let delays = Gen.oneofa [|0.001; 0.01; 0.1; 1.0|] | ||
|
||
let span_of_s s = s *. 1e9 |> Mtime.Span.of_float_ns |> Option.get | ||
|
||
let delays = | ||
let build duration every_bytes = Delay.v ~duration ~every_bytes in | ||
(* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *) | ||
Gen.(map2 build (map span_of_s delays) (1 -- 128000)) | ||
|
||
(* keep these short *) | ||
let timeouts = Gen.oneofa [|0.0; 0.001; 0.1; 0.3|] | ||
|
||
let t = | ||
let build (delay_read, delay_write, size, kind) = | ||
make ~delay_read ~delay_write ~size kind | ||
in | ||
Gen.(map build @@ tup4 (option delays) (option delays) sizes (fst file_kind)) | ||
|
||
let print = | ||
Fmt.to_to_string | ||
@@ Fmt.( | ||
record | ||
[ | ||
field "delay_read" (fun t -> t.delay_read) (option Delay.pp) | ||
; field "delay_write" (fun t -> t.delay_write) (option Delay.pp) | ||
; field "size" (fun t -> t.size) int | ||
; field "file_kind" (fun t -> (snd file_kind) t.kind) string | ||
] | ||
) | ||
|
||
let run_ro t data ~f = | ||
if Option.is_some t.delay_read then | ||
QCheck2.assume_fail () ; | ||
(* we can only implement delays on write, skip *) | ||
CancellableSleep.with_ @@ fun cancel -> | ||
let finally () = CancellableSleep.cancel cancel in | ||
let f arg = Fun.protect ~finally (fun () -> f arg) in | ||
let write = | ||
match t.delay_write with | ||
| Some delay -> | ||
Delay.apply_write cancel delay single_write_substring | ||
| None -> | ||
single_write_substring | ||
in | ||
observe_ro write ~f t.kind data | ||
|
||
let run_wo t ~f = | ||
if Option.is_some t.delay_write then | ||
QCheck2.assume_fail () ; | ||
(* we can only implement delays on write, skip *) | ||
CancellableSleep.with_ @@ fun cancel -> | ||
let finally () = CancellableSleep.cancel cancel in | ||
let f arg = Fun.protect ~finally (fun () -> f arg) in | ||
let read = | ||
match t.delay_read with | ||
| Some delay -> | ||
Delay.apply_read cancel delay read | ||
| None -> | ||
read | ||
in | ||
observe_wo read ~f t.kind |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,75 @@ | ||
(* | ||
* Copyright (C) 2023 Cloud Software Group | ||
* | ||
* This program is free software; you can redistribute it and/or modify | ||
* it under the terms of the GNU Lesser General Public License as published | ||
* by the Free Software Foundation; version 2.1 only. with the special | ||
* exception on linking described in file LICENSE. | ||
* | ||
* This program is distributed in the hope that it will be useful, | ||
* but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
* GNU Lesser General Public License for more details. | ||
*) | ||
open Xapi_fdcaps | ||
open Properties | ||
open Operations | ||
open Observations | ||
|
||
(** file descriptor behaviour specification *) | ||
type t = { | ||
size: int | ||
; delay_read: Delay.t option | ||
; delay_write: Delay.t option | ||
; kind: Unix.file_kind | ||
} | ||
|
||
val timeouts : float QCheck2.Gen.t | ||
(** [timeouts] is a generator for small timeouts *) | ||
|
||
val make : | ||
size:int | ||
-> delay_read:Delay.t option | ||
-> delay_write:Delay.t option | ||
-> Unix.file_kind | ||
-> t | ||
(** [make ~size ~delay_read ~delay_write kind] is a file descriptor test. | ||
@param size the size of the file, or the amount of data sent on a socket/pipe | ||
@param delay_read whether to insert sleeps to trigger short reads | ||
@param delay_write whether to insert sleeps to trigger short writes | ||
@param kind the {!type:Unix.file_kind} of the file descriptor to create | ||
*) | ||
|
||
val t : t QCheck2.Gen.t | ||
(** [t] is a {!mod:QCheck2} generator for {!type:t}. | ||
This doesn't yet open any file descriptors (there'd be too many leaks and we'd run out), | ||
that is done by {!val:run} | ||
Follows the naming convention to name generators after the type they generate. | ||
*) | ||
|
||
val print : t QCheck2.Print.t | ||
(** [print] is a QCheck2 pretty printer for [t] *) | ||
|
||
val run_ro : | ||
t | ||
-> string | ||
-> f:(([< readable > `rdonly], kind) make -> 'a) | ||
-> (unit, [> wronly] observation option) observations * 'a or_exn | ||
(** [run_ro t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. | ||
The file descriptor should be treated as readonly. | ||
@returns observations about [f]'s actions the file descriptor | ||
*) | ||
|
||
val run_wo : | ||
t | ||
-> f:(([< writable > `wronly], kind) make -> 'a) | ||
-> ([> rdonly] observation option, unit) observations * 'a or_exn | ||
(** [run_wo t ~f] creates a file descriptor according to [t] and calls the function under test [f]. | ||
The file descriptor should be treated as writeonly. | ||
@returns observations about [f]'s actions on the file descriptor | ||
*) |