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/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 eddf28a..65cb619 100644 --- a/apps/main-entry/mlsrc/server_main.ml +++ b/apps/main-entry/mlsrc/server_main.ml @@ -1,16 +1,19 @@ 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; - 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 +24,113 @@ 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 - { status_code; body } + 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 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 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; + 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); + }) + |> to_promise + end + in + obj |> Js_of_ocaml.Js.export_all + +open Opstic + +[@@@ocaml.warning "-11-32"] - 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 +let%global g = + let rec loop = + cli#args = "/adder" + => srv :: `obj (("x", `num __) :: ("y", `num __) :: __); + srv + *>> ( (srv#ans ==> cli :: `obj [ ("ans", `num __) ]; + loop), + srv#err ==> cli :: `obj [ ("msg", `str __) ] ) + in + loop + +let spec = [%project_global g srv] + +let () = + let open Opstic.Comm in + let rec loop acc (`cli (`args ((x, y, _), ep))) = + if x > 0. && y > 0. then + let* ep = send ep (fun x -> x#cli#ans) (x +. y +. acc) in + let* vars = receive ep in + loop acc vars + else + let* ep = + send ep + (fun x -> x#cli#err) + "Oops, both x and y should be positive" + in + close ep; + return () + in + start_service server spec (loop 0.0) 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