this repo has no description
Make Lwt
+141
-83
+1
-1
example/dune
+1
-1
example/dune
···
44
44
(package js_top_worker-unix)
45
45
(modules unix_worker)
46
46
(link_flags (-linkall))
47
-
(libraries js_top_worker logs logs.fmt rpclib.core rpclib.json findlib.top))
47
+
(libraries js_top_worker logs logs.fmt rpclib.core rpclib.json findlib.top lwt.unix))
48
48
49
49
(executable
50
50
(name unix_client)
+28
-24
example/unix_worker.ml
+28
-24
example/unix_worker.ml
···
50
50
Sys.remove filename_out;
51
51
Sys.remove filename_err)
52
52
53
+
let (let*) = Lwt.bind
54
+
55
+
53
56
let binary_handler process s =
54
-
let ic = Unix.in_channel_of_descr s in
55
-
let oc = Unix.out_channel_of_descr s in
56
57
(* Read a 16 byte length encoded as a string *)
57
58
let len_buf = Bytes.make 16 '\000' in
58
-
really_input ic len_buf 0 (Bytes.length len_buf);
59
+
let* _ = Lwt_unix.read s len_buf 0 (Bytes.length len_buf) in
59
60
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
60
61
let msg_buf = Bytes.make len '\000' in
61
-
really_input ic msg_buf 0 (Bytes.length msg_buf);
62
-
let ( >>= ) = M.bind in
63
-
process msg_buf >>= fun result ->
62
+
let* _ = Lwt_unix.read s msg_buf 0 (Bytes.length msg_buf) in
63
+
let* result = process msg_buf in
64
64
let len_buf = Printf.sprintf "%016d" (String.length result) in
65
-
output_string oc len_buf;
66
-
output_string oc result;
67
-
flush oc;
68
-
M.return ()
65
+
let* _ = Lwt_unix.write s (Bytes.of_string len_buf) 0 16 in
66
+
let* _ = Lwt_unix.write s (Bytes.of_string result) 0 (String.length result) in
67
+
Lwt.return ()
69
68
70
69
let mkdir_rec dir perm =
71
70
let rec p_mkdir dir =
···
76
75
p_mkdir dir
77
76
78
77
let serve_requests rpcfn path =
78
+
let (let*) = Lwt.bind in
79
79
(try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ());
80
80
mkdir_rec (Filename.dirname path) 0o0755;
81
-
let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
82
-
Unix.bind sock (Unix.ADDR_UNIX path);
83
-
Unix.listen sock 5;
84
-
while true do
85
-
let this_connection, _ = Unix.accept sock in
86
-
Fun.protect
87
-
~finally:(fun () -> Unix.close this_connection)
88
-
(fun () ->
81
+
let sock = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
82
+
let* () = Lwt_unix.bind sock (Unix.ADDR_UNIX path) in
83
+
Lwt_unix.listen sock 5;
84
+
let rec loop () =
85
+
let* this_connection, _ = Lwt_unix.accept sock in
86
+
let* () =
87
+
Lwt.finalize (fun () ->
89
88
(* Here I am calling M.run to make sure that I am running the process,
90
89
this is not much of a problem with IdM or ExnM, but in general you
91
90
should ensure that the computation is started by a runner. *)
92
-
binary_handler rpcfn this_connection |> M.run)
93
-
done
91
+
binary_handler rpcfn this_connection)
92
+
(fun () -> Lwt_unix.close this_connection)
93
+
in
94
+
loop ()
95
+
in
96
+
loop ()
94
97
95
98
let handle_findlib_error = function
96
99
| Failure msg -> Printf.fprintf stderr "%s" msg
···
108
111
109
112
let capture = capture
110
113
let sync_get _ = None
114
+
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
111
115
let create_file ~name:_ ~content:_ = failwith "Not implemented"
112
116
113
117
let import_scripts urls =
···
155
159
Logs.set_level (Some Logs.Info);
156
160
(* let pid = Unix.getpid () in *)
157
161
Server.exec execute;
158
-
Server.setup setup;
159
-
Server.init init;
162
+
Server.setup (IdlM.T.lift setup);
163
+
Server.init (IdlM.T.lift init);
160
164
Server.typecheck typecheck_phrase;
161
165
Server.complete_prefix complete_prefix;
162
166
Server.query_errors query_errors;
···
165
169
Server.exec_toplevel exec_toplevel;
166
170
let rpc_fn = IdlM.server Server.implementation in
167
171
let process x =
168
-
let open M in
172
+
let open Lwt in
169
173
rpc_fn (Jsonrpc.call_of_string (Bytes.unsafe_to_string x))
170
174
>>= fun response -> Jsonrpc.string_of_response response |> return
171
175
in
172
176
serve_requests process Js_top_worker_rpc.Toplevel_api_gen.sockpath
173
177
174
-
let _ = start_server ()
178
+
let _ = Lwt_main.run (start_server ())
+2
lib/dune
+2
lib/dune
+55
-38
lib/impl.ml
+55
-38
lib/impl.ml
···
1
1
(* Implementation *)
2
2
open Js_top_worker_rpc
3
-
module M = Idl.IdM (* Server is synchronous *)
4
-
module IdlM = Idl.Make (M)
3
+
module M = Rpc_lwt.ErrM (* Server is not synchronous *)
4
+
module IdlM = Rpc_lwt
5
+
6
+
let ( let* ) = Lwt.bind
5
7
6
8
type captured = { stdout : string; stderr : string }
7
9
···
103
105
val capture : (unit -> 'a) -> unit -> captured * 'a
104
106
val create_file : name:string -> content:string -> unit
105
107
val sync_get : string -> string option
108
+
val async_get : string -> (string, [> `Msg of string ]) result Lwt.t
106
109
val import_scripts : string list -> unit
107
110
val init_function : string -> unit -> unit
108
111
val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
···
234
237
235
238
let execute :
236
239
string ->
237
-
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) IdlM.T.resultb =
240
+
Toplevel_api_gen.exec_result =
238
241
let code_buff = Buffer.create 100 in
239
242
let res_buff = Buffer.create 100 in
240
243
let pp_code = Format.formatter_of_buffer code_buff in
···
259
262
let mime_vals = Mime_printer.get () in
260
263
Format.pp_print_flush pp_code ();
261
264
Format.pp_print_flush pp_result ();
262
-
IdlM.ErrM.return
263
-
Toplevel_api_gen.
264
-
{
265
-
stdout = string_opt o.stdout;
266
-
stderr = string_opt o.stderr;
267
-
sharp_ppf = buff_opt code_buff;
268
-
caml_ppf = buff_opt res_buff;
269
-
highlight = !highlighted;
270
-
mime_vals;
271
-
}
265
+
Toplevel_api_gen.
266
+
{
267
+
stdout = string_opt o.stdout;
268
+
stderr = string_opt o.stderr;
269
+
sharp_ppf = buff_opt code_buff;
270
+
caml_ppf = buff_opt res_buff;
271
+
highlight = !highlighted;
272
+
mime_vals;
273
+
}
272
274
273
275
let filename_of_module unit_name =
274
276
Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
···
293
295
let add_dynamic_cmis dcs =
294
296
let fetch filename =
295
297
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
298
+
S.async_get url
299
+
in
300
+
let fetch_sync filename =
301
+
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
296
302
S.sync_get url
297
303
in
298
304
let path =
299
305
match !path with Some p -> p | None -> failwith "Path not set"
300
306
in
301
-
302
-
List.iter
307
+
let (let*) = Lwt.bind in
308
+
let* () = Lwt_list.iter_p
303
309
(fun name ->
304
310
let filename = filename_of_module name in
305
-
match fetch (filename_of_module name) with
306
-
| Some content -> (
311
+
let* r = fetch (filename_of_module name) in
312
+
let () =
313
+
match r with
314
+
| Ok content -> (
307
315
let name = Filename.(concat path filename) in
308
316
try S.create_file ~name ~content with _ -> ())
309
-
| None -> ())
310
-
dcs.dcs_toplevel_modules;
317
+
| Error _ -> () in
318
+
Lwt.return ())
319
+
dcs.dcs_toplevel_modules
320
+
in
311
321
312
322
let new_load ~s ~old_loader ~allow_hidden ~unit_name =
313
323
(* Logs.info (fun m -> m "%s Loading: %s" s unit_name); *)
···
327
337
dcs.dcs_file_prefixes
328
338
then (
329
339
Logs.info (fun m -> m "Fetching %s\n%!" filename);
330
-
match fetch filename with
340
+
match fetch_sync filename with
331
341
| Some x ->
332
342
S.create_file ~name:fs_name ~content:x;
333
343
(* At this point we need to tell merlin that the dir contents
···
341
351
in
342
352
let furl = "file://" in
343
353
let l = String.length furl in
354
+
let () =
344
355
if String.length dcs.dcs_url > l && String.sub dcs.dcs_url 0 l = furl then
345
356
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
346
357
Topdirs.dir_directory path
···
351
362
352
363
let open Ocaml_typing.Persistent_env.Persistent_signature in
353
364
let old_loader = !load in
354
-
load := new_load ~s:"merl" ~old_loader
365
+
load := new_load ~s:"merl" ~old_loader in
366
+
Lwt.return ()
355
367
356
368
let init (init_libs : Toplevel_api_gen.init_config) =
357
-
try
369
+
Lwt.catch (fun () ->
358
370
Logs.info (fun m -> m "init()");
359
371
path := Some S.path;
360
372
···
364
376
| Some dcs -> dcs
365
377
| None -> "lib/ocaml/dynamic_cmis.json"
366
378
in
367
-
(match S.get_stdlib_dcs stdlib_dcs with
368
-
| [ dcs ] -> add_dynamic_cmis dcs
369
-
| _ -> ());
379
+
let* () =
380
+
match S.get_stdlib_dcs stdlib_dcs with
381
+
| [ dcs ] -> add_dynamic_cmis dcs
382
+
| _ -> Lwt.return () in
370
383
Clflags.no_check_prims := true;
371
384
372
385
requires := init_libs.findlib_requires;
···
376
389
(* Set up the toplevel environment *)
377
390
Logs.info (fun m -> m "init() finished");
378
391
379
-
IdlM.ErrM.return ()
380
-
with e ->
381
-
IdlM.ErrM.return_err
382
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
392
+
Lwt.return (Ok ()))
393
+
(fun e ->
394
+
Lwt.return (Error
395
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))))
383
396
384
397
let setup () =
385
-
try
398
+
Lwt.catch (fun () ->
386
399
Logs.info (fun m -> m "setup() ...");
387
400
388
401
let o =
···
406
419
| Some v -> S.require (not !execution_allowed) v !requires
407
420
| None -> []
408
421
in
409
-
List.iter add_dynamic_cmis dcs;
422
+
let* () = Lwt_list.iter_p add_dynamic_cmis dcs in
410
423
411
424
Logs.info (fun m -> m "setup() finished");
412
425
413
-
IdlM.ErrM.return
414
-
Toplevel_api_gen.
426
+
Lwt.return
427
+
(Ok Toplevel_api_gen.
415
428
{
416
429
stdout = string_opt o.stdout;
417
430
stderr = string_opt o.stderr;
···
419
432
caml_ppf = None;
420
433
highlight = None;
421
434
mime_vals = [];
422
-
}
423
-
with e ->
424
-
IdlM.ErrM.return_err
425
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
435
+
}))
436
+
(fun e ->
437
+
Lwt.return (Error
438
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))))
426
439
427
440
let complete _phrase = failwith "Not implemented"
428
441
···
590
603
List.fold_left
591
604
(fun acc (phr, _junk, _output) ->
592
605
let new_output =
593
-
execute phr |> IdlM.T.get |> M.run |> Result.get_ok
606
+
execute phr
594
607
in
595
608
Printf.bprintf buf "# %s\n" phr;
596
609
let r =
···
621
634
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
622
635
IdlM.ErrM.return_err
623
636
(Toplevel_api_gen.InternalError (Printexc.to_string e))
637
+
638
+
let execute (phrase : string) =
639
+
let result = execute phrase in
640
+
IdlM.ErrM.return result
624
641
625
642
let config () =
626
643
let path =
+26
-6
lib/jslib.ml
+26
-6
lib/jslib.ml
···
3
3
(fun s -> Js_of_ocaml.(Console.console##log (Js.string s)))
4
4
fmt
5
5
6
-
let sync_get url =
6
+
7
+
let map_url url =
7
8
let open Js_of_ocaml in
8
9
let global_rel_url =
9
10
let x : Js.js_string Js.t option = Js.Unsafe.js_expr "globalThis.__global_rel_url" |> Js.Optdef.to_option in
10
11
Option.map Js.to_string x
11
12
in
12
-
let url =
13
-
match global_rel_url with
14
-
| Some rel -> Filename.concat rel url
15
-
| None -> url
16
-
in
13
+
match global_rel_url with
14
+
| Some rel -> Filename.concat rel url
15
+
| None -> url
16
+
17
+
let sync_get url =
18
+
let open Js_of_ocaml in
19
+
let url = map_url url in
17
20
Console.console##log (Js.string ("Fetching: " ^ url));
18
21
let x = XmlHttpRequest.create () in
19
22
x##.responseType := Js.string "arraybuffer";
···
28
31
None)
29
32
(fun b -> Some (Typed_array.String.of_arrayBuffer b))
30
33
| _ -> None
34
+
35
+
36
+
let async_get url =
37
+
let (let*) = Lwt.bind in
38
+
let open Js_of_ocaml in
39
+
Console.console##log (Js.string ("Fetching: " ^ url));
40
+
let* frame = Js_of_ocaml_lwt.XmlHttpRequest.perform_raw
41
+
~response_type:ArrayBuffer url in
42
+
match frame.code with
43
+
| 200 ->
44
+
Lwt.return (Js.Opt.case
45
+
frame.content
46
+
(fun () ->
47
+
Error (`Msg "Failed to receive file"))
48
+
(fun b -> Ok (Typed_array.String.of_arrayBuffer b)))
49
+
| _ ->
50
+
Lwt.return (Error (`Msg (Printf.sprintf "Failed to fetch %s: %d" url frame.code)))
+5
-4
lib/worker.ml
+5
-4
lib/worker.ml
···
11
11
let server process e =
12
12
(* Jslib.log "Worker received: %s" e; *)
13
13
let _, id, call = Jsonrpc.version_id_and_call_of_string e in
14
-
Impl.M.bind (process call) (fun response ->
14
+
Lwt.bind (process call) (fun response ->
15
15
let rtxt = Jsonrpc.string_of_response ~id response in
16
16
Jslib.log "Worker sending: %s" rtxt;
17
17
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string rtxt);
18
-
Impl.M.return ())
18
+
Lwt.return ())
19
19
20
20
let loc = function
21
21
| Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
···
52
52
(captured, x)
53
53
54
54
let sync_get = Jslib.sync_get
55
+
let async_get = Jslib.async_get
55
56
let create_file = Js_of_ocaml.Sys_js.create_file
56
57
57
58
let get_stdlib_dcs uri =
···
90
91
Logs.set_reporter (Logs_browser.console_reporter ());
91
92
Logs.set_level (Some Logs.Debug);
92
93
Server.exec execute;
93
-
Server.setup setup;
94
-
Server.init init;
94
+
Server.setup (Impl.IdlM.T.lift setup);
95
+
Server.init (Impl.IdlM.T.lift init);
95
96
Server.typecheck typecheck_phrase;
96
97
Server.complete_prefix complete_prefix;
97
98
Server.query_errors query_errors;
+2
-1
test/node/dune
+2
-1
test/node/dune
+15
-3
test/node/node_test.ml
+15
-3
test/node/node_test.ml
···
34
34
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
35
35
None
36
36
37
+
let async_get f =
38
+
let f = Fpath.v ("_opam/" ^ f) in
39
+
Logs.info (fun m -> m "async_get: %a" Fpath.pp f);
40
+
Lwt.catch (fun () ->
41
+
let open Lwt.Infix in
42
+
Lwt_io.with_file ~mode:Lwt_io.input (Fpath.to_string f) Lwt_io.read
43
+
>>= fun content -> Lwt.return (Ok content))
44
+
(fun e ->
45
+
Logs.err (fun m ->
46
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
47
+
Lwt.return (Error (`Msg (Printexc.to_string e))))
48
+
37
49
let create_file = Js_of_ocaml.Sys_js.create_file
38
50
39
51
let import_scripts urls =
···
61
73
Logs.set_level (Some Logs.Info);
62
74
(* let pid = Unix.getpid () in *)
63
75
Server.exec execute;
64
-
Server.setup setup;
65
-
Server.init init;
76
+
Server.setup (IdlM.T.lift setup);
77
+
Server.init (IdlM.T.lift init);
66
78
Server.typecheck typecheck_phrase;
67
79
Server.complete_prefix complete_prefix;
68
80
Server.query_errors query_errors;
···
103
115
Logs.info (fun m -> m "Exec toplevel output: %s" o3.script); *)
104
116
IdlM.ErrM.return ()
105
117
in
106
-
match x |> IdlM.T.get |> M.run with
118
+
match x |> IdlM.T.get |> Lwt_main.run with
107
119
| Ok () -> Logs.info (fun m -> m "Success")
108
120
| Error (InternalError s) -> Logs.err (fun m -> m "Error: %s" s)
+1
-1
test/unix/dune
+1
-1
test/unix/dune
+6
-5
test/unix/unix_test.ml
+6
-5
test/unix/unix_test.ml
···
59
59
Printf.fprintf stderr "Package requires itself: %s\n" pkg
60
60
| exn -> raise exn
61
61
62
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
62
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenServer ())
63
63
64
64
module S : Impl.S = struct
65
65
type findlib_t = unit
66
66
67
67
let capture = capture
68
68
let sync_get _ = None
69
+
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
69
70
let create_file ~name:_ ~content:_ = failwith "Not implemented"
70
71
71
72
let import_scripts urls =
···
98
99
Logs.set_level (Some Logs.Info);
99
100
(* let pid = Unix.getpid () in *)
100
101
Server.exec execute;
101
-
Server.setup setup;
102
-
Server.init init;
102
+
Server.setup (IdlM.T.lift setup);
103
+
Server.init (IdlM.T.lift init);
103
104
Server.typecheck typecheck_phrase;
104
105
Server.complete_prefix complete_prefix;
105
106
Server.query_errors query_errors;
···
108
109
Server.exec_toplevel exec_toplevel;
109
110
IdlM.server Server.implementation
110
111
111
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
112
+
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenClient ())
112
113
113
114
let c1, c2, c3, c4 = "c1", "c2", "c3", "c4"
114
115
let notebook = [
···
140
141
let* _ = run notebook in
141
142
IdlM.ErrM.return ()
142
143
in
143
-
match x |> IdlM.T.get |> M.run with
144
+
match x |> IdlM.T.get |> Lwt_main.run with
144
145
| Ok () -> Printf.printf "Success\n%!"
145
146
| Error (InternalError s) -> Printf.printf "Error: %s\n%!" s