From acc6edb6f0764a2a310436fbbbb1a4c0014cc48b Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Mon, 23 Mar 2026 23:41:28 +0000 Subject: [PATCH 1/5] Add vif: OCaml 5 web framework with Miou multicore scheduler vif is built on httpcats and the Miou cooperative/preemptive scheduler, taking advantage of OCaml 5 domains for multicore HTTP serving. Key highlights: - Pure OCaml stack (TLS, crypto, compression all in OCaml) - Typed routing checked at compile time - httpcats engine for HTTP/1.1 parsing and connection management - Gzip compression via decompress (pure OCaml zlib implementation) Endpoints: baseline, pipelined, json, compression, upload, db, noisy, mixed References: - https://github.com/robur-coop/vif - https://github.com/robur-coop/httpcats - Tutorial: https://robur-coop.github.io/vif/ --- frameworks/vif/Dockerfile | 39 ++++++ frameworks/vif/README.md | 34 +++++ frameworks/vif/build.sh | 4 + frameworks/vif/dune-project | 1 + frameworks/vif/meta.json | 19 +++ frameworks/vif/run.sh | 2 + frameworks/vif/src/dune | 3 + frameworks/vif/src/server.ml | 265 +++++++++++++++++++++++++++++++++++ 8 files changed, 367 insertions(+) create mode 100644 frameworks/vif/Dockerfile create mode 100644 frameworks/vif/README.md create mode 100755 frameworks/vif/build.sh create mode 100644 frameworks/vif/dune-project create mode 100644 frameworks/vif/meta.json create mode 100755 frameworks/vif/run.sh create mode 100644 frameworks/vif/src/dune create mode 100644 frameworks/vif/src/server.ml diff --git a/frameworks/vif/Dockerfile b/frameworks/vif/Dockerfile new file mode 100644 index 00000000..79cff8e5 --- /dev/null +++ b/frameworks/vif/Dockerfile @@ -0,0 +1,39 @@ +# Build stage +FROM ocaml/opam:debian-12-ocaml-5.3 AS builder + +# Switch to root for system deps +USER root +RUN apt-get update && apt-get install -y --no-install-recommends \ + pkg-config libsqlite3-dev libgmp-dev libffi-dev && \ + rm -rf /var/lib/apt/lists/* + +# Switch back to opam user +USER opam +WORKDIR /home/opam/app + +# Install OCaml dependencies +RUN opam update && \ + opam install -y vif yojson sqlite3 + +# Copy source +COPY --chown=opam:opam dune-project ./ +COPY --chown=opam:opam src/ src/ + +# Build +RUN eval $(opam env) && dune build --release src/server.exe + +# Runtime stage +FROM debian:12-slim + +RUN apt-get update && apt-get install -y --no-install-recommends \ + libsqlite3-0 libgmp10 libffi8 ca-certificates && \ + rm -rf /var/lib/apt/lists/* + +WORKDIR /app +COPY --from=builder /home/opam/app/_build/default/src/server.exe /app/server +COPY run.sh /app/run.sh +RUN chmod +x /app/run.sh + +EXPOSE 8080 + +CMD ["/app/run.sh"] diff --git a/frameworks/vif/README.md b/frameworks/vif/README.md new file mode 100644 index 00000000..bd8667bf --- /dev/null +++ b/frameworks/vif/README.md @@ -0,0 +1,34 @@ +# Vif — OCaml 5 Web Framework + +[Vif](https://github.com/robur-coop/vif) is a simple web framework for OCaml 5 +built on [httpcats](https://github.com/robur-coop/httpcats) and the +[Miou](https://github.com/robur-coop/miou) cooperative/preemptive scheduler. + +## Key Features + +- **Multicore OCaml 5** — takes advantage of domains via Miou +- **httpcats engine** — high-performance HTTP/1.1 and H2 implementation +- **Typed routing** — routes are type-checked at compile time +- **Pure OCaml stack** — TLS, crypto, compression all implemented in OCaml + +## Architecture + +- Single binary, multicore via Miou domains +- httpcats handles HTTP parsing and connection management +- Gzip compression via decompress (pure OCaml zlib) +- JSON via Yojson, SQLite via sqlite3-ocaml + +## Build + +```bash +./build.sh +``` + +## Run + +```bash +docker run -p 8080:8080 \ + -v $(pwd)/../../data/dataset.json:/data/dataset.json:ro \ + -v $(pwd)/../../data/dataset-large.json:/data/dataset-large.json:ro \ + httparena-vif +``` diff --git a/frameworks/vif/build.sh b/frameworks/vif/build.sh new file mode 100755 index 00000000..c3cdeef4 --- /dev/null +++ b/frameworks/vif/build.sh @@ -0,0 +1,4 @@ +#!/bin/bash +set -euo pipefail +cd "$(dirname "$0")" +docker build --network host -t httparena-vif . diff --git a/frameworks/vif/dune-project b/frameworks/vif/dune-project new file mode 100644 index 00000000..37f995d6 --- /dev/null +++ b/frameworks/vif/dune-project @@ -0,0 +1 @@ +(lang dune 3.0) diff --git a/frameworks/vif/meta.json b/frameworks/vif/meta.json new file mode 100644 index 00000000..78025ce5 --- /dev/null +++ b/frameworks/vif/meta.json @@ -0,0 +1,19 @@ +{ + "display_name": "vif", + "language": "OCaml", + "type": "framework", + "engine": "httpcats/Miou", + "description": "Vif web framework for OCaml 5 with multicore support via Miou scheduler and httpcats HTTP engine.", + "repo": "https://github.com/robur-coop/vif", + "enabled": true, + "tests": [ + "baseline", + "pipelined", + "limited-conn", + "json", + "upload", + "compression", + "noisy", + "mixed" + ] +} diff --git a/frameworks/vif/run.sh b/frameworks/vif/run.sh new file mode 100755 index 00000000..c8dd0721 --- /dev/null +++ b/frameworks/vif/run.sh @@ -0,0 +1,2 @@ +#!/bin/sh +exec /app/server diff --git a/frameworks/vif/src/dune b/frameworks/vif/src/dune new file mode 100644 index 00000000..079d28e2 --- /dev/null +++ b/frameworks/vif/src/dune @@ -0,0 +1,3 @@ +(executable + (name server) + (libraries vif flux yojson sqlite3)) diff --git a/frameworks/vif/src/server.ml b/frameworks/vif/src/server.ml new file mode 100644 index 00000000..4291a26b --- /dev/null +++ b/frameworks/vif/src/server.ml @@ -0,0 +1,265 @@ +open Vif + +(* --------------------------------------------------------------------------- + Startup: load datasets once + --------------------------------------------------------------------------- *) + +let dataset_path = + try Sys.getenv "DATASET_PATH" with Not_found -> "/data/dataset.json" + +let large_dataset_path = "/data/dataset-large.json" +let db_path = "/data/benchmark.db" + +let read_file path = + if Sys.file_exists path then begin + let ic = open_in path in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + Some (Bytes.unsafe_to_string s) + end else None + +(* Process items: add "total" = price * quantity rounded to 2 decimals *) +let process_items (items : Yojson.Basic.t list) : Yojson.Basic.t list = + List.map (fun item -> + match item with + | `Assoc fields -> + let price = match List.assoc_opt "price" fields with + | Some (`Float f) -> f + | Some (`Int n) -> Float.of_int n + | _ -> 0.0 in + let quantity = match List.assoc_opt "quantity" fields with + | Some (`Int n) -> n + | Some (`Float f) -> Float.to_int f + | _ -> 0 in + let total = Float.round (price *. Float.of_int quantity *. 100.0) /. 100.0 in + `Assoc (fields @ [("total", `Float total)]) + | other -> other + ) items + +(* Small dataset — raw JSON array *) +let dataset_raw : Yojson.Basic.t list option = + match read_file dataset_path with + | Some s -> + (match Yojson.Basic.from_string s with + | `List items -> Some items + | _ -> None + | exception _ -> None) + | None -> None + +(* Large dataset — pre-processed JSON string *) +let large_payload : string option = + match read_file large_dataset_path with + | Some s -> + (match Yojson.Basic.from_string s with + | `List items -> + let processed = process_items items in + let result = `Assoc [ + ("items", `List processed); + ("count", `Int (List.length processed)) + ] in + Some (Yojson.Basic.to_string result) + | _ -> None + | exception _ -> None) + | None -> None + +(* --------------------------------------------------------------------------- + Helpers + --------------------------------------------------------------------------- *) + +let server_header () = + Response.add ~field:"server" "vif" + +let sum_query_params req = + let params = Queries.all req in + List.fold_left (fun acc (_key, values) -> + List.fold_left (fun acc v -> + match int_of_string_opt v with + | Some n -> acc + n + | None -> acc + ) acc values + ) 0 params + +let read_body req = + let src = Request.source req in + let stream = Flux.Stream.from src in + Flux.Stream.into Flux.Sink.string stream + +let count_body_bytes req = + let src = Request.source req in + let stream = Flux.Stream.from src in + Flux.Stream.into (Flux.Sink.fold (fun acc chunk -> acc + String.length chunk) 0) stream + +(* --------------------------------------------------------------------------- + Routes + --------------------------------------------------------------------------- *) + +(* GET /pipeline — simple "ok" response *) +let pipeline req _server () = + let open Response.Syntax in + let* () = server_header () in + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req "ok" in + Response.respond `OK + +(* GET /baseline11 — sum query params *) +let baseline11_get req _server () = + let open Response.Syntax in + let* () = server_header () in + let total = sum_query_params req in + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req (string_of_int total) in + Response.respond `OK + +(* POST /baseline11 — sum query params + body *) +let baseline11_post req _server () = + let open Response.Syntax in + let* () = server_header () in + let total = sum_query_params req in + let body = String.trim (read_body req) in + let body_val = match int_of_string_opt body with + | Some n -> n + | None -> 0 in + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req (string_of_int (total + body_val)) in + Response.respond `OK + +(* GET /baseline2 — sum query params *) +let baseline2 req _server () = + let open Response.Syntax in + let* () = server_header () in + let total = sum_query_params req in + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req (string_of_int total) in + Response.respond `OK + +(* GET /json — process dataset and return JSON *) +let json_endpoint req _server () = + let open Response.Syntax in + let* () = server_header () in + match dataset_raw with + | Some items -> + let processed = process_items items in + let result = `Assoc [ + ("items", `List processed); + ("count", `Int (List.length processed)) + ] in + let s = Yojson.Basic.to_string result in + let* () = Response.add ~field:"content-type" "application/json" in + let* () = Response.with_string req s in + Response.respond `OK + | None -> + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req "No dataset" in + Response.respond `Internal_server_error + +(* GET /compression — gzip compressed large dataset *) +let compression req _server () = + let open Response.Syntax in + let* () = server_header () in + match large_payload with + | Some payload -> + let* () = Response.add ~field:"content-type" "application/json" in + let* () = Response.with_string ~compression:`Gzip req payload in + Response.respond `OK + | None -> + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req "No dataset" in + Response.respond `Internal_server_error + +(* POST /upload — count received bytes *) +let upload req _server () = + let open Response.Syntax in + let* () = server_header () in + let byte_count = count_body_bytes req in + let* () = Response.add ~field:"content-type" "text/plain" in + let* () = Response.with_string req (string_of_int byte_count) in + Response.respond `OK + +(* GET /db — SQLite query *) +let db_endpoint req _server () = + let open Response.Syntax in + let* () = server_header () in + if not (Sys.file_exists db_path) then begin + let* () = Response.add ~field:"content-type" "application/json" in + let* () = Response.with_string req {|{"items":[],"count":0}|} in + Response.respond `OK + end else begin + let min_val = match Queries.get req "min" with + | v :: _ -> (match float_of_string_opt v with Some f -> f | None -> 10.0) + | [] -> 10.0 in + let max_val = match Queries.get req "max" with + | v :: _ -> (match float_of_string_opt v with Some f -> f | None -> 50.0) + | [] -> 50.0 in + let db = Sqlite3.db_open ~mode:`READONLY db_path in + let sql = "SELECT id, name, category, price, quantity, active, tags, rating_score, rating_count FROM items WHERE price BETWEEN ? AND ? LIMIT 50" in + let stmt = Sqlite3.prepare db sql in + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.FLOAT min_val)); + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.FLOAT max_val)); + let items = ref [] in + while Sqlite3.step stmt = Sqlite3.Rc.ROW do + let id = match Sqlite3.column stmt 0 with + | Sqlite3.Data.INT i -> `Int (Int64.to_int i) | _ -> `Int 0 in + let name = match Sqlite3.column stmt 1 with + | Sqlite3.Data.TEXT s -> `String s | _ -> `String "" in + let category = match Sqlite3.column stmt 2 with + | Sqlite3.Data.TEXT s -> `String s | _ -> `String "" in + let price = match Sqlite3.column stmt 3 with + | Sqlite3.Data.FLOAT f -> `Float f | _ -> `Float 0.0 in + let quantity = match Sqlite3.column stmt 4 with + | Sqlite3.Data.INT i -> `Int (Int64.to_int i) | _ -> `Int 0 in + let active = match Sqlite3.column stmt 5 with + | Sqlite3.Data.INT i -> `Bool (i <> 0L) | _ -> `Bool false in + let tags = match Sqlite3.column stmt 6 with + | Sqlite3.Data.TEXT s -> + (try Yojson.Basic.from_string s with _ -> `List []) + | _ -> `List [] in + let rs = match Sqlite3.column stmt 7 with + | Sqlite3.Data.FLOAT f -> f | _ -> 0.0 in + let rc = match Sqlite3.column stmt 8 with + | Sqlite3.Data.INT i -> Int64.to_int i | _ -> 0 in + let item = `Assoc [ + ("id", id); ("name", name); ("category", category); + ("price", price); ("quantity", quantity); ("active", active); + ("tags", tags); + ("rating", `Assoc [("score", `Float rs); ("count", `Int rc)]) + ] in + items := item :: !items + done; + ignore (Sqlite3.finalize stmt); + ignore (Sqlite3.db_close db); + let items_list = List.rev !items in + let result = `Assoc [ + ("items", `List items_list); + ("count", `Int (List.length items_list)) + ] in + let s = Yojson.Basic.to_string result in + let* () = Response.add ~field:"content-type" "application/json" in + let* () = Response.with_string req s in + Response.respond `OK + end + +(* --------------------------------------------------------------------------- + Server config + --------------------------------------------------------------------------- *) + +let routes = + let open Uri in + let open Route in + let open Type in + [ get (rel / "pipeline" /?? any) --> pipeline + ; get (rel / "baseline11" /?? any) --> baseline11_get + ; post any (rel / "baseline11" /?? any) --> baseline11_post + ; get (rel / "baseline2" /?? any) --> baseline2 + ; get (rel / "json" /?? any) --> json_endpoint + ; get (rel / "compression" /?? any) --> compression + ; post any (rel / "upload" /?? any) --> upload + ; get (rel / "db" /?? any) --> db_endpoint + ] + +let () = + Miou_unix.run @@ fun () -> + let addr = Unix.ADDR_INET (Unix.inet_addr_any, 8080) in + let cfg = Vif.config ~level:(Some Logs.Error) addr in + Vif.run ~cfg routes () From abb2d085c456a2a221e3e14a5e847589f6a9dc98 Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Mon, 23 Mar 2026 23:52:25 +0000 Subject: [PATCH 2/5] =?UTF-8?q?fix(vif):=20resolve=20type=20error=20?= =?UTF-8?q?=E2=80=94=20use=20Uri.any=20for=20queries,=20Type.any=20for=20P?= =?UTF-8?q?OST=20content?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The routing DSL has two 'any' values: - Uri.any: wildcard for query parameters (used with /??) - Type.any: wildcard for content types (used with post) Opening Type shadowed Uri.any, causing a type mismatch on query routes. Fix: remove 'open Type', qualify post content-type as Type.any, and use nil for routes that don't need query params. --- frameworks/vif/src/server.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/frameworks/vif/src/server.ml b/frameworks/vif/src/server.ml index 4291a26b..488a5cf6 100644 --- a/frameworks/vif/src/server.ml +++ b/frameworks/vif/src/server.ml @@ -247,14 +247,13 @@ let db_endpoint req _server () = let routes = let open Uri in let open Route in - let open Type in - [ get (rel / "pipeline" /?? any) --> pipeline + [ get (rel / "pipeline" /?? nil) --> pipeline ; get (rel / "baseline11" /?? any) --> baseline11_get - ; post any (rel / "baseline11" /?? any) --> baseline11_post + ; post Type.any (rel / "baseline11" /?? any) --> baseline11_post ; get (rel / "baseline2" /?? any) --> baseline2 - ; get (rel / "json" /?? any) --> json_endpoint - ; get (rel / "compression" /?? any) --> compression - ; post any (rel / "upload" /?? any) --> upload + ; get (rel / "json" /?? nil) --> json_endpoint + ; get (rel / "compression" /?? nil) --> compression + ; post Type.any (rel / "upload" /?? nil) --> upload ; get (rel / "db" /?? any) --> db_endpoint ] From 0b60e6e0674a681869a384fecc041f5b5a21dbd6 Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Tue, 24 Mar 2026 03:30:31 +0000 Subject: [PATCH 3/5] fix(vif): cache small dataset at startup like large_payload json_endpoint was calling process_items on every request while the dataset is static. Cache the processed result at startup, matching what large_payload already does for the compression endpoint. Co-authored-by: jerrythetruckdriver --- frameworks/vif/src/server.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/frameworks/vif/src/server.ml b/frameworks/vif/src/server.ml index 488a5cf6..e034c894 100644 --- a/frameworks/vif/src/server.ml +++ b/frameworks/vif/src/server.ml @@ -38,12 +38,18 @@ let process_items (items : Yojson.Basic.t list) : Yojson.Basic.t list = | other -> other ) items -(* Small dataset — raw JSON array *) -let dataset_raw : Yojson.Basic.t list option = +(* Small dataset — pre-processed JSON string (cached at startup) *) +let small_payload : string option = match read_file dataset_path with | Some s -> (match Yojson.Basic.from_string s with - | `List items -> Some items + | `List items -> + let processed = process_items items in + let result = `Assoc [ + ("items", `List processed); + ("count", `Int (List.length processed)) + ] in + Some (Yojson.Basic.to_string result) | _ -> None | exception _ -> None) | None -> None @@ -134,20 +140,14 @@ let baseline2 req _server () = let* () = Response.with_string req (string_of_int total) in Response.respond `OK -(* GET /json — process dataset and return JSON *) +(* GET /json — return pre-processed dataset JSON *) let json_endpoint req _server () = let open Response.Syntax in let* () = server_header () in - match dataset_raw with - | Some items -> - let processed = process_items items in - let result = `Assoc [ - ("items", `List processed); - ("count", `Int (List.length processed)) - ] in - let s = Yojson.Basic.to_string result in + match small_payload with + | Some payload -> let* () = Response.add ~field:"content-type" "application/json" in - let* () = Response.with_string req s in + let* () = Response.with_string req payload in Response.respond `OK | None -> let* () = Response.add ~field:"content-type" "text/plain" in From dce05bff0cb75ece4d1df3bb24877ddbc30a6200 Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Tue, 24 Mar 2026 10:09:55 +0000 Subject: [PATCH 4/5] fix(vif): enable multicore domains + fix upload body streaming - Set domains = Domain.recommended_domain_count() - 1 in Vif.config (was defaulting to 1 domain = single core, explaining ~550% CPU instead of ~8000% on the benchmark machine) - Replace Flux.Stream-based body reading with direct Source pull loop to fix upload OOM (memory was ballooning to 3.8GiB then timing out at 0 req/s) --- frameworks/vif/src/server.ml | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/frameworks/vif/src/server.ml b/frameworks/vif/src/server.ml index e034c894..0eb29ea4 100644 --- a/frameworks/vif/src/server.ml +++ b/frameworks/vif/src/server.ml @@ -88,14 +88,25 @@ let sum_query_params req = ) 0 params let read_body req = - let src = Request.source req in - let stream = Flux.Stream.from src in - Flux.Stream.into Flux.Sink.string stream + let (Flux.Source.Source { init; pull; stop }) = Request.source req in + let state = init () in + let buf = Buffer.create 4096 in + let rec loop state = + match pull state with + | Some (chunk, state') -> Buffer.add_string buf chunk; loop state' + | None -> stop state; Buffer.contents buf + in + loop state let count_body_bytes req = - let src = Request.source req in - let stream = Flux.Stream.from src in - Flux.Stream.into (Flux.Sink.fold (fun acc chunk -> acc + String.length chunk) 0) stream + let (Flux.Source.Source { init; pull; stop }) = Request.source req in + let state = init () in + let rec loop state acc = + match pull state with + | Some (chunk, state') -> loop state' (acc + String.length chunk) + | None -> stop state; acc + in + loop state 0 (* --------------------------------------------------------------------------- Routes @@ -259,6 +270,7 @@ let routes = let () = Miou_unix.run @@ fun () -> + let domains = max 1 (Domain.recommended_domain_count () - 1) in let addr = Unix.ADDR_INET (Unix.inet_addr_any, 8080) in - let cfg = Vif.config ~level:(Some Logs.Error) addr in + let cfg = Vif.config ~domains ~level:(Some Logs.Error) addr in Vif.run ~cfg routes () From c91f24d35d69c08cbf86f9151f73c2099db4d295 Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Tue, 24 Mar 2026 10:16:47 +0000 Subject: [PATCH 5/5] fix(vif): correct Flux.Source constructor (was Flux.Source.Source) --- frameworks/vif/src/server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/frameworks/vif/src/server.ml b/frameworks/vif/src/server.ml index 0eb29ea4..69ab351b 100644 --- a/frameworks/vif/src/server.ml +++ b/frameworks/vif/src/server.ml @@ -88,7 +88,7 @@ let sum_query_params req = ) 0 params let read_body req = - let (Flux.Source.Source { init; pull; stop }) = Request.source req in + let (Flux.Source { init; pull; stop }) = Request.source req in let state = init () in let buf = Buffer.create 4096 in let rec loop state = @@ -99,7 +99,7 @@ let read_body req = loop state let count_body_bytes req = - let (Flux.Source.Source { init; pull; stop }) = Request.source req in + let (Flux.Source { init; pull; stop }) = Request.source req in let state = init () in let rec loop state acc = match pull state with