Commit initial

lib/generator/g.ml

@@ -0,0 +1,21 @@
+open Ctypes
+
+module U = T.Types(My_types)
+
+module P(F:Cstubs.FOREIGN) = struct
+  open F
+  let error_name =                  foreign "libusb_error_name"                  (U.error @-> returning string)
+  let error_description =           foreign "libusb_strerror"                    (U.error @-> returning string)
+  let init =                        foreign "libusb_init"                        (ptr void @-> returning U.error)
+  let exit =                        foreign "libusb_exit"                        (ptr void @-> returning void)
+  let get_version =                 foreign "libusb_get_version"                 (void @-> returning (ptr U.version))
+  let get_device_list =             foreign "libusb_get_device_list"             (ptr void @-> ptr (ptr (ptr U.device)) @-> returning U.error)
+  let free_device_list =            foreign "libusb_free_device_list"            (ptr (ptr U.device) @-> int @-> returning void)
+  let unref_device =                foreign "libusb_unref_device"                (ptr U.device @-> returning void)
+  let open_device =                 foreign "libusb_open"                        (ptr U.device @-> ptr (ptr U.device_handle) @-> returning U.error)
+  let close_device =                foreign "libusb_close"                       (ptr U.device_handle @-> returning void)
+  let get_device_descriptor =       foreign "libusb_get_device_descriptor"       (ptr U.device @-> ptr U.device_descriptor @-> returning U.error)
+  let get_string_descriptor_ascii = foreign "libusb_get_string_descriptor_ascii" (ptr U.device_handle @-> uint8_t @-> ptr char @-> int @-> returning U.error)
+  let control_transfer =            foreign "libusb_control_transfer"            (ptr U.device_handle @-> uint8_t @-> uint8_t @-> uint16_t @-> uint16_t @-> ptr char @-> uint16_t @-> uint @-> returning U.error)
+  let bulk_transfer =               foreign "libusb_bulk_transfer"               (ptr U.device_handle @-> uint8_t @-> ptr char @-> int @-> ptr int @-> uint @-> returning U.error)
+end

lib/generator/generator.ml

@@ -0,0 +1,16 @@
+open G
+
+let () =
+
+  (***  C part ***)
+  let oc = open_out "cstub_libusb.c" in
+  let cstub = Format.formatter_of_out_channel oc in
+  Format.fprintf cstub "#include <libusb.h>\n";
+  Cstubs.write_c cstub "libusb" (module P);
+  close_out oc;
+
+  (***  ML part ***)
+  let oc = open_out "bindings.ml" in
+  let bindings = Format.formatter_of_out_channel oc in
+  Cstubs.write_ml bindings "libusb" (module P);
+  close_out oc

lib/generator/jbuild

@@ -0,0 +1,6 @@
+(executable(
+           (name generator)
+           (libraries (ctypes.stubs))
+))
+
+(copy_files stubs/{t,my_types}.ml)

lib/generator/stubs/c_types_generator/c_types_generator.ml

@@ -0,0 +1,3 @@
+let () =
+  Format.fprintf Format.std_formatter "#include <libusb.h>@.";
+  Cstubs.Types.write_c Format.std_formatter (module T.Types)

lib/generator/stubs/c_types_generator/jbuild

@@ -0,0 +1,9 @@
+(executable(
+           (name c_types_generator)
+           (libraries (ctypes.stubs))
+))
+
+(rule(
+     (targets (t.ml))
+     (action (copy ../t.ml t.ml))
+))

lib/generator/stubs/ctypes_cflags_generator/ctypes_cflags_generator.ml

@@ -0,0 +1,5 @@
+Printf.printf "-I%s%!"
+  (
+    Findlib.init ();
+    Findlib.package_directory "ctypes"
+  )

lib/generator/stubs/ctypes_cflags_generator/jbuild

@@ -0,0 +1,4 @@
+(executable(
+           (name ctypes_cflags_generator)
+           (libraries (findlib))
+))

