curl_lwt.ml

   1 (** Lwt support for Curl *)
   2
   3 module M = Curl.Multi
   4
   5 type multi = {
   6   mt : Curl.Multi.mt;
   7   all_events : (Unix.file_descr, Lwt_engine.event list) Hashtbl.t;
   8   wakeners : (Curl.t, Curl.curlCode Lwt.u) Hashtbl.t;
   9 }
  10
  11 let create () =
  12   let mt = M.create () in
  13   let timer_event = ref Lwt_engine.fake_event in
  14   let all_events = Hashtbl.create 32 in
  15   let wakeners = Hashtbl.create 32 in
  16   let finished _ =
  17     let rec loop n =
  18       match M.remove_finished mt with
  19       | None -> ()
  20       | Some (h,code) ->
  21         begin try
  22           let w = Hashtbl.find wakeners h in
  23           Hashtbl.remove wakeners h;
  24           Lwt.wakeup w code
  25         with Not_found ->
  26           prerr_endline "curl_lwt: orphan handle, how come?"
  27         end;
  28         loop (n+1)
  29     in
  30     loop 0
  31   in
  32   let on_readable fd _ =
  33     let (_:int) = M.action mt fd M.EV_IN in
  34     finished "on_readable";
  35   in
  36   let on_writable fd _ =
  37     let (_:int) = M.action mt fd M.EV_OUT in
  38     finished "on_writable";
  39   in
  40   let on_timer _ =
  41     Lwt_engine.stop_event !timer_event;
  42     M.action_timeout mt;
  43     finished "on_timer"
  44   in
  45   M.set_timer_function mt begin fun timeout ->
  46     Lwt_engine.stop_event !timer_event; (* duplicate stop_event is ok *)
  47     timer_event := Lwt_engine.on_timer (float_of_int timeout /. 1000.) false on_timer
  48   end;
  49   M.set_socket_function mt begin fun fd what ->
  50     begin
  51     try
  52       List.iter Lwt_engine.stop_event (Hashtbl.find all_events fd);
  53       Hashtbl.remove all_events fd;
  54     with
  55       Not_found -> () (* first event for the socket - no association *)
  56     end;
  57     let events = match what with
  58     | M.POLL_REMOVE | M.POLL_NONE -> []
  59     | M.POLL_IN -> [Lwt_engine.on_readable fd (on_readable fd)]
  60     | M.POLL_OUT -> [Lwt_engine.on_writable fd (on_writable fd)]
  61     | M.POLL_INOUT -> [Lwt_engine.on_readable fd (on_readable fd); Lwt_engine.on_writable fd (on_writable fd)]
  62     in
  63     match events with
  64     | [] -> ()
  65     | _ -> Hashtbl.add all_events fd events;
  66   end;
  67   { mt; all_events; wakeners; }
  68
  69 (* lwt may not run in parallel so one global is OK'ish *)
  70 let global = lazy (create ())
  71
  72 let setopt opt =
  73   let t = Lazy.force global in
  74   M.setopt t.mt opt
  75
  76 let perform h =
  77   let t = Lazy.force global in
  78   let (waiter,wakener) = Lwt.wait () in
  79   let waiter = Lwt.protected waiter in
  80   Lwt.on_cancel waiter (fun () ->
  81     Curl.Multi.remove t.mt h;
  82     Hashtbl.remove t.wakeners h;
  83   );
  84   Hashtbl.add t.wakeners h wakener;
  85   M.add t.mt h;
  86   waiter