Add Morph OCaml framework (#6066)

* Add Morph OCaml framework

* Fix running tests

* Update meta files

* Simplify dockerfile

* Minor refactor

* Fix copy of esy.lock

* Add static option

* Make sure libev is used

frameworks/OCaml/.gitignore

@@ -2,3 +2,5 @@
 **/_build
 .merlin
 .ocamlformat
+_esy
+*.install

frameworks/OCaml/morph/README.md

@@ -0,0 +1,53 @@
+# Morph Benchmarking Test
+
+### Test Type Implementation Source Code
+
+* [JSON](./src/bin/Json_handler.re)
+* [PLAINTEXT](./src/bin/Json_handler.re)
+* [DB](./src/bin/Db_handler.re)
+* [QUERY](./src/bin/Query_handler.re)
+<!--
+* [CACHED QUERY](Relative/Path/To/Your/Source/File)
+* [UPDATE](Relative/Path/To/Your/Source/File)
+* [FORTUNES](Relative/Path/To/Your/Source/File)
+-->
+
+## Important Libraries
+The tests were run with:
+* [Morph](https://github.com/reason-native-web/morph)
+* [<ttpaf (fork)](https://github.com/anmonteiro/httpaf)
+* [Caqti](https://github.com/paurkedal/ocaml-caqti)
+* [Lwt](https://github.com/ocsigen/lwt)
+* [Yojson](https://github.com/ocaml-community/yojson)
+* [Ptime](https://github.com/dbuenzli/ptime)
+
+## Test URLs
+### JSON
+
+http://localhost:8080/json
+
+### PLAINTEXT
+
+http://localhost:8080/plaintext
+
+### DB
+
+http://localhost:8080/db
+
+### QUERY
+
+http://localhost:8080/query?queries=
+
+<!--
+### CACHED QUERY
+
+http://localhost:8080/cached_query?queries=
+
+### UPDATE
+
+http://localhost:8080/update?queries=
+
+### FORTUNES
+
+http://localhost:8080/fortunes
+-->

frameworks/OCaml/morph/benchmark_config.json

@@ -0,0 +1,49 @@
+{
+  "framework": "morph",
+  "tests": [
+    {
+      "default": {
+        "json_url": "/json",
+        "plaintext_url": "/plaintext",
+        "db_url": "/db",
+        "query_url": "/queries/",
+        "port": 8080,
+        "approach": "Realistic",
+        "classification": "Micro",
+        "database": "postgres",
+        "framework": "Morph",
+        "language": "OCaml",
+        "flavor": "None",
+        "orm": "Raw",
+        "platform": "None",
+        "webserver": "None",
+        "os": "Linux",
+        "database_os": "Linux",
+        "display_name": "Morph",
+        "notes": "",
+        "versus": "None"
+      },
+      "static": {
+        "json_url": "/json",
+        "plaintext_url": "/plaintext",
+        "db_url": "/db",
+        "query_url": "/queries/",
+        "port": 8080,
+        "approach": "Realistic",
+        "classification": "Micro",
+        "database": "postgres",
+        "framework": "Morph",
+        "language": "OCaml",
+        "flavor": "None",
+        "orm": "Raw",
+        "platform": "None",
+        "webserver": "None",
+        "os": "Linux",
+        "database_os": "Linux",
+        "display_name": "Morph",
+        "notes": "",
+        "versus": "None"
+      }
+    }
+  ]
+}

frameworks/OCaml/morph/morph-static.dockerfile

@@ -0,0 +1,33 @@
+FROM alpine:latest as certs
+RUN apk --update add ca-certificates
+
+FROM reasonnative/web:4.10.0 as builder
+
+RUN mkdir /app
+WORKDIR /app
+
+COPY src/esy.json src/morph-tfb.opam src/dune-project /app/
+
+RUN esy install
+RUN esy build-dependencies --release
+
+COPY ./src/bin /app/bin
+
+RUN esy dune build --profile=docker --release
+
+RUN esy mv "#{self.target_dir / 'default' / 'bin' / 'tfb.exe'}" main.exe
+
+RUN strip main.exe
+
+FROM scratch as runtime
+
+ENV OPENSSL_STATIC=1
+ENV SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt
+ENV SSL_CERT_DIR=/etc/ssl/certs
+COPY --from=certs /etc/ssl/certs/ca-certificates.crt /etc/ssl/certs/
+
+WORKDIR /app
+
+COPY --from=builder /app/main.exe main.exe
+
+ENTRYPOINT ["/app/main.exe"]

frameworks/OCaml/morph/morph.dockerfile

@@ -0,0 +1,15 @@
+FROM reasonnative/web:4.10.0 as builder
+
+RUN mkdir /app
+WORKDIR /app
+
+COPY src/esy.json src/morph-tfb.opam src/dune-project /app/
+
+RUN esy install
+RUN esy build-dependencies --release
+
+COPY ./src/bin /app/bin
+
+RUN esy build --release
+
+ENTRYPOINT ["esy", "x", "--release", "tfb"]

frameworks/OCaml/morph/src/.gitignore

@@ -0,0 +1,2 @@
+.merlin
+!bin/

frameworks/OCaml/morph/src/bin/Db_middleware.re

@@ -0,0 +1,18 @@
+module Env = {
+  let key = Hmap.Key.create();
+};
+
+let get_db = (request: Morph.Request.t) => Hmap.get(Env.key, request.ctx);
+
+let use = (request, query) => {
+  let pool = get_db(request);
+  Caqti_lwt.Pool.use(query, pool);
+};
+
+let middleware:
+  (~db: Caqti_lwt.Pool.t(module Caqti_lwt.CONNECTION, 'e)) =>
+  Morph.Server.middleware =
+  (~db, handler, request) => {
+    let next_request = {...request, ctx: Hmap.add(Env.key, db, request.ctx)};
+    handler(next_request);
+  };

frameworks/OCaml/morph/src/bin/Db_middleware.rei

@@ -0,0 +1,10 @@
+let use:
+  (
+    Morph.Request.t,
+    (module Caqti_lwt.CONNECTION) => Lwt.t(result('a, Caqti_error.t))
+  ) =>
+  Lwt.t(result('a, Caqti_error.t));
+
+let middleware:
+  (~db: Caqti_lwt.Pool.t(module Caqti_lwt.CONNECTION, Caqti_error.t)) =>
+  Morph.Server.middleware;

frameworks/OCaml/morph/src/bin/Handlers.re

@@ -0,0 +1,63 @@
+let select_random =
+  Caqti_request.find(
+    Caqti_type.int,
+    Caqti_type.(tup2(int, int)),
+    "SELECT id, randomNumber FROM World WHERE id = $1",
+  );
+
+let text = _req => {
+  Morph.Response.text("Hello, World!") |> Lwt.return;
+};
+
+let json = _req => {
+  let json = `Assoc([("message", `String("Hello, World!"))]);
+  Yojson.Safe.to_string(json) |> Morph.Response.json |> Lwt.return;
+};
+
+let db = req => {
+  open Lwt_result.Infix;
+  let read_db' = (module C: Caqti_lwt.CONNECTION) =>
+    C.find(select_random, Random.int(10000 + 1));
+  Db_middleware.use(req, read_db')
+  |> Lwt_result.map_err(e => `Server(Caqti_error.show(e)))
+  >>= (
+    ((id, randomNumber)) => {
+      `Assoc([("id", `Int(id)), ("randomNumber", `Int(randomNumber))])
+      |> Yojson.Safe.to_string
+      |> Morph.Response.json
+      |> Lwt.return;
+    }
+  );
+};
+
+let queries = (queries, req: Morph.Request.t) => {
+  open Lwt.Infix;
+
+  let query_ids = List.init(queries, _ => Random.int(10000 + 1));
+
+  let read_query' = (x, module C: Caqti_lwt.CONNECTION) => {
+    C.find(select_random, x);
+  };
+
+  let pool = Db_middleware.use(req);
+
+  query_ids
+  |> List.map(id =>
+       pool(read_query'(id))
+       >|= (
+         fun
+         | Ok((id, randomNumber)) =>
+           Ok(
+             `Assoc([
+               ("id", `Int(id)),
+               ("randomNumber", `Int(randomNumber)),
+             ]),
+           )
+         | Error(err) => Error(err)
+       )
+     )
+  |> Lwt.all
+  >|= List.filter_map(Result.to_option)
+  >|= (l => Yojson.Safe.to_string(`List(l)))
+  >|= Morph.Response.json;
+};

frameworks/OCaml/morph/src/bin/Handlers.rei

@@ -0,0 +1,7 @@
+let text: Morph.Server.handler;
+
+let json: Morph.Server.handler;
+
+let db: Morph.Server.handler;
+
+let queries: int => Morph.Server.handler;

frameworks/OCaml/morph/src/bin/Headers_middleware.ml

@@ -0,0 +1,36 @@
+let weekday_to_string = function
+| `Mon -> "Mon"
+| `Tue -> "Tue"
+| `Wed -> "Wed"
+| `Thu -> "Thu"
+| `Fri -> "Fri"
+| `Sat -> "Sat"
+| `Sun -> "Sun"
+
+let month_to_string = function
+| 1 -> "Jan"
+| 2 -> "Feb"
+| 3 -> "Mar"
+| 4 -> "Apr"
+| 5 -> "May"
+| 6 -> "Jun"
+| 7 -> "Jul"
+| 8 -> "Aug"
+| 9 -> "Sep"
+| 10 -> "Oct"
+| 11 -> "Nov"
+| 12 -> "Dec"
+| _ -> failwith "month"
+
+let timestamp now =
+  let weekday_str = weekday_to_string (Ptime.weekday now) in
+  let ((year, month, day), ((hour, minute, second), _)) = Ptime.to_date_time now in
+  let month_str = month_to_string month in
+  Printf.sprintf "%s, %02u %s %04u %02u:%02u:%02u GMT" weekday_str day month_str year hour minute second
+
+let make (handler: Morph.Server.handler) request =
+  let open Lwt.Infix in
+  handler(request) >|= Morph.Response.add_headers [
+    ("Date", (timestamp (Ptime_clock.now ())));
+    ("Server", "Morph");
+  ] 

frameworks/OCaml/morph/src/bin/Logger.ml

@@ -0,0 +1,57 @@
+(*----------------------------------------------------------------------------
+ * Copyright (c) 2019-2020, António Nuno Monteiro
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ *    this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+ *
+ * 3. Neither the name of the copyright holder nor the names of its
+ *    contributors may be used to endorse or promote products derived from
+ *    this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *---------------------------------------------------------------------------*)
+
+(* The following snippet is borrowed from https://github.com/anmonteiro/piaf/blob/master/bin/carl.ml *)
+
+let setup_log ?style_renderer level =
+  let pp_header src ppf (l, h) =
+    if l = Logs.App then Format.fprintf ppf "%a" Logs_fmt.pp_header (l, h)
+    else
+      let x =
+        match Array.length Sys.argv with
+        | 0 -> Filename.basename Sys.executable_name
+        | _n -> Filename.basename Sys.argv.(0)
+      in
+      let x =
+        if Logs.Src.equal src Logs.default then x else Logs.Src.name src
+      in
+      Format.fprintf ppf "%s: %a " x Logs_fmt.pp_header (l, h)
+  in
+  let format_reporter =
+    let report src =
+      let { Logs.report } = Logs_fmt.reporter ~pp_header:(pp_header src) () in
+      report src
+    in
+    { Logs.report }
+  in
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level ~all:true level;
+  Logs.set_reporter format_reporter

frameworks/OCaml/morph/src/bin/Router.ml

@@ -0,0 +1,36 @@
+let json_route : (Morph.Server.handler, 'a) Routes.target =
+  Routes.(s "json" /? nil)
+
+let plaintext_route : (Morph.Server.handler, 'a) Routes.target =
+  Routes.(s "plaintext" /? nil)
+
+let db_route : (Morph.Server.handler, 'a) Routes.target =
+  Routes.(s "db" /? nil)
+
+let query_route_missing : (Morph.Server.handler, 'a) Routes.target =
+  Routes.(s "queries" //? nil)
+
+let query_route_int =
+  Routes.(s "queries" / int /? nil)
+
+
+let query_route_str =
+  Routes.(s "queries" / str /? nil)
+
+let not_found_handler _request =
+  Morph.Response.not_found () |> Lwt.return
+
+let routes = Routes.[
+  json_route @--> Handlers.json;
+  plaintext_route @--> Handlers.text;
+  db_route @--> Handlers.db;
+  query_route_missing @--> Handlers.queries 1;
+  query_route_int @--> (function
+  | queries when queries > 500 -> Handlers.queries 500
+  | queries when queries < 1 -> Handlers.queries 1
+  | queries -> Handlers.queries queries
+  );
+  query_route_str @--> (fun _ -> Handlers.queries 1);
+]
+
+let handler = Morph.Router.make ~get:routes ~print:true ~not_found_handler ();

frameworks/OCaml/morph/src/bin/dune

@@ -0,0 +1,13 @@
+(executable
+ (name tfb)
+ (public_name tfb)
+ (link_flags -ccopt -lpq -cclib -lpgport -cclib -lpgcommon -ccopt
+   %{env:LDFLAGS=-lpq} -cclib %{env:LIBEV_LIBS=-lev})
+ (libraries caqti caqti-lwt caqti-driver-postgresql lwt logs logs.fmt fmt.tty
+   morph archi archi-lwt routes yojson ptime ptime.clock ptime.clock.os))
+
+(env
+ (docker
+  (flags
+   (:standard -ccopt -static -ccopt %{env:CFLAGS=/lib} -cclib
+     %{env:LDFLAGS=-lpq} -cclib -L%{env:LD_LIBRARY_PATH=/lib}))))

frameworks/OCaml/morph/src/bin/tfb.re

@@ -0,0 +1,94 @@
+module Database = {
+  let start =
+      ()
+      : Lwt.t(
+          result(
+            Caqti_lwt.Pool.t(module Caqti_lwt.CONNECTION, Caqti_error.t),
+            string,
+          ),
+        ) => {
+    let connection_url = "postgresql://benchmarkdbuser:benchmarkdbpass@tfb-database:5432/hello_world?connect_timeout=15";
+
+    Caqti_lwt.connect_pool(~max_size=10, Uri.of_string(connection_url))
+    |> (
+      fun
+      | Ok(pool) => Ok(pool)
+      | Error(error) => Error(Caqti_error.show(error))
+    )
+    |> Lwt.return;
+  };
+
+  let stop = _pool => {
+    Logs.info(m => m("Disconnected from database")) |> Lwt.return;
+  };
+
+  let component = Archi_lwt.Component.make(~start, ~stop);
+};
+
+module WebServer = {
+  let port =
+    try(Sys.getenv("PORT") |> int_of_string) {
+    | _ => 8080
+    };
+
+  let server = Morph.Server.make(~port, ~address=Unix.inet_addr_any, ());
+
+  let start = ((), db) => {
+    Logs.app(m => m("Starting server on %n", port));
+
+    let handler =
+      Headers_middleware.make(Db_middleware.middleware(~db, Router.handler));
+
+    server.start(handler) |> Lwt_result.ok;
+  };
+
+  let stop = _server => {
+    Logs.info(m => m("Stopped Server")) |> Lwt.return;
+  };
+
+  let component =
+    Archi_lwt.Component.using(
+      ~start,
+      ~stop,
+      ~dependencies=[Database.component],
+    );
+};
+
+let system =
+  Archi_lwt.System.make([
+    ("database", Database.component),
+    ("web_server", WebServer.component),
+  ]);
+
+let main = () => {
+  open Lwt.Infix;
+  Logger.setup_log(Some(Logs.Info));
+
+  Archi_lwt.System.start((), system)
+  >|= (
+    fun
+    | Ok(system) => {
+        Logs.info(m => m("Starting"));
+
+        Sys.(
+          set_signal(
+            sigint,
+            Signal_handle(
+              _ => {
+                Logs.err(m => m("SIGNINT received, tearing down.@."));
+                Archi_lwt.System.stop(system) |> ignore;
+              },
+            ),
+          )
+        );
+      }
+    | Error(error) => {
+        Logs.err(m => m("ERROR: %s@.", error));
+        exit(1);
+      }
+  );
+};
+
+Lwt_engine.set((new Lwt_engine.libev)());
+
+let () = Lwt_main.run(main());

frameworks/OCaml/morph/src/dune-project

@@ -0,0 +1,29 @@
+(lang dune 2.5)
+
+(name morph-tfb)
+
+(generate_opam_files true)
+
+(authors "Ulrik Strid")
+
+(maintainers "[email protected]")
+
+(package
+ (name morph-tfb)
+ (synopsis "Framework Benchmark for Morph")
+ (depends
+  (ocaml
+   (>= 4.11.0))
+  archi
+  archi-lwt
+  pgx
+  pgx_lwt_unix
+  dune
+  fmt
+  logs
+  lwt
+  routes
+  uri
+  yojson
+  morph
+  piaf))

frameworks/OCaml/morph/src/esy.json

@@ -0,0 +1,49 @@
+{
+  "name": "morph-tfb",
+  "version": "0.0.0",
+  "description": "Benchmarks for morph",
+  "esy": {
+    "build": ["dune build -p #{self.name}"],
+    "buildDev": "dune build --root=. --promote-install-file"
+  },
+  "scripts": {
+    "start": "redemon -p ./src dune exec src/tfb.exe",
+    "test": "dune runtest --no-buffer",
+    "watch:test": "redemon -p ./oidc -p ./oidc-client -p ./test esy x RunTests.exe",
+    "docs": "dune build @doc --root .",
+    "fmt": "dune build @fmt --auto-promote --root .",
+    "docs-path": "esy echo #{self.target_dir / 'default' / '_doc' / '_html' / 'index.html'}"
+  },
+  "dependencies": {
+    "@esy-ocaml/reason": "^3.6.2",
+    "@opam/archi": "*",
+    "@opam/archi-lwt": "*",
+    "@opam/caqti": "^1.2.0",
+    "@opam/caqti-lwt": "^1.2.0",
+    "@opam/caqti-driver-postgresql": "^1.2.0",
+    "@opam/dune": "^2.5.0",
+    "@opam/fmt": "*",
+    "@opam/logs": "*",
+    "@opam/lwt": "^5.0.0",
+    "@opam/routes": "*",
+    "@opam/uri": "*",
+    "@opam/yojson": "*",
+    "@reason-native-web/morph": "^0.6.1",
+    "@reason-native-web/piaf": "^1.4.0",
+    "@reason-native-web/esy-openssl": "^1.1.1006",
+    "@opam/conf-libev": "esy-packages/libev:package.json#0b5eb6685b688649045aceac55dc559f6f21b829",
+    "ocaml": "~4.10.0"
+  },
+  "devDependencies": {
+    "@opam/merlin": "*",
+    "@opam/ocaml-lsp-server": "ocaml/ocaml-lsp:ocaml-lsp-server.opam",
+    "@opam/ocamlformat": "*"
+  },
+  "resolutions": {
+    "@reason-native-web/morph": "reason-native-web/morph:morph.json#c7bdd60dbfb99eccd4ce27559117919455061e0e",
+    "@opam/caqti": "ulrikstrid/ocaml-caqti:caqti.opam#c0ead31422c3670f8250a50043a1038cab4f011f",
+    "@opam/conf-postgresql": "ulrikstrid/postgresql:package.json#193d72af7f2132e30ad429401232da6359b248a2",
+    "@opam/conf-pkg-config": "esy-ocaml/yarn-pkg-config#db3a0b63883606dd57c54a7158d560d6cba8cd79",
+    "@opam/session": "inhabitedtype/ocaml-session:session.opam#6180413"
+  }
+}

frameworks/OCaml/morph/src/morph-tfb.opam

@@ -0,0 +1,45 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Framework Benchmark for Morph"
+maintainer: ["[email protected]"]
+authors: ["Ulrik Strid"]
+depends: [
+  "ocaml" {>= "4.11.0"}
+  "archi"
+  "archi-lwt"
+  "pgx"
+  "pgx_lwt_unix"
+  "dune"
+  "fmt"
+  "logs"
+  "lwt"
+  "routes"
+  "uri"
+  "yojson"
+  "morph"
+  "piaf"
+]
+build: [
+  ["dune" "subst"] {pinned}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+pin-depends: [
+  [ "reason.dev" "git+https://github.com/facebook/reason#master"]
+  [ "piaf.dev" "git+https://github.com/anmonteiro/piaf.git#master" ]
+  [ "httpaf.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "httpaf-lwt.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "httpaf-lwt-unix.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "ssl.dev" "git+https://github.com/savonet/ocaml-ssl.git#6b75fac" ]
+  [ "morph.dev" "git+https://github.com/reason-native-web/morph.git#master" ]
+  [ "session.dev" "git+https://github.com/inhabitedtype/ocaml-session.git#master" ]
+]

frameworks/OCaml/morph/src/morph-tfb.opam.template

@@ -0,0 +1,10 @@
+pin-depends: [
+  [ "reason.dev" "git+https://github.com/facebook/reason#master"]
+  [ "piaf.dev" "git+https://github.com/anmonteiro/piaf.git#master" ]
+  [ "httpaf.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "httpaf-lwt.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "httpaf-lwt-unix.dev" "git+https://github.com/anmonteiro/httpaf.git#fork" ]
+  [ "ssl.dev" "git+https://github.com/savonet/ocaml-ssl.git#6b75fac" ]
+  [ "morph.dev" "git+https://github.com/reason-native-web/morph.git#master" ]
+  [ "session.dev" "git+https://github.com/inhabitedtype/ocaml-session.git#master" ]
+]