lib/generator/stubs/jbuild

@@ -0,0 +1,36 @@
+(rule(
+     (targets (my_types.ml))
+     (deps (my_types_generator.exe))
+     (action (with-stdout-to ${@} (run ${<})))
+))
+
+(rule(
+     (targets (my_types_generator.exe))
+     (deps (my_types_generator.c))
+     (action (run ${CC}
+               -o ${@}
+               ${read:libusb_cflags}
+               ${read:ctypes_cflags}
+               -I${ocaml-config:standard_library}
+               ${<}))
+))
+
+(rule(
+     (targets (my_types_generator.c))
+     (action
+      (with-stdout-to ${@}
+       (run c_types_generator/c_types_generator.exe)
+     ))
+))
+
+(rule(
+     (targets (ctypes_cflags))
+     (action (with-stdout-to ${@}
+              (run ctypes_cflags_generator/ctypes_cflags_generator.exe)))
+))
+
+(rule(
+     (targets (libusb_cflags))
+     (action (with-stdout-to ${@}
+              (run libusb_cflags_generator/libusb_cflags_generator.exe)))
+))

lib/generator/stubs/libusb_cflags_generator/jbuild

@@ -0,0 +1,4 @@
+(executable(
+           (name libusb_cflags_generator)
+           (libraries (configurator))
+))

lib/generator/stubs/libusb_cflags_generator/libusb_cflags_generator.ml

@@ -0,0 +1,14 @@
+let (>>|) a f = match a with None -> None | Some a -> f a
+
+let libusb_c_flags =
+  let open Configurator in
+  create "c"
+  |> Pkg_config.get
+  >>| Pkg_config.query ~package:"libusb-1.0"
+  >>| (fun Pkg_config.{cflags} ->
+      Some (String.concat " " cflags))
+  |> (function
+      | None -> "libusb flag not found"
+      | Some f -> f)
+
+let () = Printf.printf "%s%!" libusb_c_flags

lib/generator/stubs/t.ml

