1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
|
(* Js_of_ocaml library
* http://www.ocsigen.org/js_of_ocaml/
* Copyright (C) 2014 Hugo Heuzard
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Js_of_ocaml
open! Import
let rec random_identifier size =
let b = Buffer.create size in
for _i = 0 to size - 1 do
Buffer.add_char b (Char.chr (97 + Random.int 26))
done;
let s = Buffer.contents b in
if Js.Optdef.test (Js.Unsafe.get Dom_html.window (Js.string s))
then (* name already in use, choose another one*)
random_identifier size
else s
let raw_call name uri error_cb user_cb =
let script = Dom_html.(createScript document) in
let finalize () =
Js.Unsafe.delete Dom_html.window (Js.string name);
Js.Opt.iter script##.parentNode (fun parent -> Dom.removeChild parent script)
in
let executed = ref false in
Js.Unsafe.set Dom_html.window (Js.string name) (fun x ->
executed := true;
finalize ();
user_cb x);
script##.src := Js.string uri;
script##._type := Js.string "text/javascript";
script##.async := Js._true;
((Js.Unsafe.coerce script)##.onerror
:= fun x ->
finalize ();
error_cb x);
((Js.Unsafe.coerce script)##.onload
:= fun x ->
Lwt.async (fun () ->
Lwt.bind (Lwt_js.sleep 1.) (fun () ->
if !executed
then Lwt.return_unit
else (
Firebug.console##warn
(Js.string "Jsonp: script loaded but callback not executed");
finalize ();
error_cb x;
Lwt.return_unit))));
let init () = ignore (Dom.appendChild Dom_html.document##.body script) in
init, finalize
let call_ prefix make_uri error_cb user_cb =
let name = prefix ^ random_identifier 10 in
let uri = make_uri name in
raw_call name uri error_cb user_cb
let call_custom_url ?timeout ?(prefix = "") make_uri =
let t, w = Lwt.task () in
let init, finalize = call_ prefix make_uri (fun _ -> Lwt.cancel t) (Lwt.wakeup w) in
Lwt.on_cancel t finalize;
let new_t =
match timeout with
| None -> t
| Some delay ->
let wait =
Lwt.bind (Lwt_js.sleep delay) (fun () ->
Lwt.cancel t;
t)
in
Lwt.choose [ wait; t ]
in
init ();
new_t
let add_param name value l =
let l = List.filter (fun (x, _) -> not (String.equal x name)) l in
(name, value) :: l
let call ?timeout ?(param = "callback") ?(prefix = "") url =
let make_uri cbname =
match Url.url_of_string url with
| None -> failwith "Jsonp.call: Cannot parse url"
| Some url ->
let new_url =
match url with
| Url.Http http ->
Url.Http
{ http with
Url.hu_arguments = add_param param cbname http.Url.hu_arguments
}
| Url.Https http ->
Url.Https
{ http with
Url.hu_arguments = add_param param cbname http.Url.hu_arguments
}
| Url.File file ->
Url.File
{ file with
Url.fu_arguments = add_param param cbname file.Url.fu_arguments
}
in
Url.string_of_url new_url
in
call_custom_url ?timeout ~prefix make_uri
|