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
open Js_of_ocaml
open Lwt.Infix
open EzWsCommon
include Types
let ready socket = match socket##.readyState with
| WebSockets.CONNECTING -> Error "websocket not yet ready"
| WebSockets.CLOSING -> Error "websocket closing"
| WebSockets.CLOSED -> Error "websocket closed"
| _ -> Ok ()
let catch f =
try Ok (f ()) with exn -> Error (Printexc.to_string exn)
let send_frame socket content =
catch (fun () -> socket##send (Js.string content))
let connect ?msg ?protocols ?error ~react url =
let url = match String.get url 0 with
| 'h' -> "ws" ^ String.sub url 4 (String.length url - 4)
| _ -> url in
let protocols = match protocols with
| None -> new%js Js.array_empty
| Some l -> Js.array @@ Array.of_list @@ List.map Js.string l in
log ~action:"connect" url msg;
let w0, n0 = Lwt.wait () in
Lwt.catch
(fun () ->
let socket = new%js WebSockets.webSocket_withProtocols (Js.string url) protocols in
let send content = match ready socket with
| Error e -> Lwt.return (Error e)
| Ok () -> Lwt.return @@ send_frame socket content in
let close code =
let code = match code with None -> 1002 | Some code -> code in
Lwt.return @@ catch (fun () -> socket##close_withCode code) in
let action = {send; close} in
socket##.onmessage := Dom.handler @@ (fun e ->
log url msg;
let s = Js.to_string e##.data in
Lwt.async (fun () ->
react action s >|= function
| Ok () -> ()
| Error e -> match error with
| Some f -> f action e
| None -> ());
Js._true);
socket##.onerror := Dom.handler @@ (fun e ->
match error with
| Some f -> f action ("websocket error: " ^ Js.to_string e##._type); Js._true
| None -> (); Js._true);
let conn, n = Lwt.wait () in
socket##.onclose := Dom.handler @@ (fun _e ->
Lwt.wakeup n @@ Ok (); Js._true);
socket##.onopen := Dom.handler @@ (fun _e ->
Lwt.wakeup n0 (Ok {action; conn}); Js._true);
w0)
(fun exn -> Lwt.return_error (Printexc.to_string exn))
let connect0 ?msg ?protocols ?error ~react base service =
let EzAPI.URL url = EzAPI.forge0 base service [] in
let input = EzAPI.Service.input service.EzAPI.s in
let output = EzAPI.Service.output service.EzAPI.s in
let errors = EzAPI.Service.errors_encoding service.EzAPI.s in
let react a s =
let send i = a.send (EzAPI.IO.to_string input i) in
match EzAPI.IO.res_from_string output (res_encoding errors) (react {send; close=a.close}) s with
| Ok r -> r
| Error (`destruct_exn exn) -> Lwt.return_error (Printexc.to_string exn) in
connect ?msg ?protocols ?error ~react url >|= function
| Error e -> Error e
| Ok r ->
let send i = r.action.send (EzAPI.IO.to_string input i) in
let action = {send; close=r.action.close} in
Ok {r with action}