Fix remote calls involving client closures. (#1118)

This patch fixes a problem with calling remote server functions that
will call a client side function. Previously, client side closures
were stored in a global table `_closureTable`. Such a closure would
get serialised as an index into this table, however, the server
evaluator is unaware of how to invoke a closure contained within this
table, thus resulting in a 500 Internal Error being thrown.

This patch adds a new value form on the server side `\`ClientClosure
of int` to represent a client side closure, where the integer payload
is the index into the global closure table. In addition the evaluator
is extended with a clause for `\`ClientClosure` which produces a
client side call a special function that knows how to access and
invoke the targetted closure in the global table.

Resolves #1050

core/evalir.ml

@@ -235,23 +235,26 @@ struct
           apply_cont cont env (`AccessPointID (`ServerAccessPoint apid))
   and apply (cont : continuation) env : Value.t * Value.t list -> result =
     let invoke_session_exception () =
-      special env cont (DoOperation (Value.session_exception_operation,
-        [], Types.Not_typed)) in
+      special env cont
+        (DoOperation (Value.session_exception_operation, [], Types.Not_typed))
+    in
     function
     | `FunctionPtr (f, fvs), ps ->
       let (_finfo, (xs, body), z, _location) =
-           try find_fun f
-           with NotFound _ ->
-             raise (internal_error ("Failed to find function name: " ^ (string_of_int f)))
+        try find_fun f
+        with NotFound _ ->
+          raise (internal_error ("Failed to find function name: " ^ (string_of_int f)))
       in
       let env =
         match z, fvs with
-        | None, None            -> env
         | Some z, Some fvs -> Value.Env.bind z (fvs, Scope.Local) env
-        | _, _ -> assert false in
-
+        | None, None -> env
+        | _, _ -> assert false
+      in
       (* extend env with arguments *)
-      let env = List.fold_right2 (fun x p -> Value.Env.bind x (p, Scope.Local)) xs ps env in
+      let env =
+        List.fold_right2 (fun x p -> Value.Env.bind x (p, Scope.Local)) xs ps env
+      in
       computation_yielding env cont body
     | `PrimitiveFunction ("registerEventHandlers",_), [hs] ->
       let key = EventHandlers.register hs in
@@ -524,6 +527,9 @@ struct
     | `Resumption r, vs ->
        resume env cont r vs
     | `Alien, _ -> eval_error "Cannot make alien call on the server.";
+    | `ClientClosure index, vs ->
+       let req_data = Value.Env.request_data env in
+       client_call req_data "_$ClosureTable.apply" cont (`Int index :: vs)
     | v, _ -> type_error ~action:"apply" "function" v
   and resume env (cont : continuation) (r : resumption) vs =
     Proc.yield (fun () -> K.Eval.resume ~env cont r vs)

core/json.ml

@@ -115,7 +115,8 @@ let rec jsonize_value' : Value.t -> Yojson.Basic.t =
     lit ~tag:"FunctionPtr" fields'
   | `ClientDomRef i ->
      lit ~tag:"ClientDomRef" [("_domRefKey", `String (string_of_int i))]
