Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

CP-47001 Introduce file descriptor testing framework #83

Closed
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension


Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .github/workflows/ocaml-ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ jobs:
name: Ocaml tests
runs-on: ubuntu-20.04
env:
package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck"
package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-fdcaps xapi-fd-test"

steps:
- name: Checkout code
Expand Down
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
_build/
_coverage/
*.install
.merlin
7 changes: 6 additions & 1 deletion Makefile
Original file line number Diff line number Diff line change
@@ -1,10 +1,15 @@
PROFILE=release

.PHONY: build install uninstall clean test doc format
.PHONY: build install uninstall clean test doc format coverage

build:
dune build @install --profile=$(PROFILE)

coverage:
dune runtest --instrument-with bisect_ppx --force
bisect-ppx-report html
bisect-ppx-report summary --per-file

install:
dune install

Expand Down
28 changes: 28 additions & 0 deletions dune-project
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@
(formatting (enabled_for ocaml))
(name xapi-stdext)

(cram enable)
(implicit_transitive_deps false)
(generate_opam_files true)

(source (github xapi-project/stdext))
Expand All @@ -21,6 +23,8 @@
(xapi-stdext-threads (= :version))
(xapi-stdext-unix (= :version))
(xapi-stdext-zerocheck (= :version))
(xapi-fdcaps (= :version))
(xapi-fdcaps-test (and (= :version) :with-test))
)
)

Expand Down Expand Up @@ -104,3 +108,27 @@
(odoc :with-doc)
)
)

(package
(name xapi-fdcaps)
(synopsis "Static capabilities for file descriptor operations")
(depends
(alcotest :with-test)
base-unix
fmt
(bisect_ppx :with-test)
)
)

(package
(name xapi-fd-test)
(synopsis "Test framework for file descriptor operations")
(depends
(alcotest :with-test)
base-unix
fmt
(mtime (>= 2.0.0))
logs
(qcheck-core (>= 0.21.2))
)
)
9 changes: 9 additions & 0 deletions lib/xapi-fd-test/dune
Original file line number Diff line number Diff line change
@@ -0,0 +1,9 @@
; This will be used to test stdext itself, so do not depend on stdext here
(library
(public_name xapi-fd-test)
(name xapi_fd_test)
(libraries (re_export xapi-fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix)

; off by default, enable with --instrument-with bisect_ppx
(instrumentation (backend bisect_ppx))
)
114 changes: 114 additions & 0 deletions lib/xapi-fd-test/generate.ml
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
75 changes: 75 additions & 0 deletions lib/xapi-fd-test/generate.mli
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
*)
Loading
Loading