From ff79fa21db3ff0a290872680fc05e6aa853ab722 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Tue, 27 Jun 2023 13:24:28 +0900 Subject: [PATCH 1/3] format --- .ocamlformat | 22 ++++++ apps/main-entry/mlsrc/server_main.ml | 112 +++++++++++++-------------- 2 files changed, 78 insertions(+), 56 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..73b75d0 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,22 @@ +profile = default +version = 0.25.1 +type-decl=sparse +margin=72 + +# dock-collection-brackets=false +# break-separators=before + +# break-collection-expressions=wrap + +# sequence-style=before + +# break-fun-decl=smart +# break-fun-decl=fit-or-vertical + +# let-binding-indent=2 +# parens-tuple=multi-line-only +# break-fun-sig=fit-or-vertical +# function-indent=2 +# function-indent-nested=always + +# type-decl-indent=2 diff --git a/apps/main-entry/mlsrc/server_main.ml b/apps/main-entry/mlsrc/server_main.ml index eddf28a..f6ffa1b 100644 --- a/apps/main-entry/mlsrc/server_main.ml +++ b/apps/main-entry/mlsrc/server_main.ml @@ -3,14 +3,14 @@ open Kxclib.Json open Log0 type http_response = { - status_code : int; - body : jv; - } + status_code : int; + body : jv; +} let json_of_http_response : http_response -> jv = - fun { status_code; body } -> - `obj [ "status_code", `num (float_of_int status_code); - "body", body ] + fun { status_code; body } -> + `obj + [ ("status_code", `num (float_of_int status_code)); ("body", body) ] let jsobj_of_http_response : http_response -> Pjv.t = json_of_http_response &> Kxclib_jsoo.Json_ext.to_xjv @@ -21,68 +21,68 @@ let json_of_jsobj : Pjv.t -> jv = &> Kxclib_jsoo.Json_ext.of_xjv module Resp = struct - let msg ?(status_code=200) s = { - status_code; body = `obj [ "message", `str s ] - } - let msg' ?status_code fmt = - Format.kasprintf (msg ?status_code) fmt - let ret ?(status_code=200) ?wrap body = - let body = match wrap with - | Some (`in_field fname) -> `obj [ fname, body ] - | None -> body in + let msg ?(status_code = 200) s = + { status_code; body = `obj [ ("message", `str s) ] } + + let msg' ?status_code fmt = Format.kasprintf (msg ?status_code) fmt + + let ret ?(status_code = 200) ?wrap body = + let body = + match wrap with + | Some (`in_field fname) -> `obj [ (fname, body) ] + | None -> body + in { status_code; body } end -let coverage_helper_js = object%js - method reset_counters_js = - info "Bisect.Runtime.reset_counters"; - Bisect.Runtime.reset_counters(); - Pjv.undefined - method write_coverage_data_js = - info "Bisect.Runtime.write_coverage_data"; - Bisect.Runtime.write_coverage_data(); - Pjv.undefined - method get_coverage_data_js = - info "Bisect.Runtime.get_coverage_data"; - Bisect.Runtime.get_coverage_data () - >? Pjv.of_string - |? Pjv.null - end [@@coverage off] +let coverage_helper_js = + object%js + method reset_counters_js = + info "Bisect.Runtime.reset_counters"; + Bisect.Runtime.reset_counters (); + Pjv.undefined + + method write_coverage_data_js = + info "Bisect.Runtime.write_coverage_data"; + Bisect.Runtime.write_coverage_data (); + Pjv.undefined + + method get_coverage_data_js = + info "Bisect.Runtime.get_coverage_data"; + Bisect.Runtime.get_coverage_data () >? Pjv.of_string |? Pjv.null + end + [@@coverage off] let () = info "%s loaded" __FILE__; object%js - val coverage_helper_js = coverage_helper_js val handle_get_ = fun path_js -> - let path = Pjv.to_string path_js in - verbose "handle_get[%s]" path; - (match path with - | "/" -> Resp.msg "hello?" - | _ -> Resp.msg' ~status_code:404 "path not found: %s" path - ) |> jsobj_of_http_response + let path = Pjv.to_string path_js in + verbose "handle_get[%s]" path; + (match path with + | "/" -> Resp.msg "hello?" + | _ -> Resp.msg' ~status_code:404 "path not found: %s" path) + |> jsobj_of_http_response val handle_post_ = fun path_js reqbody_js -> - let path = Pjv.to_string path_js in - let reqbody = json_of_jsobj reqbody_js in - verbose "handle_post[%s]@\n @[%a@]" path Json.pp_lit reqbody; - (match path with - | "/addxy" -> ( - match - reqbody - |> Jv.(pump_field "y" &> pump_field "x") - with - | `obj ["x", `num x; "y", `num y] -> - verbose "/addxy parsed x=%f, y=%f" x y; - Resp.ret ~wrap:(`in_field "result") (`num (x +. y)) - | _ -> - Resp.msg ~status_code:400 {|bad request. example: { "x": 1, "y": 2 }|} - ) - | _ -> Resp.msg' ~status_code:404 "path not found: %s" path - ) |> jsobj_of_http_response - - end |> Js_of_ocaml.Js.export_all + let path = Pjv.to_string path_js in + let reqbody = json_of_jsobj reqbody_js in + verbose "handle_post[%s]@\n @[%a@]" path Json.pp_lit reqbody; + (match path with + | "/addxy" -> ( + match reqbody |> Jv.(pump_field "y" &> pump_field "x") with + | `obj [ ("x", `num x); ("y", `num y) ] -> + verbose "/addxy parsed x=%f, y=%f" x y; + Resp.ret ~wrap:(`in_field "result") (`num (x +. y)) + | _ -> + Resp.msg ~status_code:400 + {|bad request. example: { "x": 1, "y": 2 }|}) + | _ -> Resp.msg' ~status_code:404 "path not found: %s" path) + |> jsobj_of_http_response + end + |> Js_of_ocaml.Js.export_all From 11bb79a8ef81d6b9a20ec0516c0813dc7e482eb6 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Fri, 14 Jul 2023 05:15:15 +0900 Subject: [PATCH 2/3] opstic --- apps/main-entry/mlsrc/dune | 11 +- apps/main-entry/mlsrc/server_main.bc.d.ts | 5 +- apps/main-entry/mlsrc/server_main.ml | 128 ++++++++++++++++------ apps/main-entry/mlsrc/server_main.spec.ts | 4 +- apps/main-entry/src/main.ts | 24 +++- vendors/kxclib | 1 - vendors/opstic | 1 + vendors/prr | 1 - 8 files changed, 130 insertions(+), 45 deletions(-) delete mode 160000 vendors/kxclib create mode 120000 vendors/opstic delete mode 160000 vendors/prr diff --git a/apps/main-entry/mlsrc/dune b/apps/main-entry/mlsrc/dune index e89f74d..89c8b04 100644 --- a/apps/main-entry/mlsrc/dune +++ b/apps/main-entry/mlsrc/dune @@ -1,12 +1,13 @@ (executables (names server_main) (libraries + opstic bisect_ppx.runtime prr kxclib kxclib.jsoo) (preprocess - (pps js_of_ocaml-ppx)) + (pps js_of_ocaml-ppx opstic.ppx rows.ppx)) (instrumentation (backend bisect_ppx)) (modes byte js) (flags @@ -23,7 +24,13 @@ --source-map --target-env browser ;; note that this is intentional even when we target nodejs - --no-inline)) + --no-inline + ; --pretty + ; --debug-info + ; --disable staticeval + ; --disable + ; share + )) (link_flags ((:standard \ --source-map-inline --pretty) --source-map)))) diff --git a/apps/main-entry/mlsrc/server_main.bc.d.ts b/apps/main-entry/mlsrc/server_main.bc.d.ts index bd223ca..4e54b47 100644 --- a/apps/main-entry/mlsrc/server_main.bc.d.ts +++ b/apps/main-entry/mlsrc/server_main.bc.d.ts @@ -3,10 +3,11 @@ export type Http_response = { body: unknown; }; -export declare function handle_get(path: string): Http_response; +export declare function handle_get(path: string): Promise; export declare function handle_post( path: string, - reqbody: unknown + reqbody: unknown, + express: express ): Http_response; export interface Bisect_ppx_jsoo_coverage_helper { diff --git a/apps/main-entry/mlsrc/server_main.ml b/apps/main-entry/mlsrc/server_main.ml index f6ffa1b..fe97992 100644 --- a/apps/main-entry/mlsrc/server_main.ml +++ b/apps/main-entry/mlsrc/server_main.ml @@ -1,6 +1,9 @@ module Pjv = Prr.Jv open Kxclib.Json -open Log0 +open Kxclib.Log0 +open Opstic.Monad + +let ( let* ) = Opstic.Monad.bind type http_response = { status_code : int; @@ -53,36 +56,99 @@ let coverage_helper_js = end [@@coverage off] +let server = Opstic.Server.create () + +let to_promise : http_response Prr.Fut.or_error -> Pjv.t = + fun m -> Prr.Fut.to_promise ~ok:jsobj_of_http_response m + let () = info "%s loaded" __FILE__; + let obj = + object%js + val coverage_helper_js = coverage_helper_js - object%js - val coverage_helper_js = coverage_helper_js - - val handle_get_ = - fun path_js -> - let path = Pjv.to_string path_js in - verbose "handle_get[%s]" path; - (match path with - | "/" -> Resp.msg "hello?" - | _ -> Resp.msg' ~status_code:404 "path not found: %s" path) - |> jsobj_of_http_response - - val handle_post_ = - fun path_js reqbody_js -> - let path = Pjv.to_string path_js in - let reqbody = json_of_jsobj reqbody_js in - verbose "handle_post[%s]@\n @[%a@]" path Json.pp_lit reqbody; - (match path with - | "/addxy" -> ( - match reqbody |> Jv.(pump_field "y" &> pump_field "x") with - | `obj [ ("x", `num x); ("y", `num y) ] -> - verbose "/addxy parsed x=%f, y=%f" x y; - Resp.ret ~wrap:(`in_field "result") (`num (x +. y)) - | _ -> - Resp.msg ~status_code:400 - {|bad request. example: { "x": 1, "y": 2 }|}) - | _ -> Resp.msg' ~status_code:404 "path not found: %s" path) - |> jsobj_of_http_response - end - |> Js_of_ocaml.Js.export_all + val handle_get_ = + fun path_js -> + let path = Pjv.to_string path_js in + verbose "handle_get[%s]" path; + (match path with + | "/" -> return (Resp.msg "hello?") + | _ -> + return + (Resp.msg' ~status_code:404 "path not found: %s" path)) + |> to_promise + + val handle_post_ = + fun path_js reqbody_js _req_js -> + let path = Pjv.to_string path_js in + let reqbody = json_of_jsobj reqbody_js in + verbose "handle_post[%s]@\n @[%a@]" path Json.pp_lit reqbody; + (match path with + | "/adder" -> + Opstic.Monad.then_ + (fun () -> + Opstic.Server.handle_request server ~path reqbody + reqbody_js) + (function + | Ok body -> return { status_code = 200; body } + | Error err -> + return + { + status_code = 500; + body = `str (Opstic.Monad.error_to_string err); + }) + | "/hello" -> + Opstic.Monad.return + { status_code = 200; body = `str "hello" } + | "/addxy" -> ( + match + reqbody |> Jv.(pump_field "y" &> pump_field "x") + with + | `obj [ ("x", `num x); ("y", `num y) ] -> + verbose "/addxy parsed x=%f, y=%f" x y; + return + (Resp.ret ~wrap:(`in_field "result") + (`num (x +. y))) + | _ -> + return + (Resp.msg ~status_code:400 (Json.unparse reqbody)) + (* {|bad request. example: { "x": 1, "y": 2 }|} *)) + | _ -> return (Resp.msg ~status_code:404 "path not found")) + |> to_promise + end + in + obj |> Js_of_ocaml.Js.export_all + +open Opstic + +[@@@ocaml.warning "-11-32"] + +let%global g = + let rec loop = + b#args = "/adder" => a :: `obj (("x", `num __):: ("y", `num __) :: __ ); + a + *>> ( (a#ans ==> b :: `obj [ ("ans", `num __) ]; + loop), + a#err ==> b :: `obj [ ("msg", `str __) ] ) + in + loop + +let spec = [%project_global g a] + +let () = + let open Opstic.Comm in + let rec loop (`b (`args ((x, y, _), ep))) = + if x > 0. && y > 0. then + let* ep = send ep (fun x -> x#b#ans) (x +. y) in + let* vars = receive ep in + loop vars + else + let* ep = + send ep + (fun x -> x#b#err) + "Oops, both x and y should be positive" + in + close ep; + return () + in + start_service server spec loop diff --git a/apps/main-entry/mlsrc/server_main.spec.ts b/apps/main-entry/mlsrc/server_main.spec.ts index 655a428..91d3493 100644 --- a/apps/main-entry/mlsrc/server_main.spec.ts +++ b/apps/main-entry/mlsrc/server_main.spec.ts @@ -6,8 +6,8 @@ describe("mlsrc/server_main correctness", () => { coverage_helper.write_coverage_data(); coverage_helper.reset_counters(); }); - it("gives 404 on non-existing GET paths", () => { - const { status_code, body } = camlimpl.handle_get( + it("gives 404 on non-existing GET paths", async () => { + const { status_code, body } = await camlimpl.handle_get( "/this-path-should-not-exists-or-we-are-screwed" ); expect(status_code).toEqual(404); diff --git a/apps/main-entry/src/main.ts b/apps/main-entry/src/main.ts index 178f4d7..80d1cc8 100644 --- a/apps/main-entry/src/main.ts +++ b/apps/main-entry/src/main.ts @@ -9,14 +9,26 @@ app.get("/_ping", (req, res) => { res.send(answerForPing()); }); -app.get("/*", (req, res) => { - const { status_code, body } = camlimpl.handle_get(req.path); - res.status(status_code).send(body); +app.get("/*", async (req, res) => { + const { status_code, body } = await camlimpl.handle_get(req.path);; + return res.status(status_code).send(body); }); -app.post("/*", (req, res) => { - const { status_code, body } = camlimpl.handle_post(req.path, req.body); - res.status(status_code).send(body); +app.post("/*", async (req, res) => { + console.log(req.body) + try { + const { status_code, body } = await camlimpl.handle_post(req.path, req.body, req); + return res.status(status_code).send(body); + } catch (err) { + console.log("Error:" + (err as any)); + if (err instanceof Error) { + if (err.name == "OpsticError") { + return res.status(500).send(err.name + ": " + err.message); + } + } + throw err; + } + }); /* istanbul ignore next */ diff --git a/vendors/kxclib b/vendors/kxclib deleted file mode 160000 index 5d800d9..0000000 --- a/vendors/kxclib +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5d800d9336a06937356a17eb4f84ec28051c7d49 diff --git a/vendors/opstic b/vendors/opstic new file mode 120000 index 0000000..32c95e2 --- /dev/null +++ b/vendors/opstic @@ -0,0 +1 @@ +/Users/keigoi/Dropbox/Code/opstic \ No newline at end of file diff --git a/vendors/prr b/vendors/prr deleted file mode 160000 index c11b0c1..0000000 --- a/vendors/prr +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c11b0c1d033f2fd238de3651239e71f0c5b9728d From 553962267bd60092c389b9a2637b96f2a2114f87 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Wed, 19 Jul 2023 06:49:20 +0900 Subject: [PATCH 3/3] change protocol / remove unrelated things from handle_post --- apps/main-entry/mlsrc/server_main.ml | 76 +++++++++++----------------- 1 file changed, 29 insertions(+), 47 deletions(-) diff --git a/apps/main-entry/mlsrc/server_main.ml b/apps/main-entry/mlsrc/server_main.ml index fe97992..65cb619 100644 --- a/apps/main-entry/mlsrc/server_main.ml +++ b/apps/main-entry/mlsrc/server_main.ml @@ -29,13 +29,13 @@ module Resp = struct let msg' ?status_code fmt = Format.kasprintf (msg ?status_code) fmt - let ret ?(status_code = 200) ?wrap body = - let body = - match wrap with - | Some (`in_field fname) -> `obj [ (fname, body) ] - | None -> body - in - { status_code; body } + (* let ret ?(status_code = 200) ?wrap body = + let body = + match wrap with + | Some (`in_field fname) -> `obj [ (fname, body) ] + | None -> body + in + { status_code; body } *) end let coverage_helper_js = @@ -83,37 +83,18 @@ let () = let path = Pjv.to_string path_js in let reqbody = json_of_jsobj reqbody_js in verbose "handle_post[%s]@\n @[%a@]" path Json.pp_lit reqbody; - (match path with - | "/adder" -> - Opstic.Monad.then_ - (fun () -> - Opstic.Server.handle_request server ~path reqbody - reqbody_js) - (function - | Ok body -> return { status_code = 200; body } - | Error err -> - return - { - status_code = 500; - body = `str (Opstic.Monad.error_to_string err); - }) - | "/hello" -> - Opstic.Monad.return - { status_code = 200; body = `str "hello" } - | "/addxy" -> ( - match - reqbody |> Jv.(pump_field "y" &> pump_field "x") - with - | `obj [ ("x", `num x); ("y", `num y) ] -> - verbose "/addxy parsed x=%f, y=%f" x y; - return - (Resp.ret ~wrap:(`in_field "result") - (`num (x +. y))) - | _ -> + Opstic.Monad.then_ + (fun () -> + Opstic.Server.handle_request server ~path reqbody + reqbody_js) + (function + | Ok body -> return { status_code = 200; body } + | Error err -> return - (Resp.msg ~status_code:400 (Json.unparse reqbody)) - (* {|bad request. example: { "x": 1, "y": 2 }|} *)) - | _ -> return (Resp.msg ~status_code:404 "path not found")) + { + status_code = 500; + body = `str (Opstic.Monad.error_to_string err); + }) |> to_promise end in @@ -125,30 +106,31 @@ open Opstic let%global g = let rec loop = - b#args = "/adder" => a :: `obj (("x", `num __):: ("y", `num __) :: __ ); - a - *>> ( (a#ans ==> b :: `obj [ ("ans", `num __) ]; + cli#args = "/adder" + => srv :: `obj (("x", `num __) :: ("y", `num __) :: __); + srv + *>> ( (srv#ans ==> cli :: `obj [ ("ans", `num __) ]; loop), - a#err ==> b :: `obj [ ("msg", `str __) ] ) + srv#err ==> cli :: `obj [ ("msg", `str __) ] ) in loop -let spec = [%project_global g a] +let spec = [%project_global g srv] let () = let open Opstic.Comm in - let rec loop (`b (`args ((x, y, _), ep))) = + let rec loop acc (`cli (`args ((x, y, _), ep))) = if x > 0. && y > 0. then - let* ep = send ep (fun x -> x#b#ans) (x +. y) in + let* ep = send ep (fun x -> x#cli#ans) (x +. y +. acc) in let* vars = receive ep in - loop vars + loop acc vars else let* ep = send ep - (fun x -> x#b#err) + (fun x -> x#cli#err) "Oops, both x and y should be positive" in close ep; return () in - start_service server spec loop + start_service server spec (loop 0.0)