-  | `ClientFunction name -> lit ~tag:"ClientFunction" [("func", `String name); ("_tag", `String "ClientFunction")]
+  | `ClientFunction name -> lit ~tag:"ClientFunction" [("func", `String name)]
+  | `ClientClosure index -> lit ~tag:"ClientClosure" [("index", `Int index)]
   | #Value.primitive_value as p -> jsonize_primitive p
   | `Variant (label, value) ->
      lit ~tag:"Variant" [("_label", `String label); ("_value", jsonize_value' value)]

core/resolveJsonState.ml

@@ -17,7 +17,8 @@ let rec extract_json_values : Value.t -> (handler_id_set * (Value.chan list)) =
   (* Empties *)
   | `List [] | `SpawnLocation _ | `Pid _
   | `AccessPointID _ | `ClientDomRef _
-  | `ClientFunction _ | `Alien -> empty_state
+  | `ClientFunction _ | `ClientClosure _
+  |  `Alien -> empty_state
 
   (* Session channels *)
   | `SessionChannel c -> (IntSet.empty, [c])

core/serialisation.ml

@@ -130,6 +130,7 @@ module Compressible = struct
       | `PrimitiveFunction of string
       | `ClientDomRef of int
       | `ClientFunction of string
+      | `ClientClosure of int
       | `Continuation of K.compressed_t
       | `Resumption of K.compressed_r
       | `Alien ]
@@ -167,6 +168,7 @@ module Compressible = struct
       | `PrimitiveFunction (f, _op) -> `PrimitiveFunction f
       | `ClientDomRef i -> `ClientDomRef i
       | `ClientFunction f -> `ClientFunction f
+      | `ClientClosure i  -> `ClientClosure i
       | `Continuation cont -> `Continuation (K.compress cont)
       | `Resumption r -> `Resumption (K.compress_r r)
       | `Pid _ -> assert false (* mmmmm *)
@@ -210,6 +212,7 @@ module Compressible = struct
       | `PrimitiveFunction f -> `PrimitiveFunction (f,None)
       | `ClientDomRef i -> `ClientDomRef i
       | `ClientFunction f -> `ClientFunction f
+      | `ClientClosure i -> `ClientClosure i
       | `Continuation cont -> `Continuation (K.decompress ~globals cont)
       | `Resumption res -> `Resumption (K.decompress_r ~globals res)
       | `Alien -> `Alien
@@ -459,7 +462,8 @@ module UnsafeJsonSerialiser : SERIALISER with type s := Yojson.Basic.t = struct
             match List.assoc "db" bs |> from_json with
             | `Database db -> db
             | _ -> raise (error ("first argument to a table must be a database"))
-          end in
+          end
+        in
         let name = assoc_string "name" bs in
         let keys = List.assoc "keys" bs |> unwrap_list in
         let keys =
@@ -496,6 +500,11 @@ module UnsafeJsonSerialiser : SERIALISER with type s := Yojson.Basic.t = struct
         in
         Value.make_table ~database ~name ~keys ~temporality ~temporal_fields ~row
       in
+      let parse_client_closure xs () =
+        match List.assoc_opt "_closureTable" xs with
+        | Some index -> Some (`ClientClosure (unwrap_int index))
+        | None -> None
+      in
 
       let (<|>) (o1: unit -> t option) (o2: unit -> t option) : unit -> t option =
         match o1 () with
@@ -598,6 +607,7 @@ module UnsafeJsonSerialiser : SERIALISER with type s := Yojson.Basic.t = struct
            <|> (parse_session_channel xs)
            <|> (parse_server_func xs)
            <|> (parse_date xs)
+           <|> (parse_client_closure xs)
          in
          begin
            match result () with

core/value.ml

@@ -741,6 +741,7 @@ type t = [
 | `PrimitiveFunction of string * Var.var option
 | `ClientDomRef of int
 | `ClientFunction of string
+| `ClientClosure of int
 | `Continuation of continuation
 | `Resumption of resumption
 | `Pid of dist_pid
@@ -785,7 +786,8 @@ let rec p_value (ppf : formatter) : t -> 'a = function
   | `List l -> fprintf ppf "[@[<hov 0>";
                p_list_elements ppf l
   | `ClientDomRef i -> fprintf ppf "%i" i
-  | `ClientFunction _n -> fprintf ppf "fun"
+  | `ClientClosure _
+  | `ClientFunction _ -> fprintf ppf "fun"
   | `PrimitiveFunction (name, _op) -> fprintf ppf "%s" name
   | `Variant (label, `Record []) -> fprintf ppf "@{<constructor>%s@}" label
   (* avoid duplicate parenthesis for Foo(a = 5, b = 3) *)

core/value.mli

@@ -245,6 +245,7 @@ type t = [
 | `PrimitiveFunction of string * Var.var option
 | `ClientDomRef of int
 | `ClientFunction of string
+| `ClientClosure of int
 | `Continuation of continuation
 | `Resumption of resumption
 | `Pid of dist_pid

core/webif.ml

@@ -31,7 +31,6 @@ struct
   let parse_remote_call (valenv, _, _) cgi_args =
     let fname = Utility.base64decode (assoc "__name" cgi_args) in
     let args = Utility.base64decode (assoc "__args" cgi_args) in
-    (* Debug.print ("args: " ^ Value.show (Json.parse_json args)); *)
     let args = Value.untuple (U.Value.load (Yojson.Basic.from_string args)) in
 
     let fvs = U.Value.load (Yojson.Basic.from_string (Utility.base64decode (assoc "__env" cgi_args))) in
@@ -48,8 +47,9 @@ struct
           if Lib.is_primitive_var i_fname
           then `PrimitiveFunction (Lib.primitive_name i_fname, Some i_fname)
           else `FunctionPtr (int_of_string fname, None)
-      | _          -> `FunctionPtr (int_of_string fname, Some fvs) in
-    RemoteCall(func, valenv, args)
+      | _ -> `FunctionPtr (int_of_string fname, Some fvs)
+    in
+    RemoteCall (func, valenv, args)
 
   (** Boolean tests for cgi parameters *)
 
@@ -124,19 +124,17 @@ struct
         Eval.apply render_cont valenv (t, []) >>= fun (_, v) ->
         let res = render_servercont_cont v in
         Lwt.return ("text/html", res)
-      | ClientReturn(cont, arg) ->
+      | ClientReturn (cont, arg) ->
         Debug.print("Doing ClientReturn for client ID " ^ client_id_str);
         Proc.resolve_external_processes arg;
         Eval.apply_cont cont valenv arg >>= fun (_, result) ->
         let json_state = generate_json_state req_data result in
         let result_json =
           Json.jsonize_value_with_state result json_state |> Json.json_to_string in
         Lwt.return ("text/plain", Utility.base64encode result_json)
-      | RemoteCall(func, env, args) ->
+      | RemoteCall (func, env, args) ->
         Debug.print("Doing RemoteCall for function " ^ Value.string_of_value func
           ^ ", client ID: " ^ client_id_str);
-        (* Debug.print ("func: " ^ Value.show func); *)
-        (* Debug.print ("args: " ^ mapstrcat ", " Value.show args); *)
         Proc.resolve_external_processes func;
         List.iter Proc.resolve_external_processes args;
         List.iter (Proc.resolve_external_processes -<- fst -<- snd)
@@ -165,36 +163,34 @@ struct
     (* We need to be a bit careful about what we respond here. If we are evaluating
      * a ServerCont or EvalMain, that is fine -- but we need to construct a b64-encoded
      * JSON object if we're responding to a ClientReturn or RemoteCall. *)
-
     let handle_ajax_error e =
       let json =
         `Assoc [("error", `String (Errors.format_exception e))] in
       Lwt.return
-        ("text/plain", Utility.base64encode (Yojson.Basic.to_string json)) in
-
+        ("text/plain", Utility.base64encode (Yojson.Basic.to_string json))
+    in
     let handle_html_error e =
       let mime_type = "text/html; charset=utf-8" in
       match e with
        | Failure msg as e ->
           Debug.print (Printf.sprintf "Failure(%s)" msg);
           Lwt.return (mime_type, error_page (Errors.format_exception_html e))
        | exc ->
-          Lwt.return (mime_type, error_page (Errors.format_exception_html exc)) in
-
+          Lwt.return (mime_type, error_page (Errors.format_exception_html exc))
+    in
     let handle_exception = function
       | Aborted r -> Lwt.return r (* Aborts are not "real" errors, as
                                      every client call throws a
                                      Proc.Aborted. *)
       | e ->
          let req_data = Value.Env.request_data valenv in
          RequestData.set_http_response_code req_data 500;
-         if (RequestData.is_ajax_call cgi_args) then
-           handle_ajax_error e
-         else
-           handle_html_error e in
-
+         if (RequestData.is_ajax_call cgi_args)
+         then handle_ajax_error e
+         else handle_html_error e
+    in
     Lwt.catch
-      (fun () -> perform_request valenv run render_cont render_servercont_cont request )
+      (fun () -> perform_request valenv run render_cont render_servercont_cont request)
       handle_exception >>=
       fun (content_type, content) ->
       response_printer [("Content-type", content_type)] content

lib/js/jslib.js

@@ -468,7 +468,26 @@ const _$Constants = Object.freeze({
 
 let _client_id;  // the unique ID given to this client
 
-let _closureTable = {};
+const _$ClosureTable = (function() {
+    // Internal state.
+    const closures = [];
+    let nextId = 0;
+
+    return Object.freeze({
+        "add": function(f) {
+            closures[nextId] = f;
+            return nextId++;
+        },
+        "get": function(i) {
+            return closures[i];
+        },
+        "apply": function() {
+            const index = arguments[0];
+            const args = Array.prototype.slice.call(arguments, 1, arguments.length);
+            return closures[index].apply(null, args);
+        }
+    });
+})();
 
 /* Functions for handling the websocket connection to the server. */
 const _$Websocket = (function() {
@@ -1480,6 +1499,8 @@ const _$Links = (function() {
               });
           }
           break;
+      case "ClientClosure":
+          return _$ClosureTable.get(obj.index);
       case "Process": {
           // resolveProcessMessage builds the continuation in bottom-up
           // fashion, so in order to resolve the object in-order at
@@ -1658,15 +1679,14 @@ const _$Links = (function() {
           _env: value.environment,
         };
       }
-      const id = nextFuncID++;
-      _closureTable[id] = function (env) { return value; };
+      const id = _$ClosureTable.add(value);
 
-      return { _closureTable: id };
+      return {"_closureTable": id};
     } else if ( // SL: HACK for sending XML to the server
       key !== "_xml" &&
       _isXmlItem(value)
     ) {
-      return { _xml: value };
+      return {"_xml": value };
     } else if (value === _$List.nil) {
       return _$List.nil;
     } else if (value.nodeType !== undefined) {
@@ -1675,7 +1695,7 @@ const _$Links = (function() {
       // If date is set, then we need to serialise the UTC timestamp
       if (value._type == "timestamp") {
         const ts = Math.floor(value._value.getTime() / 1000);
-        return { _type: "timestamp", _value: ts };
+        return {"_type": "timestamp", "_value": ts};
       } else {
         return value;
       }