Source file background_lwt.ml

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
open Ezjs_min
open Chrome_lwt
open Common.Types

let (let>) = Lwt.bind
let (let>?) p f = Lwt.bind p (function Error e -> Lwt.return_error e | Ok x -> f x)
let (let|>?) p f = Lwt.map (Result.map f) p

let print_conn (port : Utils.Runtime.port t) =
  match Optdef.to_option port##.sender with
  | None -> ()
  | Some sender ->
    match Optdef.to_option sender##.url with
    | None -> log_str "connection received"
    | Some url -> log "%s connected" (to_string url)

let load_config = function
  | None -> ()
  | Some (filename, f) ->
    let config_url = Runtime.getURL filename in
    EzLwtSys.run @@ fun () ->
    let> r = EzReq_lwt.get (EzAPI.URL config_url) in
    (match r with
     | Error _ -> ()
     | Ok s -> f s);
    Lwt.return_unit

let port_table : (int, Utils.Runtime.port t * request_source) Hashtbl.t = Hashtbl.create 512

let add_port ~id ~src (port : Utils.Runtime.port t) =
  match Hashtbl.find_opt port_table id with
  | Some (_, src) -> src
  | None -> Hashtbl.add port_table id (port, src); src

let get_port ~id =
  Hashtbl.find_opt port_table id

let remove_port ~port =
  Hashtbl.iter (fun id (p, _) -> if p = port then Hashtbl.remove port_table id) port_table

module type S = sig
  include S
  val handle_config : (string * (string -> unit)) option
  val handle_request :
    src:request_source -> id:int -> request ->
    (response_ok option, response_error) result Lwt.t
end

module Lib(S : S) = struct
  include Make(S)

  let send_res ?(ok=true) ~id ?port res_output =
    match get_port ~id, port with
    | None, None -> ()
    | Some (port, _), _ | _, Some port ->
      let res = response_aux_to_jsoo response_jsoo_conv
          {res_output; res_id=id; res_src=`background; res_ok=ok} in
      port##postMessage res

  let main () =
    load_config S.handle_config;
    Runtime.onConnect (fun port ->
        print_conn port;
        Utils.Browser.addListener1 (port##.onDisconnect) (fun port -> remove_port ~port);
        Utils.Browser.addListener1 (port##.onMessage) @@ fun req ->
        try
          let req = request_aux_of_jsoo S.request_jsoo_conv req in
          let id, src = req.req_id, req.req_src in
          let src = add_port ~id ~src port in
          EzLwtSys.run @@ fun () ->
          Lwt.catch (fun () ->
              let> r = S.handle_request ~id ~src req.req_input in
              let () = match r with
                | Ok None -> ()
                | Ok (Some r) -> send_res ~id (Ok r)
                | Error e -> send_res ~id ~ok:false (Error (`custom e)) in
              Lwt.return_unit)
            (fun exn ->
               send_res ~id ~ok:false
                 (Error (`generic ("extension error", Printexc.to_string exn)));
               Lwt.return_unit)
        with exn ->
          send_res ~id:req##.id ~port ~ok:false
            (Error (`generic ("wrong request", Printexc.to_string exn))))
end

module Make(S : S) = struct
  include Lib(S)
  let () = main ()
end