Fix #154 (#851)

* Fix #154 by checking for ajax request data

core/errors.ml

@@ -50,7 +50,7 @@ exception DynlinkError of string
 exception ModuleError of string * Position.t option
 exception DisabledExtension of Position.t option * (string * bool) option * string option * string
 exception PrimeAlien of Position.t
-exception ClientCallOutsideWebMode of string
+exception ForbiddenClientCall of string * string
 exception MissingBuiltinType of string
 
 exception LocateFailure of string
@@ -184,8 +184,8 @@ let format_exception =
      pos_prefix (Printf.sprintf "Error: Cannot load plugin dependency '%s' (link error: %s)\n" file (Dynlink.error_message err))
   | LoadFailure (file, err) ->
      pos_prefix (Printf.sprintf "Error: Cannot load plugin '%s' (link error: %s)\n" file (Dynlink.error_message err))
-  | ClientCallOutsideWebMode fn ->
-     pos_prefix (Printf.sprintf "Error: Cannot call client side function '%s' outside of web mode\n" fn)
+  | ForbiddenClientCall (fn, reason) ->
+     pos_prefix (Printf.sprintf "Error: Cannot call client side function '%s' because of %s\n" fn reason)
   | MissingBuiltinType alias -> Printf.sprintf "Error: Missing builtin type with alias '%s'. Is it defined in the prelude?" alias
   | Sys.Break -> "Caught interrupt"
   | exn -> pos_prefix ("Error: " ^ Printexc.to_string exn)
@@ -230,4 +230,4 @@ let module_error ?pos message = (ModuleError (message, pos))
 let disabled_extension ?pos ?setting ?flag name =
   DisabledExtension (pos, setting, flag, name)
 let prime_alien pos = PrimeAlien pos
-let client_call_outside_webmode fn = ClientCallOutsideWebMode fn
+let forbidden_client_call fn reason = ForbiddenClientCall (fn, reason)

core/errors.mli

@@ -55,5 +55,5 @@ val driver_locate_failure : string -> exn
 val illformed_plugin_description : string -> exn
 val dependency_load_failure : string -> Dynlink.error -> exn
 val load_failure : string -> Dynlink.error -> exn
-val client_call_outside_webmode : string -> exn
+val forbidden_client_call : string -> string -> exn
 val rethrow_errors_if_better_position : Position.t -> ('a -> 'b) -> 'a -> 'b

core/evalir.ml

@@ -129,7 +129,9 @@ struct
 
        fun req_data name cont args ->
          if not(Settings.get webs_running) then
-           raise (Errors.client_call_outside_webmode name);
+           raise (Errors.forbidden_client_call name "outside of web mode");
+         if not(RequestData.is_ajax_call (RequestData.get_cgi_parameters req_data)) then
+           raise (Errors.forbidden_client_call name "before server page is ready");
          (*if not(Proc.singlethreaded()) then
            raise (internal_error "Remaining procs on server at client call!"); *)
          Debug.print("Making client call to " ^ name);

core/requestData.ml

@@ -110,3 +110,13 @@ let decode : string -> string = fun s ->
 
   end
 
+(** remote client->server call *)
+let is_remote_call params =
+  List.mem_assoc "__name" params && List.mem_assoc "__args" params
+
+(** return __result from server->client call with server continuation __continuation *)
+let is_client_return params =
+  List.mem_assoc "__continuation" params && List.mem_assoc "__result" params
+
+let is_ajax_call cgi_args =
+  (is_remote_call cgi_args) || (is_client_return cgi_args)

core/requestData.mli

@@ -30,3 +30,7 @@ module DecodeRequestHeaders :
 sig
   val decode : string -> string
 end
+
+val is_remote_call : (string * string) list -> bool
+val is_client_return : (string * string) list -> bool
+val is_ajax_call : (string * string) list -> bool

core/utility.ml

@@ -1458,5 +1458,3 @@ struct
         (sequence xs) >>= fun xs ->
         Lwt.return (x :: xs)
 end
-
-

core/webif.ml

@@ -44,14 +44,6 @@ struct
 
   (** Boolean tests for cgi parameters *)
 
-  (** remote client->server call *)
-  let is_remote_call params =
-    mem_assoc "__name" params && mem_assoc "__args" params
-
-  (** return __result from server->client call with server continuation __continuation *)
-  let is_client_return params =
-    mem_assoc "__continuation" params && mem_assoc "__result" params
-
   (** invoke server continuation _k
       (e.g. from a hypertext link or a formlet post)
    *)
@@ -88,14 +80,10 @@ struct
       body ^
       "\n  </body></html>\n"
 
-  let is_ajax_call cgi_args =
-    (is_remote_call cgi_args) || (is_client_return cgi_args)
-
-  (* jcheney: lifted from serve_request, to de-clutter *)
   let parse_request env cgi_args  =
-    if      (is_remote_call cgi_args)
+    if      (RequestData.is_remote_call cgi_args)
     then parse_remote_call env cgi_args
-    else if (is_client_return cgi_args)
+    else if (RequestData.is_client_return cgi_args)
     then parse_client_return env cgi_args
     else if (is_server_cont cgi_args)
     then parse_server_cont env cgi_args
@@ -188,7 +176,7 @@ struct
            Lwt.return (mime_type, error_page (Errors.format_exception_html exc)) in
 
     let handle_error e =
-      if (is_ajax_call cgi_args) then
+      if (RequestData.is_ajax_call cgi_args) then
         handle_ajax_error e
       else
         handle_html_error e in

core/webif.mli

@@ -5,8 +5,6 @@ open Webserver_types
 module WebIf : functor (Webs : WEBSERVER) ->
 sig
 
-  val is_ajax_call : (string * string) list -> bool
-
   val do_request :
     (Value.env * Ir.var Env.String.t * Types.typing_environment) ->
     (string * string) list ->

core/webserver.ml

@@ -162,7 +162,7 @@ struct
 
 
   let get_or_make_client_id cgi_args =
-    if (Webif.is_ajax_call cgi_args) then
+    if (RequestData.is_ajax_call cgi_args) then
       get_client_id_or_die cgi_args
     else
       ClientID.create ()