ocaml-libusb/lib/libusb.ml

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

let unref_devices = List.iter unref_device

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 claim_interface dh i =
  match L.claim_interface dh i with
  | Number _ -> assert false
  | Success -> Ok ()
  | e -> Error e

let release_interface dh i =
  match L.release_interface dh i with
  | Number _ -> assert false
  | Success -> Ok ()
  | 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;
      num_configurations = getf desc GT.device_descriptor_bnumconfigurations |> 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
  unref_devices 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)

(*
 a bigarray,
 a Ctypes.CArray.t value,
 memory returned by malloc,
 memoryreturned by Ctypes.allocate,
*)
let bulk_transfer ~device_handle ~endpoint ~buffer ~timeout () =
  let length = Bigarray.Array1.dim buffer in
  let transferred = allocate int 0 in
  match
    L.bulk_transfer
      device_handle
      (Unsigned.UInt8.of_int endpoint)
      (bigarray_start array1 buffer)
      length
      transferred
      (Unsigned.UInt.of_int timeout)
  with
  | Success -> Ok (!@ transferred)
  | Number n -> assert false
  | e -> Error e