diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml index 2602e89fe5f4b7cef908529ccf56db56f41dc3ad..cdfd4058c19fbc1d5421f88fce69cb311d268957 100644 --- a/src/plugins/server/main.ml +++ b/src/plugins/server/main.ml @@ -100,6 +100,20 @@ type 'a server = { exception Killed +(* -------------------------------------------------------------------------- *) +(* --- Errors --- *) +(* -------------------------------------------------------------------------- *) + +exception Error of string + +let error msg = + raise (Error msg) + +let error_from_json msg json = + let pretty_json = Yojson.Basic.pretty_print ~std:false in + let msg = Format.asprintf "%s@\n@[<hov 2>at: %a@]@." msg pretty_json json in + raise (Error msg) + (* -------------------------------------------------------------------------- *) (* --- Debug --- *) (* -------------------------------------------------------------------------- *) @@ -136,17 +150,21 @@ let no_yield () = () let execute yield exec : _ response = let db = !Db.progress in - try - Db.progress := if exec.yield then yield else no_yield ; - let data = exec.handler exec.data in - Db.progress := db ; `Data(exec.id,data) - with - | Killed -> Db.progress := db ; `Killed exec.id - | exn -> - Db.progress := db ; - Senv.warning "[%s] Uncaught exception:@\n%s" - exec.request (Cmdline.protect exn) ; - `Error(exec.id,Printexc.to_string exn) + let response = + try + Db.progress := if exec.yield then yield else no_yield ; + let data = exec.handler exec.data in + `Data(exec.id,data) + with + | Killed -> `Killed exec.id + | Error msg -> `Error(exec.id,msg) + | exn -> + Senv.warning "[%s] Uncaught exception:@\n%s" + exec.request (Cmdline.protect exn) ; + `Error(exec.id,Printexc.to_string exn) + in + Db.progress := db ; + response let execute_debug pp yield exec = if Senv.debug_atleast 1 then diff --git a/src/plugins/server/main.mli b/src/plugins/server/main.mli index 721291d96e9b93c4d65676fb83b216fafba39bd7..ab0fa1732cd1e12adf26c1cb5ff3e5b99029da79 100644 --- a/src/plugins/server/main.mli +++ b/src/plugins/server/main.mli @@ -66,6 +66,21 @@ type 'a message = { callback : 'a response list -> unit ; } +(** Exception thrown during request execution. + The string parameter is the message to be sent to the client. *) +exception Error of string + +(** Throw an Error exception with the given message. + It shall only be called during the execution of a request. *) +val error : string -> 'a + +(** Throw an Error exception with the given message and json object. + It shall only be called during the execution of a request and is intended + to be called with the parameters of a Yojson.Basic.Util.Type_error + exception. *) +val error_from_json : string -> json -> 'a + + (** Run a server with the provided low-level network primitives to actually exchange data. diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml index b355b3907879b1e91eef4345b217d39680fb98bc..1be516b87311d64da495f53e308edfa714384b96 100644 --- a/src/plugins/server/request.ml +++ b/src/plugins/server/request.ml @@ -276,9 +276,16 @@ let mk_input (type a) name defaults (input : a rq_input) : (rq -> json -> a) = | Pnone -> Senv.fatal "No input defined for request '%s'" name | Pdata d -> let module D = (val d) in - (fun rq js -> rq.result <- defaults ; D.of_json js) + begin fun rq js -> + rq.result <- defaults ; + try D.of_json js + with Jutil.Type_error (msg, js) -> Main.error_from_json msg js + end | Pfields _ -> - (fun rq js -> rq.param <- fmap_of_json rq.param js) + begin fun rq js -> + try rq.param <- fmap_of_json rq.param js + with Jutil.Type_error (msg, js) -> Main.error_from_json msg js + end (* json output processing *) let mk_output (type b) name required (output : b rq_output) : (rq -> b -> json) =