From: Jérémie D. <Ba...@us...> - 2010-02-23 21:11:31
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "krobot". The branch, master has been updated via d5dd29f7cee70a51a4bbfb294b48c970927ace06 (commit) from 55485c76b7ae61643fb73003c6f7c02ec144c984 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d5dd29f7cee70a51a4bbfb294b48c970927ace06 Author: Jérémie Dimino <je...@di...> Date: Tue Feb 23 22:10:51 2010 +0100 [generators] remove some ugly hacks ----------------------------------------------------------------------- Changes: diff --git a/PC_Mainboard/driver/card.ml b/PC_Mainboard/driver/card.ml deleted file mode 100644 index 4956a72..0000000 --- a/PC_Mainboard/driver/card.ml +++ /dev/null @@ -1,350 +0,0 @@ -(* - * card.ml - * ------- - * Copyright : (c) 2009, Jeremie Dimino <je...@di...> - * Licence : BSD3 - * - * This file is a part of [kro]bot. - *) - -module Log = Lwt_log.Make(struct let section = "card" end) - -open Lwt - -(* +-----------------------------------------------------------------+ - | 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.[PcInterface.up_hseq]; - device_serial = Char.code buf.[PcInterface.up_dseq]; - command = Char.code buf.[PcInterface.up_cmd]; - error = Char.code buf.[PcInterface.up_err]; - data = String.sub buf PcInterface.up_data 52; -} - -(* Créé un buffer brut depuis un message: *) -let forge_message msg = - let buf = String.make 64 '\000' in - buf.[PcInterface.up_hseq] <- Char.chr msg.host_serial; - buf.[PcInterface.up_dseq] <- Char.chr msg.device_serial; - buf.[PcInterface.up_cmd] <- Char.chr msg.command; - buf.[PcInterface.up_err] <- Char.chr msg.error; - if String.length msg.data > 52 then - Printf.ksprintf invalid_arg "message body too big: %d > 52" (String.length msg.data) - else begin - String.blit msg.data 0 buf PcInterface.up_data (String.length msg.data); - buf - end - -(* +-----------------------------------------------------------------+ - | Definitions | - +-----------------------------------------------------------------+ *) - -exception Card_closed -exception Card_crashed of string - -module Int_map = Map.Make(struct type t = int let compare = compare end) - -(* Type of a up and running card *) -type card = { - 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.u Int_map.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 events : (string -> unit) Lwt_sequence.t Int_map.t; - (* Connected events *) - - abort_waiter : int Lwt.t; - abort_wakener : int Lwt.u; - (* Sleeping thread which is wakeup when the card is closed *) - - wrapper : wrapper; - (* The associated wrapper *) -} - -and state = - | Opened of card - | Closed of exn - -and wrapper = { - mutable state : state; - name : string; - watch : [ `Error of exn | `Closed ] Lwt.t; -} - -type t = wrapper - -let name wrapper = wrapper.name -let closed wrapper = match wrapper.state with - | Opened _ -> false - | Closed _ -> true - -let watch wrapper = wrapper.watch - -(* Return a running card, if possible. *) -let rec get_card wrapper = match wrapper.state with - | Opened card -> - return card - | Closed exn -> - fail exn - -(* +-----------------------------------------------------------------+ - | Aborting | - +-----------------------------------------------------------------+ *) - -let abort wrapper exn = - match wrapper.state with - | Closed exn -> - return exn - | Opened card -> - wrapper.state <- Closed exn; - try_lwt - lwt () = USB.release_interface card.handle 0 in - if card.kernel_active then USB.attach_kernel_driver card.handle 0; - USB.close card.handle; - return exn - finally - wakeup_exn card.abort_wakener exn; - Int_map.iter (fun serial w -> wakeup_exn w exn) card.reply_waiters; - return () - -(* +-----------------------------------------------------------------+ - | Dispatching | - +-----------------------------------------------------------------+ *) - -let dropped typ msg = - lwt () = Log.warning_f "%s dropped" typ in - lwt () = Log.warning_f "===== -host_serial = %d -device_serial = %d -command = %d -error = %d -data:" msg.host_serial msg.device_serial msg.command msg.error in - Lwt_stream.iter_s (fun line -> Log.warning line) (Lwt_stream.hexdump (Lwt_stream.of_string msg.data)) - -(* Dispatch incomming messages continously *) -let rec dispatch card = - let buffer = String.create 64 in - begin - try_lwt - select [card.abort_waiter; - USB.interrupt_recv - ~handle:card.handle - ~endpoint:1 - buffer 0 64] >|= fun len -> `OK len - with exn -> - return (`Error exn) - end >>= function - | `Error exn -> - lwt () = Log.exn_f exn "stop dispatching on %s card" card.wrapper.name in - lwt _ = abort card.wrapper exn in - return () - | `OK len -> - if len <> 64 then begin - let msg = Printf.sprintf "read on %s card returned %d instead of 64" card.wrapper.name len in - lwt () = Log.error msg in - lwt _ = abort card.wrapper (Card_crashed msg) in - return () - end else begin - let msg = parse_message buffer in - if msg.command = PcInterface.cmd_respond then begin - match try Some(Int_map.find msg.host_serial card.reply_waiters) with Not_found -> None with - | Some wakener -> - card.reply_waiters <- Int_map.remove msg.host_serial card.reply_waiters; - card.serial_pool <- card.serial_pool @ [msg.host_serial]; - Lwt.wakeup wakener msg.data - | None -> - ignore (dropped "response" msg) - end else begin - match try Some(Int_map.find msg.command card.events) with Not_found -> None with - | Some seq -> - Lwt_sequence.iter_l - (fun push -> - try - push msg.data - with exn -> - ignore (Log.exn_f exn "pushing event %d from %s card failed with" msg.command card.wrapper.name)) - seq - | None -> - ignore (dropped "command" msg) - end; - dispatch card - end - -(* +-----------------------------------------------------------------+ - | Opening and closing | - +-----------------------------------------------------------------+ *) - -let close wrapper = match wrapper.state with - | Opened _ -> - lwt _ = abort wrapper Card_closed in - return () - | Closed _ -> - return () - -let rec make ~name ~handle = - 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 abort_waiter, abort_wakener = wait () in - let rec card = { - serial_pool = (let rec loop = function - | 256 -> [] - | n -> n :: loop (n + 1) - in - loop 1); - reply_waiters = Int_map.empty; - events = Int_map.empty; - handle = handle; - kernel_active = kernel_active; - mutex = Lwt_mutex.create (); - abort_waiter = abort_waiter; - abort_wakener = abort_wakener; - wrapper = wrapper; - } and wrapper = { - state = Opened card; - name = name; - watch = (try_lwt - lwt _ = abort_waiter in - (* Never happen: *) - return `Closed - with - | Card_closed -> - return `Closed - | exn -> - return (`Error exn)) - } in - ignore (dispatch card); - return wrapper - -(* +-----------------------------------------------------------------+ - | Sending/receiving messages | - +-----------------------------------------------------------------+ *) - -let send card buffer = - lwt len = select [card.abort_waiter; USB.interrupt_send ~handle:card.handle ~endpoint:1 buffer 0 64] in - if len <> 64 then begin - let msg = Printf.sprintf "write on %s card returned %d instead of 64" card.wrapper.name len in - lwt () = Log.error msg in - fail =<< abort card.wrapper (Card_crashed msg) - end else - return () - -(* Send a command and wait for the response: *) -let rec send_request wrapper command data = - lwt card = get_card wrapper in - let serial = match card.serial_pool with - | [] -> - failwith "Card.send_request: no more serial available!" - | serial :: rest -> - card.serial_pool <- rest; - serial - in - let waiter, wakener = Lwt.task () in - card.reply_waiters <- Int_map.add serial wakener card.reply_waiters; - on_cancel waiter (fun () -> - card.reply_waiters <- Int_map.remove serial card.reply_waiters; - card.serial_pool <- card.serial_pool @ [serial]); - let buffer = forge_message { host_serial = serial; - device_serial = 0; - command = command; - error = 0; - data = data } in - try_lwt - Lwt_mutex.with_lock card.mutex - (fun () -> - lwt () = send card buffer in - waiter) - with - | Canceled -> - fail Canceled - | exn -> - lwt () = Log.exn_f exn "write to %s card failed with" wrapper.name in - fail =<< abort wrapper exn - -(* Send a command without waiting for the reply: *) -let rec send_command wrapper command data = - lwt card = get_card wrapper in - let buffer = forge_message { host_serial = 0; - device_serial = 0; - command = command; - error = 0; - data = data } in - try_lwt - Lwt_mutex.with_lock card.mutex (fun () -> send card buffer) - with - | Canceled -> - fail Canceled - | exn -> - lwt () = Log.exn_f exn "write to %s card failed with" wrapper.name in - fail =<< abort wrapper exn - -let connect wrapper command = match wrapper.state with - | Closed exn -> - raise exn - | Opened card -> - let event, push = React.E.create () in - let seq = - try - Int_map.find command card.events - with Not_found -> - let seq = Lwt_sequence.create () in - card.events <- Int_map.add command seq card.events; - seq - in - let node = Lwt_sequence.add_l push seq in - let stop = lazy( - Lwt_sequence.remove node; - if Lwt_sequence.is_empty seq then - card.events <- Int_map.remove command card.events; - React.E.stop event - ) in - (object - method event = event - method stop = Lazy.force stop - end) diff --git a/PC_Mainboard/driver/card.mli b/PC_Mainboard/driver/card.mli deleted file mode 100644 index d435a21..0000000 --- a/PC_Mainboard/driver/card.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* - * card.mli - * -------- - * Copyright : (c) 2009, Jeremie Dimino <je...@di...> - * Licence : BSD3 - * - * This file is a part of [kro]bot. - *) - -(** Lowlevel card interfaces *) - -type t - (** Type of a card *) - -val name : t -> string - (** Returns the name of a card. It can be applied on a closed - card. *) - -val closed : t -> bool - (** Returns [true] iff the card has been closed *) - -val watch : t -> [ `Error of exn | `Closed ] Lwt.t - (** [watch card] is a thread which is wakeup when the card is - closed, or when a fatal error happen. The argument describe the - reason. *) - -exception Card_closed - (** Exception raised when trying to use a closed card *) - -exception Card_crashed of string - (** Exception raised when a fatal error happen on the card *) - -(** {6 Card opening/closing} *) - -val make : name : string -> handle : USB.handle -> t Lwt.t - (** [make ~name ~handle] creates a card using the given USB - handle. [name] is used for debug messages. *) - -val close : t -> unit Lwt.t - (** Close the given card *) - -(** {6 Sending/receving messages} *) - -val make_buffer : unit -> string - (** Creates a new buffer for serialization (with the right size) *) - -val send_request : t -> int -> string -> string Lwt.t - (** [send_request card request data] sends a request to the USB - device and wait for the reply *) - -val send_command : t -> int -> string -> unit Lwt.t - (** Sends a command to the device *) - -val connect : t -> int -> < event : string React.event; stop : unit > - (** [connect card command] connects to signals [command] emitted by - [card] *) diff --git a/PC_Mainboard/driver/driver.ml b/PC_Mainboard/driver/driver.ml index b367a56..aa0b6f4 100644 --- a/PC_Mainboard/driver/driver.ml +++ b/PC_Mainboard/driver/driver.ml @@ -22,7 +22,7 @@ module Compass = struct type t = { obus : OBus_object.t; - card : Card.t; + card : Krobot_card.t; mutable data : int; } @@ -68,7 +68,7 @@ module AX12 = struct type t = { obus : OBus_object.t; - card : Card.t; + card : Krobot_card.t; } module OBus = OBus_object.Make(struct @@ -95,7 +95,7 @@ module Logic_sensors = struct type t = { obus : OBus_object.t; - card : Card.t; + card : Krobot_card.t; mutable data : bool array; } @@ -140,7 +140,7 @@ module Range_finders = struct type t = { obus : OBus_object.t; - card : Card.t; + card : Krobot_card.t; mutable data : int array; } @@ -219,7 +219,7 @@ struct type t = { obus : OBus_object.t; - card : Card.t; + card : Krobot_card.t; mutable inhibit_forward_until : float; mutable inhibit_backward_until : float; @@ -452,7 +452,7 @@ struct return () let make card path = - let commands = React.E.map (fun data -> Char.code data.[0]) (Card.connect card PcInterface.cmd_traj)#event in + let commands = React.E.map (fun data -> Char.code data.[0]) (Krobot_card.connect card PcInterface.cmd_traj)#event in let dev = { obus = OBus_object.make path; card = card; @@ -489,9 +489,9 @@ struct | None -> return () | Some card -> - Card.close card + Krobot_card.close card - OL_method CardStates : OBus_connection.t -> Types.card_state * Types.card_state * Types.card_state = fun () connection -> + OL_method Krobot_cardStates : OBus_connection.t -> Types.card_state * Types.card_state * Types.card_state = fun () connection -> let state card = match React.S.value card with | Some _ -> `Present | None -> `Absent @@ -515,10 +515,10 @@ end | Objects for cards | +-----------------------------------------------------------------+ *) -module MCard = +module Card = struct type t = { - card : Card.t option React.signal; + card : Krobot_card.t option React.signal; obus : OBus_object.t; name : string; mutable state : unit Lwt.t React.signal; @@ -535,12 +535,12 @@ struct | Some card -> card - include DBus_exports.Common(OBus)(struct let get = get_card end) + include DBus_exports.Card(OBus)(struct let get = get_card end) include OBus.MakeInterface(struct let name = "fr.krobot.Card" end) OL_property_r Name : string = fun dev -> - return (Card.name (get_card dev)) + return (Krobot_card.name (get_card dev)) OL_method GetState : Types.card_state = fun dev -> match React.S.value dev.card with @@ -550,19 +550,19 @@ struct return `Present OL_method GetFirmwareBuild : string = fun dev -> - USB_commands.Common.get_firmware_build (get_card dev) + USB_commands.Card.get_firmware_build (get_card dev) OL_method GetBoardInfo : string = fun dev -> - USB_commands.Common.get_board_info (get_card dev) + USB_commands.Card.get_board_info (get_card dev) OL_method Bootloader : unit = fun dev -> - USB_commands.Common.bootloader (get_card dev) + USB_commands.Card.bootloader (get_card dev) OL_method Reset : unit = fun dev -> - USB_commands.Common.reset (get_card dev) + USB_commands.Card.reset (get_card dev) OL_method Test : unit = fun dev -> - USB_commands.Common.test (get_card dev) + USB_commands.Card.test (get_card dev) OL_signal StateChanged : Types.card_state @@ -582,7 +582,7 @@ struct end (* +-----------------------------------------------------------------+ - | Cards management | + | Krobot_cards management | +-----------------------------------------------------------------+ *) (* Continously try to open the card with given parameters *) @@ -595,16 +595,16 @@ let rec monitor_card ~name ~vendor_id ~product_id ~set on_up on_down = lwt () = Log.info_f "%s card opened" name in begin try_lwt - lwt card = Card.make name handle in - return (`Card card) + lwt card = Krobot_card.make name handle in + return (`Krobot_card card) with exn -> return (`Error exn) end >>= function - | `Card card -> + | `Krobot_card card -> lwt () = Log.info_f "%s card is up and running" name in set (Some card); lwt () = on_up card in - lwt result = Card.watch card in + lwt result = Krobot_card.watch card in set None; lwt () = on_down () in lwt () = @@ -715,9 +715,9 @@ lwt () = return ()) end; - MCard.OBus.export bus (MCard.make "interface" card_interface ["fr"; "krobot"; "Cards"; "Interface"]); - MCard.OBus.export bus (MCard.make "sensor" card_sensor ["fr"; "krobot"; "Cards"; "Sensor"]); - MCard.OBus.export bus (MCard.make "motor" card_motor ["fr"; "krobot"; "Cards"; "Motor"]); + Card.OBus.export bus (Card.make "interface" card_interface ["fr"; "krobot"; "Cards"; "Interface"]); + Card.OBus.export bus (Card.make "sensor" card_sensor ["fr"; "krobot"; "Cards"; "Sensor"]); + Card.OBus.export bus (Card.make "motor" card_motor ["fr"; "krobot"; "Cards"; "Motor"]); Manager.OBus.export bus (); diff --git a/PC_Mainboard/driver/krobot_card.ml b/PC_Mainboard/driver/krobot_card.ml new file mode 100644 index 0000000..a2ba1be --- /dev/null +++ b/PC_Mainboard/driver/krobot_card.ml @@ -0,0 +1,350 @@ +(* + * krobot_card.ml + * -------------- + * Copyright : (c) 2009-2010, Jeremie Dimino <je...@di...> + * Licence : BSD3 + * + * This file is a part of [kro]bot. + *) + +module Log = Lwt_log.Make(struct let section = "card" end) + +open Lwt + +(* +-----------------------------------------------------------------+ + | 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.[PcInterface.up_hseq]; + device_serial = Char.code buf.[PcInterface.up_dseq]; + command = Char.code buf.[PcInterface.up_cmd]; + error = Char.code buf.[PcInterface.up_err]; + data = String.sub buf PcInterface.up_data 52; +} + +(* Créé un buffer brut depuis un message: *) +let forge_message msg = + let buf = String.make 64 '\000' in + buf.[PcInterface.up_hseq] <- Char.chr msg.host_serial; + buf.[PcInterface.up_dseq] <- Char.chr msg.device_serial; + buf.[PcInterface.up_cmd] <- Char.chr msg.command; + buf.[PcInterface.up_err] <- Char.chr msg.error; + if String.length msg.data > 52 then + Printf.ksprintf invalid_arg "message body too big: %d > 52" (String.length msg.data) + else begin + String.blit msg.data 0 buf PcInterface.up_data (String.length msg.data); + buf + end + +(* +-----------------------------------------------------------------+ + | Definitions | + +-----------------------------------------------------------------+ *) + +exception Card_closed +exception Card_crashed of string + +module Int_map = Map.Make(struct type t = int let compare = compare end) + +(* Type of a up and running card *) +type card = { + 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.u Int_map.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 events : (string -> unit) Lwt_sequence.t Int_map.t; + (* Connected events *) + + abort_waiter : int Lwt.t; + abort_wakener : int Lwt.u; + (* Sleeping thread which is wakeup when the card is closed *) + + wrapper : wrapper; + (* The associated wrapper *) +} + +and state = + | Opened of card + | Closed of exn + +and wrapper = { + mutable state : state; + name : string; + watch : [ `Error of exn | `Closed ] Lwt.t; +} + +type t = wrapper + +let name wrapper = wrapper.name +let closed wrapper = match wrapper.state with + | Opened _ -> false + | Closed _ -> true + +let watch wrapper = wrapper.watch + +(* Return a running card, if possible. *) +let rec get_card wrapper = match wrapper.state with + | Opened card -> + return card + | Closed exn -> + fail exn + +(* +-----------------------------------------------------------------+ + | Aborting | + +-----------------------------------------------------------------+ *) + +let abort wrapper exn = + match wrapper.state with + | Closed exn -> + return exn + | Opened card -> + wrapper.state <- Closed exn; + try_lwt + lwt () = USB.release_interface card.handle 0 in + if card.kernel_active then USB.attach_kernel_driver card.handle 0; + USB.close card.handle; + return exn + finally + wakeup_exn card.abort_wakener exn; + Int_map.iter (fun serial w -> wakeup_exn w exn) card.reply_waiters; + return () + +(* +-----------------------------------------------------------------+ + | Dispatching | + +-----------------------------------------------------------------+ *) + +let dropped typ msg = + lwt () = Log.warning_f "%s dropped" typ in + lwt () = Log.warning_f "===== +host_serial = %d +device_serial = %d +command = %d +error = %d +data:" msg.host_serial msg.device_serial msg.command msg.error in + Lwt_stream.iter_s (fun line -> Log.warning line) (Lwt_stream.hexdump (Lwt_stream.of_string msg.data)) + +(* Dispatch incomming messages continously *) +let rec dispatch card = + let buffer = String.create 64 in + begin + try_lwt + select [card.abort_waiter; + USB.interrupt_recv + ~handle:card.handle + ~endpoint:1 + buffer 0 64] >|= fun len -> `OK len + with exn -> + return (`Error exn) + end >>= function + | `Error exn -> + lwt () = Log.exn_f exn "stop dispatching on %s card" card.wrapper.name in + lwt _ = abort card.wrapper exn in + return () + | `OK len -> + if len <> 64 then begin + let msg = Printf.sprintf "read on %s card returned %d instead of 64" card.wrapper.name len in + lwt () = Log.error msg in + lwt _ = abort card.wrapper (Card_crashed msg) in + return () + end else begin + let msg = parse_message buffer in + if msg.command = PcInterface.cmd_respond then begin + match try Some(Int_map.find msg.host_serial card.reply_waiters) with Not_found -> None with + | Some wakener -> + card.reply_waiters <- Int_map.remove msg.host_serial card.reply_waiters; + card.serial_pool <- card.serial_pool @ [msg.host_serial]; + Lwt.wakeup wakener msg.data + | None -> + ignore (dropped "response" msg) + end else begin + match try Some(Int_map.find msg.command card.events) with Not_found -> None with + | Some seq -> + Lwt_sequence.iter_l + (fun push -> + try + push msg.data + with exn -> + ignore (Log.exn_f exn "pushing event %d from %s card failed with" msg.command card.wrapper.name)) + seq + | None -> + ignore (dropped "command" msg) + end; + dispatch card + end + +(* +-----------------------------------------------------------------+ + | Opening and closing | + +-----------------------------------------------------------------+ *) + +let close wrapper = match wrapper.state with + | Opened _ -> + lwt _ = abort wrapper Card_closed in + return () + | Closed _ -> + return () + +let rec make ~name ~handle = + 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 abort_waiter, abort_wakener = wait () in + let rec card = { + serial_pool = (let rec loop = function + | 256 -> [] + | n -> n :: loop (n + 1) + in + loop 1); + reply_waiters = Int_map.empty; + events = Int_map.empty; + handle = handle; + kernel_active = kernel_active; + mutex = Lwt_mutex.create (); + abort_waiter = abort_waiter; + abort_wakener = abort_wakener; + wrapper = wrapper; + } and wrapper = { + state = Opened card; + name = name; + watch = (try_lwt + lwt _ = abort_waiter in + (* Never happen: *) + return `Closed + with + | Card_closed -> + return `Closed + | exn -> + return (`Error exn)) + } in + ignore (dispatch card); + return wrapper + +(* +-----------------------------------------------------------------+ + | Sending/receiving messages | + +-----------------------------------------------------------------+ *) + +let send card buffer = + lwt len = select [card.abort_waiter; USB.interrupt_send ~handle:card.handle ~endpoint:1 buffer 0 64] in + if len <> 64 then begin + let msg = Printf.sprintf "write on %s card returned %d instead of 64" card.wrapper.name len in + lwt () = Log.error msg in + fail =<< abort card.wrapper (Card_crashed msg) + end else + return () + +(* Send a command and wait for the response: *) +let rec send_request wrapper command data = + lwt card = get_card wrapper in + let serial = match card.serial_pool with + | [] -> + failwith "Card.send_request: no more serial available!" + | serial :: rest -> + card.serial_pool <- rest; + serial + in + let waiter, wakener = Lwt.task () in + card.reply_waiters <- Int_map.add serial wakener card.reply_waiters; + on_cancel waiter (fun () -> + card.reply_waiters <- Int_map.remove serial card.reply_waiters; + card.serial_pool <- card.serial_pool @ [serial]); + let buffer = forge_message { host_serial = serial; + device_serial = 0; + command = command; + error = 0; + data = data } in + try_lwt + Lwt_mutex.with_lock card.mutex + (fun () -> + lwt () = send card buffer in + waiter) + with + | Canceled -> + fail Canceled + | exn -> + lwt () = Log.exn_f exn "write to %s card failed with" wrapper.name in + fail =<< abort wrapper exn + +(* Send a command without waiting for the reply: *) +let rec send_command wrapper command data = + lwt card = get_card wrapper in + let buffer = forge_message { host_serial = 0; + device_serial = 0; + command = command; + error = 0; + data = data } in + try_lwt + Lwt_mutex.with_lock card.mutex (fun () -> send card buffer) + with + | Canceled -> + fail Canceled + | exn -> + lwt () = Log.exn_f exn "write to %s card failed with" wrapper.name in + fail =<< abort wrapper exn + +let connect wrapper command = match wrapper.state with + | Closed exn -> + raise exn + | Opened card -> + let event, push = React.E.create () in + let seq = + try + Int_map.find command card.events + with Not_found -> + let seq = Lwt_sequence.create () in + card.events <- Int_map.add command seq card.events; + seq + in + let node = Lwt_sequence.add_l push seq in + let stop = lazy( + Lwt_sequence.remove node; + if Lwt_sequence.is_empty seq then + card.events <- Int_map.remove command card.events; + React.E.stop event + ) in + (object + method event = event + method stop = Lazy.force stop + end) diff --git a/PC_Mainboard/driver/krobot_card.mli b/PC_Mainboard/driver/krobot_card.mli new file mode 100644 index 0000000..06063a3 --- /dev/null +++ b/PC_Mainboard/driver/krobot_card.mli @@ -0,0 +1,56 @@ +(* + * krobot_card.mli + * --------------- + * Copyright : (c) 2009-2010, Jeremie Dimino <je...@di...> + * Licence : BSD3 + * + * This file is a part of [kro]bot. + *) + +(** Lowlevel card interfaces *) + +type t + (** Type of a card *) + +val name : t -> string + (** Returns the name of a card. It can be applied on a closed + card. *) + +val closed : t -> bool + (** Returns [true] iff the card has been closed *) + +val watch : t -> [ `Error of exn | `Closed ] Lwt.t + (** [watch card] is a thread which is wakeup when the card is + closed, or when a fatal error happen. The argument describe the + reason. *) + +exception Card_closed + (** Exception raised when trying to use a closed card *) + +exception Card_crashed of string + (** Exception raised when a fatal error happen on the card *) + +(** {6 Card opening/closing} *) + +val make : name : string -> handle : USB.handle -> t Lwt.t + (** [make ~name ~handle] creates a card using the given USB + handle. [name] is used for debug messages. *) + +val close : t -> unit Lwt.t + (** Close the given card *) + +(** {6 Sending/receving messages} *) + +val make_buffer : unit -> string + (** Creates a new buffer for serialization (with the right size) *) + +val send_request : t -> int -> string -> string Lwt.t + (** [send_request card request data] sends a request to the USB + device and wait for the reply *) + +val send_command : t -> int -> string -> unit Lwt.t + (** Sends a command to the device *) + +val connect : t -> int -> < event : string React.event; stop : unit > + (** [connect card command] connects to signals [command] emitted by + [card] *) diff --git a/PC_Mainboard/generators/gen_dbus_exports.ml b/PC_Mainboard/generators/gen_dbus_exports.ml index ae94a26..f761e04 100644 --- a/PC_Mainboard/generators/gen_dbus_exports.ml +++ b/PC_Mainboard/generators/gen_dbus_exports.ml @@ -70,12 +70,10 @@ let rec print path indent = function print_apply (sprintf "USB_commands.%s%s (Get.get dev)" path (Name.lid cmd.cmd_name)) cmd.cmd_args | Module(name, items) -> - printf "%smodule %s(M : Object.S)(Get : sig val get : M.t -> Card.t end) = struct\n" + printf "%smodule %s(M : Object.S)(Get : sig val get : M.t -> Krobot_card.t end) = struct\n" + indent (Name.uid name); + printf "%s include M.MakeInterface(struct let name = \"fr.krobot.Device.%s.Unsafe\" end)\n" indent (Name.uid name); - printf "%s include M.MakeInterface(struct let name = %S end)\n" indent - (match name with - | "common" -> "fr.krobot.Card.Unsafe" - | _ -> sprintf "fr.krobot.Device.%s.Unsafe" (Name.uid name)); List.iter (print (path ^ Name.uid name ^ ".") (indent ^ " ")) items; printf "%send\n" indent @@ -87,4 +85,10 @@ let rec print path indent = function let () = printf "open OBus_pervasives\n"; - List.iter (print "" "") interface + + printf "module Card(M : Object.S)(Get : sig val get : M.t -> Krobot_card.t end) = struct\n"; + printf " include M.MakeInterface(struct let name = \"fr.krobot.Card.Unsafe\" end)\n"; + List.iter (print "Card." " ") card; + printf "end\n"; + + List.iter (print "" "") interfaces diff --git a/PC_Mainboard/generators/gen_dbus_imports.ml b/PC_Mainboard/generators/gen_dbus_imports.ml index 9fe5e5f..cdd7552 100644 --- a/PC_Mainboard/generators/gen_dbus_imports.ml +++ b/PC_Mainboard/generators/gen_dbus_imports.ml @@ -48,19 +48,6 @@ let rec print indent = function cmd.cmd_args; printf "unit\n"; - | Module("common", items) -> - printf "%smodule Common = struct\n" indent; - printf "%s let proxy krobot (card : Krobot.Card.card) =\n" indent; - printf "%s OBus_proxy.make (Krobot.peer krobot)\n" indent; - printf "%s [\"fr\"; \"krobot\"; \"Cards\"; (match card with\n" indent; - printf "%s | `Interface -> \"Interface\"\n" indent; - printf "%s | `Sensor -> \"Sensor\"\n" indent; - printf "%s | `Motor -> \"Motor\")]\n" indent; - printf "%s let op_method_call member typ krobot card =\n" indent; - printf "%s OBus_proxy.method_call (proxy krobot card) ~interface:\"fr.krobot.Card.Unsafe\" ~member typ\n" indent; - List.iter (print (indent ^ " ")) items; - printf "%send\n" indent - | Module(name, items) -> printf "%smodule %s = struct\n" indent (Name.uid name); printf "%s include MakeDevice(struct let name = \"%s\" end)\n" indent (Name.caml_case name); @@ -85,5 +72,16 @@ module MakeDevice(Name : sig val name : string end) = (struct let name = \"fr.krobot.Device.\" ^ Name.name ^ \".Unsafe\" end) +module Card = struct + let proxy krobot (card : Krobot.Card.card) = + OBus_proxy.make (Krobot.peer krobot) + [\"fr\"; \"krobot\"; \"Cards\"; (match card with + | `Interface -> \"Interface\" + | `Sensor -> \"Sensor\" + | `Motor -> \"Motor\")] + let op_method_call member typ krobot card = + OBus_proxy.method_call (proxy krobot card) ~interface:\"fr.krobot.Card.Unsafe\" ~member typ "; - List.iter (print "") interface + List.iter (print " ") card; + printf "end\n"; + List.iter (print "") interfaces diff --git a/PC_Mainboard/generators/gen_script_commands.ml b/PC_Mainboard/generators/gen_script_commands.ml index 9f9298f..fd82083 100644 --- a/PC_Mainboard/generators/gen_script_commands.ml +++ b/PC_Mainboard/generators/gen_script_commands.ml @@ -80,23 +80,20 @@ let rec print path caml_path = function printf "]) ^ \"}\" in\n"; printf " let _ = print_%s in\n" (Name.lid record.rec_name) | Module(name, items) -> - let items = - if name = "common" then begin - printf "let __type_card name = keyword name [(\"interface\", `Interface); (\"sensor\", `Sensor); (\"motor\", `Motor)] in\n"; - let card = typ "card" in - List.map - (function - | Request req -> Request{ req with req_args = Arg("card", card) :: req.req_args } - | Command cmd -> Command{ cmd with cmd_args = Arg("card", card) :: cmd.cmd_args } - | item -> item) - items - end else - items - in List.iter (print (sprintf "%s; \"%s\"" path (String.lowercase name)) (caml_path ^ Name.uid name ^ ".")) items let () = printf "open Script_commands\n"; printf "let register () =\n"; - List.iter (print "\"unsafe\"" "") (List.filter (function Module _ -> true | _ -> false) interface); + printf " let __type_card name = keyword name [(\"interface\", `Interface); (\"sensor\", `Sensor); (\"motor\", `Motor)] in\n"; + let card_type = typ "card" in + List.iter + (print "\"unsafe\"" "Card.") + (List.map + (function + | Request req -> Request{ req with req_args = Arg("card", card_type) :: req.req_args } + | Command cmd -> Command{ cmd with cmd_args = Arg("card", card_type) :: cmd.cmd_args } + | item -> item) + card); + List.iter (print "\"unsafe\"" "") interfaces; printf " ()" diff --git a/PC_Mainboard/generators/gen_usb_commands.ml b/PC_Mainboard/generators/gen_usb_commands.ml index af190a9..70bfb92 100644 --- a/PC_Mainboard/generators/gen_usb_commands.ml +++ b/PC_Mainboard/generators/gen_usb_commands.ml @@ -20,7 +20,7 @@ let print_common indent name args = | Cst _ -> ()) args; printf " =\n"; - printf "%s let data = Card.make_buffer () in\n" indent; + printf "%s let data = Krobot_card.make_buffer () in\n" indent; if args <> [] then begin printf "%s let writer = RW.writer data in\n" indent; List.iter @@ -35,7 +35,7 @@ let print_common indent name args = let rec print indent = function | Request req -> print_common indent req.req_name req.req_args; - printf "%s lwt data = Card.send_request card %d data in\n" indent req.req_code; + printf "%s lwt data = Krobot_card.send_request card %d data in\n" indent req.req_code; if req.req_repl <> [] then begin printf "%s let reader = RW.reader data in\n" indent; let repl = @@ -56,7 +56,7 @@ let rec print indent = function printf "%s return ()\n" indent | Command cmd -> print_common indent cmd.cmd_name cmd.cmd_args; - printf "%s Card.send_command card %d data\n" indent cmd.cmd_code + printf "%s Krobot_card.send_command card %d data\n" indent cmd.cmd_code | Enum enum -> printf "%slet put_%s writer value =\n" indent (Name.lid enum.enum_name); printf "%s let code = match value with\n" indent; @@ -102,4 +102,4 @@ let rec print indent = function let () = printf "open Lwt\n"; printf "open RW\n"; - List.iter (print "") interface + List.iter (print "") (Module("card", card) :: interfaces) diff --git a/PC_Mainboard/interface/interface.ml b/PC_Mainboard/interface/interface.ml index 011678a..e00fdee 100644 --- a/PC_Mainboard/interface/interface.ml +++ b/PC_Mainboard/interface/interface.ml @@ -198,32 +198,34 @@ let typ name = | Interface | +-----------------------------------------------------------------+ *) -let interface = [ - Module("common", [ - request - ~name:"get-firmware-build" - ~code:PcInterface.get_firmware_build - ~repl:[Arg("date", string)] - (); - request - ~name:"get-board-info" - ~code:PcInterface.get_board_info - ~repl:[Arg("info", string)] - (); - command - ~name:"bootloader" - ~code:PcInterface.cmd_bootloader - (); - command - ~name:"reset" - ~code:PcInterface.cmd_reset - (); - command - ~name:"test" - ~code:PcInterface.cmd_test - (); - ]); +(* Card related commands *) +let card = [ + request + ~name:"get-firmware-build" + ~code:PcInterface.get_firmware_build + ~repl:[Arg("date", string)] + (); + request + ~name:"get-board-info" + ~code:PcInterface.get_board_info + ~repl:[Arg("info", string)] + (); + command + ~name:"bootloader" + ~code:PcInterface.cmd_bootloader + (); + command + ~name:"reset" + ~code:PcInterface.cmd_reset + (); + command + ~name:"test" + ~code:PcInterface.cmd_test + (); +] +(* All other interfaces *) +let interfaces = [ Module("compass", [ request ~name:"get" hooks/post-receive -- krobot |