@@ -0,0 +1,117 @@
+open Ctypes
+
+type error =
+  | Number of int             (** A positive number *)
+	| Success                   (** Success (no error) *)
+  | Error_io                  (** Input/output error *)
+  | Error_invalid_param       (** Invalid parameter *)
+  | Error_access              (** Access denied (insufficient permissions) *)
+  | Error_no_device           (** No such device (it may have been disconnected) *)
+  | Error_not_found           (** Entity not found *)
+  | Error_busy                (** Resource busy *)
+  | Error_timeout             (** Operation timed out *)
+  | Error_overflow            (** Overflow *)
+  | Error_pipe                (** Pipe error *)
+  | Error_interrupted         (** System call interrupted (perhaps due to signal) *)
+  | Error_no_mem              (** Insufficient memory *)
+  | Error_not_supported       (** Operation not supported or unimplemented on this platform *)
+  | Error_other               (** Other error *)
+
+type version = {
+  major: int;                   (** Library major version *)
+  minor: int;                   (** Library major version *)
+  micro: int;                   (** Library micro version *)
+  nano: int;                    (** Library nano version *)
+  rc: string;                   (** Library release candidate suffix string, e.g. "-rc4" *)
+  describe: string;             (** For ABI compatibility only *)
+}
+
+type device_descriptor = {
+  id_vendor: int;	      (** Vendor ID. *)
+  id_product: int;   	  (** Product ID.*)
+  i_manufacturer: int;	(** Index of string descriptor describing manufacturer. *)
+  i_product: int;	      (** Index of string descriptor describing product. *)
+}
+
+module Types(T:Cstubs.Types.TYPE) = struct
+  let success              = T.constant "LIBUSB_SUCCESS"             T.int64_t
+  let error_io             = T.constant "LIBUSB_ERROR_IO"            T.int64_t
+  let error_invalid_param  = T.constant "LIBUSB_ERROR_INVALID_PARAM" T.int64_t
+  let error_access         = T.constant "LIBUSB_ERROR_ACCESS"        T.int64_t
+  let error_no_device      = T.constant "LIBUSB_ERROR_NO_DEVICE"     T.int64_t
+  let error_not_found      = T.constant "LIBUSB_ERROR_NOT_FOUND"     T.int64_t
+  let error_busy           = T.constant "LIBUSB_ERROR_BUSY"          T.int64_t
+  let error_timeout        = T.constant "LIBUSB_ERROR_TIMEOUT"       T.int64_t
+  let error_overflow       = T.constant "LIBUSB_ERROR_OVERFLOW"      T.int64_t
+  let error_pipe           = T.constant "LIBUSB_ERROR_PIPE"          T.int64_t
+  let error_interrupted    = T.constant "LIBUSB_ERROR_INTERRUPTED"   T.int64_t
+  let error_no_mem         = T.constant "LIBUSB_ERROR_NO_MEM"        T.int64_t
+  let error_not_supported  = T.constant "LIBUSB_ERROR_NOT_SUPPORTED" T.int64_t
+  let error_other          = T.constant "LIBUSB_ERROR_OTHER"         T.int64_t
+
+  let error = T.enum "libusb_error" [
+      Success,               success;
+      Error_io,              error_io;
+      Error_invalid_param,   error_invalid_param ;
+      Error_access,          error_access ;
+	    Error_no_device,       error_no_device ;
+	    Error_not_found,       error_not_found;
+ 	    Error_busy,   	       error_busy ;
+      Error_timeout,         error_timeout;
+      Error_overflow,        error_overflow;
+	    Error_pipe,  	         error_pipe ;
+      Error_interrupted,     error_interrupted;
+	    Error_no_mem,          error_no_mem ;
+      Error_not_supported,   error_not_supported;
+      Error_other,           error_other ;
+    ] ~unexpected:(fun x -> Number (Int64.to_int x))
+
+  let request_type_standard  = T.constant "LIBUSB_REQUEST_TYPE_STANDARD" T.int64_t
+  let request_type_class     = T.constant "LIBUSB_REQUEST_TYPE_CLASS"    T.int64_t
+  let request_type_vendor    = T.constant "LIBUSB_REQUEST_TYPE_VENDOR"   T.int64_t
+  let request_type_reserved  = T.constant "LIBUSB_REQUEST_TYPE_RESERVED" T.int64_t
+
+  let endpoint_direction_in  = T.constant "LIBUSB_ENDPOINT_IN"  T.int64_t
+  let endpoint_direction_out = T.constant "LIBUSB_ENDPOINT_OUT" T.int64_t
+
+  let libusb_recipient_device    = T.constant "LIBUSB_RECIPIENT_DEVICE"    T.int64_t
+  let libusb_recipient_interface = T.constant "LIBUSB_RECIPIENT_INTERFACE" T.int64_t
+  let libusb_recipient_endpoint  = T.constant "LIBUSB_RECIPIENT_ENDPOINT"  T.int64_t
+  let libusb_recipient_other     = T.constant "LIBUSB_RECIPIENT_OTHER"     T.int64_t
+
+  type version
+  let version : version structure typ = structure "libusb_version"
+  let (|:) n t = field version n t
+  let version_major = "major" |: uint16_t
+  let version_minor = "minor" |: uint16_t
+  let version_micro = "micro" |: uint16_t
+  let version_nano = "nano" |: uint16_t
+  let version_rc = "rc" |: string
+  let version_describe = "describe" |: string
+  let () = seal version
+
+  type device
+  let device : device structure typ = structure "libusb_device"
+
+  type device_handle
+  let device_handle : device_handle structure typ = structure "libusb_device_handle"
+
+  type device_descriptor
+  let device_descriptor : device_descriptor structure typ = structure "libusb_device_descriptor"
+  let (|:) n t = field device_descriptor n t
+  let device_descriptor_blength =            "bLength"            |: uint8_t  (* Size of this descriptor (in bytes) *)
+  let device_descriptor_bdescriptortype =    "bDescriptorType"    |: uint8_t  (* Descriptor type. *)
+  let device_descriptor_bcdusb =             "bcdUSB"             |: uint16_t (* USB specification release number in binary-coded decimal. *)
+  let device_descriptor_bdeviceclass =       "bDeviceClass"       |: uint8_t  (* USB-IF class code for the device. *)
+  let device_descriptor_bdevicesubclass =    "bDeviceSubClass"    |: uint8_t  (* USB-IF subclass code for the device, qualified by the bDeviceClass value. *)
+  let device_descriptor_bdeviceprotocol =    "bDeviceProtocol"    |: uint8_t  (* USB-IF protocol code for the device, qualified by the bDeviceClass and bDeviceSubClass values. *)
+  let device_descriptor_bmaxpacketsize0 =    "bMaxPacketSize0"    |: uint8_t  (* Maximum packet size for endpoint 0. *)
+  let device_descriptor_idvendor =           "idVendor"           |: uint16_t (* USB-IF vendor ID. *)
+  let device_descriptor_idproduct =          "idProduct"          |: uint16_t (* USB-IF product ID.*)
+  let device_descriptor_bcddevice =          "bcdDevice"          |: uint16_t (* Device release number in binary-coded decimal. *)
+  let device_descriptor_imanufacturer =      "iManufacturer"      |: uint8_t  (* Index of string descriptor describing manufacturer. *)
+  let device_descriptor_iproduct =           "iProduct"           |: uint8_t  (* Index of string descriptor describing product. *)
+  let device_descriptor_iserialnumber =      "iSerialNumber"      |: uint8_t  (* Index of string descriptor containing device serial number. *)
+  let device_descriptor_bnumconfigurations = "bNumConfigurations" |: uint8_t 	(* Number of possible configurations.  *)
+  let () = seal device_descriptor
+end

