--- a
+++ b/PC_Mainboard/Apps/cards/usb/card.ml
@@ -0,0 +1,178 @@
+(*
+ * card.ml
+ * -------
+ * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org>
+ * Licence   : BSD3
+ *
+ * This file is a part of [kro]bot.
+ *)
+
+open Lwt
+
+let fatal fmt = Printf.ksprintf (fun txt -> prerr_endline ("Fatal error: " ^ txt); exit 2) fmt
+
+(* +-----------------------------------------------------------------+
+   | Messages                                                        |
+   +-----------------------------------------------------------------+ *)
+
+let data_length = 52
+  (* Taille en octet du corps d'un message *)
+
+type serial = int
+    (* Type d'un numéro de série d'un message *)
+
+type message = {
+  host_serial : serial;
+  (* Le numéro de série du message, émis par l'ordinateur. Vaut 0 pour
+     les messages émis par le PIC. *)
+
+  device_serial : serial;
+  (* Le numéro de série du message, émis par le PIC. Vaut 0 pour les
+     messages émis par l'ordinateur. *)
+
+  command : int;
+  (* La commande, en fait c'est plutôt le type du message *)
+
+  error : int;
+  (* Si c'est un message d'erreur ce flag est non-nul *)
+
+  data : string;
+  (* Les données du messages, il y a 52 octets. *)
+}
+
+let make_buffer () = String.make data_length '\000'
+
+(* Parse un message depuis un buffer brut: *)
+let parse_message buf = {
+  host_serial = Char.code buf.[Protocol.up_hseq];
+  device_serial = Char.code buf.[Protocol.up_dseq];
+  command = Char.code buf.[Protocol.up_cmd];
+  error = Char.code buf.[Protocol.up_err];
+  data = String.sub buf Protocol.up_data 52;
+}
+
+(* Créé un buffer brut depuis un message: *)
+let forge_message msg =
+  let buf = String.make 64 '\000' in
+  buf.[Protocol.up_hseq] <- Char.chr msg.host_serial;
+  buf.[Protocol.up_dseq] <- Char.chr msg.device_serial;
+  buf.[Protocol.up_cmd] <- Char.chr msg.command;
+  buf.[Protocol.up_err] <- Char.chr msg.error;
+  if String.length msg.data > 52 then
+    fatal "message trop grand pour être envoyé"
+  else begin
+    String.blit msg.data 0 buf Protocol.up_data (String.length msg.data);
+    buf
+  end
+
+(* +-----------------------------------------------------------------+
+   | Connections                                                     |
+   +-----------------------------------------------------------------+ *)
+
+module SerialMap = Map.Make(struct type t = serial let compare = compare end)
+
+type t = {
+
+  mutable serial_pool : serial list;
+  (* Pool de serial disponibles, comme il n'y a que 256 serial
+     disponibles on évite de juste incrémenter un compteur au pif. *)
+
+  mutable reply_waiters : (string Lwt.t * string Lwt.u) SerialMap.t;
+  (* Threads en attente d'une réponse *)
+
+  handle : USB.handle;
+  (* Handle pour le périphérique usb *)
+
+  kernel_active : bool;
+  (* Est-ce qu'un driver noyau était attaché à la carte avant qu'on
+     l'utilise ? *)
+
+  mutex : Lwt_mutex.t;
+  (* Mutex pour envoyer des commandes, les cartes n'aiment pas les
+     appels parallèles. *)
+
+  mutable abort : bool;
+}
+
+let close k =
+  lwt _ = USB.release_interface k.handle 0 in
+  if k.kernel_active then USB.attach_kernel_driver k.handle 0;
+  USB.close k.handle;
+  return ()
+
+let rec dispatch k =
+  let buffer = String.create 64 in
+  lwt len = USB.interrupt_recv ~handle:k.handle ~endpoint:1 buffer 0 64 in
+  if len <> 64 then
+    fatal "message de moins de 64 octets reçu!"
+  else begin
+    let msg = parse_message buffer in
+    if msg.command = Protocol.cmd_respond then begin
+      (* Réponse à un message *)
+      match try Some(SerialMap.find msg.host_serial k.reply_waiters) with Not_found -> None with
+        | Some (_, w) ->
+            k.reply_waiters <- SerialMap.remove msg.host_serial k.reply_waiters;
+            k.serial_pool <- k.serial_pool @ [msg.host_serial];
+            Lwt.wakeup w msg.data
+        | None ->
+            ()
+    end;
+    dispatch k
+  end
+
+let open_card ~vendor_id ~product_id =
+  let handle = USB.open_device_with ~vendor_id ~product_id in
+  lwt _ = USB.reset_device handle in
+  let kernel_active = USB.kernel_driver_active handle 0 in
+  if kernel_active then USB.detach_kernel_driver handle 0;
+  lwt _ = USB.set_configuration handle 1 in
+  lwt _ = USB.claim_interface handle 0 in
+  let k = { serial_pool = (let rec loop = function
+                             | 256 -> []
+                             | n -> n :: loop (n + 1)
+                           in
+                           loop 1);
+            reply_waiters = SerialMap.empty;
+            handle = handle;
+            kernel_active = kernel_active;
+            mutex = Lwt_mutex.create ();
+            abort = false } in
+  let _ = Lwt_sequence.add_l (fun _ -> close k) Lwt_main.exit_hooks in
+  ignore (dispatch k);
+  return k
+
+(* Envoie une commande et attend une réponse: *)
+let send_request k command data =
+  if k.abort then fail (Failure "abort") else begin
+    let serial = match k.serial_pool with
+      | [] ->
+          fatal "plus aucun serial disponible!"
+      | s :: l ->
+          k.serial_pool <- l;
+          s
+    in
+    let (w1, w2) as w = Lwt.wait () in
+    k.reply_waiters <- SerialMap.add serial w k.reply_waiters;
+    let buffer = forge_message { host_serial = serial;
+                                 device_serial = 0;
+                                 command = command;
+                                 error = 0;
+                                 data = data } in
+    Lwt_mutex.with_lock k.mutex
+      (fun _ -> USB.interrupt_send ~handle:k.handle ~endpoint:1 buffer 0 64 >> w1)
+  end
+
+(* Envoie une commande et attend une commande: *)
+let send_command k command data =
+  if k.abort then fail (Failure "abort") else begin
+    let buffer = forge_message { host_serial = 0;
+                                 device_serial = 0;
+                                 command = command;
+                                 error = 0;
+                                 data = data } in
+  lwt _ = USB.interrupt_send ~handle:k.handle ~endpoint:1 buffer 0 64 in
+  return ()
+ end
+
+
+let connect card command = failwith "not implemented"