Merge pull request #78 from yomimono/moar_maintenance

add a blkproto.mli with only the needed definitions

lib/blkback.ml

@@ -82,8 +82,6 @@ module Opt = struct
     | Some x -> x
 end
 
-let empty = Cstruct.create 0
-
 module Request = struct
   type kind = Read | Write
 

lib/blkproto.ml

@@ -24,7 +24,6 @@ let list l k =
   else Ok (List.assoc k l)
 let int x = try Ok (int_of_string x) with _ -> Error (`Msg ("not an int: " ^ x))
 let int32 x = try Ok (Int32.of_string x) with _ -> Error (`Msg ("not an int32: " ^ x))
-let int64 x = try Ok (Int64.of_string x) with _ -> Error (`Msg ("not an int64: " ^ x))
 
 (* Control messages via xenstore *)
 
@@ -33,29 +32,19 @@ module Mode = struct
   let to_string = function
     | ReadOnly -> "r"
     | ReadWrite -> "w"
-  let of_string = function
-    | "r" -> Some ReadOnly
-    | "w" -> Some ReadWrite
-    | _ -> None
   let to_int = function
     | ReadOnly -> 4 (* VDISK_READONLY *)
     | ReadWrite -> 0
-  let of_int x = if (x land 4) = 4 then ReadOnly else ReadWrite
 end
 
 module Media = struct
   type t = CDROM | Disk
   let to_string = function
     | CDROM -> "cdrom"
     | Disk -> "disk"
-  let of_string = function
-    | "cdrom" -> Some CDROM
-    | "disk" -> Some Disk
-    | _ -> None
   let to_int = function
     | CDROM -> 1 (* VDISK_CDROM *)
     | Disk  -> 0
-  let of_int x = if (x land 1) = 1 then CDROM else Disk
 end
 
 module State = struct
@@ -72,17 +61,7 @@ module State = struct
   let to_string t = string_of_int (List.assoc t table' )
   let of_string t = try Some (List.assoc (int_of_string t) table) with _ -> None
 
-  let of_int x =
-    if List.mem_assoc x table
-    then Ok (List.assoc x table)
-    else Error (`Msg (Printf.sprintf "unknown device state: %d" x))
-
   let _state = "state"
-  let keys = [ _state ]
-  let of_assoc_list l =
-    list l _state >>= fun x ->
-    int x >>= fun x ->
-    of_int x
   let to_assoc_list t = [
     _state, string_of_int (List.assoc t table')
   ]
@@ -153,13 +132,6 @@ module FeatureIndirect = struct
     then [] (* don't advertise the feature *)
     else [ _max_indirect_segments, string_of_int t.max_indirect_segments ]
 
-  let of_assoc_list l =
-    if not(List.mem_assoc _max_indirect_segments l)
-    then Ok { max_indirect_segments = 0 }
-    else
-      let x = List.assoc _max_indirect_segments l in
-      int x >>= fun max_indirect_segments ->
-      Ok { max_indirect_segments }
 end
 
 module DiskInfo = struct
@@ -180,16 +152,6 @@ module DiskInfo = struct
     _info, string_of_int (Media.to_int t.media lor (Mode.to_int t.mode));
   ]
 
-  let of_assoc_list l =
-    list l _sector_size >>= fun x -> int x
-    >>= fun sector_size ->
-    list l _sectors >>= fun x -> int64 x
-    >>= fun sectors ->
-    list l _info >>= fun x -> int x
-    >>= fun info ->
-    let media = Media.of_int info
-    and mode = Mode.of_int info in
-    Ok { sectors; sector_size; media; mode }
 end
 
 module RingInfo = struct
@@ -213,12 +175,6 @@ module RingInfo = struct
     _protocol;
   ]
 
-  let to_assoc_list t = [
-    _ring_ref, Int32.to_string t.ref;
-    _event_channel, string_of_int t.event_channel;
-    _protocol, Protocol.to_string t.protocol
-  ]
-
   let of_assoc_list l =
     list l _ring_ref >>= fun x -> int32 x
     >>= fun ref ->
@@ -256,8 +212,6 @@ module Req = struct
   | Flush -> "Flush" | Op_reserved_1 -> "Op_reserved_1" | Trim -> "Trim"
   | Indirect_op -> "Indirect_op"
 
-  exception Unknown_request_type of int
-
   (* Defined in include/xen/io/blkif.h BLKIF_MAX_SEGMENTS_PER_REQUEST *)
   let segments_per_request = 11
 
@@ -267,17 +221,10 @@ module Req = struct
     last_sector: int;
   }
 
-  let string_of_seg seg =
-    Printf.sprintf "{gref=%ld first=%d last=%d}" seg.gref seg.first_sector seg.last_sector
-
   type segs =
   | Direct of seg array
   | Indirect of int32 array
 
-  let string_of_segs = function
-  | Direct segs -> Printf.sprintf "direct [ %s ]" (String.concat "; " (List.map string_of_seg (Array.to_list segs)))
-  | Indirect refs -> Printf.sprintf "indirect [ %s ]" (String.concat "; " (List.map Int32.to_string (Array.to_list refs)))
-
   (* Defined in include/xen/io/blkif.h : blkif_request_t *)
   type t = {
     op: op option;
@@ -288,11 +235,6 @@ module Req = struct
     segs: segs;
   }
 
-  let string_of t =
-    Printf.sprintf "{ op=%s handle=%d id=%Ld sector=%Ld segs=%s (total %d) }"
-    (match t.op with Some x -> string_of_op x | None -> "None")
-      t.handle t.id t.sector (string_of_segs t.segs) t.nr_segs
-
   (* The segment looks the same in both 32-bit and 64-bit versions *)
   [%%cstruct
   type segment = {
@@ -335,8 +277,14 @@ module Req = struct
     val get_hdr_indirect_op: Cstruct.t -> int
     val set_hdr_indirect_op: Cstruct.t -> int -> unit
   end
-
-  module Marshalling(D: DIRECT)(I: INDIRECT) = struct
+  module type PROTOCOL_IMPLEMENTATION = sig 
+    val total_size : int 
+    val segments_per_indirect_page : int 
+    val write_segments : seg array -> Cstruct.t -> unit
+    val write_request : t -> Cstruct.t -> int64
+    val read_request : Cstruct.t -> t
+  end
+  module Marshalling(D: DIRECT)(I: INDIRECT) : PROTOCOL_IMPLEMENTATION = struct
     (* total size of a request structure, in bytes *)
     let total_size = D.sizeof_hdr + (sizeof_segment * segments_per_request)
 

lib/blkproto.mli

@@ -0,0 +1,122 @@
+val max_segments_per_request : int
+
+module FeatureIndirect : sig
+  type t = { max_indirect_segments : int }
+
+  val _max_indirect_segments : string
+
+  val to_assoc_list : t -> (string * string) list
+end
+
+module State : sig
+  type t = | Initialising | InitWait | Initialised | Connected | Closing | Closed
+  val _state : string
+  val of_string : string -> t option
+  val to_assoc_list : t -> (string * string) list
+  val to_string : t -> string
+end
+
+module Mode : sig
+  type t = ReadOnly | ReadWrite
+end
+
+module Media : sig
+  type t = CDROM | Disk
+end
+
+module DiskInfo : sig
+  type t = {
+    sector_size : int;
+    sectors : int64;
+    media : Media.t;
+    mode : Mode.t;
+  }
+
+  val to_assoc_list : t -> (string * string) list
+end
+
+module Hotplug : sig
+  val _hotplug_status : string
+  val _online : string
+end
+
+module Connection : sig
+  type t = {
+    virtual_device: string;
+    backend_path: string;
+    backend_domid: int;
+    frontend_path: string;
+    frontend_domid: int;
+    mode: Mode.t;
+    media: Media.t;
+    removable: bool;
+  }
+
+  val to_assoc_list : t -> (int * (string * string)) list
+end
+
+module Req : sig
+  type seg = {
+    gref : int32;
+    first_sector : int;
+    last_sector : int;
+  }
+
+  type segs = | Direct of seg array | Indirect of int32 array
+
+  type op = | Read | Write | Write_barrier | Flush | Op_reserved_1 | Trim | Indirect_op
+
+  val string_of_op : op -> string
+
+  type t = {
+    op : op option;
+    handle : int;
+    id : int64;
+    sector : int64;
+    nr_segs : int;
+    segs : segs;
+  }
+
+  val get_segments : Cstruct.t -> int -> seg array
+
+  module type PROTOCOL_IMPLEMENTATION = sig
+    val total_size : int
+    val segments_per_indirect_page : int
+    val write_segments : seg array -> Cstruct.t -> unit
+    val write_request : t -> Cstruct.t -> int64
+    val read_request : Cstruct.t -> t
+  end
+
+  module Proto_32 : PROTOCOL_IMPLEMENTATION
+  module Proto_64 : PROTOCOL_IMPLEMENTATION
+
+end
+
+module Res : sig
+  type rsp = | OK | Error | Not_supported
+
+  type t = {
+    op : Req.op option;
+    st : rsp option;
+  }
+
+  val write_response : int64 * t -> Cstruct.t -> unit
+
+  val read_response : Cstruct.t -> int64 * t
+end
+
+module Protocol : sig
+  type t = X86_64 | X86_32 | Native
+end
+
+module RingInfo : sig
+  type t = {
+    ref : int32;
+    event_channel : int;
+    protocol : Protocol.t;
+  }
+
+  val keys : string list
+  val to_string : t -> string
+  val of_assoc_list : (string * string) list -> (t, [`Msg of string]) result
+end