lib/jbuild

@@ -0,0 +1,30 @@
+(library(
+        (name libusb)
+        (public_name libusb)
+        (libraries (ctypes))
+        (c_names (cstub_libusb))
+        (c_flags (:include libusb_cflags_and_no_discarded_qualifiers))
+        (c_library_flags (-lusb-1.0))
+))
+
+(rule(
+     (targets (libusb_cflags_and_no_discarded_qualifiers))
+     (deps (generator/stubs/libusb_cflags))
+     (action (with-stdout-to ${@}
+              (progn
+               (echo "(")
+               (cat ${<})
+               (echo "  -Wno-discarded-qualifiers")
+               (echo ")")
+              )
+     ))
+))
+
+(copy_files generator/g.ml)
+(copy_files generator/stubs/{t,my_types}.ml)
+
+(rule(
+     (targets (cstub_libusb.c bindings.ml))
+     (deps (generator/generator.exe))
+     (action (run ${<}))
+))

lib/libusb.ml

@@ -0,0 +1,135 @@
+open Ctypes
+
+include T
+module L = G.P(Bindings)
+module GT = G.U
+
+let request_type_standard = GT.request_type_standard |> Signed.Int64.to_int
+let request_type_class    = GT.request_type_class    |> Signed.Int64.to_int
+let request_type_vendor   = GT.request_type_vendor   |> Signed.Int64.to_int
+let request_type_reserved = GT.request_type_reserved |> Signed.Int64.to_int
+
+let endpoint_direction_in  = GT.endpoint_direction_in  |> Signed.Int64.to_int
+let endpoint_direction_out = GT.endpoint_direction_out |> Signed.Int64.to_int
+
+let recipient_device    = GT.libusb_recipient_device    |> Signed.Int64.to_int
+let recipient_interface = GT.libusb_recipient_interface |> Signed.Int64.to_int
+let recipient_endpoint  = GT.libusb_recipient_endpoint  |> Signed.Int64.to_int
+let recipient_other     = GT.libusb_recipient_other     |> Signed.Int64.to_int
+
+let string_of_error = function
+  | Success -> "Success"
+  | Number n -> Printf.sprintf "Positive number: %d" n
+  | e -> L.error_name e
+
+let description_of_error = function
+  | Success -> "Success"
+  | Number n -> Printf.sprintf "Positive number: %d" n
+  | e -> L.error_description e
+
+let init_libusb () =
+  match L.init null with
+  | Success -> Ok ()
+  | Number _ -> assert false
+  | e -> Error e
+
+let exit_libusb () = L.exit null
+
+let get_version () =
+  let sv = !@ (L.get_version ()) in
+  {
+    major = getf sv GT.version_major |> Unsigned.UInt16.to_int;
+    minor = getf sv GT.version_minor |> Unsigned.UInt16.to_int;
+    micro = getf sv GT.version_micro |> Unsigned.UInt16.to_int;
+    nano = getf sv GT.version_nano |> Unsigned.UInt16.to_int;
+    rc = getf sv GT.version_rc;
+    describe = getf sv GT.version_describe;
+  }
+
+type device = GT.device structure ptr
+
+let get_device_list () =
+  let dl =
+    from_voidp GT.device null
+    |> allocate (ptr GT.device)
+    |> allocate (ptr (ptr GT.device)) in
+
+  match L.get_device_list null dl with
+  | Success ->
+    L.free_device_list !@dl 0;
+    Ok []
+  | Number nb_devices ->
+    let l = CArray.from_ptr !@dl nb_devices
+            |> CArray.to_list in
+    L.free_device_list !@dl 0;
+    Ok l
+  | err -> Error err
+
+let unref_device d = L.unref_device d
+
+type device_handle = GT.device_handle structure ptr
+
+let open_device ?(unref=true) d =
+  let h = from_voidp GT.device_handle null
+          |> allocate (ptr GT.device_handle) in
+  match L.open_device d h with
+  | Success ->
+    if unref then unref_device d;
+    Ok !@h
+  | Number _ -> assert false
+  | e -> Error e
+
+let close_device h = L.close_device h
+
+let get_device_descriptor d =
+  let desc = make GT.device_descriptor in
+  match L.get_device_descriptor d (addr desc) with
+  | Success ->
+    Ok {
+      id_vendor = getf desc GT.device_descriptor_idvendor |> Unsigned.UInt16.to_int;
+      id_product = getf desc GT.device_descriptor_idproduct |> Unsigned.UInt16.to_int;
+      i_manufacturer = getf desc GT.device_descriptor_imanufacturer |> Unsigned.UInt8.to_int;
+      i_product = getf desc GT.device_descriptor_iproduct |> Unsigned.UInt8.to_int;
+    }
+  | Number _ -> assert false
+  | e -> Error e
+
+let get_string_descriptor d i =
+  if
+    i <= 0
+  then
+    Error Error_not_found
+  else
+    let sz = Unsigned.UInt8.(to_int max_int) in
+    let strptr = allocate_n char ~count:sz in
+    match L.get_string_descriptor_ascii d (Unsigned.UInt8.of_int i) strptr sz with
+    | Success -> assert false
+    | Number n -> Ok (string_from_ptr strptr ~length:n |> String.trim)
+    | e -> Error e
+
+let is_vendor v d =
+  match get_device_descriptor d with
+  | Ok dd -> dd.id_vendor = v
+  | _ -> false
+
+let is_product p d =
+match get_device_descriptor d with
+  | Ok dd -> dd.id_product = p
+  | _ -> false
+
+let filter_devices f dl =
+  let keep, unref = List.partition f dl in
+  List.iter unref_device unref;
+  keep
+
+let control_transfer ~device_handle ~request_type ~request ~value ~index ~buffer ~timeout =
+  let sz = Bigarray.Array1.dim buffer in
+  L.control_transfer
+    device_handle
+    (Unsigned.UInt8.of_int request_type)
+    (Unsigned.UInt8.of_int request)
+    (Unsigned.UInt16.of_int value)
+    (Unsigned.UInt16.of_int index)
+    (bigarray_start array1 buffer)
+    (Unsigned.UInt16.of_int sz)
+    (Unsigned.UInt.of_int timeout)

lib/libusb.mli

@@ -0,0 +1,89 @@
+open Ctypes
+include module type of T
+
+
+(** {1 Errors} *)
+
+val string_of_error: error -> string
+
+val description_of_error: error -> string
+
+(** {1 Flags} *)
+
+val request_type_standard: int
+val request_type_class:    int
+val request_type_vendor:   int
+val request_type_reserved: int
+
+val endpoint_direction_in:  int
+val endpoint_direction_out: int
+
+val recipient_device:    int
+val recipient_interface: int
+val recipient_endpoint:  int
+val recipient_other:     int
+
+(** {1 Initialisation}  *)
+
+val init_libusb: unit -> (unit, error) result
+(** This function must be called before calling any other libusb function. *)
+
+val exit_libusb: unit -> unit
+(** Should be called after closing all open devices and before your application terminates. *)
+
+val get_version: unit -> version
+(** @return the version of the running libusb library *)
+
+(** {1 Devices enumeration} *)
+
+type device
+(** A C pointer to a device *)
+
+val get_device_list: unit -> (device list, error) result
+(** @return a list of C pointers to libusb devices.
+
+    Each device returned in the list has it's reference counter set to 1. Do not
+    forget to {!Libusb.unref_device} each of them after use. *)
+
+val unref_device: device -> unit
+(** Decrement the reference count of a device.
+
+    If the decrement operation causes the reference count to reach zero, the
+    device shall be destroyed. *)
+
+val is_vendor: int -> device -> bool
+(** [is_vendor vend d] checks if device [d] vendor id is [vend]  *)
+
+val is_product: int -> device -> bool
+(** [is_product prod d] checks if device [d] product id is [prod]  *)
+
+val filter_devices: (device -> bool) -> device list -> device list
+(** [filter_devices f dl] filters [dl] devices list using [f].
+    The devices of [dl] which are not part of the returned list are
+    unreferenced with {!Libusb.unref_device}. *)
+
+(** {1 Device opening} *)
+
+type device_handle
+(** A opaque type to manipulate opened devices *)
+
+val open_device: ?unref:bool -> device -> (device_handle, error) result
+(** Opens the device.
+
+    The C libusb library device opening increments the device reference count.
+
+    If the operation is successfull, and if [unref] is true (which is it's
+   default value) {!Libusb.open_device} decrements the device reference counter
+   of the device: this allows the device to be destroyed automatically when
+   {!Libusb.close_device} will be called. *)
+
+val close_device: device_handle -> unit
+(** Closes the device. This operation decrements the reference counter. *)
+
+val get_device_descriptor: device -> (device_descriptor, error) result
+
+val get_string_descriptor: device_handle -> int -> (string, error) result
+
+(** {1 Transfers} *)
+
+val control_transfer: device_handle:device_handle -> request_type:int -> request:int -> value:int -> index:int -> buffer:(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t -> timeout:int -> error

libusb.opam

@@ -0,0 +1,17 @@
+opam-version: "1.2"
+name: "extremes"
+version: "2017-11-20-1"
+maintainer: "Matthieu Dubuget <matthieu.dubuget@metalscan.fr>"
+authors: "Matthieu Dubuget <matthieu.dubuget@metalscan.fr>"
+homepage: "none"
+bug-reports: "Matthieu Dubuget <matthieu.dubuget@gmail.com>"
+
+build: [
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+
+license: "Not yet decided"
+bug-reports: "dontuse@metalscan.fr"
+depends: [
+  "jbuilder" {build & >= "1.0+beta13"}
+]