xapi-project / nbd / 23

Committed 4 Oct 2022 - 16:00 coverage: 64.791% (-0.2%) from 65.027%

Build # 23

Build Type

github

Committed by GitHub

Commit Message

Merge e84e70580 into aa1bfc5eb

Pull Request Pull Request #164: ci: use a single workflow

Run Details

357 of 551 relevant lines covered (64.79%)

3270.64 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

50.23

/lib/protocol.ml

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * 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.
 *)

(* NBD client library *)

open Sexplib.Std

(* We need to serialise/deserialise result values *)
type ('a, 'b) _result = [`Ok of 'a | `Error of 'b] [@@deriving sexp]

let result_of_sexp a b s =
  match _result_of_sexp a b s with `Ok x -> Ok x | `Error y -> Error y

let sexp_of_result a b r =
  sexp_of__result a b (match r with Ok x -> `Ok x | Error y -> `Error y)

let _nbd_cmd_read = 0l

let _nbd_cmd_write = 1l

let _nbd_cmd_disc = 2l

let _nbd_cmd_flush = 3l

let _nbd_cmd_trim = 4l

let nbd_request_magic = 0x25609513l

let nbd_reply_magic = 0x67446698l

let nbd_flag_has_flags = 1

let nbd_flag_read_only = 2

let nbd_flag_send_flush = 4

let nbd_flag_send_fua = 8

let nbd_flag_rotational = 16

let nbd_flag_send_trim = 32

let nbd_flag_fixed_newstyle = 1

let nbd_flag_no_zeroes = 2

let nbd_flag_c_fixed_newstyle = 1

let nbd_flag_c_no_zeroes = 2

let zero buf =
  for i = 0 to Cstruct.length buf - 1 do
    Cstruct.set_uint8 buf i 0
  done

module PerExportFlag = struct
  type t = Read_only | Send_flush | Send_fua | Rotational | Send_trim
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 x =
    let flags = Int32.to_int x in
    let is_set i mask = i land mask = mask in
    List.map snd
      (List.filter
         (fun (mask, _) -> is_set flags mask)
         [
           (nbd_flag_read_only, Read_only)
         ; (nbd_flag_send_flush, Send_flush)
         ; (nbd_flag_send_fua, Send_fua)
         ; (nbd_flag_rotational, Rotational)
         ; (nbd_flag_send_trim, Send_trim)
         ]
      )

  let to_int flags =
    let one = function
      | Read_only ->
          nbd_flag_read_only
      | Send_flush ->
          nbd_flag_send_flush
      | Send_fua ->
          nbd_flag_send_fua
      | Rotational ->
          nbd_flag_rotational
      | Send_trim ->
          nbd_flag_send_trim
    in
    List.fold_left ( lor ) nbd_flag_has_flags (List.map one flags)

  let to_int32 flags = Int32.of_int (to_int flags)
end

module GlobalFlag = struct
  type t = Fixed_newstyle | No_zeroes [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int flags =
    let is_set i mask = i land mask = mask in
    List.map snd
      (List.filter
         (fun (mask, _) -> is_set flags mask)
         [
           (nbd_flag_fixed_newstyle, Fixed_newstyle)
         ; (nbd_flag_no_zeroes, No_zeroes)
         ]
      )

  let to_int flags =
    let one = function
      | Fixed_newstyle ->
          nbd_flag_fixed_newstyle
      | No_zeroes ->
          nbd_flag_no_zeroes
    in
    List.fold_left ( lor ) 0 (List.map one flags)
end

module ClientFlag = struct
  type t = Fixed_newstyle | No_zeroes [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 flags =
    let flags = Int32.to_int flags in
    let is_set mask = mask land flags <> 0 in
    List.map snd
      (List.filter
         (fun (mask, _) -> is_set mask)
         [
           (nbd_flag_c_fixed_newstyle, Fixed_newstyle)
         ; (nbd_flag_c_no_zeroes, No_zeroes)
         ]
      )

  let to_int32 flags =
    let one = function
      | Fixed_newstyle ->
          nbd_flag_c_fixed_newstyle
      | No_zeroes ->
          nbd_flag_c_no_zeroes
    in
    Int32.of_int (List.fold_left ( lor ) 0 (List.map one flags))
end

module Error = struct
  type t = [`EPERM | `EIO | `ENOMEM | `EINVAL | `ENOSPC | `Unknown of int32]
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 = function
    | 1l ->
        `EPERM
    | 5l ->
        `EIO
    | 12l ->
        `ENOMEM
    | 22l ->
        `EINVAL
    | 28l ->
        `ENOSPC
    | x ->
        `Unknown x

  let to_int32 = function
    | `EPERM ->
        1l
    | `EIO ->
        5l
    | `ENOMEM ->
        12l
    | `EINVAL ->
        22l
    | `ENOSPC ->
        28l
    | `Unknown x ->
        x
end

module Command = struct
  type t = Read | Write | Disc | Flush | Trim | Unknown of int32
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 = function
    | 0l ->
        Read
    | 1l ->
        Write
    | 2l ->
        Disc
    | 3l ->
        Flush
    | 4l ->
        Trim
    | c ->
        Unknown c

  let to_int32 = function
    | Read ->
        0l
    | Write ->
        1l
    | Disc ->
        2l
    | Flush ->
        3l
    | Trim ->
        4l
    | Unknown c ->
        c
end

module Option = struct
  type t = ExportName | Abort | List | StartTLS | Unknown of int32
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 = function
    | 1l ->
        ExportName
    | 2l ->
        Abort
    | 3l ->
        List
    (* 4 is not in use in the NBD protocol. *)
    | 5l ->
        StartTLS
    (* 6, 7, 8 are not supported in this implementation. *)
    | c ->
        Unknown c

  let to_int32 = function
    | ExportName ->
        1l
    | Abort ->
        2l
    | List ->
        3l
    | StartTLS ->
        5l
    | Unknown c ->
        c
end

module OptionResponse = struct
  type t =
    | Ack
    | Server
    | Unsupported
    | Policy
    | Invalid
    | Platform
    | TlsReqd
    | Unknown of int32
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let of_int32 = function
    | 1l ->
        Ack
    | 2l ->
        Server
    | -2147483647l ->
        Unsupported
    | -2147483646l ->
        Policy
    | -2147483645l ->
        Invalid
    | -2147483644l ->
        Platform
    | -2147483643l ->
        TlsReqd
    | x ->
        Unknown x

  let to_int32 = function
    | Ack ->
        1l
    | Server ->
        2l
    | Unsupported ->
        -2147483647l
    | Policy ->
        -2147483646l
    | Invalid ->
        -2147483645l
    | Platform ->
        -2147483644l
    | TlsReqd ->
        -2147483643l
    | Unknown x ->
        x
end

(* Sent by the server to the client which includes an initial
   protocol choice *)
module Announcement = struct
  type t = [`V1 | `V2] [@@deriving sexp]

  type%cstruct t = {passwd: uint8_t [@len 8]; magic: uint64_t} [@@big_endian]

  let sizeof = sizeof_t

  let expected_passwd = "NBDMAGIC"

  let v1_magic = 0x00420281861253L

  let v2_magic = 0x49484156454F5054L (* Ascii encoding of "IHAVEOPT" *)

  let marshal buf t =
    set_t_passwd expected_passwd 0 buf ;
    set_t_magic buf (match t with `V1 -> v1_magic | `V2 -> v2_magic)

  let unmarshal buf =
    let passwd = Cstruct.to_string (get_t_passwd buf) in
    if passwd <> expected_passwd then
      Error (Failure "Bad magic in negotiate")
    else
      let magic = get_t_magic buf in
      if magic = v1_magic then
        Ok `V1
      else if magic = v2_magic then
        Ok `V2
      else
        Error
          (Failure
             (Printf.sprintf "Bad magic; expected %Ld or %Ld got %Ld" v1_magic
                v2_magic magic
             )
          )
end

module Negotiate = struct
  type v1 = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp]

  type v2 = GlobalFlag.t list [@@deriving sexp]

  type t = V1 of v1 | V2 of v2 [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  type%cstruct v1 = {
      size: uint64_t
    ; flags: uint32_t
    ; padding: uint8_t [@len 124]
  }
  [@@big_endian]

  type%cstruct v2 = {flags: uint16_t} [@@big_endian]

  let sizeof = function `V1 -> sizeof_v1 | `V2 -> sizeof_v2

  let marshal buf t =
    zero buf ;
    match t with
    | V1 t ->
        set_v1_size buf t.size ;
        set_v1_flags buf (PerExportFlag.to_int32 t.flags)
    | V2 t ->
        set_v2_flags buf (GlobalFlag.to_int t)

  let unmarshal buf t =
    match t with
    | `V1 ->
        let size = get_v1_size buf in
        let flags = PerExportFlag.of_int32 (get_v1_flags buf) in
        Ok (V1 {size; flags})
    | `V2 ->
        let flags = GlobalFlag.of_int (get_v2_flags buf) in
        Ok (V2 flags)
end

module NegotiateResponse = struct
  type t = ClientFlag.t list [@@deriving sexp]

  let sizeof = 4

  let marshal buf t = Cstruct.BE.set_uint32 buf 0 (ClientFlag.to_int32 t)

  let unmarshal buf = ClientFlag.of_int32 (Cstruct.BE.get_uint32 buf 0)
end

(* In the 'new' and 'new fixed' protocols, options are preceeded by
   a common header which includes a type and a length. *)
module OptionRequestHeader = struct
  type t = {ty: Option.t; length: int32} [@@deriving sexp]

  type%cstruct t = {magic: uint64_t; ty: uint32_t; length: uint32_t}
  [@@big_endian]

  let sizeof = sizeof_t

  let marshal buf t =
    set_t_magic buf Announcement.v2_magic ;
    set_t_ty buf (Option.to_int32 t.ty) ;
    set_t_length buf t.length

  let unmarshal buf =
    let open Rresult in
    let magic = get_t_magic buf in
    ( if Announcement.v2_magic <> magic then
        Error
          (Failure
             (Printf.sprintf "Bad reply magic: expected %Ld, got %Ld"
                Announcement.v2_magic magic
             )
          )
    else
      Ok ()
    )
    >>= fun () ->
    let ty = Option.of_int32 (get_t_ty buf) in
    let length = get_t_length buf in
    Ok {ty; length}
end

(* This is the option sent by the client to select a particular disk
   export. *)
module ExportName = struct
  type t = string [@@deriving sexp]

  let sizeof = String.length

  let marshal buf x = Cstruct.blit_from_string x 0 buf 0 (String.length x)
end

(* In both the 'new' style handshake and the 'fixed new' style handshake,
   the server will reply to an ExportName option with either a connection
   close or a DiskInfo: *)
module DiskInfo = struct
  type t = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp]

  type%cstruct t = {
      size: uint64_t
    ; flags: uint16_t
    ; padding: uint8_t [@len 124]
  }
  [@@big_endian]

  let sizeof = sizeof_t

  let unmarshal buf =
    let size = get_t_size buf in
    let flags = PerExportFlag.of_int32 (Int32.of_int (get_t_flags buf)) in
    Ok {size; flags}

  let marshal buf t =
    set_t_size buf t.size ;
    set_t_flags buf (PerExportFlag.to_int t.flags)
end

(* In the 'fixed new' style handshake, all options apart from ExportName
   should result in reply packets as follows: *)
module OptionResponseHeader = struct
  type%cstruct t = {
      magic: uint64_t
    ; request_type: uint32_t
    ; response_type: uint32_t
    ; length: uint32_t
  }
  [@@big_endian]

  type t = {
      request_type: Option.t
    ; response_type: OptionResponse.t
    ; length: int32
  }
  [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  let sizeof = sizeof_t

  let expected_magic = 0x3e889045565a9L

  let unmarshal buf =
    let open Rresult in
    let magic = get_t_magic buf in
    ( if expected_magic <> magic then
        Error
          (Failure
             (Printf.sprintf "Bad reply magic: expected %Ld, got %Ld"
                expected_magic magic
             )
          )
    else
      Ok ()
    )
    >>= fun () ->
    let request_type = Option.of_int32 (get_t_request_type buf) in
    let response_type = OptionResponse.of_int32 (get_t_response_type buf) in
    let length = get_t_length buf in
    Ok {request_type; response_type; length}

  let marshal buf t =
    set_t_magic buf expected_magic ;
    set_t_request_type buf (Option.to_int32 t.request_type) ;
    set_t_response_type buf (OptionResponse.to_int32 t.response_type) ;
    set_t_length buf t.length
end

(* A description of an export, sent in response to a List option *)
module Server = struct
  type t = {name: string} [@@deriving sexp]

  type%cstruct t = {length: uint32_t} [@@big_endian]

  let sizeof t = sizeof_t + String.length t.name

  let unmarshal buf =
    let length = Int32.to_int (get_t_length buf) in
    let buf = Cstruct.shift buf sizeof_t in
    let name = Cstruct.to_string (Cstruct.sub buf 0 length) in
    Ok {name}
end

module Request = struct
  type t = {ty: Command.t; handle: int64; from: int64; len: int32}
  [@@deriving sexp]

  let to_string t =
    Printf.sprintf "{ Command = %s; handle = %Ld; from = %Ld; len = %ld }"
      (Command.to_string t.ty) t.handle t.from t.len

  type%cstruct t = {
      magic: uint32_t
    ; ty: uint32_t
    ; handle: uint64_t
    ; from: uint64_t
    ; len: uint32_t
  }
  [@@big_endian]

  let unmarshal (buf : Cstruct.t) =
    let open Rresult in
    let magic = get_t_magic buf in
    ( if nbd_request_magic <> magic then
        Error
          (Failure
             (Printf.sprintf "Bad request magic: expected %ld, got %ld" magic
                nbd_request_magic
             )
          )
    else
      Ok ()
    )
    >>= fun () ->
    let ty = Command.of_int32 (get_t_ty buf) in
    let handle = get_t_handle buf in
    let from = get_t_from buf in
    let len = get_t_len buf in
    Ok {ty; handle; from; len}

  let sizeof = sizeof_t

  let marshal (buf : Cstruct.t) t =
    set_t_magic buf nbd_request_magic ;
    set_t_ty buf (Command.to_int32 t.ty) ;
    set_t_handle buf t.handle ;
    set_t_from buf t.from ;
    set_t_len buf t.len
end

module Reply = struct
  type t = {error: (unit, Error.t) result; handle: int64} [@@deriving sexp]

  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)

  type%cstruct t = {magic: uint32_t; error: uint32_t; handle: uint64_t}
  [@@big_endian]

  let unmarshal (buf : Cstruct.t) =
    let open Rresult in
    let magic = get_t_magic buf in
    ( if nbd_reply_magic <> magic then
        Error
          (Failure
             (Printf.sprintf "Bad reply magic: expected %ld, got %ld" magic
                nbd_reply_magic
             )
          )
    else
      Ok ()
    )
    >>= fun () ->
    let error = get_t_error buf in
    let error = if error = 0l then Ok () else Error (Error.of_int32 error) in
    let handle = get_t_handle buf in
    Ok {error; handle}

  let sizeof = sizeof_t

  let marshal (buf : Cstruct.t) t =
    set_t_magic buf nbd_reply_magic ;
    let error =
      match t.error with Ok () -> 0l | Error e -> Error.to_int32 e
    in
    set_t_error buf error ; set_t_handle buf t.handle
end

1	(*
2	* Copyright (C) Citrix Systems Inc.
3	*
4	* This program is free software; you can redistribute it and/or modify
5	* it under the terms of the GNU Lesser General Public License as published
6	* by the Free Software Foundation; version 2.1 only. with the special
7	* exception on linking described in file LICENSE.
8	*
9	* This program is distributed in the hope that it will be useful,
10	* but WITHOUT ANY WARRANTY; without even the implied warranty of
11	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12	* GNU Lesser General Public License for more details.
13	*)
14
15	(* NBD client library *)
16
17	open Sexplib.Std
18
19	(* We need to serialise/deserialise result values *)
20	type ('a, 'b) _result = [`Ok of 'a \| `Error of 'b] [@@deriving sexp]	!
21
22	let result_of_sexp a b s =
23	match _result_of_sexp a b s with `Ok x -> Ok x \| `Error y -> Error y	!
24
25	let sexp_of_result a b r =
26	sexp_of__result a b (match r with Ok x -> `Ok x \| Error y -> `Error y)	!
27
28	let _nbd_cmd_read = 0l
29
30	let _nbd_cmd_write = 1l
31
32	let _nbd_cmd_disc = 2l
33
34	let _nbd_cmd_flush = 3l
35
36	let _nbd_cmd_trim = 4l
37
38	let nbd_request_magic = 0x25609513l
39
40	let nbd_reply_magic = 0x67446698l
41
42	let nbd_flag_has_flags = 1
43
44	let nbd_flag_read_only = 2
45
46	let nbd_flag_send_flush = 4
47
48	let nbd_flag_send_fua = 8
49
50	let nbd_flag_rotational = 16
51
52	let nbd_flag_send_trim = 32
53
54	let nbd_flag_fixed_newstyle = 1
55
56	let nbd_flag_no_zeroes = 2
57
58	let nbd_flag_c_fixed_newstyle = 1
59
60	let nbd_flag_c_no_zeroes = 2
61
62	let zero buf =
63	for i = 0 to Cstruct.length buf - 1 do	11×
64	Cstruct.set_uint8 buf i 0	22×
65	done
66
67	module PerExportFlag = struct
68	type t = Read_only \| Send_flush \| Send_fua \| Rotational \| Send_trim	!
69	[@@deriving sexp]
70
71	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
72
73	let of_int32 x =
74	let flags = Int32.to_int x in	3×
75	let is_set i mask = i land mask = mask in	3×
76	List.map snd
77	(List.filter	3×
78	(fun (mask, _) -> is_set flags mask)	15×
79	[
80	(nbd_flag_read_only, Read_only)
81	; (nbd_flag_send_flush, Send_flush)
82	; (nbd_flag_send_fua, Send_fua)
83	; (nbd_flag_rotational, Rotational)
84	; (nbd_flag_send_trim, Send_trim)
85	]
86	)
87
88	let to_int flags =
89	let one = function	4×
90	\| Read_only ->	1×
91	nbd_flag_read_only
92	\| Send_flush ->	!
93	nbd_flag_send_flush
94	\| Send_fua ->	!
95	nbd_flag_send_fua
96	\| Rotational ->	!
97	nbd_flag_rotational
98	\| Send_trim ->	!
99	nbd_flag_send_trim
100	in
101	List.fold_left ( lor ) nbd_flag_has_flags (List.map one flags)	4×
102
103	let to_int32 flags = Int32.of_int (to_int flags)	!
104	end
105
106	module GlobalFlag = struct
107	type t = Fixed_newstyle \| No_zeroes [@@deriving sexp]	!
108
109	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
110
111	let of_int flags =
112	let is_set i mask = i land mask = mask in	8×
113	List.map snd
114	(List.filter	8×
115	(fun (mask, _) -> is_set flags mask)	16×
116	[
117	(nbd_flag_fixed_newstyle, Fixed_newstyle)
118	; (nbd_flag_no_zeroes, No_zeroes)
119	]
120	)
121
122	let to_int flags =
123	let one = function	11×
124	\| Fixed_newstyle ->	11×
125	nbd_flag_fixed_newstyle
126	\| No_zeroes ->	!
127	nbd_flag_no_zeroes
128	in
129	List.fold_left ( lor ) 0 (List.map one flags)	11×
130	end
131
132	module ClientFlag = struct
133	type t = Fixed_newstyle \| No_zeroes [@@deriving sexp]	!
134
135	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
136
137	let of_int32 flags =
138	let flags = Int32.to_int flags in	11×
139	let is_set mask = mask land flags <> 0 in	11×
140	List.map snd
141	(List.filter	11×
142	(fun (mask, _) -> is_set mask)	22×
143	[
144	(nbd_flag_c_fixed_newstyle, Fixed_newstyle)
145	; (nbd_flag_c_no_zeroes, No_zeroes)
146	]
147	)
148
149	let to_int32 flags =
150	let one = function	8×
151	\| Fixed_newstyle ->	8×
152	nbd_flag_c_fixed_newstyle
153	\| No_zeroes ->	!
154	nbd_flag_c_no_zeroes
155	in
156	Int32.of_int (List.fold_left ( lor ) 0 (List.map one flags))	8×
157	end
158
159	module Error = struct
160	type t = [`EPERM \| `EIO \| `ENOMEM \| `EINVAL \| `ENOSPC \| `Unknown of int32]	!
161	[@@deriving sexp]	!
162
163	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
164
165	let of_int32 = function
166	\| 1l ->	!
167	`EPERM
168	\| 5l ->	!
169	`EIO
170	\| 12l ->	!
171	`ENOMEM
172	\| 22l ->	!
173	`EINVAL
174	\| 28l ->	!
175	`ENOSPC
176	\| x ->	!
177	`Unknown x
178
179	let to_int32 = function
180	\| `EPERM ->	1×
181	1l
182	\| `EIO ->	!
183	5l
184	\| `ENOMEM ->	!
185	12l
186	\| `EINVAL ->	!
187	22l
188	\| `ENOSPC ->	!
189	28l
190	\| `Unknown x ->	!
191	x
192	end
193
194	module Command = struct
195	type t = Read \| Write \| Disc \| Flush \| Trim \| Unknown of int32	!
196	[@@deriving sexp]
197
198	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
199
200	let of_int32 = function
201	\| 0l ->	3×
202	Read
203	\| 1l ->	3×
204	Write
205	\| 2l ->	1×
206	Disc
207	\| 3l ->	!
208	Flush
209	\| 4l ->	!
210	Trim
211	\| c ->	!
212	Unknown c
213
214	let to_int32 = function
215	\| Read ->	2×
216	0l
217	\| Write ->	1×
218	1l
219	\| Disc ->	!
220	2l
221	\| Flush ->	!
222	3l
223	\| Trim ->	!
224	4l
225	\| Unknown c ->	!
226	c
227	end
228
229	module Option = struct
230	type t = ExportName \| Abort \| List \| StartTLS \| Unknown of int32	!
231	[@@deriving sexp]
232
233	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
234
235	let of_int32 = function
236	\| 1l ->	5×
237	ExportName
238	\| 2l ->	10×
239	Abort
240	\| 3l ->	13×
241	List
242	(* 4 is not in use in the NBD protocol. *)
243	\| 5l ->	!
244	StartTLS
245	(* 6, 7, 8 are not supported in this implementation. *)
246	\| c ->	!
247	Unknown c
248
249	let to_int32 = function
250	\| ExportName ->	3×
251	1l
252	\| Abort ->	11×
253	2l
254	\| List ->	12×
255	3l
256	\| StartTLS ->	!
257	5l
258	\| Unknown c ->	!
259	c
260	end
261
262	module OptionResponse = struct
263	type t =	!
264	\| Ack	!
265	\| Server	!
266	\| Unsupported	!
267	\| Policy	!
268	\| Invalid	!
269	\| Platform	!
270	\| TlsReqd	!
271	\| Unknown of int32	!
272	[@@deriving sexp]
273
274	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
275
276	let of_int32 = function
277	\| 1l ->	7×
278	Ack
279	\| 2l ->	5×
280	Server
281	\| -2147483647l ->	!
282	Unsupported
283	\| -2147483646l ->	2×
284	Policy
285	\| -2147483645l ->	!
286	Invalid
287	\| -2147483644l ->	!
288	Platform
289	\| -2147483643l ->	!
290	TlsReqd
291	\| x ->	!
292	Unknown x
293
294	let to_int32 = function
295	\| Ack ->	8×
296	1l
297	\| Server ->	4×
298	2l
299	\| Unsupported ->	!
300	-2147483647l
301	\| Policy ->	1×
302	-2147483646l
303	\| Invalid ->	!
304	-2147483645l
305	\| Platform ->	!
306	-2147483644l
307	\| TlsReqd ->	!
308	-2147483643l
309	\| Unknown x ->	!
310	x
311	end
312
313	(* Sent by the server to the client which includes an initial
314	protocol choice *)
315	module Announcement = struct
316	type t = [`V1 \| `V2] [@@deriving sexp]	!
317
318	type%cstruct t = {passwd: uint8_t [@len 8]; magic: uint64_t} [@@big_endian]
319
320	let sizeof = sizeof_t
321
322	let expected_passwd = "NBDMAGIC"
323
324	let v1_magic = 0x00420281861253L
325
326	let v2_magic = 0x49484156454F5054L (* Ascii encoding of "IHAVEOPT" *)
327
328	let marshal buf t =
329	set_t_passwd expected_passwd 0 buf ;	11×
330	set_t_magic buf (match t with `V1 -> v1_magic \| `V2 -> v2_magic)	!
331
332	let unmarshal buf =
333	let passwd = Cstruct.to_string (get_t_passwd buf) in	8×
334	if passwd <> expected_passwd then	8×
335	Error (Failure "Bad magic in negotiate")	!
336	else
337	let magic = get_t_magic buf in	8×
338	if magic = v1_magic then	8×
339	Ok `V1	!
340	else if magic = v2_magic then	8×
341	Ok `V2	8×
342	else
343	Error	!
344	(Failure
345	(Printf.sprintf "Bad magic; expected %Ld or %Ld got %Ld" v1_magic	!
346	v2_magic magic
347	)
348	)
349	end
350
351	module Negotiate = struct
352	type v1 = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp]	!
353
354	type v2 = GlobalFlag.t list [@@deriving sexp]	!
355
356	type t = V1 of v1 \| V2 of v2 [@@deriving sexp]	!
357
358	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
359
360	type%cstruct v1 = {
361	size: uint64_t
362	; flags: uint32_t
363	; padding: uint8_t [@len 124]
364	}
365	[@@big_endian]
366
367	type%cstruct v2 = {flags: uint16_t} [@@big_endian]
368
369	let sizeof = function `V1 -> sizeof_v1 \| `V2 -> sizeof_v2	!
370
371	let marshal buf t =
372	zero buf ;	11×
373	match t with	11×
374	\| V1 t ->	!
375	set_v1_size buf t.size ;
376	set_v1_flags buf (PerExportFlag.to_int32 t.flags)	!
377	\| V2 t ->	11×
378	set_v2_flags buf (GlobalFlag.to_int t)	11×
379
380	let unmarshal buf t =
381	match t with	8×
382	\| `V1 ->	!
383	let size = get_v1_size buf in
384	let flags = PerExportFlag.of_int32 (get_v1_flags buf) in	!
385	Ok (V1 {size; flags})	!
386	\| `V2 ->	8×
387	let flags = GlobalFlag.of_int (get_v2_flags buf) in	8×
388	Ok (V2 flags)	8×
389	end
390
391	module NegotiateResponse = struct
392	type t = ClientFlag.t list [@@deriving sexp]	!
393
394	let sizeof = 4
395
396	let marshal buf t = Cstruct.BE.set_uint32 buf 0 (ClientFlag.to_int32 t)	8×
397
398	let unmarshal buf = ClientFlag.of_int32 (Cstruct.BE.get_uint32 buf 0)	11×
399	end
400
401	(* In the 'new' and 'new fixed' protocols, options are preceeded by
402	a common header which includes a type and a length. *)
403	module OptionRequestHeader = struct
404	type t = {ty: Option.t; length: int32} [@@deriving sexp]	!
405
406	type%cstruct t = {magic: uint64_t; ty: uint32_t; length: uint32_t}
407	[@@big_endian]
408
409	let sizeof = sizeof_t
410
411	let marshal buf t =
412	set_t_magic buf Announcement.v2_magic ;	13×
413	set_t_ty buf (Option.to_int32 t.ty) ;	13×
414	set_t_length buf t.length	13×
415
416	let unmarshal buf =
417	let open Rresult in	14×
418	let magic = get_t_magic buf in
419	( if Announcement.v2_magic <> magic then	14×
420	Error	!
421	(Failure
422	(Printf.sprintf "Bad reply magic: expected %Ld, got %Ld"	!
423	Announcement.v2_magic magic
424	)
425	)
426	else
427	Ok ()	14×
428	)
429	>>= fun () ->
430	let ty = Option.of_int32 (get_t_ty buf) in	14×
431	let length = get_t_length buf in	14×
432	Ok {ty; length}	14×
433	end
434
435	(* This is the option sent by the client to select a particular disk
436	export. *)
437	module ExportName = struct
438	type t = string [@@deriving sexp]	!
439
440	let sizeof = String.length
441
442	let marshal buf x = Cstruct.blit_from_string x 0 buf 0 (String.length x)	3×
443	end
444
445	(* In both the 'new' style handshake and the 'fixed new' style handshake,
446	the server will reply to an ExportName option with either a connection
447	close or a DiskInfo: *)
448	module DiskInfo = struct
449	type t = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp]	!
450
451	type%cstruct t = {
452	size: uint64_t
453	; flags: uint16_t
454	; padding: uint8_t [@len 124]
455	}
456	[@@big_endian]
457
458	let sizeof = sizeof_t
459
460	let unmarshal buf =
461	let size = get_t_size buf in	3×
462	let flags = PerExportFlag.of_int32 (Int32.of_int (get_t_flags buf)) in	3×
463	Ok {size; flags}	3×
464
465	let marshal buf t =
466	set_t_size buf t.size ;	4×
467	set_t_flags buf (PerExportFlag.to_int t.flags)	4×
468	end
469
470	(* In the 'fixed new' style handshake, all options apart from ExportName
471	should result in reply packets as follows: *)
472	module OptionResponseHeader = struct
473	type%cstruct t = {
474	magic: uint64_t
475	; request_type: uint32_t
476	; response_type: uint32_t
477	; length: uint32_t
478	}
479	[@@big_endian]
480
481	type t = {	!
482	request_type: Option.t	!
483	; response_type: OptionResponse.t	!
484	; length: int32	!
485	}
UNCOV 486	[@@deriving sexp]	!
487
488	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
489
490	let sizeof = sizeof_t
491
492	let expected_magic = 0x3e889045565a9L
493
494	let unmarshal buf =
495	let open Rresult in	14×
496	let magic = get_t_magic buf in
497	( if expected_magic <> magic then	14×
498	Error	!
499	(Failure
500	(Printf.sprintf "Bad reply magic: expected %Ld, got %Ld"	!
501	expected_magic magic
502	)
503	)
504	else
505	Ok ()	14×
506	)
507	>>= fun () ->
508	let request_type = Option.of_int32 (get_t_request_type buf) in	14×
509	let response_type = OptionResponse.of_int32 (get_t_response_type buf) in	14×
510	let length = get_t_length buf in	14×
511	Ok {request_type; response_type; length}	14×
512
513	let marshal buf t =
514	set_t_magic buf expected_magic ;	13×
515	set_t_request_type buf (Option.to_int32 t.request_type) ;	13×
516	set_t_response_type buf (OptionResponse.to_int32 t.response_type) ;	13×
517	set_t_length buf t.length	13×
518	end
519
520	(* A description of an export, sent in response to a List option *)
521	module Server = struct
522	type t = {name: string} [@@deriving sexp]	!
523
524	type%cstruct t = {length: uint32_t} [@@big_endian]
525
526	let sizeof t = sizeof_t + String.length t.name	!
527
528	let unmarshal buf =
529	let length = Int32.to_int (get_t_length buf) in	5×
530	let buf = Cstruct.shift buf sizeof_t in	5×
531	let name = Cstruct.to_string (Cstruct.sub buf 0 length) in	5×
532	Ok {name}	5×
533	end
534
535	module Request = struct
536	type t = {ty: Command.t; handle: int64; from: int64; len: int32}	!
UNCOV 537	[@@deriving sexp]	!
538
539	let to_string t =
540	Printf.sprintf "{ Command = %s; handle = %Ld; from = %Ld; len = %ld }"	!
541	(Command.to_string t.ty) t.handle t.from t.len	!
542
543	type%cstruct t = {
544	magic: uint32_t
545	; ty: uint32_t
546	; handle: uint64_t
547	; from: uint64_t
548	; len: uint32_t
549	}
550	[@@big_endian]
551
552	let unmarshal (buf : Cstruct.t) =
553	let open Rresult in	7×
554	let magic = get_t_magic buf in
555	( if nbd_request_magic <> magic then	7×
556	Error	!
557	(Failure
558	(Printf.sprintf "Bad request magic: expected %ld, got %ld" magic	!
559	nbd_request_magic
560	)
561	)
562	else
563	Ok ()	7×
564	)
565	>>= fun () ->
566	let ty = Command.of_int32 (get_t_ty buf) in	7×
567	let handle = get_t_handle buf in	7×
568	let from = get_t_from buf in	7×
569	let len = get_t_len buf in	7×
570	Ok {ty; handle; from; len}	7×
571
572	let sizeof = sizeof_t
573
574	let marshal (buf : Cstruct.t) t =
575	set_t_magic buf nbd_request_magic ;	3×
576	set_t_ty buf (Command.to_int32 t.ty) ;	3×
577	set_t_handle buf t.handle ;	3×
578	set_t_from buf t.from ;	3×
579	set_t_len buf t.len	3×
580	end
581
582	module Reply = struct
583	type t = {error: (unit, Error.t) result; handle: int64} [@@deriving sexp]	!
584
585	let to_string t = Sexplib.Sexp.to_string (sexp_of_t t)	!
586
587	type%cstruct t = {magic: uint32_t; error: uint32_t; handle: uint64_t}
588	[@@big_endian]
589
590	let unmarshal (buf : Cstruct.t) =
591	let open Rresult in	3×
592	let magic = get_t_magic buf in
593	( if nbd_reply_magic <> magic then	3×
594	Error	!
595	(Failure
596	(Printf.sprintf "Bad reply magic: expected %ld, got %ld" magic	!
597	nbd_reply_magic
598	)
599	)
600	else
601	Ok ()	3×
602	)
603	>>= fun () ->
604	let error = get_t_error buf in	3×
605	let error = if error = 0l then Ok () else Error (Error.of_int32 error) in	!
606	let handle = get_t_handle buf in
607	Ok {error; handle}	3×
608
609	let sizeof = sizeof_t
610
611	let marshal (buf : Cstruct.t) t =
612	set_t_magic buf nbd_reply_magic ;	6×
613	let error =	6×
614	match t.error with Ok () -> 0l \| Error e -> Error.to_int32 e	1×
615	in
616	set_t_error buf error ; set_t_handle buf t.handle	6×
617	end

xapi-project / nbd / 23

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous