+29

.beads/.gitignore

reviewed

··· 1 1 + # SQLite databases 2 2 + *.db 3 3 + *.db?* 4 4 + *.db-journal 5 5 + *.db-wal 6 6 + *.db-shm 7 7 + 8 8 + # Daemon runtime files 9 9 + daemon.lock 10 10 + daemon.log 11 11 + daemon.pid 12 12 + bd.sock 13 13 + 14 14 + # Legacy database files 15 15 + db.sqlite 16 16 + bd.db 17 17 + 18 18 + # Merge artifacts (temporary files from 3-way merge) 19 19 + beads.base.jsonl 20 20 + beads.base.meta.json 21 21 + beads.left.jsonl 22 22 + beads.left.meta.json 23 23 + beads.right.jsonl 24 24 + beads.right.meta.json 25 25 + 26 26 + # Keep JSONL exports and config (source of truth for git) 27 27 + !issues.jsonl 28 28 + !metadata.json 29 29 + !config.json

+1

.beads/.local_version

reviewed

··· 1 1 + 0.29.0

+81

.beads/README.md

reviewed

··· 1 1 + # Beads - AI-Native Issue Tracking 2 2 + 3 3 + Welcome to Beads! This repository uses **Beads** for issue tracking - a modern, AI-native tool designed to live directly in your codebase alongside your code. 4 4 + 5 5 + ## What is Beads? 6 6 + 7 7 + Beads is issue tracking that lives in your repo, making it perfect for AI coding agents and developers who want their issues close to their code. No web UI required - everything works through the CLI and integrates seamlessly with git. 8 8 + 9 9 + **Learn more:** [github.com/steveyegge/beads](https://github.com/steveyegge/beads) 10 10 + 11 11 + ## Quick Start 12 12 + 13 13 + ### Essential Commands 14 14 + 15 15 + ```bash 16 16 + # Create new issues 17 17 + bd create "Add user authentication" 18 18 + 19 19 + # View all issues 20 20 + bd list 21 21 + 22 22 + # View issue details 23 23 + bd show <issue-id> 24 24 + 25 25 + # Update issue status 26 26 + bd update <issue-id> --status in_progress 27 27 + bd update <issue-id> --status done 28 28 + 29 29 + # Sync with git remote 30 30 + bd sync 31 31 + ``` 32 32 + 33 33 + ### Working with Issues 34 34 + 35 35 + Issues in Beads are: 36 36 + - **Git-native**: Stored in `.beads/issues.jsonl` and synced like code 37 37 + - **AI-friendly**: CLI-first design works perfectly with AI coding agents 38 38 + - **Branch-aware**: Issues can follow your branch workflow 39 39 + - **Always in sync**: Auto-syncs with your commits 40 40 + 41 41 + ## Why Beads? 42 42 + 43 43 + ✨ **AI-Native Design** 44 44 + - Built specifically for AI-assisted development workflows 45 45 + - CLI-first interface works seamlessly with AI coding agents 46 46 + - No context switching to web UIs 47 47 + 48 48 + 🚀 **Developer Focused** 49 49 + - Issues live in your repo, right next to your code 50 50 + - Works offline, syncs when you push 51 51 + - Fast, lightweight, and stays out of your way 52 52 + 53 53 + 🔧 **Git Integration** 54 54 + - Automatic sync with git commits 55 55 + - Branch-aware issue tracking 56 56 + - Intelligent JSONL merge resolution 57 57 + 58 58 + ## Get Started with Beads 59 59 + 60 60 + Try Beads in your own projects: 61 61 + 62 62 + ```bash 63 63 + # Install Beads 64 64 + curl -sSL https://raw.githubusercontent.com/steveyegge/beads/main/scripts/install.sh | bash 65 65 + 66 66 + # Initialize in your repo 67 67 + bd init 68 68 + 69 69 + # Create your first issue 70 70 + bd create "Try out Beads" 71 71 + ``` 72 72 + 73 73 + ## Learn More 74 74 + 75 75 + - **Documentation**: [github.com/steveyegge/beads/docs](https://github.com/steveyegge/beads/tree/main/docs) 76 76 + - **Quick Start Guide**: Run `bd quickstart` 77 77 + - **Examples**: [github.com/steveyegge/beads/examples](https://github.com/steveyegge/beads/tree/main/examples) 78 78 + 79 79 + --- 80 80 + 81 81 + *Beads: Issue tracking that moves at the speed of thought* ⚡

+62

.beads/config.yaml

reviewed

··· 1 1 + # Beads Configuration File 2 2 + # This file configures default behavior for all bd commands in this repository 3 3 + # All settings can also be set via environment variables (BD_* prefix) 4 4 + # or overridden with command-line flags 5 5 + 6 6 + # Issue prefix for this repository (used by bd init) 7 7 + # If not set, bd init will auto-detect from directory name 8 8 + # Example: issue-prefix: "myproject" creates issues like "myproject-1", "myproject-2", etc. 9 9 + # issue-prefix: "" 10 10 + 11 11 + # Use no-db mode: load from JSONL, no SQLite, write back after each command 12 12 + # When true, bd will use .beads/issues.jsonl as the source of truth 13 13 + # instead of SQLite database 14 14 + # no-db: false 15 15 + 16 16 + # Disable daemon for RPC communication (forces direct database access) 17 17 + # no-daemon: false 18 18 + 19 19 + # Disable auto-flush of database to JSONL after mutations 20 20 + # no-auto-flush: false 21 21 + 22 22 + # Disable auto-import from JSONL when it's newer than database 23 23 + # no-auto-import: false 24 24 + 25 25 + # Enable JSON output by default 26 26 + # json: false 27 27 + 28 28 + # Default actor for audit trails (overridden by BD_ACTOR or --actor) 29 29 + # actor: "" 30 30 + 31 31 + # Path to database (overridden by BEADS_DB or --db) 32 32 + # db: "" 33 33 + 34 34 + # Auto-start daemon if not running (can also use BEADS_AUTO_START_DAEMON) 35 35 + # auto-start-daemon: true 36 36 + 37 37 + # Debounce interval for auto-flush (can also use BEADS_FLUSH_DEBOUNCE) 38 38 + # flush-debounce: "5s" 39 39 + 40 40 + # Git branch for beads commits (bd sync will commit to this branch) 41 41 + # IMPORTANT: Set this for team projects so all clones use the same sync branch. 42 42 + # This setting persists across clones (unlike database config which is gitignored). 43 43 + # Can also use BEADS_SYNC_BRANCH env var for local override. 44 44 + # If not set, bd sync will require you to run 'bd config set sync.branch <branch>'. 45 45 + # sync-branch: "beads-sync" 46 46 + 47 47 + # Multi-repo configuration (experimental - bd-307) 48 48 + # Allows hydrating from multiple repositories and routing writes to the correct JSONL 49 49 + # repos: 50 50 + # primary: "." # Primary repo (where this database lives) 51 51 + # additional: # Additional repos to hydrate from (read-only) 52 52 + # - ~/beads-planning # Personal planning repo 53 53 + # - ~/work-planning # Work planning repo 54 54 + 55 55 + # Integration settings (access with 'bd config get/set') 56 56 + # These are stored in the database, not in this file: 57 57 + # - jira.url 58 58 + # - jira.project 59 59 + # - linear.url 60 60 + # - linear.api-key 61 61 + # - github.org 62 62 + # - github.repo

+108

.beads/issues.jsonl

reviewed

··· 1 1 + {"id":"hcs-0ro","title":"Implement WebSocket frame types and parsing","description":"Implement WebSocket wire format in hcs-core/ws_frame.ml:\n\n```ocaml\ntype frame =\n | Text of string\n | Binary of Cstruct.t\n | Ping of Cstruct.t\n | Pong of Cstruct.t\n | Close of int option * string option\n\ntype parse_result =\n | Complete of frame * int (* frame and bytes consumed *)\n | Incomplete of int (* need more bytes *)\n | Error of string\n\nval parse_frame : Cstruct.t -\u003e parse_result\nval serialize_frame : ?mask:bool -\u003e frame -\u003e Cstruct.t\n\n(* Handshake *)\nval make_handshake_request : Uri.t -\u003e ?protocols:string list -\u003e Headers.t -\u003e request\nval validate_handshake_response : response -\u003e (string option, string) result (* selected protocol *)\nval make_handshake_response : request -\u003e ?protocol:string -\u003e (response, string) result\n```\n\nPure parsing/serialization.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:34:32.864373772+01:00","updated_at":"2025-12-29T16:00:43.877842667+01:00","closed_at":"2025-12-29T16:00:43.877842667+01:00","dependencies":[{"issue_id":"hcs-0ro","depends_on_id":"hcs-lhr","type":"parent-child","created_at":"2025-12-29T14:34:52.111489961+01:00","created_by":"gdiazlo"}]} 2 2 + {"id":"hcs-0zq","title":"Testing Infrastructure and Compliance","description":"Set up testing infrastructure including unit tests, integration tests, and HTTP compliance test suites for both client and server implementations.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:35:43.905080385+01:00","updated_at":"2025-12-29T17:57:31.987947689+01:00","closed_at":"2025-12-29T17:57:31.987947689+01:00","dependencies":[{"issue_id":"hcs-0zq","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:35:55.080432801+01:00","created_by":"gdiazlo"}]} 3 3 + {"id":"hcs-1h7","title":"Create Go WebSocket benchmark server","description":"Go server using gorilla/websocket or nhooyr.io/websocket. Same interface as HCS: accept connections, keep alive, report count.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T09:59:59.144195314+01:00","updated_at":"2025-12-30T10:08:50.856707182+01:00","closed_at":"2025-12-30T10:08:50.856707182+01:00","dependencies":[{"issue_id":"hcs-1h7","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:30.601603816+01:00","created_by":"gdiazlo"}]} 4 4 + {"id":"hcs-1uy","title":"HTTP/2 Specific Features","description":"Implement H2 module with server push, stream priority, and HTTP/2 detection.","status":"closed","priority":3,"issue_type":"epic","created_at":"2025-12-29T14:25:37.55760677+01:00","updated_at":"2025-12-29T17:40:54.000014455+01:00","closed_at":"2025-12-29T17:40:54.000014455+01:00","dependencies":[{"issue_id":"hcs-1uy","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:20.914923161+01:00","created_by":"gdiazlo"}]} 5 5 + {"id":"hcs-1vt","title":"Implement HTTP/2 server (Eio)","description":"Implement HTTP/2 server for Eio in hcs-eio/h2_server.ml:\n\n```ocaml\nval handle_connection :\n flow:Eio.Flow.two_way -\u003e\n clock:Eio.Time.clock -\u003e\n config:Server.config -\u003e\n handler:(request -\u003e (response, error) result) -\u003e\n unit\n```\n\nFeatures:\n- HPACK header compression\n- Stream multiplexing (concurrent requests)\n- Flow control\n- Server push support\n- GOAWAY for graceful shutdown\n- Priority handling\n\nDepends on hpack package.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:33:25.282940788+01:00","updated_at":"2025-12-29T16:00:42.340368477+01:00","closed_at":"2025-12-29T16:00:42.340368477+01:00","dependencies":[{"issue_id":"hcs-1vt","depends_on_id":"hcs-rw6","type":"parent-child","created_at":"2025-12-29T14:33:42.729783837+01:00","created_by":"gdiazlo"}]} 6 6 + {"id":"hcs-23f","title":"Implement synchronous Stream module (core)","description":"Implement the synchronous Stream module in hcs-core/stream.ml:\n\nProducers:\n- empty, singleton, of_list, of_seq\n- unfold : ('s -\u003e ('a * 's) option) -\u003e 's -\u003e 'a t\n\nTransformers:\n- map, filter, filter_map\n- take, drop, chunks\n\nConsumers:\n- fold, iter, drain\n- to_string (for Cstruct.t streams)\n\nCombinators:\n- concat, zip\n\nThis is the pure, synchronous implementation. Runtime-specific async streams will wrap this.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:28:01.435958367+01:00","updated_at":"2025-12-29T14:51:05.189865738+01:00","closed_at":"2025-12-29T14:51:05.189865738+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-23f","depends_on_id":"hcs-czm","type":"parent-child","created_at":"2025-12-29T14:28:16.036236675+01:00","created_by":"gdiazlo"}]} 7 7 + {"id":"hcs-2ca","title":"Implement Eio TLS integration","description":"Implement TLS context creation for Eio runtime in hcs-eio/tls.ml:\n\n- Convert Tls_config.client to Tls.Config.client\n- Convert Tls_config.server to Tls.Config.server \n- Load system certificates using ca-certs\n- Handle ALPN negotiation for HTTP/2\n- Wrap Eio flows with TLS\n\nDepends on tls-eio, ca-certs, x509 packages.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:30:34.350512358+01:00","updated_at":"2025-12-29T15:24:43.224163622+01:00","closed_at":"2025-12-29T15:24:43.224163622+01:00","dependencies":[{"issue_id":"hcs-2ca","depends_on_id":"hcs-y9w","type":"parent-child","created_at":"2025-12-29T14:30:47.016262637+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-2ca","depends_on_id":"hcs-cyb","type":"blocks","created_at":"2025-12-29T14:30:47.870432453+01:00","created_by":"gdiazlo"}]} 8 8 + {"id":"hcs-2ie","title":"Router Implementation","description":"Implement Path DSL for type-safe extraction and Router module with trie-based route lookup, scoping, and middleware support.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:30.896190732+01:00","updated_at":"2025-12-29T15:41:48.160193387+01:00","closed_at":"2025-12-29T15:41:48.160193387+01:00","dependencies":[{"issue_id":"hcs-2ie","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:15.462426699+01:00","created_by":"gdiazlo"}]} 9 9 + {"id":"hcs-320","title":"Create benchmark client for load generation","description":"Create a benchmark client (bin/hcs_bench_client.ml) that generates load and measures performance:\n- Configurable concurrency (number of parallel connections)\n- Configurable duration or request count\n- Support for HTTP/1.1 and HTTP/2\n- Measures: requests/second, latency (min/max/avg/p50/p99), errors\n- Reports results in human-readable and JSON formats\n\nShould use Eio fibers for concurrent requests.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T18:03:53.28432088+01:00","updated_at":"2025-12-29T18:15:36.842283087+01:00","closed_at":"2025-12-29T18:15:36.842283087+01:00","dependencies":[{"issue_id":"hcs-320","depends_on_id":"hcs-jtz","type":"parent-child","created_at":"2025-12-29T18:04:20.175343889+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-320","depends_on_id":"hcs-40d","type":"blocks","created_at":"2025-12-29T18:04:35.617524274+01:00","created_by":"gdiazlo"}]} 10 10 + {"id":"hcs-3dn","title":"Create HCS-based benchmark client for testing all servers","description":"","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T22:21:41.677601767+01:00","updated_at":"2025-12-30T22:31:12.664814017+01:00","closed_at":"2025-12-30T22:31:12.664814017+01:00"} 11 11 + {"id":"hcs-3ww","title":"Middleware System","description":"Implement Middleware module with composition, logging, security (CORS, auth), rate limiting, compression, caching, and static files.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:34.907454455+01:00","updated_at":"2025-12-29T17:40:52.182994384+01:00","closed_at":"2025-12-29T17:40:52.182994384+01:00","dependencies":[{"issue_id":"hcs-3ww","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:19.080036903+01:00","created_by":"gdiazlo"}]} 12 12 + {"id":"hcs-40d","title":"Implement latency histogram and percentile calculations","description":"Create a statistics module (lib/bench_stats.ml or in the benchmark binary) for accurate latency measurements:\n- HDR histogram or simple sorted array for percentiles\n- Calculate min, max, mean, stddev\n- Calculate p50, p90, p95, p99, p99.9 percentiles\n- Track request count, error count, bytes transferred\n- Support for merging stats from multiple workers","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T18:03:57.696657065+01:00","updated_at":"2025-12-29T18:15:29.902324683+01:00","closed_at":"2025-12-29T18:15:29.902324683+01:00","dependencies":[{"issue_id":"hcs-40d","depends_on_id":"hcs-jtz","type":"parent-child","created_at":"2025-12-29T18:04:22.619809769+01:00","created_by":"gdiazlo"}]} 13 13 + {"id":"hcs-42q","title":"Implement runtime-parameterized async Stream","description":"Design async stream interface that works with both Eio and Lwt:\n\n```ocaml\nmodule type ASYNC_STREAM = sig\n type 'a io\n type 'a t\n \n val from_flow : ... -\u003e Cstruct.t t\n val from_file : ... -\u003e Cstruct.t t\n val to_sink : ... -\u003e Cstruct.t t -\u003e unit io\nend\n\nmodule Make_stream (R : RUNTIME) : ASYNC_STREAM with type 'a io = 'a R.t\n```\n\nThe Eio implementation uses Eio.Flow, the future Lwt version will use Lwt_io.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:28:05.317935403+01:00","updated_at":"2025-12-29T17:08:13.483830721+01:00","closed_at":"2025-12-29T17:08:13.483830721+01:00","labels":["architecture","core"],"dependencies":[{"issue_id":"hcs-42q","depends_on_id":"hcs-czm","type":"parent-child","created_at":"2025-12-29T14:28:16.763534695+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-42q","depends_on_id":"hcs-23f","type":"blocks","created_at":"2025-12-29T14:28:17.658557754+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-42q","depends_on_id":"hcs-6bi","type":"blocks","created_at":"2025-12-29T14:28:18.52508237+01:00","created_by":"gdiazlo"}]} 14 14 + {"id":"hcs-4w8","title":"Create benchmark server with configurable endpoints","description":"Create a dedicated benchmark server (bin/hcs_bench_server.ml) with endpoints optimized for benchmarking:\n- GET /ping - minimal response (measures raw throughput)\n- GET /bytes/:n - returns n bytes (measures payload handling)\n- POST /echo - echoes request body (measures request body parsing)\n- GET /delay/:ms - adds artificial delay (measures concurrency)\n- GET /headers/:n - returns n headers (measures header handling)\n\nServer should support both HTTP/1.1 and HTTP/2, with configurable port and worker count.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T18:03:49.541780606+01:00","updated_at":"2025-12-29T18:15:27.763639409+01:00","closed_at":"2025-12-29T18:15:27.763639409+01:00","dependencies":[{"issue_id":"hcs-4w8","depends_on_id":"hcs-jtz","type":"parent-child","created_at":"2025-12-29T18:04:17.563056726+01:00","created_by":"gdiazlo"}]} 15 15 + {"id":"hcs-505","title":"Add HTTP/2 benchmark endpoints and comparison scripts","description":"","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T00:14:16.705365323+01:00","updated_at":"2025-12-30T00:28:18.304877441+01:00","closed_at":"2025-12-30T00:28:18.304877441+01:00"} 16 16 + {"id":"hcs-56z","title":"Implement HTTP/1.1 server parser/serializer","description":"Implement HTTP/1.1 server wire format in hcs-core/h1.ml (extend existing):\n\n```ocaml\n(* Request parsing *)\ntype request_parse_result =\n | Complete of request * int (* request and bytes consumed *)\n | Incomplete of int (* need more bytes *)\n | Error of string\n\nval parse_request_head : Cstruct.t -\u003e request_parse_result\n\n(* Response serialization *)\nval serialize_response : response -\u003e Cstruct.t\nval serialize_response_head : response -\u003e Cstruct.t\n```\n\nPure parsing, zero-copy with Cstruct views.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:33:19.050407222+01:00","updated_at":"2025-12-29T14:56:39.076056919+01:00","closed_at":"2025-12-29T14:56:39.076056919+01:00","dependencies":[{"issue_id":"hcs-56z","depends_on_id":"hcs-rw6","type":"parent-child","created_at":"2025-12-29T14:33:41.058840522+01:00","created_by":"gdiazlo"}]} 17 17 + {"id":"hcs-5eu","title":"Implement Log module","description":"Implement logging in hcs-core/log.ml:\n\n```ocaml\ntype level = Debug | Info | Warn | Error\n\ntype event =\n | Request_start of { id: string; meth: method_; uri: Uri.t }\n | Request_end of { id: string; status: status; duration_ms: float }\n | Connection_open of { host: string; port: int }\n | Connection_close of { host: string; port: int; reason: string }\n | Connection_reuse of { host: string; port: int }\n | Tls_handshake of { host: string; protocol: string }\n | Retry of { id: string; attempt: int; reason: error }\n | Error of { id: string; error: error }\n\ntype logger = level -\u003e event -\u003e unit\n\n(* Built-in loggers *)\nval null : logger\nval stderr : ?min_level:level -\u003e unit -\u003e logger\nval custom : (level -\u003e string -\u003e unit) -\u003e logger\n\n(* Format event as string *)\nval event_to_string : event -\u003e string\nval level_to_string : level -\u003e string\n```\n\nPure OCaml, no runtime dependency.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:30:26.138649492+01:00","updated_at":"2025-12-29T17:06:37.134220488+01:00","closed_at":"2025-12-29T17:06:37.134220488+01:00","dependencies":[{"issue_id":"hcs-5eu","depends_on_id":"hcs-fgd","type":"parent-child","created_at":"2025-12-29T14:30:45.51204607+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-5eu","depends_on_id":"hcs-gmb","type":"blocks","created_at":"2025-12-29T14:30:48.61530863+01:00","created_by":"gdiazlo"}]} 18 18 + {"id":"hcs-5wp","title":"Epic: Unified multi-protocol server + comprehensive benchmark suite","description":"Create unified servers (HCS, Hyper, Go) supporting HTTP/1.1, HTTP/2 h2c upgrade, and WebSocket. Build comprehensive benchmark client and automated benchmark runner.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-31T14:13:14.360303024+01:00","updated_at":"2025-12-31T14:47:54.828065477+01:00","closed_at":"2025-12-31T14:47:54.828065477+01:00"} 19 19 + {"id":"hcs-6bi","title":"Design Runtime Abstraction Layer","description":"Design and implement a runtime abstraction layer that allows the library to work with both Eio and Lwt (future). This should include:\n\n1. Define a RUNTIME module signature abstracting:\n - Promise/fiber types ('a t)\n - Concurrency primitives (bind, return, map, both, all)\n - Cancellation tokens\n - Clock/time operations\n - Network operations (connect, listen, read, write)\n - Flow/stream abstractions\n\n2. Structure the library as:\n - `hcs-core`: Pure types, parsers, router trie, codec signatures (no IO)\n - `hcs-eio`: Eio runtime implementation\n - `hcs-lwt`: (future) Lwt runtime implementation\n\n3. Use functors where IO is needed:\n ```ocaml\n module type RUNTIME = sig\n type +'a t\n val return : 'a -\u003e 'a t\n val bind : 'a t -\u003e ('a -\u003e 'b t) -\u003e 'b t\n val both : 'a t -\u003e 'b t -\u003e ('a * 'b) t\n \n module Net : sig ... end\n module Time : sig ... end\n module Cancel : sig ... end\n end\n \n module Make_client (R : RUNTIME) : CLIENT with type 'a io = 'a R.t\n module Make_server (R : RUNTIME) : SERVER with type 'a io = 'a R.t\n ```\n\n4. Keep the core types (request, response, headers, body) runtime-agnostic where possible.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:26:44.115541536+01:00","updated_at":"2025-12-29T15:18:00.901135582+01:00","closed_at":"2025-12-29T15:18:00.901135582+01:00","labels":["architecture","design"],"dependencies":[{"issue_id":"hcs-6bi","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:55.24314139+01:00","created_by":"gdiazlo"}]} 20 20 + {"id":"hcs-6hx","title":"Create WebSocket benchmark client","description":"Tool to open N concurrent WebSocket connections. Ramp up gradually, keep alive, report success/failure rates. Can target any server.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T10:00:01.720658703+01:00","updated_at":"2025-12-30T10:13:10.676804856+01:00","closed_at":"2025-12-30T10:13:10.676804856+01:00","dependencies":[{"issue_id":"hcs-6hx","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:40.686385073+01:00","created_by":"gdiazlo"}]} 21 21 + {"id":"hcs-6ki","title":"Create Rust WebSocket benchmark server","description":"Rust server using tokio-tungstenite. Same interface as HCS: accept connections, keep alive, report count.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T09:59:59.970998267+01:00","updated_at":"2025-12-30T10:08:50.863660424+01:00","closed_at":"2025-12-30T10:08:50.863660424+01:00","dependencies":[{"issue_id":"hcs-6ki","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:35.642901603+01:00","created_by":"gdiazlo"}]} 22 22 + {"id":"hcs-6yl","title":"Implement method_ type and helpers","description":"Implement the HTTP method type in types.ml:\n- GET, POST, PUT, DELETE, PATCH, HEAD, OPTIONS, CONNECT, TRACE variants\n- to_string/of_string functions\n- Comparison and equality\n\nThis is pure OCaml with no runtime dependency.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:08.798345263+01:00","updated_at":"2025-12-29T14:50:42.057204391+01:00","closed_at":"2025-12-29T14:50:42.057204391+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-6yl","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:38.28650235+01:00","created_by":"gdiazlo"}]} 23 23 + {"id":"hcs-763","title":"Create HTTP/1.1 server compliance tests","description":"Create comprehensive HTTP/1.1 server tests using curl and custom test client:\n\nTest categories (based on RFC 7230-7235):\n\n1. **Request parsing:**\n - Valid/invalid request lines\n - Header field parsing (folding, whitespace)\n - Host header requirement\n - Content-Length handling\n - Transfer-Encoding: chunked\n\n2. **Response generation:**\n - Status line format\n - Required headers (Date, Content-Length/Transfer-Encoding)\n - Connection: close/keep-alive\n\n3. **Methods:**\n - HEAD returns no body\n - OPTIONS with Allow header\n - TRACE (if supported)\n - Unknown methods\n\n4. **Connection management:**\n - Keep-alive (HTTP/1.1 default)\n - Pipelining support\n - Connection: close handling\n - Timeout behavior\n\n5. **Error handling:**\n - 400 Bad Request (malformed)\n - 405 Method Not Allowed\n - 411 Length Required\n - 413 Payload Too Large\n - 414 URI Too Long\n - 431 Request Header Fields Too Large\n - 501 Not Implemented\n\n6. **Edge cases:**\n - Empty body vs no body\n - Zero Content-Length\n - Multiple Content-Length headers (reject)\n - LF vs CRLF tolerance","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:36:24.121658164+01:00","updated_at":"2025-12-29T17:52:19.19217344+01:00","closed_at":"2025-12-29T17:52:19.19217344+01:00","dependencies":[{"issue_id":"hcs-763","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:50.138423904+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-763","depends_on_id":"hcs-cyk","type":"blocks","created_at":"2025-12-29T14:36:59.919859607+01:00","created_by":"gdiazlo"}]} 24 24 + {"id":"hcs-7dw","title":"Run benchmarks after optimizations","description":"Re-run single-CPU benchmarks with run_h2_comparison.sh --single-cpu to measure improvement.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T08:57:27.925408893+01:00","updated_at":"2025-12-30T09:01:48.794721842+01:00","closed_at":"2025-12-30T09:01:48.794721842+01:00","dependencies":[{"issue_id":"hcs-7dw","depends_on_id":"hcs-cq4","type":"parent-child","created_at":"2025-12-30T08:57:54.882328415+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-7dw","depends_on_id":"hcs-f2r","type":"blocks","created_at":"2025-12-30T08:57:59.924301728+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-7dw","depends_on_id":"hcs-jqx","type":"blocks","created_at":"2025-12-30T08:58:04.960054323+01:00","created_by":"gdiazlo"}]} 25 25 + {"id":"hcs-7my","title":"Implement zero-copy optimizations in H2_server (Body_bigstring, Body_prebuilt)","description":"","status":"closed","priority":1,"issue_type":"feature","created_at":"2025-12-30T00:14:14.612100017+01:00","updated_at":"2025-12-30T00:19:21.483563727+01:00","closed_at":"2025-12-30T00:19:21.483563727+01:00"} 26 26 + {"id":"hcs-7n9","title":"Implement HTTP/1.1 client (Eio)","description":"Implement HTTP/1.1 client for Eio in hcs-eio/h1_client.ml:\n\n```ocaml\nval request :\n flow:Eio.Flow.two_way -\u003e\n clock:Eio.Time.clock -\u003e\n config:Client.config -\u003e\n ?cancel:Cancel.t -\u003e\n request -\u003e\n (response, error) result\n```\n\nFeatures:\n- Send request, read response using h1 parser\n- Handle Content-Length and chunked bodies\n- Support streaming response body\n- Respect timeouts from config\n- Handle keep-alive\n- Integrate with logging","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:31:20.182355085+01:00","updated_at":"2025-12-29T15:03:26.826860172+01:00","closed_at":"2025-12-29T15:03:26.826860172+01:00","dependencies":[{"issue_id":"hcs-7n9","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:48.505518121+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-7n9","depends_on_id":"hcs-8zr","type":"blocks","created_at":"2025-12-29T14:31:52.981022505+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-7n9","depends_on_id":"hcs-kg1","type":"blocks","created_at":"2025-12-29T14:31:53.49623941+01:00","created_by":"gdiazlo"}]} 27 27 + {"id":"hcs-82y","title":"HTTP/2 Performance Comparison: HCS vs Rust vs Go","description":"Compare HTTP/2 server performance across HCS (OCaml), Rust (hyper/axum), and Go (net/http). Focus on throughput, latency, and resource usage under various workloads.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-30T08:21:37.583365059+01:00","updated_at":"2025-12-30T08:49:54.887556286+01:00","closed_at":"2025-12-30T08:49:54.887556286+01:00"} 28 28 + {"id":"hcs-8br","title":"Implement Cancel module","description":"Implement cooperative cancellation in hcs-core/cancel.ml:\n\n```ocaml\nmodule Cancel : sig\n type t\n \n val create : unit -\u003e t\n val cancel : t -\u003e unit\n val is_cancelled : t -\u003e bool\n val check : t -\u003e (unit, error) result (* Returns Error Cancelled if cancelled *)\n \n (* Combine multiple tokens - cancelled if any is cancelled *)\n val any : t list -\u003e t\nend\n```\n\nImplementation: Use an Atomic.t bool internally for thread-safety. The `any` combinator creates a new token that polls children.\n\nThis is the core, runtime-agnostic cancellation. Runtime-specific implementations (Eio.Cancel, Lwt.cancel) will wrap this or provide their own.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:29:20.005246967+01:00","updated_at":"2025-12-29T14:56:31.063102088+01:00","closed_at":"2025-12-29T14:56:31.063102088+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-8br","depends_on_id":"hcs-pnc","type":"parent-child","created_at":"2025-12-29T14:30:09.074639524+01:00","created_by":"gdiazlo"}]} 29 29 + {"id":"hcs-8zr","title":"Implement HTTP/1.1 client parser/serializer","description":"Implement HTTP/1.1 wire format in hcs-core/h1.ml:\n\n```ocaml\n(* Request serialization *)\nval serialize_request : request -\u003e Cstruct.t\nval serialize_request_head : request -\u003e Cstruct.t (* without body *)\n\n(* Response parsing *)\ntype parse_result = \n | Complete of response * int (* response and bytes consumed *)\n | Incomplete of int (* need more bytes, minimum *)\n | Error of string\n\nval parse_response_head : Cstruct.t -\u003e parse_result\n\n(* Chunked transfer encoding *)\nval parse_chunk_header : Cstruct.t -\u003e (int * int, string) result (* size, header_len *)\nval serialize_chunk : Cstruct.t -\u003e Cstruct.t\nval serialize_last_chunk : Cstruct.t\n```\n\nPure parsing/serialization, no IO. Use zero-copy where possible with Cstruct views.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:31:17.431899471+01:00","updated_at":"2025-12-29T14:56:37.246977449+01:00","closed_at":"2025-12-29T14:56:37.246977449+01:00","dependencies":[{"issue_id":"hcs-8zr","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:46.61571522+01:00","created_by":"gdiazlo"}]} 30 30 + {"id":"hcs-9dz","title":"Clean up duplicate implementations: remove non-optimized functions and rename optimized ones","description":"","status":"closed","priority":1,"issue_type":"chore","created_at":"2025-12-30T21:00:09.361966265+01:00","updated_at":"2025-12-30T21:08:48.343581414+01:00","closed_at":"2025-12-30T21:08:48.343581414+01:00"} 31 31 + {"id":"hcs-9y1","title":"Implement Client.config type","description":"Implement client configuration in hcs-core/client_config.ml:\n\n```ocaml\ntype config = {\n (* Connection pooling *)\n max_connections_per_host : int; (* default: 100 *)\n max_total_connections : int; (* default: 1000 *)\n idle_timeout : float; (* seconds, default: 60.0 *)\n\n (* Timeouts *)\n connect_timeout : float; (* default: 30.0 *)\n read_timeout : float; (* default: 30.0 *)\n write_timeout : float; (* default: 30.0 *)\n\n (* Behavior *)\n follow_redirects : int option; (* None = don't follow, default: Some 10 *)\n http2_prior_knowledge : bool; (* default: false *)\n\n (* Buffers *)\n buffer_size : int; (* default: 16384 *)\n max_response_body : int64 option; (* None = unlimited *)\n\n (* TLS *)\n tls : Tls_config.client option;\n\n (* Compression *)\n accept_compression : bool; (* default: true *)\n decompress_response : bool; (* default: true *)\n\n (* Logging *)\n logger : Log.logger; (* default: Log.null *)\n}\n\nval default : config\nval with_timeout : float -\u003e config -\u003e config\nval with_max_connections : int -\u003e config -\u003e config\n(* ... other builders ... *)\n```\n\nPure configuration, no IO.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:31:05.431230385+01:00","updated_at":"2025-12-29T15:40:22.434194947+01:00","closed_at":"2025-12-29T15:40:22.434194947+01:00","dependencies":[{"issue_id":"hcs-9y1","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:42.307867928+01:00","created_by":"gdiazlo"}]} 32 32 + {"id":"hcs-9yc","title":"Go: Unified server with HTTP/1.1 + h2c + WebSocket","description":"Update Go net/http server to handle HTTP/1.1, h2c, and WebSocket on single port.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-31T14:13:36.193925748+01:00","updated_at":"2025-12-31T14:26:13.33110701+01:00","closed_at":"2025-12-31T14:26:13.33110701+01:00","dependencies":[{"issue_id":"hcs-9yc","depends_on_id":"hcs-5wp","type":"parent-child","created_at":"2025-12-31T14:14:30.935375958+01:00","created_by":"gdiazlo"}]} 33 33 + {"id":"hcs-ag6","title":"Implement H2 module (HTTP/2 specific features)","description":"Implement HTTP/2 specific features in hcs-eio/h2.ml:\n\n```ocaml\n(* Server push *)\nval push : request -\u003e Uri.t -\u003e (unit, error) result\n\n(* Stream priority *)\ntype priority = {\n dependency : int32;\n weight : int; (* 1-256 *)\n exclusive : bool;\n}\n\nval set_priority : priority -\u003e (unit, error) result\n\n(* Check protocol *)\nval is_h2 : request -\u003e bool\n```\n\nLower priority - can be added after basic HTTP/2 works.","status":"closed","priority":3,"issue_type":"task","created_at":"2025-12-29T14:34:36.59579057+01:00","updated_at":"2025-12-29T17:39:24.986755909+01:00","closed_at":"2025-12-29T17:39:24.986755909+01:00","dependencies":[{"issue_id":"hcs-ag6","depends_on_id":"hcs-1uy","type":"parent-child","created_at":"2025-12-29T14:34:53.890566238+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ag6","depends_on_id":"hcs-d5s","type":"blocks","created_at":"2025-12-29T14:34:58.997623679+01:00","created_by":"gdiazlo"}]} 34 34 + {"id":"hcs-ajr","title":"Compare HCS performance against external tools (wrk, hey)","description":"Validate HCS benchmark results by comparing against established tools:\n- Use wrk or hey to benchmark HCS server\n- Compare results with HCS benchmark client\n- Document any discrepancies\n- This validates both our server performance and benchmark accuracy\n\nOptional: Add script to run comparison benchmarks.","status":"closed","priority":3,"issue_type":"task","created_at":"2025-12-29T18:04:05.806924896+01:00","updated_at":"2025-12-29T18:18:13.778810608+01:00","closed_at":"2025-12-29T18:18:13.778810608+01:00","dependencies":[{"issue_id":"hcs-ajr","depends_on_id":"hcs-jtz","type":"parent-child","created_at":"2025-12-29T18:04:25.893845517+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ajr","depends_on_id":"hcs-4w8","type":"blocks","created_at":"2025-12-29T18:04:39.385790421+01:00","created_by":"gdiazlo"}]} 35 35 + {"id":"hcs-ax6","title":"Implement With_codec functor","description":"Implement the With_codec functor in hcs-core/codec.ml:\n\n```ocaml\nmodule With_codec (C : CODEC) : sig\n val encode_body : 'a C.encoder -\u003e 'a -\u003e (body, error) result\n val decode_body : 'a C.decoder -\u003e body -\u003e ('a, error) result\n\n (* Request helpers *)\n val set_body : 'a C.encoder -\u003e 'a -\u003e request -\u003e (request, error) result\n\n (* Response helpers *) \n val read_body : 'a C.decoder -\u003e response -\u003e ('a, error) result\n val make_response : ?status:status -\u003e 'a C.encoder -\u003e 'a -\u003e (response, error) result\nend\n```\n\nThe functor should:\n- Handle body type variants (Empty, Fixed, Stream, File)\n- Set appropriate Content-Type header from C.content_type\n- Convert between Cstruct.t and body types\n- Propagate codec errors as Codec_error\n\nPure OCaml, depends on types.ml and error.ml.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:28:47.94509919+01:00","updated_at":"2025-12-29T17:04:35.621002337+01:00","closed_at":"2025-12-29T17:04:35.621002337+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-ax6","depends_on_id":"hcs-m4r","type":"parent-child","created_at":"2025-12-29T14:29:00.595372107+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ax6","depends_on_id":"hcs-pwc","type":"blocks","created_at":"2025-12-29T14:29:02.656963585+01:00","created_by":"gdiazlo"}]} 36 36 + {"id":"hcs-bea","title":"Implement core middleware combinators","description":"Implement middleware composition in hcs-core/middleware.ml:\n\n```ocaml\ntype middleware = (request -\u003e (response, error) result) -\u003e request -\u003e (response, error) result\n\n(* Composition *)\nval ( @\u003e ) : middleware -\u003e middleware -\u003e middleware\nval compose : middleware list -\u003e middleware\nval identity : middleware\n\n(* Pure middleware (no IO needed) *)\nval default_headers : (string * string) list -\u003e middleware\nval catch_errors : (error -\u003e response) -\u003e middleware\nval body_limit : int64 -\u003e middleware\nval request_id : ?header:string -\u003e ?generator:(unit -\u003e string) -\u003e unit -\u003e middleware\n\n(* Security headers *)\nval security_headers : middleware\nval cors :\n ?origins:[ `All | `List of string list ] -\u003e\n ?methods:method_ list -\u003e\n ?headers:string list -\u003e\n ?max_age:int -\u003e\n ?credentials:bool -\u003e\n unit -\u003e\n middleware\n\n(* Auth - validation functions are pure *)\nval basic_auth : realm:string -\u003e validate:(user:string -\u003e pass:string -\u003e bool) -\u003e middleware\nval bearer_auth : validate:(token:string -\u003e bool) -\u003e middleware\n```\n\nPure OCaml.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:34:27.663177003+01:00","updated_at":"2025-12-29T15:18:06.262737908+01:00","closed_at":"2025-12-29T15:18:06.262737908+01:00","dependencies":[{"issue_id":"hcs-bea","depends_on_id":"hcs-3ww","type":"parent-child","created_at":"2025-12-29T14:34:50.365242865+01:00","created_by":"gdiazlo"}]} 37 37 + {"id":"hcs-chm","title":"Implement body type","description":"Implement the body type in types.ml:\n- Empty variant\n- Fixed of string variant\n- Stream of (unit -\u003e Cstruct.t option) - pull-based streaming\n- File of string * int64 * int64 (path, offset, length)\n\nNote: The Stream variant uses a function type that is runtime-agnostic. For async streaming, we'll need a runtime-parameterized body type in the IO layer.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:16.560667848+01:00","updated_at":"2025-12-29T14:50:45.579783806+01:00","closed_at":"2025-12-29T14:50:45.579783806+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-chm","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:40.664331169+01:00","created_by":"gdiazlo"}]} 38 38 + {"id":"hcs-cks","title":"Implement Headers module","description":"Implement case-insensitive header map in headers.ml:\n- type t (backed by Map with lowercase keys)\n- empty, singleton, add, add_list\n- find, find_all, remove, mem\n- fold, to_list, of_list\n- Consider using a more efficient representation (e.g., sorted list for small headers)\n\nPure OCaml, no runtime dependency.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:12.768404369+01:00","updated_at":"2025-12-29T14:50:44.414829218+01:00","closed_at":"2025-12-29T14:50:44.414829218+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-cks","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:39.839372964+01:00","created_by":"gdiazlo"}]} 39 39 + {"id":"hcs-cmg","title":"Implement version type","description":"Implement the HTTP version type:\n- HTTP_1_1, HTTP_2 variants\n- to_string/of_string functions\n\nPure OCaml, no runtime dependency.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:10.081239709+01:00","updated_at":"2025-12-29T14:50:42.943845373+01:00","closed_at":"2025-12-29T14:50:42.943845373+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-cmg","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:39.140549859+01:00","created_by":"gdiazlo"}]} 40 40 + {"id":"hcs-cq4","title":"HTTP/2 Server Performance Optimizations","description":"Implement optimizations identified from benchmarking: skip body reading for GET, optimize path extraction, reduce allocations","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-30T08:57:10.907204503+01:00","updated_at":"2025-12-30T09:02:03.611661211+01:00","closed_at":"2025-12-30T09:02:03.611661211+01:00"} 41 41 + {"id":"hcs-cwz","title":"Set up httpbin for client compliance testing","description":"Set up httpbin (or go-httpbin) for testing the HTTP client:\n\n1. Add Docker Compose file with go-httpbin service\n2. Create test suite covering:\n - All HTTP methods (GET, POST, PUT, DELETE, PATCH, HEAD, OPTIONS)\n - Request headers sent correctly\n - Query parameters encoding\n - Request body (form, JSON-like, binary)\n - Response status codes (1xx-5xx)\n - Redirects (301, 302, 303, 307, 308) with redirect limits\n - Basic auth, Bearer auth\n - Cookies (send and receive)\n - Compression (gzip, deflate)\n - Chunked transfer encoding\n - Connection keep-alive\n - Timeouts (delayed responses)\n - Large responses / streaming\n\n3. Integrate into `dune runtest` or separate compliance target","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:36:08.700591408+01:00","updated_at":"2025-12-29T17:56:36.02148206+01:00","closed_at":"2025-12-29T17:56:36.02148206+01:00","dependencies":[{"issue_id":"hcs-cwz","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:44.727305222+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-cwz","depends_on_id":"hcs-j2z","type":"blocks","created_at":"2025-12-29T14:36:54.844910505+01:00","created_by":"gdiazlo"}]} 42 42 + {"id":"hcs-cxj","title":"Add domain_count to server config","description":"Add domain_count field to H1_server.config and H2_server to specify max CPUs. Default to 1 for backward compatibility.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T09:05:52.544967921+01:00","updated_at":"2025-12-30T09:10:47.510063908+01:00","closed_at":"2025-12-30T09:10:47.510063908+01:00","dependencies":[{"issue_id":"hcs-cxj","depends_on_id":"hcs-zq3","type":"parent-child","created_at":"2025-12-30T09:06:14.106250303+01:00","created_by":"gdiazlo"}]} 43 43 + {"id":"hcs-cyb","title":"Implement Tls_config module","description":"Implement TLS configuration in hcs-core/tls_config.ml:\n\n```ocaml\ntype client\ntype server\n\ntype verification =\n | System_certificates\n | Custom_certificates of string list (* PEM file paths *)\n | Fingerprint of string\n | Insecure_no_verify\n\n(* Client config builder - returns config, actual TLS context created by runtime *)\nval client :\n ?verification:verification -\u003e\n ?alpn_protocols:string list -\u003e\n ?hostname:string -\u003e\n unit -\u003e\n client\n\n(* Server config builder *)\nval server :\n cert_file:string -\u003e\n key_file:string -\u003e\n ?alpn_protocols:string list -\u003e\n ?client_auth:[ `None | `Optional | `Required ] -\u003e\n ?ca_file:string -\u003e\n unit -\u003e\n server\n```\n\nThe actual TLS context creation (using tls-eio or tls-lwt) happens in the runtime layer. This module just holds configuration.\n\nPure OCaml, configuration types only.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:30:31.480806804+01:00","updated_at":"2025-12-29T15:24:40.571579433+01:00","closed_at":"2025-12-29T15:24:40.571579433+01:00","dependencies":[{"issue_id":"hcs-cyb","depends_on_id":"hcs-y9w","type":"parent-child","created_at":"2025-12-29T14:30:46.125231092+01:00","created_by":"gdiazlo"}]} 44 44 + {"id":"hcs-cyk","title":"Implement unified Server module (Eio)","description":"Implement unified server API in hcs-eio/server.ml:\n\n```ocaml\ntype t\n\nval create :\n sw:Eio.Switch.t -\u003e\n net:Eio.Net.t -\u003e\n clock:Eio.Time.clock -\u003e\n ?config:config -\u003e\n Router.compiled -\u003e\n t\n\nval run : t -\u003e unit (* Blocks until shutdown *)\nval shutdown : ?timeout:float -\u003e t -\u003e unit\nval listening_on : t -\u003e (string * int)\nval connection_count : t -\u003e int\n```\n\nFeatures:\n- Accept connections, spawn fibers\n- Protocol detection (ALPN for TLS, prior knowledge)\n- Dispatch to H1 or H2 handler\n- Connection limiting\n- Graceful shutdown with drain timeout\n- TLS support","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:33:29.304626659+01:00","updated_at":"2025-12-29T17:00:22.652965066+01:00","closed_at":"2025-12-29T17:00:22.652965066+01:00","dependencies":[{"issue_id":"hcs-cyk","depends_on_id":"hcs-rw6","type":"parent-child","created_at":"2025-12-29T14:33:43.591242696+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-cyk","depends_on_id":"hcs-lqi","type":"blocks","created_at":"2025-12-29T14:33:45.174337222+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-cyk","depends_on_id":"hcs-1vt","type":"blocks","created_at":"2025-12-29T14:33:46.071365575+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-cyk","depends_on_id":"hcs-sny","type":"blocks","created_at":"2025-12-29T14:33:46.914541815+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-cyk","depends_on_id":"hcs-2ca","type":"blocks","created_at":"2025-12-29T14:33:47.760104216+01:00","created_by":"gdiazlo"}]} 45 45 + {"id":"hcs-czm","title":"Streaming Abstraction","description":"Implement the Stream module with producers, transformers, consumers, and combinators for lazy, backpressure-aware streaming.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:20.968837055+01:00","updated_at":"2025-12-29T17:41:32.374046501+01:00","closed_at":"2025-12-29T17:41:32.374046501+01:00","dependencies":[{"issue_id":"hcs-czm","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:25:57.77315075+01:00","created_by":"gdiazlo"}]} 46 46 + {"id":"hcs-d3q","title":"Set up Autobahn for WebSocket compliance testing","description":"Integrate Autobahn|Testsuite for WebSocket compliance:\n\n1. Add Autobahn to CI via Docker (crossbario/autobahn-testsuite)\n2. Test both client and server modes:\n\n**Server testing** (Autobahn as client):\n```\ndocker run -it --rm \\\n -v \"${PWD}/reports:/reports\" \\\n crossbario/autobahn-testsuite \\\n wstest -m fuzzingclient -s /config/fuzzingclient.json\n```\n\n**Client testing** (Autobahn as server):\n```\ndocker run -it --rm \\\n -v \"${PWD}/reports:/reports\" \\\n crossbario/autobahn-testsuite \\\n wstest -m fuzzingserver -s /config/fuzzingserver.json\n```\n\nTest cases cover:\n- Framing (text, binary, fragmentation)\n- Ping/Pong\n- Close handshake\n- Reserved bits\n- Opcodes\n- UTF-8 validation\n- Compression (permessage-deflate)\n- Limits and performance\n\nTarget: Pass all non-optional Autobahn test cases","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:36:18.251422099+01:00","updated_at":"2025-12-29T17:57:13.521624023+01:00","closed_at":"2025-12-29T17:57:13.521624023+01:00","dependencies":[{"issue_id":"hcs-d3q","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:48.059495592+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-d3q","depends_on_id":"hcs-nad","type":"blocks","created_at":"2025-12-29T14:36:58.909180795+01:00","created_by":"gdiazlo"}]} 47 47 + {"id":"hcs-d5s","title":"Implement HTTP/2 client (Eio)","description":"Implement HTTP/2 client for Eio in hcs-eio/h2_client.ml:\n\n```ocaml\ntype t (* HTTP/2 connection with multiplexed streams *)\n\nval create : flow:Eio.Flow.two_way -\u003e clock:Eio.Time.clock -\u003e config:Client.config -\u003e t\nval request : t -\u003e ?cancel:Cancel.t -\u003e request -\u003e (response, error) result\nval close : t -\u003e unit\n```\n\nFeatures:\n- HPACK header compression\n- Stream multiplexing\n- Flow control per stream and connection\n- SETTINGS frame handling\n- Priority hints (optional)\n- GOAWAY handling\n\nDepends on hpack package.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:31:23.240487001+01:00","updated_at":"2025-12-29T16:00:40.891022027+01:00","closed_at":"2025-12-29T16:00:40.891022027+01:00","dependencies":[{"issue_id":"hcs-d5s","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:50.019661778+01:00","created_by":"gdiazlo"}]} 48 48 + {"id":"hcs-dd4","title":"Set up h2spec for HTTP/2 compliance testing","description":"Integrate h2spec for HTTP/2 server compliance:\n\n1. Add h2spec to CI (available as binary or Docker)\n2. Create test harness that:\n - Starts hcs HTTP/2 server on test port\n - Runs h2spec against it\n - Parses results\n\nh2spec tests:\n- HPACK header compression\n- Stream states and transitions\n- Flow control (window updates)\n- Error handling (RST_STREAM, GOAWAY)\n- SETTINGS frames\n- PRIORITY frames\n- CONTINUATION frames\n- Frame size limits\n- Connection preface\n\nTarget: Pass all h2spec generic tests\n\nCommand: `h2spec -h localhost -p 8080 --strict`","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:36:13.071332042+01:00","updated_at":"2025-12-29T17:57:10.493059681+01:00","closed_at":"2025-12-29T17:57:10.493059681+01:00","dependencies":[{"issue_id":"hcs-dd4","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:46.491278695+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-dd4","depends_on_id":"hcs-cyk","type":"blocks","created_at":"2025-12-29T14:36:57.517342388+01:00","created_by":"gdiazlo"}]} 49 49 + {"id":"hcs-ddd","title":"Create HTTP/2 cross-language benchmark script","description":"Create run_h2_comparison.sh that starts all three servers (HCS, Rust, Go) and runs h2load benchmarks against each. Test /ping, /bytes/1024, /bytes/10240 endpoints. Output structured results for comparison.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T08:21:57.169092148+01:00","updated_at":"2025-12-30T08:48:51.028339202+01:00","closed_at":"2025-12-30T08:48:51.028339202+01:00","dependencies":[{"issue_id":"hcs-ddd","depends_on_id":"hcs-osg","type":"blocks","created_at":"2025-12-30T08:22:14.06532517+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ddd","depends_on_id":"hcs-l9p","type":"blocks","created_at":"2025-12-30T08:22:16.71293984+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ddd","depends_on_id":"hcs-82y","type":"parent-child","created_at":"2025-12-30T08:22:25.823611037+01:00","created_by":"gdiazlo"}]} 50 50 + {"id":"hcs-dle","title":"Request/Response Helpers","description":"Implement Request and Response helper modules with body handling, status shortcuts, and codec integration.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:33.481216228+01:00","updated_at":"2025-12-29T15:40:53.163093449+01:00","closed_at":"2025-12-29T15:40:53.163093449+01:00","dependencies":[{"issue_id":"hcs-dle","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:17.959259297+01:00","created_by":"gdiazlo"}]} 51 51 + {"id":"hcs-dsf","title":"Set up project structure and dune build","description":"Set up the OCaml project structure with dune:\n\n```\nhcs/\n├── dune-project\n├── hcs-core/ # Pure, runtime-agnostic\n│ ├── dune\n│ ├── types.ml\n│ ├── error.ml\n│ ├── headers.ml\n│ ├── stream.ml # Synchronous stream operations\n│ ├── codec.ml\n│ └── hcs_core.ml # Public API re-exports\n├── hcs-eio/ # Eio runtime\n│ ├── dune\n│ ├── runtime.ml # RUNTIME implementation for Eio\n│ ├── client.ml\n│ ├── server.ml\n│ └── hcs_eio.ml\n└── hcs/ # Convenience package (re-exports hcs-eio)\n ├── dune\n └── hcs.ml\n```\n\nConfigure opam dependencies.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:26.717322855+01:00","updated_at":"2025-12-29T14:50:39.789609025+01:00","closed_at":"2025-12-29T14:50:39.789609025+01:00","labels":["infrastructure"],"dependencies":[{"issue_id":"hcs-dsf","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:43.02614445+01:00","created_by":"gdiazlo"}]} 52 52 + {"id":"hcs-dzr","title":"Create TechEmpower-style benchmark suite with hyper, fasthttp, and HCS servers","description":"","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-30T22:21:05.455078159+01:00","updated_at":"2025-12-30T22:33:15.399922114+01:00","closed_at":"2025-12-30T22:33:15.399922114+01:00"} 53 53 + {"id":"hcs-f2r","title":"Skip body reading for bodiless methods (GET/HEAD/DELETE)","description":"In h2_server.ml, skip Buffer.create, Promise.create, and body reading for GET/HEAD/DELETE methods. These have no body but currently allocate a buffer and promise.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T08:57:23.954431824+01:00","updated_at":"2025-12-30T09:01:38.714453571+01:00","closed_at":"2025-12-30T09:01:38.714453571+01:00","dependencies":[{"issue_id":"hcs-f2r","depends_on_id":"hcs-cq4","type":"parent-child","created_at":"2025-12-30T08:57:44.799141738+01:00","created_by":"gdiazlo"}]} 54 54 + {"id":"hcs-fgd","title":"Logging System","description":"Implement Log module with level, event types, built-in loggers (null, stderr, custom), and event formatting.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:26.517303879+01:00","updated_at":"2025-12-29T17:40:48.765669075+01:00","closed_at":"2025-12-29T17:40:48.765669075+01:00","dependencies":[{"issue_id":"hcs-fgd","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:08.827592455+01:00","created_by":"gdiazlo"}]} 55 55 + {"id":"hcs-fsc","title":"Implement Request helper module","description":"Implement request helpers in hcs-core/request.ml:\n\n```ocaml\nval path : request -\u003e string\nval query : string -\u003e request -\u003e string option\nval query_all : string -\u003e request -\u003e string list\nval header : string -\u003e request -\u003e string option\nval header_all : string -\u003e request -\u003e string list\nval content_type : request -\u003e string option\nval content_length : request -\u003e int64 option\nval is_keep_alive : request -\u003e bool\n\n(* Body consumption - sync versions *)\nval body_string : request -\u003e (string, error) result\nval body_to_cstruct : request -\u003e (Cstruct.t, error) result\n\n(* Form data parsing *)\nval form : request -\u003e ((string * string) list, error) result\n```\n\nPure OCaml + uri package.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:34:09.842512086+01:00","updated_at":"2025-12-29T15:40:29.136273489+01:00","closed_at":"2025-12-29T15:40:29.136273489+01:00","dependencies":[{"issue_id":"hcs-fsc","depends_on_id":"hcs-dle","type":"parent-child","created_at":"2025-12-29T14:34:47.838799048+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-fsc","depends_on_id":"hcs-lpr","type":"blocks","created_at":"2025-12-29T14:34:54.851316989+01:00","created_by":"gdiazlo"}]} 56 56 + {"id":"hcs-g2y","title":"Research HTTP compliance test suites","description":"Research and document available HTTP compliance testing tools and servers:\n\n**For Client Testing (test servers):**\n\n1. **httpbin** (https://httpbin.org / kennethreitz/httpbin)\n - Returns request info as JSON\n - Tests: methods, headers, redirects, auth, cookies, response codes\n - Can run locally via Docker\n\n2. **go-httpbin** (mccutchen/go-httpbin)\n - Go reimplementation, faster and more features\n - Better for local testing\n\n3. **h2spec** (summerwind/h2spec)\n - HTTP/2 conformance testing tool\n - Tests HPACK, streams, flow control, error handling\n - Essential for HTTP/2 compliance\n\n4. **curl test suite**\n - curl's own test servers have extensive edge cases\n\n**For Server Testing (test clients):**\n\n1. **h2load** (nghttp2)\n - HTTP/2 benchmarking and testing\n - Tests multiplexing, flow control\n\n2. **curl** with verbose options\n - Good for basic HTTP/1.1 compliance\n\n3. **nghttp** (nghttp2)\n - HTTP/2 client for testing server responses\n\n4. **Autobahn|Testsuite** (for WebSocket)\n - Comprehensive WebSocket protocol compliance\n - https://github.com/crossbario/autobahn-testsuite\n\n**RFC Compliance:**\n- RFC 7230-7235 (HTTP/1.1)\n- RFC 7540 (HTTP/2)\n- RFC 6455 (WebSocket)\n- RFC 7541 (HPACK)\n\nEvaluate which tools to integrate into CI.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:36:03.601972706+01:00","updated_at":"2025-12-29T17:31:46.947022974+01:00","closed_at":"2025-12-29T17:31:46.947022974+01:00","dependencies":[{"issue_id":"hcs-g2y","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:42.697870585+01:00","created_by":"gdiazlo"}]} 57 57 + {"id":"hcs-gmb","title":"Implement error type","description":"Implement comprehensive error type in error.ml:\n- Connection_failed, Connection_closed\n- Timeout variants (Connect, Read, Write, Total)\n- Cancelled\n- Invalid_url, Invalid_response\n- Too_many_redirects\n- Protocol_error, Tls_error, Codec_error\n- Body_too_large, IO_error\n\nInclude to_string for debugging. Pure OCaml.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:22.136715155+01:00","updated_at":"2025-12-29T14:50:40.75088559+01:00","closed_at":"2025-12-29T14:50:40.75088559+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-gmb","depends_on_id":"hcs-ugs","type":"parent-child","created_at":"2025-12-29T14:27:42.239579889+01:00","created_by":"gdiazlo"}]} 58 58 + {"id":"hcs-h2a","title":"Benchmark runner script with memory profiling","description":"Create benchmark runner that tests all servers across all protocols, measures req/s, msg/s, memory/connection, and produces summary report.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-31T14:13:51.31059033+01:00","updated_at":"2025-12-31T14:47:32.444742919+01:00","closed_at":"2025-12-31T14:47:32.444742919+01:00","dependencies":[{"issue_id":"hcs-h2a","depends_on_id":"hcs-rzc","type":"blocks","created_at":"2025-12-31T14:14:05.717334469+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-h2a","depends_on_id":"hcs-9yc","type":"blocks","created_at":"2025-12-31T14:14:10.761462149+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-h2a","depends_on_id":"hcs-s94","type":"blocks","created_at":"2025-12-31T14:14:15.805316293+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-h2a","depends_on_id":"hcs-peu","type":"blocks","created_at":"2025-12-31T14:14:20.849391195+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-h2a","depends_on_id":"hcs-5wp","type":"parent-child","created_at":"2025-12-31T14:14:46.066127034+01:00","created_by":"gdiazlo"}]} 59 59 + {"id":"hcs-hkf","title":"Add benchmark runner script with standard scenarios","description":"Create a benchmark runner script (bench/run_benchmarks.sh) that runs standard benchmark scenarios:\n1. Minimal GET (/ping) - pure overhead measurement\n2. Small payload (1KB) - typical API response\n3. Medium payload (10KB) - larger JSON responses \n4. Large payload (100KB) - file downloads\n5. POST with body - request body handling\n6. Varying concurrency (1, 10, 50, 100, 200 connections)\n7. HTTP/1.1 vs HTTP/2 comparison\n\nOutput results to bench/results/ with timestamps for tracking over time.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T18:04:02.294539956+01:00","updated_at":"2025-12-29T18:17:10.742622288+01:00","closed_at":"2025-12-29T18:17:10.742622288+01:00","dependencies":[{"issue_id":"hcs-hkf","depends_on_id":"hcs-jtz","type":"parent-child","created_at":"2025-12-29T18:04:24.660841757+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-hkf","depends_on_id":"hcs-4w8","type":"blocks","created_at":"2025-12-29T18:04:36.967445707+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-hkf","depends_on_id":"hcs-320","type":"blocks","created_at":"2025-12-29T18:04:38.425355179+01:00","created_by":"gdiazlo"}]} 60 60 + {"id":"hcs-i4f","title":"Setup bench/ directory structure with .gitignore","description":"","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T22:21:21.51511238+01:00","updated_at":"2025-12-30T22:23:03.029513364+01:00","closed_at":"2025-12-30T22:23:03.029513364+01:00"} 61 61 + {"id":"hcs-i8j","title":"Implement OCaml/HCS benchmark server (plaintext + json, HTTP/1+2, CPU scaling)","description":"","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T22:21:36.638072425+01:00","updated_at":"2025-12-30T22:28:28.339092129+01:00","closed_at":"2025-12-30T22:28:28.339092129+01:00"} 62 62 + {"id":"hcs-j2z","title":"Implement unified Client module (Eio)","description":"Implement unified client API in hcs-eio/client.ml:\n\n```ocaml\ntype t\n\nval create :\n sw:Eio.Switch.t -\u003e\n net:Eio.Net.t -\u003e\n clock:Eio.Time.clock -\u003e\n ?config:config -\u003e\n unit -\u003e\n t\n\nval request : ?cancel:Cancel.t -\u003e t -\u003e request -\u003e (response, error) result\nval fetch : ?cancel:Cancel.t -\u003e t -\u003e request -\u003e (status * Headers.t * string, error) result\nval stream : ?cancel:Cancel.t -\u003e t -\u003e request -\u003e (status * Headers.t * Cstruct.t Stream.t, error) result\n\nval close_idle : t -\u003e unit\nval pool_stats : t -\u003e { active: int; idle: int; total: int }\n```\n\nFeatures:\n- Protocol selection (HTTP/1.1 vs HTTP/2) via ALPN or config\n- Connection pooling\n- Automatic redirect following\n- Compression handling\n- TLS with system certs by default","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:31:27.67982735+01:00","updated_at":"2025-12-29T17:00:20.730823454+01:00","closed_at":"2025-12-29T17:00:20.730823454+01:00","dependencies":[{"issue_id":"hcs-j2z","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:51.749045471+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-j2z","depends_on_id":"hcs-7n9","type":"blocks","created_at":"2025-12-29T14:31:54.365652586+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-j2z","depends_on_id":"hcs-d5s","type":"blocks","created_at":"2025-12-29T14:31:55.246269371+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-j2z","depends_on_id":"hcs-2ca","type":"blocks","created_at":"2025-12-29T14:31:55.835151512+01:00","created_by":"gdiazlo"}]} 63 63 + {"id":"hcs-j5q","title":"Move Go benchmark server to dedicated folder (bench/comparison/go_fasthttp/)","description":"","status":"closed","priority":2,"issue_type":"chore","created_at":"2025-12-30T00:14:15.760072799+01:00","updated_at":"2025-12-30T00:17:18.571463212+01:00","closed_at":"2025-12-30T00:17:18.571463212+01:00"} 64 64 + {"id":"hcs-j7j","title":"Implement Go/fasthttp benchmark server (plaintext + json, HTTP/1+2, CPU scaling)","description":"","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T22:21:31.597229058+01:00","updated_at":"2025-12-30T22:28:28.338758567+01:00","closed_at":"2025-12-30T22:28:28.338758567+01:00"} 65 65 + {"id":"hcs-jk8","title":"WebSocket Benchmark: Memory and Connection Scaling","description":"Compare HCS (OCaml) vs Go vs Rust WebSocket implementations. Metrics: memory per connection, max connections per CPU.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-30T09:59:44.349580383+01:00","updated_at":"2025-12-30T10:23:00.707208406+01:00","closed_at":"2025-12-30T10:23:00.707208406+01:00"} 66 66 + {"id":"hcs-jqx","title":"Cache :path header extraction in request_handler","description":"H2.Headers.get is O(n). For the :path pseudo-header which is always present and accessed for every request, consider direct access or caching.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T08:57:26.215703677+01:00","updated_at":"2025-12-30T09:01:43.754321197+01:00","closed_at":"2025-12-30T09:01:43.754321197+01:00","dependencies":[{"issue_id":"hcs-jqx","depends_on_id":"hcs-cq4","type":"parent-child","created_at":"2025-12-30T08:57:49.840282561+01:00","created_by":"gdiazlo"}]} 67 67 + {"id":"hcs-jsl","title":"Implement Path DSL","description":"Implement type-safe path DSL in hcs-core/path.ml:\n\n```ocaml\ntype 'a t\n\n(* Combinators *)\nval root : unit t (* / *)\nval const : string -\u003e unit t (* /literal *)\nval str : string t (* /:param - captures string *)\nval int : int t (* /:param - captures int *)\nval int32 : int32 t\nval int64 : int64 t\nval uuid : string t (* validates UUID format *)\nval rest : string list t (* /** - captures remaining *)\n\nval ( / ) : 'a t -\u003e 'b t -\u003e ('a * 'b) t\nval ( /: ) : unit t -\u003e 'a t -\u003e 'a t (* const / capture shorthand *)\n\nval trailing_slash : 'a t -\u003e 'a t\n\n(* For router compilation *)\ntype segment =\n | Literal of string\n | Param_string\n | Param_int\n | Param_int32\n | Param_int64 \n | Param_uuid\n | Wildcard\n\nval to_segments : 'a t -\u003e segment list\nval parse : 'a t -\u003e string list -\u003e ('a, string) result\n```\n\nPure OCaml, uses GADTs for type safety.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:32:24.842727479+01:00","updated_at":"2025-12-29T14:56:33.544162475+01:00","closed_at":"2025-12-29T14:56:33.544162475+01:00","dependencies":[{"issue_id":"hcs-jsl","depends_on_id":"hcs-2ie","type":"parent-child","created_at":"2025-12-29T14:32:55.556666992+01:00","created_by":"gdiazlo"}]} 68 68 + {"id":"hcs-jtz","title":"Benchmark Suite for HCS HTTP Library","description":"Create a comprehensive benchmark suite to measure HCS HTTP library performance. Focus on requests/second for both HTTP/1.1 and HTTP/2, comparing client and server performance under various conditions.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T18:03:37.371206713+01:00","updated_at":"2025-12-29T18:18:17.12058364+01:00","closed_at":"2025-12-29T18:18:17.12058364+01:00"} 69 69 + {"id":"hcs-k8f","title":"Implement multi-domain server run functions","description":"Create run_parallel and run_parallel_opt functions that spawn N domains, each with their own accept loop using SO_REUSEPORT.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T09:05:54.711085855+01:00","updated_at":"2025-12-30T09:10:52.550223218+01:00","closed_at":"2025-12-30T09:10:52.550223218+01:00","dependencies":[{"issue_id":"hcs-k8f","depends_on_id":"hcs-zq3","type":"parent-child","created_at":"2025-12-30T09:06:19.149511092+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-k8f","depends_on_id":"hcs-cxj","type":"blocks","created_at":"2025-12-30T09:06:34.264044099+01:00","created_by":"gdiazlo"}]} 70 70 + {"id":"hcs-kfm","title":"Set up property-based testing for parsers","description":"Use property-based testing (QCheck or Crowbar) for parsers and router:\n\n1. **HTTP/1.1 parser properties:**\n - parse(serialize(request)) = request (roundtrip)\n - parse partial input = Incomplete\n - parse garbage = Error (no crashes)\n - parse valid + garbage = Complete with correct consumed bytes\n\n2. **Router properties:**\n - All registered routes are matchable\n - More specific routes match before less specific\n - No path matches multiple routes (deterministic)\n - Captured params have correct types\n\n3. **Headers properties:**\n - Case-insensitive lookup\n - add then find = Some value\n - remove then find = None\n - of_list(to_list(h)) preserves all values\n\n4. **WebSocket frame properties:**\n - parse(serialize(frame)) = frame\n - Masked frames unmask correctly\n - Fragmented messages reassemble correctly\n\nAdd to dune test configuration with reasonable iteration counts.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:36:30.160273757+01:00","updated_at":"2025-12-29T17:52:17.694190669+01:00","closed_at":"2025-12-29T17:52:17.694190669+01:00","dependencies":[{"issue_id":"hcs-kfm","depends_on_id":"hcs-0zq","type":"parent-child","created_at":"2025-12-29T14:36:52.71433591+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-kfm","depends_on_id":"hcs-8zr","type":"blocks","created_at":"2025-12-29T14:37:00.796778902+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-kfm","depends_on_id":"hcs-sny","type":"blocks","created_at":"2025-12-29T14:37:01.737277561+01:00","created_by":"gdiazlo"}]} 71 71 + {"id":"hcs-kg1","title":"Implement connection pool","description":"Implement connection pooling with runtime abstraction:\n\nhcs-core/pool.ml (data structures):\n```ocaml\ntype key = { host: string; port: int; is_tls: bool }\ntype 'conn entry = { conn: 'conn; last_used: float; created: float }\ntype 'conn t\n\nval create : max_per_host:int -\u003e max_total:int -\u003e 'conn t\nval get : 'conn t -\u003e key -\u003e 'conn entry option\nval put : 'conn t -\u003e key -\u003e 'conn -\u003e now:float -\u003e unit\nval remove : 'conn t -\u003e key -\u003e 'conn -\u003e unit\nval close_idle : 'conn t -\u003e older_than:float -\u003e 'conn list\nval stats : 'conn t -\u003e { active: int; idle: int; total: int }\n```\n\nhcs-eio/pool.ml (Eio-specific):\n```ocaml\nmodule Eio_pool : sig\n type t\n val create : config:Client.config -\u003e t\n val acquire : t -\u003e key -\u003e (Eio.Flow.two_way, error) result\n val release : t -\u003e key -\u003e Eio.Flow.two_way -\u003e unit\n val with_connection : t -\u003e key -\u003e (Eio.Flow.two_way -\u003e 'a) -\u003e ('a, error) result\nend\n```\n\nUse LRU eviction, health checks on reuse.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:31:11.052080452+01:00","updated_at":"2025-12-29T15:18:04.471112737+01:00","closed_at":"2025-12-29T15:18:04.471112737+01:00","dependencies":[{"issue_id":"hcs-kg1","depends_on_id":"hcs-qnb","type":"parent-child","created_at":"2025-12-29T14:31:44.252516545+01:00","created_by":"gdiazlo"}]} 72 72 + {"id":"hcs-l23","title":"HTTP Client DSL","description":"Implement the Http module with request builder DSL for fluent API including headers, query params, body, and codec integration.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:29.533679497+01:00","updated_at":"2025-12-29T17:40:50.224704889+01:00","closed_at":"2025-12-29T17:40:50.224704889+01:00","dependencies":[{"issue_id":"hcs-l23","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:13.135112824+01:00","created_by":"gdiazlo"}]} 73 73 + {"id":"hcs-l9p","title":"Create Go HTTP/2 benchmark server (net/http)","description":"Implement a Go HTTP/2 server using net/http with h2c support. Match endpoints: /ping, /bytes/:n, /json. Use golang.org/x/net/http2/h2c for cleartext HTTP/2. Pre-allocate response buffers.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T08:21:53.967258404+01:00","updated_at":"2025-12-30T08:48:32.173036222+01:00","closed_at":"2025-12-30T08:48:32.173036222+01:00","dependencies":[{"issue_id":"hcs-l9p","depends_on_id":"hcs-82y","type":"parent-child","created_at":"2025-12-30T08:22:23.072848194+01:00","created_by":"gdiazlo"}]} 74 74 + {"id":"hcs-lhr","title":"WebSocket Support","description":"Implement Ws module with frame types, connection management, send/recv operations, server upgrade handler, and client connect.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:36.29066838+01:00","updated_at":"2025-12-29T16:01:05.272490486+01:00","closed_at":"2025-12-29T16:01:05.272490486+01:00","dependencies":[{"issue_id":"hcs-lhr","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:20.036599039+01:00","created_by":"gdiazlo"}]} 75 75 + {"id":"hcs-llr","title":"Implement Rust/hyper benchmark server (plaintext + json, HTTP/1+2, CPU scaling)","description":"","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T22:21:26.556966252+01:00","updated_at":"2025-12-30T22:28:28.337697653+01:00","closed_at":"2025-12-30T22:28:28.337697653+01:00"} 76 76 + {"id":"hcs-lpr","title":"Implement request and response record types","description":"Implement request and response records in types.ml:\n\n```ocaml\ntype request = {\n meth : method_;\n uri : Uri.t;\n version : version;\n headers : Headers.t;\n body : body;\n}\n\ntype response = {\n status : status;\n version : version;\n headers : Headers.t;\n body : body;\n}\n```\n\nInclude smart constructors and accessors. Pure OCaml + uri package.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:27:19.295375903+01:00","updated_at":"2025-12-29T14:50:46.801981182+01:00","closed_at":"2025-12-29T14:50:46.801981182+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-lpr","depends_on_id":"hcs-ugs","type":"blocks","created_at":"2025-12-29T14:27:19.300960037+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-lpr","depends_on_id":"hcs-6yl","type":"blocks","created_at":"2025-12-29T14:27:43.920564401+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-lpr","depends_on_id":"hcs-cmg","type":"blocks","created_at":"2025-12-29T14:27:44.815114113+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-lpr","depends_on_id":"hcs-cks","type":"blocks","created_at":"2025-12-29T14:27:45.656483969+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-lpr","depends_on_id":"hcs-chm","type":"blocks","created_at":"2025-12-29T14:27:46.481924426+01:00","created_by":"gdiazlo"}]} 77 77 + {"id":"hcs-lqi","title":"Implement HTTP/1.1 server (Eio)","description":"Implement HTTP/1.1 server for Eio in hcs-eio/h1_server.ml:\n\n```ocaml\nval handle_connection :\n flow:Eio.Flow.two_way -\u003e\n clock:Eio.Time.clock -\u003e\n config:Server.config -\u003e\n handler:(request -\u003e (response, error) result) -\u003e\n unit\n```\n\nFeatures:\n- Parse requests using h1 parser\n- Handle keep-alive connections\n- Support chunked and fixed-length bodies\n- Respect timeouts\n- Handle pipelining (optional)\n- Integrate with logging","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:33:22.560229088+01:00","updated_at":"2025-12-29T15:03:24.765221644+01:00","closed_at":"2025-12-29T15:03:24.765221644+01:00","dependencies":[{"issue_id":"hcs-lqi","depends_on_id":"hcs-rw6","type":"parent-child","created_at":"2025-12-29T14:33:42.102983428+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-lqi","depends_on_id":"hcs-56z","type":"blocks","created_at":"2025-12-29T14:33:44.325287786+01:00","created_by":"gdiazlo"}]} 78 78 + {"id":"hcs-m4r","title":"Codec System","description":"Implement the functor-based CODEC signature and With_codec functor for type-safe serialization/deserialization. Use Cstruct.t (buffers) instead of strings to properly support binary formats like MessagePack, Protobuf, and CBOR.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:22.203715886+01:00","updated_at":"2025-12-29T17:40:46.982752973+01:00","closed_at":"2025-12-29T17:40:46.982752973+01:00","dependencies":[{"issue_id":"hcs-m4r","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:00.496780385+01:00","created_by":"gdiazlo"}]} 79 79 + {"id":"hcs-mip","title":"Implement Http request builder DSL","description":"Implement high-level client DSL in hcs-core/http.ml:\n\n```ocaml\ntype builder\n\nval get : string -\u003e (builder, error) result\nval post : string -\u003e (builder, error) result\nval put : string -\u003e (builder, error) result\nval delete : string -\u003e (builder, error) result\n(* ... other methods ... *)\n\nval of_uri : method_ -\u003e Uri.t -\u003e builder\n\n(* Headers *)\nval header : string -\u003e string -\u003e builder -\u003e builder\nval headers : (string * string) list -\u003e builder -\u003e builder\nval content_type : string -\u003e builder -\u003e builder\nval accept : string -\u003e builder -\u003e builder\nval bearer : string -\u003e builder -\u003e builder\nval basic_auth : user:string -\u003e pass:string -\u003e builder -\u003e builder\nval user_agent : string -\u003e builder -\u003e builder\n\n(* Query parameters *)\nval query : string -\u003e string -\u003e builder -\u003e builder\nval queries : (string * string) list -\u003e builder -\u003e builder\n\n(* Body *)\nval body : body -\u003e builder -\u003e builder\nval body_string : ?content_type:string -\u003e string -\u003e builder -\u003e builder\nval form : (string * string) list -\u003e builder -\u003e builder\n\n(* Build final request *)\nval build : builder -\u003e request\n```\n\nPure OCaml, no IO.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:34:22.698743046+01:00","updated_at":"2025-12-29T17:10:04.149286655+01:00","closed_at":"2025-12-29T17:10:04.149286655+01:00","dependencies":[{"issue_id":"hcs-mip","depends_on_id":"hcs-l23","type":"parent-child","created_at":"2025-12-29T14:34:49.5612417+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-mip","depends_on_id":"hcs-lpr","type":"blocks","created_at":"2025-12-29T14:34:56.47577088+01:00","created_by":"gdiazlo"}]} 80 80 + {"id":"hcs-mli","title":"Run multi-CPU benchmarks (4, 8, 16 CPUs)","description":"Run benchmarks with 4, 8, and 16 domains for HCS, compare with Rust and Go multi-threaded.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T09:05:59.450548339+01:00","updated_at":"2025-12-30T09:16:49.37792589+01:00","closed_at":"2025-12-30T09:16:49.37792589+01:00","dependencies":[{"issue_id":"hcs-mli","depends_on_id":"hcs-zq3","type":"parent-child","created_at":"2025-12-30T09:06:29.226366436+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-mli","depends_on_id":"hcs-zln","type":"blocks","created_at":"2025-12-30T09:06:44.348550935+01:00","created_by":"gdiazlo"}]} 81 81 + {"id":"hcs-nad","title":"Implement WebSocket connection (Eio)","description":"Implement WebSocket for Eio in hcs-eio/websocket.ml:\n\n```ocaml\ntype conn\n\nval is_open : conn -\u003e bool\n\n(* Receive *)\nval recv : conn -\u003e (frame option, error) result\nval recv_timeout : Eio.Time.clock -\u003e float -\u003e conn -\u003e (frame option, error) result\n\n(* Send *)\nval send : conn -\u003e frame -\u003e (unit, error) result\nval close : ?code:int -\u003e ?reason:string -\u003e conn -\u003e (unit, error) result\n\n(* Stream interface *)\nval recv_stream : conn -\u003e frame Stream.t\nval send_stream : conn -\u003e frame Stream.t -\u003e (unit, error) result\n\n(* Server: upgrade handler *)\nval upgrade :\n ?protocols:string list -\u003e\n ?on_close:(int option -\u003e string option -\u003e unit) -\u003e\n (conn -\u003e (unit, error) result) -\u003e\n unit handler\n\n(* Client: connect *)\nval connect :\n sw:Eio.Switch.t -\u003e\n net:Eio.Net.t -\u003e\n clock:Eio.Time.clock -\u003e\n ?tls:Tls_config.client -\u003e\n ?headers:Headers.t -\u003e\n ?protocols:string list -\u003e\n string -\u003e\n (conn, error) result\n```","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:34:33.686889707+01:00","updated_at":"2025-12-29T16:00:45.086724651+01:00","closed_at":"2025-12-29T16:00:45.086724651+01:00","dependencies":[{"issue_id":"hcs-nad","depends_on_id":"hcs-lhr","type":"parent-child","created_at":"2025-12-29T14:34:52.929848888+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-nad","depends_on_id":"hcs-0ro","type":"blocks","created_at":"2025-12-29T14:34:58.053806421+01:00","created_by":"gdiazlo"}]} 82 82 + {"id":"hcs-njk","title":"Run HTTP/2 comparison benchmarks and analyze results","description":"Execute the HTTP/2 benchmarks across all three implementations. Collect req/s, latency (p50/p99), memory usage. Document results in BENCHMARKS.md with analysis of performance characteristics.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T08:21:59.417171367+01:00","updated_at":"2025-12-30T08:48:51.035410704+01:00","closed_at":"2025-12-30T08:48:51.035410704+01:00","dependencies":[{"issue_id":"hcs-njk","depends_on_id":"hcs-ddd","type":"blocks","created_at":"2025-12-30T08:22:17.716250574+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-njk","depends_on_id":"hcs-82y","type":"parent-child","created_at":"2025-12-30T08:22:28.307104582+01:00","created_by":"gdiazlo"}]} 83 83 + {"id":"hcs-oo5","title":"Benchmark suite: single-CPU comparison of HCS, hyper, fasthttp","description":"","notes":"## Benchmark Results (Dec 31, 2025)\n\n### HCS vs Eio Native (c=1000, 100k requests)\n\n| Domains | HCS run_parallel | Eio run_server | Winner |\n|---------|------------------|----------------|--------|\n| 1 | 142k | 136k | HCS +4% |\n| 2 | 196k | 200k | Eio +2% |\n| 4 | 264k | 259k | HCS +2% |\n| 8 | 259k | 267k | Eio +3% |\n\n**Key Finding**: Both approaches perform similarly. The 2-domain regression previously observed was a measurement artifact.\n\n### HCS vs Fasthttp (c=1000, 100k requests)\n\n| Domains | HCS | Fasthttp | Winner |\n|---------|-----|----------|--------|\n| 1 | 137k | 181k | Fasthttp +32% |\n| 4 | 242k | 186k | **HCS +30%** |\n| 8 | 228k | 204k | **HCS +12%** |\n\n**Key Finding**: HCS scales BETTER than Fasthttp and beats it at 4+ domains!\n\n### Conclusions\n\n1. The nested `Eio_main.run` is NOT a problem - Eio's Domain_manager.run does the same thing internally\n2. SO_REUSEPORT (HCS) vs shared socket (Eio native) perform similarly - no clear winner\n3. HCS multi-core scaling is actually quite good - beats Fasthttp at higher core counts\n4. Earlier \"2-domain regression\" was likely a measurement artifact (port reuse, warmup, etc.)\n\n### Remaining Optimization Opportunities\n\n1. Single-core performance still lags Fasthttp by ~32% - room for improvement in request parsing/response writing\n2. 8-domain shows slight regression from 4-domain for HCS - could investigate GC tuning\n3. Hyper benchmark failed to run - need to fix for comparison","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-30T22:41:13.187711389+01:00","updated_at":"2025-12-31T09:33:51.051037492+01:00","closed_at":"2025-12-31T09:33:51.051037492+01:00"} 84 84 + {"id":"hcs-osg","title":"Create Rust HTTP/2 benchmark server (hyper)","description":"Implement a Rust HTTP/2 server using hyper with h2c (cleartext HTTP/2) support. Match endpoints: /ping, /bytes/:n, /json. Use tokio runtime, pre-allocate response buffers for zero-copy.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T08:21:52.194368992+01:00","updated_at":"2025-12-30T08:48:32.166538953+01:00","closed_at":"2025-12-30T08:48:32.166538953+01:00","dependencies":[{"issue_id":"hcs-osg","depends_on_id":"hcs-82y","type":"parent-child","created_at":"2025-12-30T08:22:20.416305094+01:00","created_by":"gdiazlo"}]} 85 85 + {"id":"hcs-peu","title":"HCS benchmark client: HTTP/1.1 + HTTP/2 + WebSocket support","description":"Create comprehensive benchmark client supporting all protocols with connection reuse, multiplexing, and WebSocket message throughput.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-31T14:13:46.273123556+01:00","updated_at":"2025-12-31T14:37:50.862757453+01:00","closed_at":"2025-12-31T14:37:50.862757453+01:00","dependencies":[{"issue_id":"hcs-peu","depends_on_id":"hcs-5wp","type":"parent-child","created_at":"2025-12-31T14:14:41.0222415+01:00","created_by":"gdiazlo"}]} 86 86 + {"id":"hcs-pnc","title":"Control Flow and Cancellation","description":"Implement Cancel module for cooperative cancellation and Control module for timeout, retry, deadline, and circuit breaker patterns.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:23.840150584+01:00","updated_at":"2025-12-29T15:41:49.225247023+01:00","closed_at":"2025-12-29T15:41:49.225247023+01:00","dependencies":[{"issue_id":"hcs-pnc","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:03.266144948+01:00","created_by":"gdiazlo"}]} 87 87 + {"id":"hcs-pwc","title":"Implement CODEC module signature","description":"Implement the CODEC module signature in hcs-core/codec.ml using buffers:\n\n```ocaml\nmodule type CODEC = sig\n type 'a encoder\n type 'a decoder\n\n val content_type : string (* e.g., \"application/json\", \"application/msgpack\" *)\n\n (* Use Cstruct.t for buffer-based encoding/decoding *)\n val encode : 'a encoder -\u003e 'a -\u003e (Cstruct.t, string) result\n val decode : 'a decoder -\u003e Cstruct.t -\u003e ('a, string) result\n \n (* Optional: streaming encode/decode for large payloads *)\n val encode_stream : 'a encoder -\u003e 'a -\u003e Cstruct.t Stream.t option\n val decode_stream : 'a decoder -\u003e Cstruct.t Stream.t -\u003e ('a, string) result option\nend\n```\n\nBenefits of buffer-based approach:\n- Zero-copy for binary formats (msgpack, protobuf, cbor)\n- Efficient for large payloads\n- Can still handle text formats (JSON) by converting at boundaries\n- Consistent with body type which uses Cstruct.t for streaming\n\nPure OCaml + cstruct, no runtime dependency.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:28:42.177976816+01:00","updated_at":"2025-12-29T17:04:22.669690697+01:00","closed_at":"2025-12-29T17:04:22.669690697+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-pwc","depends_on_id":"hcs-m4r","type":"parent-child","created_at":"2025-12-29T14:28:59.747767828+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-pwc","depends_on_id":"hcs-23f","type":"blocks","created_at":"2025-12-29T14:29:04.083986956+01:00","created_by":"gdiazlo"}]} 88 88 + {"id":"hcs-qf7","title":"Implement radix trie for routing","description":"Implement radix trie in hcs-core/trie.ml:\n\n```ocaml\ntype 'a t\n\nval empty : 'a t\nval insert : Path.segment list -\u003e method_ -\u003e 'a -\u003e 'a t -\u003e 'a t\nval lookup : string list -\u003e method_ -\u003e 'a t -\u003e ('a * string list, string) result\n (* Returns handler and captured params *)\n\nval compile : 'a t -\u003e 'a t (* Optimize: compress edges, sort by priority *)\n```\n\nImplementation notes:\n- Radix trie with compressed edges for static segments\n- Parameter nodes stored separately for O(1) lookup\n- Method dispatch at leaf nodes (small array)\n- Priority: static \u003e typed param \u003e string param \u003e wildcard\n- Pre-compile regex for uuid validation\n\nPure OCaml, O(path_length) lookup.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:32:37.659665672+01:00","updated_at":"2025-12-29T15:18:02.267050922+01:00","closed_at":"2025-12-29T15:18:02.267050922+01:00","dependencies":[{"issue_id":"hcs-qf7","depends_on_id":"hcs-2ie","type":"parent-child","created_at":"2025-12-29T14:32:56.840281975+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-qf7","depends_on_id":"hcs-jsl","type":"blocks","created_at":"2025-12-29T14:32:57.708007508+01:00","created_by":"gdiazlo"}]} 89 89 + {"id":"hcs-qnb","title":"HTTP Client Implementation","description":"Implement the Client module with connection pooling, HTTP/1.1 and HTTP/2 support, request/fetch/stream methods, and configuration.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:28.006219271+01:00","updated_at":"2025-12-29T17:41:34.620441464+01:00","closed_at":"2025-12-29T17:41:34.620441464+01:00","dependencies":[{"issue_id":"hcs-qnb","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:11.475056322+01:00","created_by":"gdiazlo"}]} 90 90 + {"id":"hcs-rw6","title":"HTTP Server Implementation","description":"Implement Server module with HTTP/1.1 and HTTP/2 support, configuration, graceful shutdown, and connection management.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:32.173329865+01:00","updated_at":"2025-12-29T17:41:35.435456001+01:00","closed_at":"2025-12-29T17:41:35.435456001+01:00","dependencies":[{"issue_id":"hcs-rw6","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:17.069517446+01:00","created_by":"gdiazlo"}]} 91 91 + {"id":"hcs-rzc","title":"HCS: Unified server with HTTP/1.1 + h2c upgrade + WebSocket","description":"Create single HCS server that detects protocol and routes to H1/H2/WS handlers. Support h2c upgrade from HTTP/1.1.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-31T14:13:31.15150333+01:00","updated_at":"2025-12-31T14:24:25.878899607+01:00","closed_at":"2025-12-31T14:24:25.878899607+01:00","dependencies":[{"issue_id":"hcs-rzc","depends_on_id":"hcs-5wp","type":"parent-child","created_at":"2025-12-31T14:14:25.89281292+01:00","created_by":"gdiazlo"}]} 92 92 + {"id":"hcs-s3a","title":"Implement runtime-specific middleware (Eio)","description":"Implement Eio-specific middleware in hcs-eio/middleware.ml:\n\n```ocaml\n(* Logging - needs clock for timing *)\nval logging : Eio.Time.clock -\u003e Log.logger -\u003e middleware\n\n(* Timeout *)\nval timeout : Eio.Time.clock -\u003e float -\u003e middleware\n\n(* Rate limiting - needs clock and mutable state *)\nval rate_limit :\n clock:Eio.Time.clock -\u003e\n key:(request -\u003e string) -\u003e\n requests:int -\u003e\n per:float -\u003e\n middleware\n\n(* Compression - CPU bound but may benefit from async *)\nval compress : ?level:int -\u003e ?min_size:int -\u003e unit -\u003e middleware\nval decompress : middleware\n\n(* Static files - needs filesystem *)\nval static :\n fs:Eio.Fs.dir_ty Eio.Path.t -\u003e\n ?index:string list -\u003e\n ?etag:bool -\u003e\n string -\u003e\n middleware\n\n(* ETag generation *)\nval etag : middleware\nval cache_control : string -\u003e middleware\n```","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-29T14:34:31.955254986+01:00","updated_at":"2025-12-29T17:14:15.252061602+01:00","closed_at":"2025-12-29T17:14:15.252061602+01:00","dependencies":[{"issue_id":"hcs-s3a","depends_on_id":"hcs-3ww","type":"parent-child","created_at":"2025-12-29T14:34:51.261233247+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-s3a","depends_on_id":"hcs-bea","type":"blocks","created_at":"2025-12-29T14:34:57.261423006+01:00","created_by":"gdiazlo"}]} 93 93 + {"id":"hcs-s94","title":"Rust: Unified Hyper server with HTTP/1.1 + h2c + WebSocket","description":"Update Hyper server to handle HTTP/1.1, h2c, and WebSocket on single port.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-31T14:13:41.231763861+01:00","updated_at":"2025-12-31T14:31:18.83450995+01:00","closed_at":"2025-12-31T14:31:18.83450995+01:00","dependencies":[{"issue_id":"hcs-s94","depends_on_id":"hcs-5wp","type":"parent-child","created_at":"2025-12-31T14:14:35.978086083+01:00","created_by":"gdiazlo"}]} 94 94 + {"id":"hcs-sny","title":"Implement Router module","description":"Implement router API in hcs-core/router.ml:\n\n```ocaml\ntype 'a handler = 'a -\u003e request -\u003e (response, error) result\ntype middleware = (request -\u003e (response, error) result) -\u003e request -\u003e (response, error) result\n\ntype t\n\n(* Route registration *)\nval get : 'a Path.t -\u003e 'a handler -\u003e t\nval post : 'a Path.t -\u003e 'a handler -\u003e t\nval put : 'a Path.t -\u003e 'a handler -\u003e t\nval delete : 'a Path.t -\u003e 'a handler -\u003e t\nval patch : 'a Path.t -\u003e 'a handler -\u003e t\nval head : 'a Path.t -\u003e 'a handler -\u003e t\nval options : 'a Path.t -\u003e 'a handler -\u003e t\nval any : method_ list -\u003e 'a Path.t -\u003e 'a handler -\u003e t\n\n(* Composition *)\nval routes : t list -\u003e t\nval scope : string -\u003e t list -\u003e t\nval scope_with : string -\u003e middleware list -\u003e t list -\u003e t\nval with_middleware : middleware list -\u003e t -\u003e t\n\n(* Compilation *)\ntype compiled\nval compile : t -\u003e compiled\nval match_ : compiled -\u003e request -\u003e (response, error) result\n```\n\nPure OCaml, builds on Path and Trie.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:32:43.527248631+01:00","updated_at":"2025-12-29T15:18:03.419090442+01:00","closed_at":"2025-12-29T15:18:03.419090442+01:00","dependencies":[{"issue_id":"hcs-sny","depends_on_id":"hcs-2ie","type":"parent-child","created_at":"2025-12-29T14:32:57.378211329+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-sny","depends_on_id":"hcs-qf7","type":"blocks","created_at":"2025-12-29T14:32:58.327421433+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-sny","depends_on_id":"hcs-lpr","type":"blocks","created_at":"2025-12-29T14:32:59.27491603+01:00","created_by":"gdiazlo"}]} 95 95 + {"id":"hcs-tn3","title":"Run WebSocket benchmarks and collect results","description":"Execute the benchmark suite, collect memory and connection data, document findings.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T10:00:04.76879529+01:00","updated_at":"2025-12-30T10:22:46.346637622+01:00","closed_at":"2025-12-30T10:22:46.346637622+01:00","dependencies":[{"issue_id":"hcs-tn3","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:50.758778716+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-tn3","depends_on_id":"hcs-wkv","type":"blocks","created_at":"2025-12-30T10:01:15.964007648+01:00","created_by":"gdiazlo"}]} 96 96 + {"id":"hcs-tzc","title":"Implement Server.config type","description":"Implement server configuration in hcs-core/server_config.ml:\n\n```ocaml\ntype config = {\n host : string; (* default: \"0.0.0.0\" *)\n port : int; (* default: 8080 *)\n backlog : int; (* default: 2048 *)\n max_connections : int; (* default: 10000 *)\n\n (* Timeouts *)\n read_timeout : float; (* default: 60.0 *)\n write_timeout : float; (* default: 60.0 *)\n idle_timeout : float; (* default: 120.0 *)\n request_timeout : float; (* default: 30.0 *)\n\n (* Limits *)\n max_header_size : int; (* default: 8192 *)\n max_body_size : int64 option; (* None = unlimited *)\n\n (* Protocol *)\n http2 : bool; (* default: true *)\n buffer_size : int; (* default: 16384 *)\n\n (* TLS *)\n tls : Tls_config.server option;\n\n (* Compression *)\n compress_response : bool; (* default: true *)\n compression_min_size : int; (* default: 1024 *)\n compression_level : int; (* default: 6 *)\n\n (* Logging *)\n logger : Log.logger;\n}\n\nval default : config\n```\n\nPure configuration, no IO.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:33:15.561446445+01:00","updated_at":"2025-12-29T15:40:25.769211668+01:00","closed_at":"2025-12-29T15:40:25.769211668+01:00","dependencies":[{"issue_id":"hcs-tzc","depends_on_id":"hcs-rw6","type":"parent-child","created_at":"2025-12-29T14:33:40.219574299+01:00","created_by":"gdiazlo"}]} 97 97 + {"id":"hcs-ucw","title":"Implement Response helper module","description":"Implement response helpers in hcs-core/response.ml:\n\n```ocaml\nval make : ?version:version -\u003e ?headers:Headers.t -\u003e ?body:body -\u003e status -\u003e response\n\n(* Status shortcuts *)\nval ok : ?headers:Headers.t -\u003e body -\u003e response\nval created : ?headers:Headers.t -\u003e ?location:string -\u003e body -\u003e response\nval no_content : unit -\u003e response\nval bad_request : ?body:body -\u003e unit -\u003e response\nval unauthorized : ?www_authenticate:string -\u003e unit -\u003e response\nval forbidden : ?body:body -\u003e unit -\u003e response\nval not_found : ?body:body -\u003e unit -\u003e response\nval method_not_allowed : allowed:method_ list -\u003e unit -\u003e response\nval internal_error : ?body:body -\u003e unit -\u003e response\n(* ... all status helpers from spec ... *)\n\n(* Body helpers *)\nval text : string -\u003e response\nval html : string -\u003e response\nval redirect : ?permanent:bool -\u003e string -\u003e response\n\n(* Modify response *)\nval with_header : string -\u003e string -\u003e response -\u003e response\nval with_headers : (string * string) list -\u003e response -\u003e response\nval with_body : body -\u003e response -\u003e response\n```\n\nPure OCaml.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:34:17.870074295+01:00","updated_at":"2025-12-29T15:40:30.579234447+01:00","closed_at":"2025-12-29T15:40:30.579234447+01:00","dependencies":[{"issue_id":"hcs-ucw","depends_on_id":"hcs-dle","type":"parent-child","created_at":"2025-12-29T14:34:48.628725792+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-ucw","depends_on_id":"hcs-lpr","type":"blocks","created_at":"2025-12-29T14:34:55.629240942+01:00","created_by":"gdiazlo"}]} 98 98 + {"id":"hcs-ugs","title":"Core Types and Foundations","description":"Implement core type foundations: method_, version, status, Headers module, body type, request/response records, and error types.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:19.301411166+01:00","updated_at":"2025-12-29T15:42:11.485073934+01:00","closed_at":"2025-12-29T15:42:11.485073934+01:00","dependencies":[{"issue_id":"hcs-ugs","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:25:54.989012647+01:00","created_by":"gdiazlo"}]} 99 99 + {"id":"hcs-w1c","title":"Create HCS WebSocket benchmark server","description":"OCaml server using lib/websocket.ml. Accept connections, keep alive with ping/pong, report connection count. Port configurable via CLI.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T09:59:57.95619465+01:00","updated_at":"2025-12-30T10:03:58.03114584+01:00","closed_at":"2025-12-30T10:03:58.03114584+01:00","dependencies":[{"issue_id":"hcs-w1c","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:25.560665813+01:00","created_by":"gdiazlo"}]} 100 100 + {"id":"hcs-wkv","title":"Create WebSocket benchmark runner script","description":"Script like run_h2_comparison.sh. Start servers, run tests at 1k/10k/50k/100k connections, measure memory via /proc/[pid]/status VmRSS, report results.","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T10:00:03.612055281+01:00","updated_at":"2025-12-30T10:14:42.952379356+01:00","closed_at":"2025-12-30T10:14:42.952379356+01:00","dependencies":[{"issue_id":"hcs-wkv","depends_on_id":"hcs-jk8","type":"parent-child","created_at":"2025-12-30T10:00:45.722495633+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-wkv","depends_on_id":"hcs-w1c","type":"blocks","created_at":"2025-12-30T10:00:55.80122372+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-wkv","depends_on_id":"hcs-1h7","type":"blocks","created_at":"2025-12-30T10:01:00.843226486+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-wkv","depends_on_id":"hcs-6ki","type":"blocks","created_at":"2025-12-30T10:01:05.885715216+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-wkv","depends_on_id":"hcs-6hx","type":"blocks","created_at":"2025-12-30T10:01:10.922318474+01:00","created_by":"gdiazlo"}]} 101 101 + {"id":"hcs-x1l","title":"Create benchmark runner script for standardized testing","description":"","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-30T22:21:46.718118939+01:00","updated_at":"2025-12-30T22:33:10.362379965+01:00","closed_at":"2025-12-30T22:33:10.362379965+01:00"} 102 102 + {"id":"hcs-y9w","title":"TLS Configuration","description":"Implement Tls_config module for client and server TLS configuration with verification modes and system certificate loading.","status":"closed","priority":2,"issue_type":"epic","created_at":"2025-12-29T14:25:24.911800471+01:00","updated_at":"2025-12-29T15:25:06.384359847+01:00","closed_at":"2025-12-29T15:25:06.384359847+01:00","dependencies":[{"issue_id":"hcs-y9w","depends_on_id":"hcs-zba","type":"parent-child","created_at":"2025-12-29T14:26:05.906211432+01:00","created_by":"gdiazlo"}]} 103 103 + {"id":"hcs-zba","title":"HCS HTTP Library Implementation","description":"Implement the hcs HTTP library for OCaml 5+ supporting HTTP/1.1, HTTP/2, and WebSockets. Built with a runtime-agnostic core to support Eio initially with Lwt support planned for the future. Features zero-copy streaming and minimal allocations.\n\nDesign Principle: The library should have a pure functional core with IO effects abstracted behind a runtime interface, allowing future Lwt integration without major rewrites.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-29T14:25:07.01892354+01:00","updated_at":"2025-12-29T17:57:35.070502613+01:00","closed_at":"2025-12-29T17:57:35.070502613+01:00"} 104 104 + {"id":"hcs-zft","title":"Document CODEC implementation examples","description":"Document how users can implement their own CODEC for various formats. Include examples in documentation/comments showing the pattern:\n\n```ocaml\n(* Example: User implements JSON codec with their preferred library *)\nmodule My_json_codec : Hcs.CODEC = struct\n type 'a encoder = 'a -\u003e Yojson.Safe.t (* or Jsonm, Jsoo, etc. *)\n type 'a decoder = Yojson.Safe.t -\u003e ('a, string) result\n \n let content_type = \"application/json\"\n \n let encode enc value =\n try Ok (Cstruct.of_string (Yojson.Safe.to_string (enc value)))\n with exn -\u003e Error (Printexc.to_string exn)\n \n let decode dec buf =\n try \n let json = Yojson.Safe.from_string (Cstruct.to_string buf) in\n dec json\n with exn -\u003e Error (Printexc.to_string exn)\n \n let encode_stream _ _ = None (* Optional streaming *)\n let decode_stream _ _ = None\nend\n\n(* Example: MessagePack codec *)\nmodule My_msgpack_codec : Hcs.CODEC = struct\n (* Similar pattern with msgpck library *)\nend\n```\n\nThis is documentation only - no actual JSON library dependency in hcs. Users choose their own serialization libraries.","status":"closed","priority":3,"issue_type":"task","created_at":"2025-12-29T14:28:49.108715641+01:00","updated_at":"2025-12-29T17:32:45.942298931+01:00","closed_at":"2025-12-29T17:32:45.942298931+01:00","labels":["codec","optional"],"dependencies":[{"issue_id":"hcs-zft","depends_on_id":"hcs-m4r","type":"parent-child","created_at":"2025-12-29T14:29:01.540146453+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-zft","depends_on_id":"hcs-pwc","type":"blocks","created_at":"2025-12-29T14:29:03.003001157+01:00","created_by":"gdiazlo"}]} 105 105 + {"id":"hcs-zln","title":"Update benchmark server with --domains flag","description":"Add --domains N flag to bench_server_h2.exe to test with configurable domain count.","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-30T09:05:56.907974106+01:00","updated_at":"2025-12-30T09:16:33.434469675+01:00","closed_at":"2025-12-30T09:16:33.434469675+01:00","dependencies":[{"issue_id":"hcs-zln","depends_on_id":"hcs-zq3","type":"parent-child","created_at":"2025-12-30T09:06:24.184829345+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-zln","depends_on_id":"hcs-k8f","type":"blocks","created_at":"2025-12-30T09:06:39.306344162+01:00","created_by":"gdiazlo"}]} 106 106 + {"id":"hcs-zq3","title":"Multi-CPU Support for HTTP/2 Server","description":"Add configurable multi-CPU support using Eio domain pools. Allow users to specify max CPU count.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-30T09:04:59.162003477+01:00","updated_at":"2025-12-30T09:16:54.412371508+01:00","closed_at":"2025-12-30T09:16:54.412371508+01:00"} 107 107 + {"id":"hcs-zum","title":"Make zero-copy responses the default in high-level Server API","description":"","status":"closed","priority":1,"issue_type":"feature","created_at":"2025-12-30T00:14:13.733230476+01:00","updated_at":"2025-12-30T00:21:07.346540362+01:00","closed_at":"2025-12-30T00:21:07.346540362+01:00"} 108 108 + {"id":"hcs-zya","title":"Implement Control module","description":"Implement control flow combinators. Split into core (pure) and runtime-specific parts:\n\nhcs-core/control.ml (pure combinators):\n```ocaml\n(* Retry logic - pure, takes a \"sleep\" function *)\nval with_retry :\n sleep:(float -\u003e unit) -\u003e\n max_attempts:int -\u003e\n backoff:(int -\u003e float) -\u003e\n should_retry:(error -\u003e bool) -\u003e\n (unit -\u003e ('a, error) result) -\u003e\n ('a, error) result\n\n(* Circuit breaker state machine - pure *)\ntype circuit_state = Closed | Open of float | HalfOpen\ntype circuit_breaker\nval create_breaker : failure_threshold:int -\u003e reset_timeout:float -\u003e circuit_breaker\nval breaker_allow : circuit_breaker -\u003e now:float -\u003e bool\nval breaker_record_success : circuit_breaker -\u003e unit\nval breaker_record_failure : circuit_breaker -\u003e now:float -\u003e unit\n```\n\nRuntime-specific (hcs-eio/control.ml):\n```ocaml\nval with_timeout : Eio.Time.clock -\u003e float -\u003e (unit -\u003e ('a, error) result) -\u003e ('a, error) result\nval with_cancel : Cancel.t -\u003e (unit -\u003e ('a, error) result) -\u003e ('a, error) result\nval with_deadline : Eio.Time.clock -\u003e float -\u003e (unit -\u003e ('a, error) result) -\u003e ('a, error) result\n```","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-29T14:29:29.643574962+01:00","updated_at":"2025-12-29T15:18:05.295780311+01:00","closed_at":"2025-12-29T15:18:05.295780311+01:00","labels":["core"],"dependencies":[{"issue_id":"hcs-zya","depends_on_id":"hcs-pnc","type":"parent-child","created_at":"2025-12-29T14:30:10.213773459+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-zya","depends_on_id":"hcs-8br","type":"blocks","created_at":"2025-12-29T14:30:10.494720544+01:00","created_by":"gdiazlo"},{"issue_id":"hcs-zya","depends_on_id":"hcs-gmb","type":"blocks","created_at":"2025-12-29T14:30:10.704956596+01:00","created_by":"gdiazlo"}]}

+4

.beads/metadata.json

reviewed

··· 1 1 + { 2 2 + "database": "beads.db", 3 3 + "jsonl_export": "issues.jsonl" 4 4 + }

+49

.gitignore

reviewed

··· 1 1 + # OCaml compiled artifacts 2 2 + *.annot 3 3 + *.cmo 4 4 + *.cma 5 5 + *.cmi 6 6 + *.a 7 7 + *.o 8 8 + *.cmx 9 9 + *.cmxs 10 10 + *.cmxa 11 11 + *.cmt 12 12 + *.cmti 13 13 + *.byte 14 14 + *.native 15 15 + *.install 16 16 + 17 17 + # Build directories 18 18 + _build/ 19 19 + _opam/ 20 20 + 21 21 + # Editor/IDE 22 22 + .vscode/ 23 23 + .idea/ 24 24 + .merlin 25 25 + 26 26 + # Node.js 27 27 + node_modules/ 28 28 + 29 29 + # OpenCode 30 30 + .opencode/ 31 31 + 32 32 + # Beads 33 33 + .beads/*.log 34 34 + .beads/*.lock 35 35 + 36 36 + # Benchmark results and artifacts 37 37 + results/ 38 38 + **/results/*.txt 39 39 + bench/certs/ 40 40 + bench/fasthttp/ 41 41 + bench/hcs/alloc_*.ml 42 42 + bench/nethttp/bench-nethttp 43 43 + perf.data 44 44 + perf*.data 45 45 + 46 46 + # Misc 47 47 + setup.data 48 48 + setup.log 49 49 + *.sh

+2

.ocamlformat

reviewed

··· 1 1 + version = 0.28.1 2 2 + profile = default

+15

LICENSE

reviewed

··· 1 1 + ISC License 2 2 + 3 3 + Copyright (c) 2026 Gabriel Díaz López de la Llave 4 4 + 5 5 + Permission to use, copy, modify, and/or distribute this software for any 6 6 + purpose with or without fee is hereby granted, provided that the above 7 7 + copyright notice and this permission notice appear in all copies. 8 8 + 9 9 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 10 10 + REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 11 11 + AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 12 + INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 13 13 + LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 14 14 + OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 15 + PERFORMANCE OF THIS SOFTWARE.

+133

README.md

reviewed

··· 1 1 + # hcs 2 2 + 3 3 + HTTP library for OCaml 5+ built on [Eio](https://github.com/ocaml-multicore/eio). Supports HTTP/1.1, HTTP/2, and WebSocket. 4 4 + 5 5 + ## Modules 6 6 + 7 7 + | Module | Description | 8 8 + |--------|-------------| 9 9 + | [Client](lib/client.ml) | HTTP client with auto-protocol selection | 10 10 + | [Server](lib/server.ml) | HTTP server with multi-domain parallelism | 11 11 + | [Router](lib/router.ml) | Radix trie router with path parameters | 12 12 + | [Middleware](lib/middleware.ml) | Composable middleware | 13 13 + | [Middleware_eio](lib/middleware_eio.ml) | Eio-specific middleware (logging, timeout, rate limiting, static files) | 14 14 + | [Websocket](lib/websocket.ml) | WebSocket client and server (RFC 6455) | 15 15 + | [Pool](lib/pool.ml) | Connection pooling | 16 16 + | [Pooled_client](lib/pooled_client.ml) | Client with connection pooling | 17 17 + | [Control](lib/control.ml) | Retry, circuit breaker, backoff strategies | 18 18 + | [Stream](lib/stream.ml) | Sync and async streaming | 19 19 + | [Codec](lib/codec.ml) | Codec signature for serialization | 20 20 + | [Tls_config](lib/tls_config.ml) | TLS configuration | 21 21 + | [Log](lib/log.ml) | Structured logging | 22 22 + | [Request](lib/request.ml) | Request helpers | 23 23 + | [Response](lib/response.ml) | Response helpers | 24 24 + | [Http](lib/http.ml) | Request builder DSL | 25 25 + | [H1_client](lib/h1_client.ml) | HTTP/1.1 client | 26 26 + | [H2_client](lib/h2_client.ml) | HTTP/2 client | 27 27 + | [H1_server](lib/h1_server.ml) | HTTP/1.1 server | 28 28 + | [H2_server](lib/h2_server.ml) | HTTP/2 server | 29 29 + 30 30 + ## CLI Tools 31 31 + 32 32 + ### hc - HTTP Client 33 33 + 34 34 + ``` 35 35 + hc [OPTIONS] <URL> 36 36 + ``` 37 37 + 38 38 + **Options:** 39 39 + 40 40 + | Flag | Description | 41 41 + |------|-------------| 42 42 + | `-X, --request METHOD` | HTTP method (GET, POST, PUT, DELETE, etc.) | 43 43 + | `-H, --header "Name: Value"` | Add header (can be repeated) | 44 44 + | `-d, --data DATA` | Request body | 45 45 + | `-2, --http2` | Force HTTP/2 | 46 46 + | `-1, --http1` | Force HTTP/1.1 | 47 47 + | `-k, --insecure` | Skip TLS verification | 48 48 + | `-v, --verbose` | Show headers | 49 49 + | `-I, --head` | HEAD request only | 50 50 + | `-L, --location` | Follow redirects (default) | 51 51 + | `--no-location` | Don't follow redirects | 52 52 + | `-o, --output FILE` | Write to file | 53 53 + | `-w, --websocket` | WebSocket mode | 54 54 + | `--ws-message MSG` | Message to send in WebSocket mode | 55 55 + 56 56 + **Examples:** 57 57 + 58 58 + ```bash 59 59 + # GET request 60 60 + hc https://httpbin.org/get 61 61 + 62 62 + # POST with data 63 63 + hc -d '{"key":"value"}' -H "Content-Type: application/json" https://httpbin.org/post 64 64 + 65 65 + # Force HTTP/2 66 66 + hc -2 https://nghttp2.org/httpbin/get 67 67 + 68 68 + # WebSocket 69 69 + hc -w wss://echo.websocket.org --ws-message "hello" 70 70 + 71 71 + # Download file 72 72 + hc -o image.png https://example.com/image.png 73 73 + ``` 74 74 + 75 75 + ### hs - HTTP File Server 76 76 + 77 77 + ``` 78 78 + hs [OPTIONS] [DIRECTORY] 79 79 + ``` 80 80 + 81 81 + **Options:** 82 82 + 83 83 + | Flag | Description | 84 84 + |------|-------------| 85 85 + | `-p, --port PORT` | Port (default: 8080) | 86 86 + | `-b, --bind ADDRESS` | Bind address (default: 0.0.0.0) | 87 87 + | `-d, --domains N` | Worker domains (default: CPU count) | 88 88 + | `-1, --http1` | HTTP/1.1 only | 89 89 + | `-2, --http2` | HTTP/2 only | 90 90 + | `--index FILE` | Index file (default: index.html) | 91 91 + | `--no-index` | Disable index file | 92 92 + | `--list` | Enable directory listing | 93 93 + | `--cors` | Enable CORS headers | 94 94 + | `-v, --verbose` | Log requests | 95 95 + 96 96 + **Examples:** 97 97 + 98 98 + ```bash 99 99 + # Serve current directory 100 100 + hs 101 101 + 102 102 + # Serve specific directory on port 3000 103 103 + hs -p 3000 ./public 104 104 + 105 105 + # With directory listing and CORS 106 106 + hs --list --cors ./dist 107 107 + 108 108 + # Verbose logging 109 109 + hs -v -p 8000 . 110 110 + ``` 111 111 + 112 112 + ## Building 113 113 + 114 114 + ```bash 115 115 + opam install . --deps-only 116 116 + dune build 117 117 + ``` 118 118 + 119 119 + ## Running Tests 120 120 + 121 121 + ```bash 122 122 + dune test 123 123 + ``` 124 124 + 125 125 + ## Dependencies 126 126 + 127 127 + - [eio](https://github.com/ocaml-multicore/eio) - Structured concurrency 128 128 + - [h1](https://github.com/anmonteiro/http-protocols) - HTTP/1.1 parsing 129 129 + - [h2](https://github.com/anmonteiro/http-protocols) - HTTP/2 parsing 130 130 + - [tls-eio](https://github.com/mirleft/ocaml-tls) - TLS with Eio 131 131 + - [ca-certs](https://github.com/mirage/ca-certs) - System CA certificates 132 132 + - [uri](https://github.com/mirage/ocaml-uri) - URI parsing 133 133 + - [climate](https://github.com/gridbugs/climate) - CLI parsing

+20

bench/.gitignore

reviewed

··· 1 1 + # Rust build artifacts 2 2 + hyper/target/ 3 3 + 4 4 + # Go build artifacts 5 5 + fasthttp/bench-server 6 6 + 7 7 + # Results and logs 8 8 + results/ 9 9 + *.log 10 10 + 11 11 + # Editor/IDE 12 12 + .idea/ 13 13 + .vscode/ 14 14 + *.swp 15 15 + *.swo 16 16 + *~ 17 17 + 18 18 + # OS files 19 19 + .DS_Store 20 20 + Thumbs.db

+232

bench/client/bench_client.ml

reviewed

··· 1 1 + module Stats = struct 2 2 + type t = { 3 3 + mutable total_requests : int; 4 4 + mutable successful : int; 5 5 + mutable failed : int; 6 6 + latencies : float Queue.t; 7 7 + start_time : float; 8 8 + mutable end_time : float; 9 9 + } 10 10 + 11 11 + let create () = 12 12 + { 13 13 + total_requests = 0; 14 14 + successful = 0; 15 15 + failed = 0; 16 16 + latencies = Queue.create (); 17 17 + start_time = Unix.gettimeofday (); 18 18 + end_time = 0.0; 19 19 + } 20 20 + 21 21 + let record_success stats latency_ms = 22 22 + stats.total_requests <- stats.total_requests + 1; 23 23 + stats.successful <- stats.successful + 1; 24 24 + Queue.push latency_ms stats.latencies 25 25 + 26 26 + let record_failure stats = 27 27 + stats.total_requests <- stats.total_requests + 1; 28 28 + stats.failed <- stats.failed + 1 29 29 + 30 30 + let finish stats = stats.end_time <- Unix.gettimeofday () 31 31 + 32 32 + let percentile arr p = 33 33 + let n = Array.length arr in 34 34 + if n = 0 then 0.0 35 35 + else 36 36 + let idx = int_of_float (float_of_int (n - 1) *. p) in 37 37 + arr.(idx) 38 38 + 39 39 + let report stats ~json ~protocol = 40 40 + finish stats; 41 41 + let duration = stats.end_time -. stats.start_time in 42 42 + let rps = float_of_int stats.successful /. duration in 43 43 + 44 44 + let latencies = Queue.to_seq stats.latencies |> Array.of_seq in 45 45 + Array.sort compare latencies; 46 46 + 47 47 + let p50 = percentile latencies 0.50 in 48 48 + let p90 = percentile latencies 0.90 in 49 49 + let p99 = percentile latencies 0.99 in 50 50 + let p999 = percentile latencies 0.999 in 51 51 + let avg = 52 52 + if Array.length latencies > 0 then 53 53 + Array.fold_left ( +. ) 0.0 latencies 54 54 + /. float_of_int (Array.length latencies) 55 55 + else 0.0 56 56 + in 57 57 + 58 58 + if json then 59 59 + Printf.printf 60 60 + {|{"protocol":"%s","duration":%.2f,"total":%d,"successful":%d,"failed":%d,"rps":%.2f,"latency_avg":%.3f,"latency_p50":%.3f,"latency_p90":%.3f,"latency_p99":%.3f,"latency_p999":%.3f} 61 61 + |} 62 62 + protocol duration stats.total_requests stats.successful stats.failed rps 63 63 + avg p50 p90 p99 p999 64 64 + else begin 65 65 + Printf.printf "\n=== Benchmark Results (%s) ===\n" protocol; 66 66 + Printf.printf "Duration: %.2f seconds\n" duration; 67 67 + Printf.printf "Requests: %d total, %d successful, %d failed\n" 68 68 + stats.total_requests stats.successful stats.failed; 69 69 + Printf.printf "Throughput: %.2f req/s\n" rps; 70 70 + Printf.printf "\nLatency (ms):\n"; 71 71 + Printf.printf " avg: %.3f\n" avg; 72 72 + Printf.printf " p50: %.3f\n" p50; 73 73 + Printf.printf " p90: %.3f\n" p90; 74 74 + Printf.printf " p99: %.3f\n" p99; 75 75 + Printf.printf " p99.9: %.3f\n" p999 76 76 + end 77 77 + end 78 78 + 79 79 + module H1_benchmark = struct 80 80 + let worker ~sw ~net ~url ~stats ~stop_flag = 81 81 + let uri = Uri.of_string url in 82 82 + let host = Uri.host uri |> Option.value ~default:"localhost" in 83 83 + let port = Uri.port uri |> Option.value ~default:8080 in 84 84 + let path = Uri.path uri in 85 85 + let path = if path = "" then "/" else path in 86 86 + 87 87 + let request_line = 88 88 + Printf.sprintf 89 89 + "GET %s HTTP/1.1\r\nHost: %s\r\nConnection: keep-alive\r\n\r\n" path 90 90 + host 91 91 + in 92 92 + let request_bytes = Bytes.of_string request_line in 93 93 + let buf = Cstruct.create 4096 in 94 94 + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, port) in 95 95 + 96 96 + try 97 97 + let flow = Eio.Net.connect ~sw net addr in 98 98 + 99 99 + while not !stop_flag do 100 100 + let start = Unix.gettimeofday () in 101 101 + try 102 102 + Eio.Flow.write flow [ Cstruct.of_bytes request_bytes ]; 103 103 + let _ = Eio.Flow.single_read flow buf in 104 104 + let elapsed = (Unix.gettimeofday () -. start) *. 1000.0 in 105 105 + Stats.record_success stats elapsed 106 106 + with _ -> Stats.record_failure stats 107 107 + done; 108 108 + 109 109 + Eio.Flow.close flow 110 110 + with _ -> () 111 111 + 112 112 + let run ~net ~clock ~sw ~url ~concurrency ~duration ~json = 113 113 + if not json then begin 114 114 + Printf.printf "Benchmarking %s (HTTP/1.1)\n" url; 115 115 + Printf.printf "Concurrency: %d, Duration: %d seconds\n%!" concurrency 116 116 + duration 117 117 + end; 118 118 + 119 119 + let stats = Stats.create () in 120 120 + let stop_flag = ref false in 121 121 + 122 122 + for _ = 1 to concurrency do 123 123 + Eio.Fiber.fork ~sw (fun () -> worker ~sw ~net ~url ~stats ~stop_flag) 124 124 + done; 125 125 + 126 126 + Eio.Time.sleep clock (float_of_int duration); 127 127 + stop_flag := true; 128 128 + Eio.Time.sleep clock 0.1; 129 129 + 130 130 + Stats.report stats ~json ~protocol:"HTTP/1.1" 131 131 + end 132 132 + 133 133 + module Ws_benchmark = struct 134 134 + let worker ~sw ~net ~url ~stats ~stop_flag ~msg_size = 135 135 + let message = String.make msg_size 'x' in 136 136 + 137 137 + match Hcs.Websocket.connect ~sw ~net url with 138 138 + | Error e -> 139 139 + let err_msg = 140 140 + match e with 141 141 + | Hcs.Websocket.Connection_closed -> "Connection closed" 142 142 + | Hcs.Websocket.Protocol_error s -> "Protocol error: " ^ s 143 143 + | Hcs.Websocket.Io_error s -> "IO error: " ^ s 144 144 + in 145 145 + Printf.eprintf "WebSocket connect error: %s\n%!" err_msg 146 146 + | Ok ws -> 147 147 + while not !stop_flag do 148 148 + let start = Unix.gettimeofday () in 149 149 + match Hcs.Websocket.send_text ws message with 150 150 + | Error _ -> Stats.record_failure stats 151 151 + | Ok () -> ( 152 152 + match Hcs.Websocket.recv_message ws with 153 153 + | Error _ -> Stats.record_failure stats 154 154 + | Ok (_, _response) -> 155 155 + let elapsed = (Unix.gettimeofday () -. start) *. 1000.0 in 156 156 + Stats.record_success stats elapsed) 157 157 + done; 158 158 + Hcs.Websocket.close ws 159 159 + 160 160 + let run ~net ~clock ~sw ~url ~concurrency ~duration ~json ~msg_size = 161 161 + if not json then begin 162 162 + Printf.printf "Benchmarking %s (WebSocket)\n" url; 163 163 + Printf.printf 164 164 + "Concurrency: %d, Duration: %d seconds, Message size: %d\n%!" 165 165 + concurrency duration msg_size 166 166 + end; 167 167 + 168 168 + let stats = Stats.create () in 169 169 + let stop_flag = ref false in 170 170 + 171 171 + for _ = 1 to concurrency do 172 172 + Eio.Fiber.fork ~sw (fun () -> 173 173 + worker ~sw ~net ~url ~stats ~stop_flag ~msg_size) 174 174 + done; 175 175 + 176 176 + Eio.Time.sleep clock (float_of_int duration); 177 177 + stop_flag := true; 178 178 + Eio.Time.sleep clock 0.1; 179 179 + 180 180 + Stats.report stats ~json ~protocol:"WebSocket" 181 181 + end 182 182 + 183 183 + let run_benchmark protocol url concurrency duration json msg_size = 184 184 + Eio_main.run @@ fun env -> 185 185 + Eio.Switch.run @@ fun sw -> 186 186 + let net = Eio.Stdenv.net env in 187 187 + let clock = Eio.Stdenv.clock env in 188 188 + 189 189 + match protocol with 190 190 + | "h1" | "http1" | "http/1.1" -> 191 191 + H1_benchmark.run ~net ~clock ~sw ~url ~concurrency ~duration ~json 192 192 + | "h2" | "http2" | "http/2" | "h2c" -> 193 193 + Printf.eprintf 194 194 + "HTTP/2 benchmarks: use h2load from nghttp2\n\ 195 195 + Example: h2load -n 100000 -c %d -t 1 %s\n" 196 196 + concurrency url; 197 197 + exit 0 198 198 + | "ws" | "websocket" -> 199 199 + Ws_benchmark.run ~net ~clock ~sw ~url ~concurrency ~duration ~json 200 200 + ~msg_size 201 201 + | _ -> 202 202 + Printf.eprintf "Unknown protocol: %s (use h1, h2, or ws)\n" protocol; 203 203 + exit 1 204 204 + 205 205 + let command = 206 206 + Climate.Command.singleton 207 207 + ~doc: 208 208 + "HCS multi-protocol benchmark client (HTTP/1.1 native, WebSocket native, \ 209 209 + HTTP/2 via h2load)" 210 210 + @@ 211 211 + let open Climate.Arg_parser in 212 212 + let+ protocol = 213 213 + named_with_default [ "p"; "protocol" ] string ~default:"h1" 214 214 + ~doc: 215 215 + "Protocol to use: h1 (HTTP/1.1), h2 (HTTP/2 - prints h2load command), \ 216 216 + ws (WebSocket)" 217 217 + and+ url = named_req [ "u"; "url" ] string ~doc:"Target URL to benchmark" 218 218 + and+ concurrency = 219 219 + named_with_default [ "c"; "concurrency" ] int ~default:10 220 220 + ~doc:"Number of concurrent connections" 221 221 + and+ duration = 222 222 + named_with_default [ "d"; "duration" ] int ~default:10 223 223 + ~doc:"Test duration in seconds" 224 224 + and+ json = flag [ "json" ] ~doc:"Output results as JSON" 225 225 + and+ msg_size = 226 226 + named_with_default [ "m"; "msg-size" ] int ~default:32 227 227 + ~doc:"WebSocket message size in bytes" 228 228 + in 229 229 + 230 230 + run_benchmark protocol url concurrency duration json msg_size 231 231 + 232 232 + let () = Climate.Command.run command

+4

bench/client/dune

reviewed

··· 1 1 + (executable 2 2 + (name bench_client) 3 3 + (public_name bench-client) 4 4 + (libraries hcs eio_main uri climate unix cstruct tls-eio))

+38

bench/dream/bench_server_dream.ml

reviewed

··· 1 1 + type json_message = { message : string } 2 2 + 3 3 + let serialize_json () = 4 4 + let msg = { message = "Hello, World!" } in 5 5 + let json = `Assoc [ ("message", `String msg.message) ] in 6 6 + Yojson.Basic.to_string json 7 7 + 8 8 + let plaintext_body = "Hello, World!" 9 9 + 10 10 + let plaintext_handler _req = 11 11 + Dream.respond 12 12 + ~headers:[ ("Content-Type", "text/plain"); ("Server", "dream") ] 13 13 + plaintext_body 14 14 + 15 15 + let json_handler _req = 16 16 + let body = serialize_json () in 17 17 + Dream.respond 18 18 + ~headers:[ ("Content-Type", "application/json"); ("Server", "dream") ] 19 19 + body 20 20 + 21 21 + let command = 22 22 + Climate.Command.singleton ~doc:"TechEmpower benchmark server using Dream" 23 23 + @@ 24 24 + let open Climate.Arg_parser in 25 25 + let+ port = 26 26 + named_with_default [ "p"; "port" ] int ~default:8080 27 27 + ~doc:"Port to listen on" 28 28 + in 29 29 + 30 30 + Printf.printf "Starting Dream server on port %d\n%!" port; 31 31 + Dream.run ~port ~interface:"0.0.0.0" 32 32 + @@ Dream.router 33 33 + [ 34 34 + Dream.get "/plaintext" plaintext_handler; 35 35 + Dream.get "/json" json_handler; 36 36 + ] 37 37 + 38 38 + let () = Climate.Command.run command

+4

bench/dream/dune

reviewed

··· 1 1 + (executable 2 2 + (name bench_server_dream) 3 3 + (public_name bench-dream) 4 4 + (libraries dream yojson climate))

+13

bench/fasthttp/go.mod

reviewed

··· 1 1 + module bench-fasthttp 2 2 + 3 3 + go 1.21 4 4 + 5 5 + require github.com/valyala/fasthttp v1.51.0 6 6 + 7 7 + require ( 8 8 + github.com/andybalholm/brotli v1.0.5 // indirect 9 9 + github.com/klauspost/compress v1.17.0 // indirect 10 10 + github.com/valyala/bytebufferpool v1.0.0 // indirect 11 11 + github.com/valyala/tcplisten v1.0.0 // indirect 12 12 + golang.org/x/sys v0.13.0 // indirect 13 13 + )

+12

bench/fasthttp/go.sum

reviewed

··· 1 1 + github.com/andybalholm/brotli v1.0.5 h1:8uQZIdzKmjc/iuPu7O2ioW48L81FgatrcpfFmiq/cCs= 2 2 + github.com/andybalholm/brotli v1.0.5/go.mod h1:fO7iG3H7G2nSZ7m0zPUDn85XEX2GTukHGRSepvi9Eig= 3 3 + github.com/klauspost/compress v1.17.0 h1:Rnbp4K9EjcDuVuHtd0dgA4qNuv9yKDYKK1ulpJwgrqM= 4 4 + github.com/klauspost/compress v1.17.0/go.mod h1:ntbaceVETuRiXiv4DpjP66DpAtAGkEQskQzEyD//IeE= 5 5 + github.com/valyala/bytebufferpool v1.0.0 h1:GqA5TC/0021Y/b9FG4Oi9Mr3q7XYx6KllzawFIhcdPw= 6 6 + github.com/valyala/bytebufferpool v1.0.0/go.mod h1:6bBcMArwyJ5K/AmCkWv1jt77kVWyCJ6HpOuEn7z0Csc= 7 7 + github.com/valyala/fasthttp v1.51.0 h1:8b30A5JlZ6C7AS81RsWjYMQmrZG6feChmgAolCl1SqA= 8 8 + github.com/valyala/fasthttp v1.51.0/go.mod h1:oI2XroL+lI7vdXyYoQk03bXBThfFl2cVdIA3Xl7cH8g= 9 9 + github.com/valyala/tcplisten v1.0.0 h1:rBHj/Xf+E1tRGZyWIWwJDiRY0zc1Js+CV5DqwacVSA8= 10 10 + github.com/valyala/tcplisten v1.0.0/go.mod h1:T0xQ8SeCZGxckz9qRXTfG43PvQ/mcWh7FwZEA7Ioqkc= 11 11 + golang.org/x/sys v0.13.0 h1:Af8nKPmuFypiUBjVoU9V20FiaFXOcuZI21p0ycVYYGE= 12 12 + golang.org/x/sys v0.13.0/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg=

+128

bench/fasthttp/main.go

reviewed

··· 1 1 + // TechEmpower-style benchmark server using fasthttp 2 2 + // 3 3 + // Implements: 4 4 + // - /plaintext - Returns "Hello, World!" as text/plain 5 5 + // - /json - Returns {"message":"Hello, World!"} as application/json 6 6 + // 7 7 + // Supports HTTP/1.1 with prefork for CPU scaling. 8 8 + // Usage: ./bench-fasthttp -port 8080 -prefork -threads 4 9 9 + 10 10 + package main 11 11 + 12 12 + import ( 13 13 + "encoding/json" 14 14 + "flag" 15 15 + "fmt" 16 16 + "log" 17 17 + "runtime" 18 18 + "sync" 19 19 + "sync/atomic" 20 20 + "time" 21 21 + 22 22 + "github.com/valyala/fasthttp" 23 23 + "github.com/valyala/fasthttp/prefork" 24 24 + ) 25 25 + 26 26 + const ( 27 27 + helloWorldStr = "Hello, World!" 28 28 + contentTypeJSON = "application/json" 29 29 + contentTypeText = "text/plain" 30 30 + serverName = "fasthttp" 31 31 + ) 32 32 + 33 33 + // Message for JSON response 34 34 + type Message struct { 35 35 + Message string `json:"message"` 36 36 + } 37 37 + 38 38 + var ( 39 39 + port int 40 40 + threads int 41 41 + usePrefork bool 42 42 + ) 43 43 + 44 44 + var ( 45 45 + dateCacheMu sync.RWMutex 46 46 + dateCacheTime int64 47 47 + dateCacheVal []byte 48 48 + ) 49 49 + 50 50 + func getCachedDate() []byte { 51 51 + now := time.Now().Unix() 52 52 + cached := atomic.LoadInt64(&dateCacheTime) 53 53 + 54 54 + if now != cached { 55 55 + dateCacheMu.Lock() 56 56 + if atomic.LoadInt64(&dateCacheTime) != now { 57 57 + dateCacheVal = []byte(time.Now().UTC().Format(time.RFC1123)) 58 58 + atomic.StoreInt64(&dateCacheTime, now) 59 59 + } 60 60 + dateCacheMu.Unlock() 61 61 + } 62 62 + 63 63 + dateCacheMu.RLock() 64 64 + defer dateCacheMu.RUnlock() 65 65 + return dateCacheVal 66 66 + } 67 67 + 68 68 + func init() { 69 69 + flag.IntVar(&port, "port", 8080, "Port to listen on") 70 70 + flag.IntVar(&threads, "threads", 1, "Number of threads (GOMAXPROCS)") 71 71 + flag.BoolVar(&usePrefork, "prefork", false, "Use prefork mode for multi-process scaling") 72 72 + flag.Parse() 73 73 + } 74 74 + 75 75 + func main() { 76 76 + // Set GOMAXPROCS 77 77 + runtime.GOMAXPROCS(threads) 78 78 + 79 79 + addr := fmt.Sprintf(":%d", port) 80 80 + 81 81 + server := &fasthttp.Server{ 82 82 + Name: serverName, 83 83 + Handler: router, 84 84 + DisableHeaderNamesNormalizing: true, 85 85 + } 86 86 + 87 87 + fmt.Printf("Starting fasthttp server on port %d with %d threads (prefork=%v)\n", port, threads, usePrefork) 88 88 + 89 89 + var err error 90 90 + if usePrefork { 91 91 + err = prefork.New(server).ListenAndServe(addr) 92 92 + } else { 93 93 + err = server.ListenAndServe(addr) 94 94 + } 95 95 + 96 96 + if err != nil { 97 97 + log.Fatalf("Error starting server: %v", err) 98 98 + } 99 99 + } 100 100 + 101 101 + func router(ctx *fasthttp.RequestCtx) { 102 102 + path := string(ctx.Path()) 103 103 + switch path { 104 104 + case "/plaintext": 105 105 + plaintext(ctx) 106 106 + case "/json": 107 107 + jsonHandler(ctx) 108 108 + default: 109 109 + ctx.Error(fasthttp.StatusMessage(fasthttp.StatusNotFound), fasthttp.StatusNotFound) 110 110 + } 111 111 + } 112 112 + 113 113 + func plaintext(ctx *fasthttp.RequestCtx) { 114 114 + ctx.Response.Header.SetServer(serverName) 115 115 + ctx.Response.Header.SetBytesV("Date", getCachedDate()) 116 116 + ctx.Response.Header.SetContentType(contentTypeText) 117 117 + ctx.Response.SetBodyString(helloWorldStr) 118 118 + } 119 119 + 120 120 + func jsonHandler(ctx *fasthttp.RequestCtx) { 121 121 + msg := Message{Message: helloWorldStr} 122 122 + data, _ := json.Marshal(msg) 123 123 + 124 124 + ctx.Response.Header.SetServer(serverName) 125 125 + ctx.Response.Header.SetBytesV("Date", getCachedDate()) 126 126 + ctx.Response.Header.SetContentType(contentTypeJSON) 127 127 + ctx.Response.SetBody(data) 128 128 + }

+75

bench/hcs/bench_server.ml

reviewed

··· 1 1 + type json_message = { message : string } 2 2 + 3 3 + let serialize_json () = 4 4 + let msg = { message = "Hello, World!" } in 5 5 + let json = `Assoc [ ("message", `String msg.message) ] in 6 6 + Yojson.Basic.to_string json 7 7 + 8 8 + let plaintext_body = "Hello, World!" 9 9 + 10 10 + let plaintext_body_bstr = 11 11 + Bigstringaf.of_string ~off:0 12 12 + ~len:(String.length plaintext_body) 13 13 + plaintext_body 14 14 + 15 15 + let plaintext_headers = 16 16 + Hcs.H1_server.make_h1_headers 17 17 + [ 18 18 + ("Content-Type", "text/plain"); ("Server", "hcs"); ("Content-Length", "13"); 19 19 + ] 20 20 + 21 21 + let plaintext_h1_response = 22 22 + Hcs.H1_server.make_h1_response ~status:`OK plaintext_headers 23 23 + 24 24 + let notfound_body_bstr = Bigstringaf.of_string ~off:0 ~len:9 "Not Found" 25 25 + 26 26 + let notfound_headers = 27 27 + Hcs.H1_server.make_h1_headers [ ("Server", "hcs"); ("Content-Length", "9") ] 28 28 + 29 29 + let notfound_h1_response = 30 30 + Hcs.H1_server.make_h1_response ~status:`Not_found notfound_headers 31 31 + 32 32 + let handler (req : Hcs.H1_server.request) : Hcs.H1_server.response = 33 33 + match req.target with 34 34 + | "/plaintext" -> 35 35 + Hcs.H1_server.respond_prebuilt plaintext_h1_response plaintext_body_bstr 36 36 + | "/json" -> 37 37 + let body = serialize_json () in 38 38 + Hcs.H1_server.respond ~status:`OK 39 39 + ~headers:[ ("Content-Type", "application/json"); ("Server", "hcs") ] 40 40 + body 41 41 + | _ -> Hcs.H1_server.respond_prebuilt notfound_h1_response notfound_body_bstr 42 42 + 43 43 + let command = 44 44 + Climate.Command.singleton ~doc:"TechEmpower benchmark server using HCS" 45 45 + @@ 46 46 + let open Climate.Arg_parser in 47 47 + let+ port = 48 48 + named_with_default [ "p"; "port" ] int ~default:8080 49 49 + ~doc:"Port to listen on" 50 50 + and+ domains = 51 51 + named_with_default [ "d"; "domains" ] int ~default:1 52 52 + ~doc:"Number of domains (CPUs) to use" 53 53 + in 54 54 + 55 55 + Printf.printf "Starting HCS server on port %d with %d domains\n%!" port 56 56 + domains; 57 57 + 58 58 + Eio_main.run @@ fun env -> 59 59 + Eio.Switch.run @@ fun sw -> 60 60 + let config = 61 61 + Hcs.H1_server. 62 62 + { 63 63 + default_config with 64 64 + port; 65 65 + domain_count = domains; 66 66 + backlog = 4096; 67 67 + max_connections = 100000; 68 68 + buffer_size = 16384; 69 69 + } 70 70 + in 71 71 + Hcs.H1_server.run_parallel ~sw ~net:(Eio.Stdenv.net env) 72 72 + ~domain_mgr:(Eio.Stdenv.domain_mgr env) 73 73 + ~config handler 74 74 + 75 75 + let () = Climate.Command.run command

+62

bench/hcs/bench_server_fast.ml

reviewed

··· 1 1 + type json_message = { message : string } 2 2 + 3 3 + let serialize_json () = 4 4 + let msg = { message = "Hello, World!" } in 5 5 + let json = `Assoc [ ("message", `String msg.message) ] in 6 6 + Yojson.Basic.to_string json 7 7 + 8 8 + let plaintext_response = 9 9 + Hcs.Server.Prebuilt.create ~status:`OK 10 10 + ~headers:[ ("content-type", "text/plain"); ("server", "hcs") ] 11 11 + "Hello, World!" 12 12 + 13 13 + let notfound_response = 14 14 + Hcs.Server.Prebuilt.create ~status:`Not_found 15 15 + ~headers:[ ("server", "hcs") ] 16 16 + "Not Found" 17 17 + 18 18 + let handler (req : Hcs.Server.request) : Hcs.Server.response = 19 19 + match req.target with 20 20 + | "/plaintext" -> Hcs.Server.respond_prebuilt plaintext_response 21 21 + | "/json" -> 22 22 + let body = serialize_json () in 23 23 + Hcs.Server.respond ~status:`OK 24 24 + ~headers:[ ("content-type", "application/json"); ("server", "hcs") ] 25 25 + body 26 26 + | _ -> Hcs.Server.respond_prebuilt notfound_response 27 27 + 28 28 + let command = 29 29 + Climate.Command.singleton 30 30 + ~doc:"TechEmpower benchmark server using Server (Http1_only mode)" 31 31 + @@ 32 32 + let open Climate.Arg_parser in 33 33 + let+ port = 34 34 + named_with_default [ "p"; "port" ] int ~default:8080 35 35 + ~doc:"Port to listen on" 36 36 + and+ domains = 37 37 + named_with_default [ "d"; "domains" ] int ~default:1 38 38 + ~doc:"Number of domains (CPUs) to use" 39 39 + in 40 40 + 41 41 + Printf.printf 42 42 + "Starting HCS Server (Http1_only mode) on port %d with %d domains\n%!" port 43 43 + domains; 44 44 + 45 45 + Eio_main.run @@ fun env -> 46 46 + Eio.Switch.run @@ fun sw -> 47 47 + let config = 48 48 + Hcs.Server. 49 49 + { 50 50 + default_config with 51 51 + port; 52 52 + domain_count = domains; 53 53 + protocol = Http1_only; 54 54 + backlog = 4096; 55 55 + max_connections = 100000; 56 56 + } 57 57 + in 58 58 + Hcs.Server.run_parallel ~sw ~net:(Eio.Stdenv.net env) 59 59 + ~domain_mgr:(Eio.Stdenv.domain_mgr env) 60 60 + ~config handler 61 61 + 62 62 + let () = Climate.Command.run command

+87

bench/hcs/bench_server_h2.ml

reviewed

··· 1 1 + (** HCS HTTP/2 Benchmark Server 2 2 + 3 3 + TechEmpower-style benchmark server using HCS H2_server for HTTP/2 h2c 4 4 + (cleartext). Supports multi-domain (multi-CPU) operation via SO_REUSEPORT. 5 5 + *) 6 6 + 7 7 + (* TechEmpower-compliant JSON message type *) 8 8 + type json_message = { message : string } 9 9 + 10 10 + (* Serialize JSON per-request as required by TechEmpower spec *) 11 11 + let serialize_json () = 12 12 + let msg = { message = "Hello, World!" } in 13 13 + let json = `Assoc [ ("message", `String msg.message) ] in 14 14 + Yojson.Basic.to_string json 15 15 + 16 16 + (* Pre-built plaintext response *) 17 17 + let plaintext_body = Bigstringaf.of_string ~off:0 ~len:13 "Hello, World!" 18 18 + 19 19 + let plaintext_headers = 20 20 + Hcs.H2_server.make_h2_headers 21 21 + [ 22 22 + ("content-type", "text/plain"); 23 23 + ("server", "hcs-h2"); 24 24 + ("content-length", "13"); 25 25 + ] 26 26 + 27 27 + let plaintext_response = 28 28 + Hcs.H2_server.make_h2_response ~status:`OK plaintext_headers 29 29 + 30 30 + (* Pre-built not found response *) 31 31 + let notfound_body = Bigstringaf.of_string ~off:0 ~len:9 "Not Found" 32 32 + 33 33 + let notfound_headers = 34 34 + Hcs.H2_server.make_h2_headers 35 35 + [ ("server", "hcs-h2"); ("content-length", "9") ] 36 36 + 37 37 + let notfound_response = 38 38 + Hcs.H2_server.make_h2_response ~status:`Not_found notfound_headers 39 39 + 40 40 + let handler (req : Hcs.H2_server.request) : Hcs.H2_server.response = 41 41 + match req.target with 42 42 + | "/plaintext" -> 43 43 + Hcs.H2_server.respond_prebuilt plaintext_response plaintext_body 44 44 + | "/json" -> 45 45 + (* TechEmpower requires JSON serialization per-request *) 46 46 + let body = serialize_json () in 47 47 + Hcs.H2_server.respond_opt ~status:`OK 48 48 + ~headers:[ ("content-type", "application/json"); ("server", "hcs-h2") ] 49 49 + body 50 50 + | _ -> Hcs.H2_server.respond_prebuilt notfound_response notfound_body 51 51 + 52 52 + let command = 53 53 + Climate.Command.singleton 54 54 + ~doc:"TechEmpower benchmark server using HCS HTTP/2 (h2c)" 55 55 + @@ 56 56 + let open Climate.Arg_parser in 57 57 + let+ port = 58 58 + named_with_default [ "p"; "port" ] int ~default:8080 59 59 + ~doc:"Port to listen on" 60 60 + and+ domains = 61 61 + named_with_default [ "d"; "domains" ] int ~default:1 62 62 + ~doc:"Number of domains (CPUs) to use" 63 63 + in 64 64 + 65 65 + Printf.printf 66 66 + "Starting HCS HTTP/2 (h2c) server on port %d with %d domains\n%!" port 67 67 + domains; 68 68 + 69 69 + Eio_main.run @@ fun env -> 70 70 + Eio.Switch.run @@ fun sw -> 71 71 + let config = 72 72 + Hcs.H1_server. 73 73 + { 74 74 + default_config with 75 75 + port; 76 76 + domain_count = domains; 77 77 + backlog = 4096; 78 78 + max_connections = 100000; 79 79 + reuse_port = true; 80 80 + tcp_nodelay = true; 81 81 + } 82 82 + in 83 83 + Hcs.H2_server.run_parallel ~sw ~net:(Eio.Stdenv.net env) 84 84 + ~domain_mgr:(Eio.Stdenv.domain_mgr env) 85 85 + ~config handler 86 86 + 87 87 + let () = Climate.Command.run command

+83

bench/hcs/bench_server_unified.ml

reviewed

··· 1 1 + type json_message = { message : string } 2 2 + 3 3 + let serialize_json () = 4 4 + let msg = { message = "Hello, World!" } in 5 5 + let json = `Assoc [ ("message", `String msg.message) ] in 6 6 + Yojson.Basic.to_string json 7 7 + 8 8 + let plaintext_body = "Hello, World!" 9 9 + 10 10 + let handler (req : Hcs.Server.request) : Hcs.Server.response = 11 11 + match req.target with 12 12 + | "/plaintext" -> 13 13 + Hcs.Server.respond ~status:`OK 14 14 + ~headers:[ ("content-type", "text/plain"); ("server", "hcs-unified") ] 15 15 + plaintext_body 16 16 + | "/json" -> 17 17 + let body = serialize_json () in 18 18 + Hcs.Server.respond ~status:`OK 19 19 + ~headers: 20 20 + [ ("content-type", "application/json"); ("server", "hcs-unified") ] 21 21 + body 22 22 + | _ -> 23 23 + Hcs.Server.respond ~status:`Not_found 24 24 + ~headers:[ ("server", "hcs-unified") ] 25 25 + "Not Found" 26 26 + 27 27 + let ws_handler (ws : Hcs.Websocket.t) = 28 28 + let rec loop () = 29 29 + match Hcs.Websocket.recv_message ws with 30 30 + | Ok (Hcs.Websocket.Opcode.Text, msg) -> ( 31 31 + match Hcs.Websocket.send_text ws msg with 32 32 + | Ok () -> loop () 33 33 + | Error _ -> ()) 34 34 + | Ok (Hcs.Websocket.Opcode.Binary, msg) -> ( 35 35 + match Hcs.Websocket.send_binary ws msg with 36 36 + | Ok () -> loop () 37 37 + | Error _ -> ()) 38 38 + | Ok _ -> loop () 39 39 + | Error Hcs.Websocket.Connection_closed -> () 40 40 + | Error _ -> () 41 41 + in 42 42 + loop () 43 43 + 44 44 + let command = 45 45 + Climate.Command.singleton 46 46 + ~doc:"Unified benchmark server (HTTP/1.1 + HTTP/2 h2c + WebSocket)" 47 47 + @@ 48 48 + let open Climate.Arg_parser in 49 49 + let+ port = 50 50 + named_with_default [ "p"; "port" ] int ~default:8080 51 51 + ~doc:"Port to listen on" 52 52 + and+ domains = 53 53 + named_with_default [ "d"; "domains" ] int ~default:1 54 54 + ~doc:"Number of domains (CPUs) to use" 55 55 + in 56 56 + 57 57 + Printf.printf 58 58 + "Starting HCS Server (Auto_websocket mode) on port %d with %d domains\n%!" 59 59 + port domains; 60 60 + Printf.printf "Supports: HTTP/1.1, HTTP/2 h2c, WebSocket\n%!"; 61 61 + Printf.printf "Endpoints:\n%!"; 62 62 + Printf.printf " GET /plaintext - Plain text response\n%!"; 63 63 + Printf.printf " GET /json - JSON response\n%!"; 64 64 + Printf.printf " WS / - WebSocket echo\n%!"; 65 65 + 66 66 + Eio_main.run @@ fun env -> 67 67 + Eio.Switch.run @@ fun sw -> 68 68 + let config = 69 69 + Hcs.Server. 70 70 + { 71 71 + default_config with 72 72 + port; 73 73 + domain_count = domains; 74 74 + protocol = Auto_websocket; 75 75 + backlog = 4096; 76 76 + max_connections = 100000; 77 77 + } 78 78 + in 79 79 + Hcs.Server.run_parallel ~sw ~net:(Eio.Stdenv.net env) 80 80 + ~domain_mgr:(Eio.Stdenv.domain_mgr env) 81 81 + ~config ~ws_handler handler 82 82 + 83 83 + let () = Climate.Command.run command

+19

bench/hcs/dune

reviewed

··· 1 1 + (executable 2 2 + (name bench_server) 3 3 + (public_name bench-hcs) 4 4 + (libraries hcs eio_main yojson climate)) 5 5 + 6 6 + (executable 7 7 + (name bench_server_fast) 8 8 + (public_name bench-hcs-fast) 9 9 + (libraries hcs eio_main yojson climate)) 10 10 + 11 11 + (executable 12 12 + (name bench_server_h2) 13 13 + (public_name bench-hcs-h2) 14 14 + (libraries hcs eio_main yojson climate bigstringaf)) 15 15 + 16 16 + (executable 17 17 + (name bench_server_unified) 18 18 + (public_name bench-hcs-unified) 19 19 + (libraries hcs eio_main yojson climate bigstringaf))

+1012

bench/hyper/Cargo.lock

reviewed

··· 1 1 + # This file is automatically @generated by Cargo. 2 2 + # It is not intended for manual editing. 3 3 + version = 4 4 4 + 5 5 + [[package]] 6 6 + name = "anstream" 7 7 + version = "0.6.21" 8 8 + source = "registry+https://github.com/rust-lang/crates.io-index" 9 9 + checksum = "43d5b281e737544384e969a5ccad3f1cdd24b48086a0fc1b2a5262a26b8f4f4a" 10 10 + dependencies = [ 11 11 + "anstyle", 12 12 + "anstyle-parse", 13 13 + "anstyle-query", 14 14 + "anstyle-wincon", 15 15 + "colorchoice", 16 16 + "is_terminal_polyfill", 17 17 + "utf8parse", 18 18 + ] 19 19 + 20 20 + [[package]] 21 21 + name = "anstyle" 22 22 + version = "1.0.13" 23 23 + source = "registry+https://github.com/rust-lang/crates.io-index" 24 24 + checksum = "5192cca8006f1fd4f7237516f40fa183bb07f8fbdfedaa0036de5ea9b0b45e78" 25 25 + 26 26 + [[package]] 27 27 + name = "anstyle-parse" 28 28 + version = "0.2.7" 29 29 + source = "registry+https://github.com/rust-lang/crates.io-index" 30 30 + checksum = "4e7644824f0aa2c7b9384579234ef10eb7efb6a0deb83f9630a49594dd9c15c2" 31 31 + dependencies = [ 32 32 + "utf8parse", 33 33 + ] 34 34 + 35 35 + [[package]] 36 36 + name = "anstyle-query" 37 37 + version = "1.1.5" 38 38 + source = "registry+https://github.com/rust-lang/crates.io-index" 39 39 + checksum = "40c48f72fd53cd289104fc64099abca73db4166ad86ea0b4341abe65af83dadc" 40 40 + dependencies = [ 41 41 + "windows-sys 0.61.2", 42 42 + ] 43 43 + 44 44 + [[package]] 45 45 + name = "anstyle-wincon" 46 46 + version = "3.0.11" 47 47 + source = "registry+https://github.com/rust-lang/crates.io-index" 48 48 + checksum = "291e6a250ff86cd4a820112fb8898808a366d8f9f58ce16d1f538353ad55747d" 49 49 + dependencies = [ 50 50 + "anstyle", 51 51 + "once_cell_polyfill", 52 52 + "windows-sys 0.61.2", 53 53 + ] 54 54 + 55 55 + [[package]] 56 56 + name = "atomic-waker" 57 57 + version = "1.1.2" 58 58 + source = "registry+https://github.com/rust-lang/crates.io-index" 59 59 + checksum = "1505bd5d3d116872e7271a6d4e16d81d0c8570876c8de68093a09ac269d8aac0" 60 60 + 61 61 + [[package]] 62 62 + name = "base64" 63 63 + version = "0.21.7" 64 64 + source = "registry+https://github.com/rust-lang/crates.io-index" 65 65 + checksum = "9d297deb1925b89f2ccc13d7635fa0714f12c87adce1c75356b39ca9b7178567" 66 66 + 67 67 + [[package]] 68 68 + name = "bench-hyper" 69 69 + version = "0.1.0" 70 70 + dependencies = [ 71 71 + "clap", 72 72 + "fastwebsockets", 73 73 + "http-body-util", 74 74 + "httpdate", 75 75 + "hyper", 76 76 + "hyper-util", 77 77 + "serde", 78 78 + "serde_json", 79 79 + "socket2 0.5.10", 80 80 + "tokio", 81 81 + ] 82 82 + 83 83 + [[package]] 84 84 + name = "bitflags" 85 85 + version = "2.10.0" 86 86 + source = "registry+https://github.com/rust-lang/crates.io-index" 87 87 + checksum = "812e12b5285cc515a9c72a5c1d3b6d46a19dac5acfef5265968c166106e31dd3" 88 88 + 89 89 + [[package]] 90 90 + name = "block-buffer" 91 91 + version = "0.10.4" 92 92 + source = "registry+https://github.com/rust-lang/crates.io-index" 93 93 + checksum = "3078c7629b62d3f0439517fa394996acacc5cbc91c5a20d8c658e77abd503a71" 94 94 + dependencies = [ 95 95 + "generic-array", 96 96 + ] 97 97 + 98 98 + [[package]] 99 99 + name = "bytes" 100 100 + version = "1.11.0" 101 101 + source = "registry+https://github.com/rust-lang/crates.io-index" 102 102 + checksum = "b35204fbdc0b3f4446b89fc1ac2cf84a8a68971995d0bf2e925ec7cd960f9cb3" 103 103 + 104 104 + [[package]] 105 105 + name = "cfg-if" 106 106 + version = "1.0.4" 107 107 + source = "registry+https://github.com/rust-lang/crates.io-index" 108 108 + checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801" 109 109 + 110 110 + [[package]] 111 111 + name = "clap" 112 112 + version = "4.5.53" 113 113 + source = "registry+https://github.com/rust-lang/crates.io-index" 114 114 + checksum = "c9e340e012a1bf4935f5282ed1436d1489548e8f72308207ea5df0e23d2d03f8" 115 115 + dependencies = [ 116 116 + "clap_builder", 117 117 + "clap_derive", 118 118 + ] 119 119 + 120 120 + [[package]] 121 121 + name = "clap_builder" 122 122 + version = "4.5.53" 123 123 + source = "registry+https://github.com/rust-lang/crates.io-index" 124 124 + checksum = "d76b5d13eaa18c901fd2f7fca939fefe3a0727a953561fefdf3b2922b8569d00" 125 125 + dependencies = [ 126 126 + "anstream", 127 127 + "anstyle", 128 128 + "clap_lex", 129 129 + "strsim", 130 130 + ] 131 131 + 132 132 + [[package]] 133 133 + name = "clap_derive" 134 134 + version = "4.5.49" 135 135 + source = "registry+https://github.com/rust-lang/crates.io-index" 136 136 + checksum = "2a0b5487afeab2deb2ff4e03a807ad1a03ac532ff5a2cee5d86884440c7f7671" 137 137 + dependencies = [ 138 138 + "heck", 139 139 + "proc-macro2", 140 140 + "quote", 141 141 + "syn", 142 142 + ] 143 143 + 144 144 + [[package]] 145 145 + name = "clap_lex" 146 146 + version = "0.7.6" 147 147 + source = "registry+https://github.com/rust-lang/crates.io-index" 148 148 + checksum = "a1d728cc89cf3aee9ff92b05e62b19ee65a02b5702cff7d5a377e32c6ae29d8d" 149 149 + 150 150 + [[package]] 151 151 + name = "colorchoice" 152 152 + version = "1.0.4" 153 153 + source = "registry+https://github.com/rust-lang/crates.io-index" 154 154 + checksum = "b05b61dc5112cbb17e4b6cd61790d9845d13888356391624cbe7e41efeac1e75" 155 155 + 156 156 + [[package]] 157 157 + name = "cpufeatures" 158 158 + version = "0.2.17" 159 159 + source = "registry+https://github.com/rust-lang/crates.io-index" 160 160 + checksum = "59ed5838eebb26a2bb2e58f6d5b5316989ae9d08bab10e0e6d103e656d1b0280" 161 161 + dependencies = [ 162 162 + "libc", 163 163 + ] 164 164 + 165 165 + [[package]] 166 166 + name = "crypto-common" 167 167 + version = "0.1.7" 168 168 + source = "registry+https://github.com/rust-lang/crates.io-index" 169 169 + checksum = "78c8292055d1c1df0cce5d180393dc8cce0abec0a7102adb6c7b1eef6016d60a" 170 170 + dependencies = [ 171 171 + "generic-array", 172 172 + "typenum", 173 173 + ] 174 174 + 175 175 + [[package]] 176 176 + name = "digest" 177 177 + version = "0.10.7" 178 178 + source = "registry+https://github.com/rust-lang/crates.io-index" 179 179 + checksum = "9ed9a281f7bc9b7576e61468ba615a66a5c8cfdff42420a70aa82701a3b1e292" 180 180 + dependencies = [ 181 181 + "block-buffer", 182 182 + "crypto-common", 183 183 + ] 184 184 + 185 185 + [[package]] 186 186 + name = "equivalent" 187 187 + version = "1.0.2" 188 188 + source = "registry+https://github.com/rust-lang/crates.io-index" 189 189 + checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f" 190 190 + 191 191 + [[package]] 192 192 + name = "errno" 193 193 + version = "0.3.14" 194 194 + source = "registry+https://github.com/rust-lang/crates.io-index" 195 195 + checksum = "39cab71617ae0d63f51a36d69f866391735b51691dbda63cf6f96d042b63efeb" 196 196 + dependencies = [ 197 197 + "libc", 198 198 + "windows-sys 0.61.2", 199 199 + ] 200 200 + 201 201 + [[package]] 202 202 + name = "fastwebsockets" 203 203 + version = "0.8.0" 204 204 + source = "registry+https://github.com/rust-lang/crates.io-index" 205 205 + checksum = "26da0c7b5cef45c521a6f9cdfffdfeb6c9f5804fbac332deb5ae254634c7a6be" 206 206 + dependencies = [ 207 207 + "base64", 208 208 + "bytes", 209 209 + "http-body-util", 210 210 + "hyper", 211 211 + "hyper-util", 212 212 + "pin-project", 213 213 + "rand", 214 214 + "sha1", 215 215 + "simdutf8", 216 216 + "thiserror", 217 217 + "tokio", 218 218 + "utf-8", 219 219 + ] 220 220 + 221 221 + [[package]] 222 222 + name = "fnv" 223 223 + version = "1.0.7" 224 224 + source = "registry+https://github.com/rust-lang/crates.io-index" 225 225 + checksum = "3f9eec918d3f24069decb9af1554cad7c880e2da24a9afd88aca000531ab82c1" 226 226 + 227 227 + [[package]] 228 228 + name = "futures-channel" 229 229 + version = "0.3.31" 230 230 + source = "registry+https://github.com/rust-lang/crates.io-index" 231 231 + checksum = "2dff15bf788c671c1934e366d07e30c1814a8ef514e1af724a602e8a2fbe1b10" 232 232 + dependencies = [ 233 233 + "futures-core", 234 234 + ] 235 235 + 236 236 + [[package]] 237 237 + name = "futures-core" 238 238 + version = "0.3.31" 239 239 + source = "registry+https://github.com/rust-lang/crates.io-index" 240 240 + checksum = "05f29059c0c2090612e8d742178b0580d2dc940c837851ad723096f87af6663e" 241 241 + 242 242 + [[package]] 243 243 + name = "futures-sink" 244 244 + version = "0.3.31" 245 245 + source = "registry+https://github.com/rust-lang/crates.io-index" 246 246 + checksum = "e575fab7d1e0dcb8d0c7bcf9a63ee213816ab51902e6d244a95819acacf1d4f7" 247 247 + 248 248 + [[package]] 249 249 + name = "generic-array" 250 250 + version = "0.14.7" 251 251 + source = "registry+https://github.com/rust-lang/crates.io-index" 252 252 + checksum = "85649ca51fd72272d7821adaf274ad91c288277713d9c18820d8499a7ff69e9a" 253 253 + dependencies = [ 254 254 + "typenum", 255 255 + "version_check", 256 256 + ] 257 257 + 258 258 + [[package]] 259 259 + name = "getrandom" 260 260 + version = "0.2.16" 261 261 + source = "registry+https://github.com/rust-lang/crates.io-index" 262 262 + checksum = "335ff9f135e4384c8150d6f27c6daed433577f86b4750418338c01a1a2528592" 263 263 + dependencies = [ 264 264 + "cfg-if", 265 265 + "libc", 266 266 + "wasi", 267 267 + ] 268 268 + 269 269 + [[package]] 270 270 + name = "h2" 271 271 + version = "0.4.12" 272 272 + source = "registry+https://github.com/rust-lang/crates.io-index" 273 273 + checksum = "f3c0b69cfcb4e1b9f1bf2f53f95f766e4661169728ec61cd3fe5a0166f2d1386" 274 274 + dependencies = [ 275 275 + "atomic-waker", 276 276 + "bytes", 277 277 + "fnv", 278 278 + "futures-core", 279 279 + "futures-sink", 280 280 + "http", 281 281 + "indexmap", 282 282 + "slab", 283 283 + "tokio", 284 284 + "tokio-util", 285 285 + "tracing", 286 286 + ] 287 287 + 288 288 + [[package]] 289 289 + name = "hashbrown" 290 290 + version = "0.16.1" 291 291 + source = "registry+https://github.com/rust-lang/crates.io-index" 292 292 + checksum = "841d1cc9bed7f9236f321df977030373f4a4163ae1a7dbfe1a51a2c1a51d9100" 293 293 + 294 294 + [[package]] 295 295 + name = "heck" 296 296 + version = "0.5.0" 297 297 + source = "registry+https://github.com/rust-lang/crates.io-index" 298 298 + checksum = "2304e00983f87ffb38b55b444b5e3b60a884b5d30c0fca7d82fe33449bbe55ea" 299 299 + 300 300 + [[package]] 301 301 + name = "http" 302 302 + version = "1.4.0" 303 303 + source = "registry+https://github.com/rust-lang/crates.io-index" 304 304 + checksum = "e3ba2a386d7f85a81f119ad7498ebe444d2e22c2af0b86b069416ace48b3311a" 305 305 + dependencies = [ 306 306 + "bytes", 307 307 + "itoa", 308 308 + ] 309 309 + 310 310 + [[package]] 311 311 + name = "http-body" 312 312 + version = "1.0.1" 313 313 + source = "registry+https://github.com/rust-lang/crates.io-index" 314 314 + checksum = "1efedce1fb8e6913f23e0c92de8e62cd5b772a67e7b3946df930a62566c93184" 315 315 + dependencies = [ 316 316 + "bytes", 317 317 + "http", 318 318 + ] 319 319 + 320 320 + [[package]] 321 321 + name = "http-body-util" 322 322 + version = "0.1.3" 323 323 + source = "registry+https://github.com/rust-lang/crates.io-index" 324 324 + checksum = "b021d93e26becf5dc7e1b75b1bed1fd93124b374ceb73f43d4d4eafec896a64a" 325 325 + dependencies = [ 326 326 + "bytes", 327 327 + "futures-core", 328 328 + "http", 329 329 + "http-body", 330 330 + "pin-project-lite", 331 331 + ] 332 332 + 333 333 + [[package]] 334 334 + name = "httparse" 335 335 + version = "1.10.1" 336 336 + source = "registry+https://github.com/rust-lang/crates.io-index" 337 337 + checksum = "6dbf3de79e51f3d586ab4cb9d5c3e2c14aa28ed23d180cf89b4df0454a69cc87" 338 338 + 339 339 + [[package]] 340 340 + name = "httpdate" 341 341 + version = "1.0.3" 342 342 + source = "registry+https://github.com/rust-lang/crates.io-index" 343 343 + checksum = "df3b46402a9d5adb4c86a0cf463f42e19994e3ee891101b1841f30a545cb49a9" 344 344 + 345 345 + [[package]] 346 346 + name = "hyper" 347 347 + version = "1.8.1" 348 348 + source = "registry+https://github.com/rust-lang/crates.io-index" 349 349 + checksum = "2ab2d4f250c3d7b1c9fcdff1cece94ea4e2dfbec68614f7b87cb205f24ca9d11" 350 350 + dependencies = [ 351 351 + "atomic-waker", 352 352 + "bytes", 353 353 + "futures-channel", 354 354 + "futures-core", 355 355 + "h2", 356 356 + "http", 357 357 + "http-body", 358 358 + "httparse", 359 359 + "httpdate", 360 360 + "itoa", 361 361 + "pin-project-lite", 362 362 + "pin-utils", 363 363 + "smallvec", 364 364 + "tokio", 365 365 + "want", 366 366 + ] 367 367 + 368 368 + [[package]] 369 369 + name = "hyper-util" 370 370 + version = "0.1.19" 371 371 + source = "registry+https://github.com/rust-lang/crates.io-index" 372 372 + checksum = "727805d60e7938b76b826a6ef209eb70eaa1812794f9424d4a4e2d740662df5f" 373 373 + dependencies = [ 374 374 + "bytes", 375 375 + "futures-core", 376 376 + "http", 377 377 + "http-body", 378 378 + "hyper", 379 379 + "pin-project-lite", 380 380 + "tokio", 381 381 + ] 382 382 + 383 383 + [[package]] 384 384 + name = "indexmap" 385 385 + version = "2.12.1" 386 386 + source = "registry+https://github.com/rust-lang/crates.io-index" 387 387 + checksum = "0ad4bb2b565bca0645f4d68c5c9af97fba094e9791da685bf83cb5f3ce74acf2" 388 388 + dependencies = [ 389 389 + "equivalent", 390 390 + "hashbrown", 391 391 + ] 392 392 + 393 393 + [[package]] 394 394 + name = "is_terminal_polyfill" 395 395 + version = "1.70.2" 396 396 + source = "registry+https://github.com/rust-lang/crates.io-index" 397 397 + checksum = "a6cb138bb79a146c1bd460005623e142ef0181e3d0219cb493e02f7d08a35695" 398 398 + 399 399 + [[package]] 400 400 + name = "itoa" 401 401 + version = "1.0.17" 402 402 + source = "registry+https://github.com/rust-lang/crates.io-index" 403 403 + checksum = "92ecc6618181def0457392ccd0ee51198e065e016d1d527a7ac1b6dc7c1f09d2" 404 404 + 405 405 + [[package]] 406 406 + name = "libc" 407 407 + version = "0.2.178" 408 408 + source = "registry+https://github.com/rust-lang/crates.io-index" 409 409 + checksum = "37c93d8daa9d8a012fd8ab92f088405fb202ea0b6ab73ee2482ae66af4f42091" 410 410 + 411 411 + [[package]] 412 412 + name = "lock_api" 413 413 + version = "0.4.14" 414 414 + source = "registry+https://github.com/rust-lang/crates.io-index" 415 415 + checksum = "224399e74b87b5f3557511d98dff8b14089b3dadafcab6bb93eab67d3aace965" 416 416 + dependencies = [ 417 417 + "scopeguard", 418 418 + ] 419 419 + 420 420 + [[package]] 421 421 + name = "memchr" 422 422 + version = "2.7.6" 423 423 + source = "registry+https://github.com/rust-lang/crates.io-index" 424 424 + checksum = "f52b00d39961fc5b2736ea853c9cc86238e165017a493d1d5c8eac6bdc4cc273" 425 425 + 426 426 + [[package]] 427 427 + name = "mio" 428 428 + version = "1.1.1" 429 429 + source = "registry+https://github.com/rust-lang/crates.io-index" 430 430 + checksum = "a69bcab0ad47271a0234d9422b131806bf3968021e5dc9328caf2d4cd58557fc" 431 431 + dependencies = [ 432 432 + "libc", 433 433 + "wasi", 434 434 + "windows-sys 0.61.2", 435 435 + ] 436 436 + 437 437 + [[package]] 438 438 + name = "once_cell" 439 439 + version = "1.21.3" 440 440 + source = "registry+https://github.com/rust-lang/crates.io-index" 441 441 + checksum = "42f5e15c9953c5e4ccceeb2e7382a716482c34515315f7b03532b8b4e8393d2d" 442 442 + 443 443 + [[package]] 444 444 + name = "once_cell_polyfill" 445 445 + version = "1.70.2" 446 446 + source = "registry+https://github.com/rust-lang/crates.io-index" 447 447 + checksum = "384b8ab6d37215f3c5301a95a4accb5d64aa607f1fcb26a11b5303878451b4fe" 448 448 + 449 449 + [[package]] 450 450 + name = "parking_lot" 451 451 + version = "0.12.5" 452 452 + source = "registry+https://github.com/rust-lang/crates.io-index" 453 453 + checksum = "93857453250e3077bd71ff98b6a65ea6621a19bb0f559a85248955ac12c45a1a" 454 454 + dependencies = [ 455 455 + "lock_api", 456 456 + "parking_lot_core", 457 457 + ] 458 458 + 459 459 + [[package]] 460 460 + name = "parking_lot_core" 461 461 + version = "0.9.12" 462 462 + source = "registry+https://github.com/rust-lang/crates.io-index" 463 463 + checksum = "2621685985a2ebf1c516881c026032ac7deafcda1a2c9b7850dc81e3dfcb64c1" 464 464 + dependencies = [ 465 465 + "cfg-if", 466 466 + "libc", 467 467 + "redox_syscall", 468 468 + "smallvec", 469 469 + "windows-link", 470 470 + ] 471 471 + 472 472 + [[package]] 473 473 + name = "pin-project" 474 474 + version = "1.1.10" 475 475 + source = "registry+https://github.com/rust-lang/crates.io-index" 476 476 + checksum = "677f1add503faace112b9f1373e43e9e054bfdd22ff1a63c1bc485eaec6a6a8a" 477 477 + dependencies = [ 478 478 + "pin-project-internal", 479 479 + ] 480 480 + 481 481 + [[package]] 482 482 + name = "pin-project-internal" 483 483 + version = "1.1.10" 484 484 + source = "registry+https://github.com/rust-lang/crates.io-index" 485 485 + checksum = "6e918e4ff8c4549eb882f14b3a4bc8c8bc93de829416eacf579f1207a8fbf861" 486 486 + dependencies = [ 487 487 + "proc-macro2", 488 488 + "quote", 489 489 + "syn", 490 490 + ] 491 491 + 492 492 + [[package]] 493 493 + name = "pin-project-lite" 494 494 + version = "0.2.16" 495 495 + source = "registry+https://github.com/rust-lang/crates.io-index" 496 496 + checksum = "3b3cff922bd51709b605d9ead9aa71031d81447142d828eb4a6eba76fe619f9b" 497 497 + 498 498 + [[package]] 499 499 + name = "pin-utils" 500 500 + version = "0.1.0" 501 501 + source = "registry+https://github.com/rust-lang/crates.io-index" 502 502 + checksum = "8b870d8c151b6f2fb93e84a13146138f05d02ed11c7e7c54f8826aaaf7c9f184" 503 503 + 504 504 + [[package]] 505 505 + name = "ppv-lite86" 506 506 + version = "0.2.21" 507 507 + source = "registry+https://github.com/rust-lang/crates.io-index" 508 508 + checksum = "85eae3c4ed2f50dcfe72643da4befc30deadb458a9b590d720cde2f2b1e97da9" 509 509 + dependencies = [ 510 510 + "zerocopy", 511 511 + ] 512 512 + 513 513 + [[package]] 514 514 + name = "proc-macro2" 515 515 + version = "1.0.104" 516 516 + source = "registry+https://github.com/rust-lang/crates.io-index" 517 517 + checksum = "9695f8df41bb4f3d222c95a67532365f569318332d03d5f3f67f37b20e6ebdf0" 518 518 + dependencies = [ 519 519 + "unicode-ident", 520 520 + ] 521 521 + 522 522 + [[package]] 523 523 + name = "quote" 524 524 + version = "1.0.42" 525 525 + source = "registry+https://github.com/rust-lang/crates.io-index" 526 526 + checksum = "a338cc41d27e6cc6dce6cefc13a0729dfbb81c262b1f519331575dd80ef3067f" 527 527 + dependencies = [ 528 528 + "proc-macro2", 529 529 + ] 530 530 + 531 531 + [[package]] 532 532 + name = "rand" 533 533 + version = "0.8.5" 534 534 + source = "registry+https://github.com/rust-lang/crates.io-index" 535 535 + checksum = "34af8d1a0e25924bc5b7c43c079c942339d8f0a8b57c39049bef581b46327404" 536 536 + dependencies = [ 537 537 + "libc", 538 538 + "rand_chacha", 539 539 + "rand_core", 540 540 + ] 541 541 + 542 542 + [[package]] 543 543 + name = "rand_chacha" 544 544 + version = "0.3.1" 545 545 + source = "registry+https://github.com/rust-lang/crates.io-index" 546 546 + checksum = "e6c10a63a0fa32252be49d21e7709d4d4baf8d231c2dbce1eaa8141b9b127d88" 547 547 + dependencies = [ 548 548 + "ppv-lite86", 549 549 + "rand_core", 550 550 + ] 551 551 + 552 552 + [[package]] 553 553 + name = "rand_core" 554 554 + version = "0.6.4" 555 555 + source = "registry+https://github.com/rust-lang/crates.io-index" 556 556 + checksum = "ec0be4795e2f6a28069bec0b5ff3e2ac9bafc99e6a9a7dc3547996c5c816922c" 557 557 + dependencies = [ 558 558 + "getrandom", 559 559 + ] 560 560 + 561 561 + [[package]] 562 562 + name = "redox_syscall" 563 563 + version = "0.5.18" 564 564 + source = "registry+https://github.com/rust-lang/crates.io-index" 565 565 + checksum = "ed2bf2547551a7053d6fdfafda3f938979645c44812fbfcda098faae3f1a362d" 566 566 + dependencies = [ 567 567 + "bitflags", 568 568 + ] 569 569 + 570 570 + [[package]] 571 571 + name = "scopeguard" 572 572 + version = "1.2.0" 573 573 + source = "registry+https://github.com/rust-lang/crates.io-index" 574 574 + checksum = "94143f37725109f92c262ed2cf5e59bce7498c01bcc1502d7b9afe439a4e9f49" 575 575 + 576 576 + [[package]] 577 577 + name = "serde" 578 578 + version = "1.0.228" 579 579 + source = "registry+https://github.com/rust-lang/crates.io-index" 580 580 + checksum = "9a8e94ea7f378bd32cbbd37198a4a91436180c5bb472411e48b5ec2e2124ae9e" 581 581 + dependencies = [ 582 582 + "serde_core", 583 583 + "serde_derive", 584 584 + ] 585 585 + 586 586 + [[package]] 587 587 + name = "serde_core" 588 588 + version = "1.0.228" 589 589 + source = "registry+https://github.com/rust-lang/crates.io-index" 590 590 + checksum = "41d385c7d4ca58e59fc732af25c3983b67ac852c1a25000afe1175de458b67ad" 591 591 + dependencies = [ 592 592 + "serde_derive", 593 593 + ] 594 594 + 595 595 + [[package]] 596 596 + name = "serde_derive" 597 597 + version = "1.0.228" 598 598 + source = "registry+https://github.com/rust-lang/crates.io-index" 599 599 + checksum = "d540f220d3187173da220f885ab66608367b6574e925011a9353e4badda91d79" 600 600 + dependencies = [ 601 601 + "proc-macro2", 602 602 + "quote", 603 603 + "syn", 604 604 + ] 605 605 + 606 606 + [[package]] 607 607 + name = "serde_json" 608 608 + version = "1.0.148" 609 609 + source = "registry+https://github.com/rust-lang/crates.io-index" 610 610 + checksum = "3084b546a1dd6289475996f182a22aba973866ea8e8b02c51d9f46b1336a22da" 611 611 + dependencies = [ 612 612 + "itoa", 613 613 + "memchr", 614 614 + "serde", 615 615 + "serde_core", 616 616 + "zmij", 617 617 + ] 618 618 + 619 619 + [[package]] 620 620 + name = "sha1" 621 621 + version = "0.10.6" 622 622 + source = "registry+https://github.com/rust-lang/crates.io-index" 623 623 + checksum = "e3bf829a2d51ab4a5ddf1352d8470c140cadc8301b2ae1789db023f01cedd6ba" 624 624 + dependencies = [ 625 625 + "cfg-if", 626 626 + "cpufeatures", 627 627 + "digest", 628 628 + ] 629 629 + 630 630 + [[package]] 631 631 + name = "signal-hook-registry" 632 632 + version = "1.4.8" 633 633 + source = "registry+https://github.com/rust-lang/crates.io-index" 634 634 + checksum = "c4db69cba1110affc0e9f7bcd48bbf87b3f4fc7c61fc9155afd4c469eb3d6c1b" 635 635 + dependencies = [ 636 636 + "errno", 637 637 + "libc", 638 638 + ] 639 639 + 640 640 + [[package]] 641 641 + name = "simdutf8" 642 642 + version = "0.1.5" 643 643 + source = "registry+https://github.com/rust-lang/crates.io-index" 644 644 + checksum = "e3a9fe34e3e7a50316060351f37187a3f546bce95496156754b601a5fa71b76e" 645 645 + 646 646 + [[package]] 647 647 + name = "slab" 648 648 + version = "0.4.11" 649 649 + source = "registry+https://github.com/rust-lang/crates.io-index" 650 650 + checksum = "7a2ae44ef20feb57a68b23d846850f861394c2e02dc425a50098ae8c90267589" 651 651 + 652 652 + [[package]] 653 653 + name = "smallvec" 654 654 + version = "1.15.1" 655 655 + source = "registry+https://github.com/rust-lang/crates.io-index" 656 656 + checksum = "67b1b7a3b5fe4f1376887184045fcf45c69e92af734b7aaddc05fb777b6fbd03" 657 657 + 658 658 + [[package]] 659 659 + name = "socket2" 660 660 + version = "0.5.10" 661 661 + source = "registry+https://github.com/rust-lang/crates.io-index" 662 662 + checksum = "e22376abed350d73dd1cd119b57ffccad95b4e585a7cda43e286245ce23c0678" 663 663 + dependencies = [ 664 664 + "libc", 665 665 + "windows-sys 0.52.0", 666 666 + ] 667 667 + 668 668 + [[package]] 669 669 + name = "socket2" 670 670 + version = "0.6.1" 671 671 + source = "registry+https://github.com/rust-lang/crates.io-index" 672 672 + checksum = "17129e116933cf371d018bb80ae557e889637989d8638274fb25622827b03881" 673 673 + dependencies = [ 674 674 + "libc", 675 675 + "windows-sys 0.60.2", 676 676 + ] 677 677 + 678 678 + [[package]] 679 679 + name = "strsim" 680 680 + version = "0.11.1" 681 681 + source = "registry+https://github.com/rust-lang/crates.io-index" 682 682 + checksum = "7da8b5736845d9f2fcb837ea5d9e2628564b3b043a70948a3f0b778838c5fb4f" 683 683 + 684 684 + [[package]] 685 685 + name = "syn" 686 686 + version = "2.0.112" 687 687 + source = "registry+https://github.com/rust-lang/crates.io-index" 688 688 + checksum = "21f182278bf2d2bcb3c88b1b08a37df029d71ce3d3ae26168e3c653b213b99d4" 689 689 + dependencies = [ 690 690 + "proc-macro2", 691 691 + "quote", 692 692 + "unicode-ident", 693 693 + ] 694 694 + 695 695 + [[package]] 696 696 + name = "thiserror" 697 697 + version = "1.0.69" 698 698 + source = "registry+https://github.com/rust-lang/crates.io-index" 699 699 + checksum = "b6aaf5339b578ea85b50e080feb250a3e8ae8cfcdff9a461c9ec2904bc923f52" 700 700 + dependencies = [ 701 701 + "thiserror-impl", 702 702 + ] 703 703 + 704 704 + [[package]] 705 705 + name = "thiserror-impl" 706 706 + version = "1.0.69" 707 707 + source = "registry+https://github.com/rust-lang/crates.io-index" 708 708 + checksum = "4fee6c4efc90059e10f81e6d42c60a18f76588c3d74cb83a0b242a2b6c7504c1" 709 709 + dependencies = [ 710 710 + "proc-macro2", 711 711 + "quote", 712 712 + "syn", 713 713 + ] 714 714 + 715 715 + [[package]] 716 716 + name = "tokio" 717 717 + version = "1.48.0" 718 718 + source = "registry+https://github.com/rust-lang/crates.io-index" 719 719 + checksum = "ff360e02eab121e0bc37a2d3b4d4dc622e6eda3a8e5253d5435ecf5bd4c68408" 720 720 + dependencies = [ 721 721 + "bytes", 722 722 + "libc", 723 723 + "mio", 724 724 + "parking_lot", 725 725 + "pin-project-lite", 726 726 + "signal-hook-registry", 727 727 + "socket2 0.6.1", 728 728 + "tokio-macros", 729 729 + "windows-sys 0.61.2", 730 730 + ] 731 731 + 732 732 + [[package]] 733 733 + name = "tokio-macros" 734 734 + version = "2.6.0" 735 735 + source = "registry+https://github.com/rust-lang/crates.io-index" 736 736 + checksum = "af407857209536a95c8e56f8231ef2c2e2aff839b22e07a1ffcbc617e9db9fa5" 737 737 + dependencies = [ 738 738 + "proc-macro2", 739 739 + "quote", 740 740 + "syn", 741 741 + ] 742 742 + 743 743 + [[package]] 744 744 + name = "tokio-util" 745 745 + version = "0.7.17" 746 746 + source = "registry+https://github.com/rust-lang/crates.io-index" 747 747 + checksum = "2efa149fe76073d6e8fd97ef4f4eca7b67f599660115591483572e406e165594" 748 748 + dependencies = [ 749 749 + "bytes", 750 750 + "futures-core", 751 751 + "futures-sink", 752 752 + "pin-project-lite", 753 753 + "tokio", 754 754 + ] 755 755 + 756 756 + [[package]] 757 757 + name = "tracing" 758 758 + version = "0.1.44" 759 759 + source = "registry+https://github.com/rust-lang/crates.io-index" 760 760 + checksum = "63e71662fa4b2a2c3a26f570f037eb95bb1f85397f3cd8076caed2f026a6d100" 761 761 + dependencies = [ 762 762 + "pin-project-lite", 763 763 + "tracing-core", 764 764 + ] 765 765 + 766 766 + [[package]] 767 767 + name = "tracing-core" 768 768 + version = "0.1.36" 769 769 + source = "registry+https://github.com/rust-lang/crates.io-index" 770 770 + checksum = "db97caf9d906fbde555dd62fa95ddba9eecfd14cb388e4f491a66d74cd5fb79a" 771 771 + dependencies = [ 772 772 + "once_cell", 773 773 + ] 774 774 + 775 775 + [[package]] 776 776 + name = "try-lock" 777 777 + version = "0.2.5" 778 778 + source = "registry+https://github.com/rust-lang/crates.io-index" 779 779 + checksum = "e421abadd41a4225275504ea4d6566923418b7f05506fbc9c0fe86ba7396114b" 780 780 + 781 781 + [[package]] 782 782 + name = "typenum" 783 783 + version = "1.19.0" 784 784 + source = "registry+https://github.com/rust-lang/crates.io-index" 785 785 + checksum = "562d481066bde0658276a35467c4af00bdc6ee726305698a55b86e61d7ad82bb" 786 786 + 787 787 + [[package]] 788 788 + name = "unicode-ident" 789 789 + version = "1.0.22" 790 790 + source = "registry+https://github.com/rust-lang/crates.io-index" 791 791 + checksum = "9312f7c4f6ff9069b165498234ce8be658059c6728633667c526e27dc2cf1df5" 792 792 + 793 793 + [[package]] 794 794 + name = "utf-8" 795 795 + version = "0.7.6" 796 796 + source = "registry+https://github.com/rust-lang/crates.io-index" 797 797 + checksum = "09cc8ee72d2a9becf2f2febe0205bbed8fc6615b7cb429ad062dc7b7ddd036a9" 798 798 + 799 799 + [[package]] 800 800 + name = "utf8parse" 801 801 + version = "0.2.2" 802 802 + source = "registry+https://github.com/rust-lang/crates.io-index" 803 803 + checksum = "06abde3611657adf66d383f00b093d7faecc7fa57071cce2578660c9f1010821" 804 804 + 805 805 + [[package]] 806 806 + name = "version_check" 807 807 + version = "0.9.5" 808 808 + source = "registry+https://github.com/rust-lang/crates.io-index" 809 809 + checksum = "0b928f33d975fc6ad9f86c8f283853ad26bdd5b10b7f1542aa2fa15e2289105a" 810 810 + 811 811 + [[package]] 812 812 + name = "want" 813 813 + version = "0.3.1" 814 814 + source = "registry+https://github.com/rust-lang/crates.io-index" 815 815 + checksum = "bfa7760aed19e106de2c7c0b581b509f2f25d3dacaf737cb82ac61bc6d760b0e" 816 816 + dependencies = [ 817 817 + "try-lock", 818 818 + ] 819 819 + 820 820 + [[package]] 821 821 + name = "wasi" 822 822 + version = "0.11.1+wasi-snapshot-preview1" 823 823 + source = "registry+https://github.com/rust-lang/crates.io-index" 824 824 + checksum = "ccf3ec651a847eb01de73ccad15eb7d99f80485de043efb2f370cd654f4ea44b" 825 825 + 826 826 + [[package]] 827 827 + name = "windows-link" 828 828 + version = "0.2.1" 829 829 + source = "registry+https://github.com/rust-lang/crates.io-index" 830 830 + checksum = "f0805222e57f7521d6a62e36fa9163bc891acd422f971defe97d64e70d0a4fe5" 831 831 + 832 832 + [[package]] 833 833 + name = "windows-sys" 834 834 + version = "0.52.0" 835 835 + source = "registry+https://github.com/rust-lang/crates.io-index" 836 836 + checksum = "282be5f36a8ce781fad8c8ae18fa3f9beff57ec1b52cb3de0789201425d9a33d" 837 837 + dependencies = [ 838 838 + "windows-targets 0.52.6", 839 839 + ] 840 840 + 841 841 + [[package]] 842 842 + name = "windows-sys" 843 843 + version = "0.60.2" 844 844 + source = "registry+https://github.com/rust-lang/crates.io-index" 845 845 + checksum = "f2f500e4d28234f72040990ec9d39e3a6b950f9f22d3dba18416c35882612bcb" 846 846 + dependencies = [ 847 847 + "windows-targets 0.53.5", 848 848 + ] 849 849 + 850 850 + [[package]] 851 851 + name = "windows-sys" 852 852 + version = "0.61.2" 853 853 + source = "registry+https://github.com/rust-lang/crates.io-index" 854 854 + checksum = "ae137229bcbd6cdf0f7b80a31df61766145077ddf49416a728b02cb3921ff3fc" 855 855 + dependencies = [ 856 856 + "windows-link", 857 857 + ] 858 858 + 859 859 + [[package]] 860 860 + name = "windows-targets" 861 861 + version = "0.52.6" 862 862 + source = "registry+https://github.com/rust-lang/crates.io-index" 863 863 + checksum = "9b724f72796e036ab90c1021d4780d4d3d648aca59e491e6b98e725b84e99973" 864 864 + dependencies = [ 865 865 + "windows_aarch64_gnullvm 0.52.6", 866 866 + "windows_aarch64_msvc 0.52.6", 867 867 + "windows_i686_gnu 0.52.6", 868 868 + "windows_i686_gnullvm 0.52.6", 869 869 + "windows_i686_msvc 0.52.6", 870 870 + "windows_x86_64_gnu 0.52.6", 871 871 + "windows_x86_64_gnullvm 0.52.6", 872 872 + "windows_x86_64_msvc 0.52.6", 873 873 + ] 874 874 + 875 875 + [[package]] 876 876 + name = "windows-targets" 877 877 + version = "0.53.5" 878 878 + source = "registry+https://github.com/rust-lang/crates.io-index" 879 879 + checksum = "4945f9f551b88e0d65f3db0bc25c33b8acea4d9e41163edf90dcd0b19f9069f3" 880 880 + dependencies = [ 881 881 + "windows-link", 882 882 + "windows_aarch64_gnullvm 0.53.1", 883 883 + "windows_aarch64_msvc 0.53.1", 884 884 + "windows_i686_gnu 0.53.1", 885 885 + "windows_i686_gnullvm 0.53.1", 886 886 + "windows_i686_msvc 0.53.1", 887 887 + "windows_x86_64_gnu 0.53.1", 888 888 + "windows_x86_64_gnullvm 0.53.1", 889 889 + "windows_x86_64_msvc 0.53.1", 890 890 + ] 891 891 + 892 892 + [[package]] 893 893 + name = "windows_aarch64_gnullvm" 894 894 + version = "0.52.6" 895 895 + source = "registry+https://github.com/rust-lang/crates.io-index" 896 896 + checksum = "32a4622180e7a0ec044bb555404c800bc9fd9ec262ec147edd5989ccd0c02cd3" 897 897 + 898 898 + [[package]] 899 899 + name = "windows_aarch64_gnullvm" 900 900 + version = "0.53.1" 901 901 + source = "registry+https://github.com/rust-lang/crates.io-index" 902 902 + checksum = "a9d8416fa8b42f5c947f8482c43e7d89e73a173cead56d044f6a56104a6d1b53" 903 903 + 904 904 + [[package]] 905 905 + name = "windows_aarch64_msvc" 906 906 + version = "0.52.6" 907 907 + source = "registry+https://github.com/rust-lang/crates.io-index" 908 908 + checksum = "09ec2a7bb152e2252b53fa7803150007879548bc709c039df7627cabbd05d469" 909 909 + 910 910 + [[package]] 911 911 + name = "windows_aarch64_msvc" 912 912 + version = "0.53.1" 913 913 + source = "registry+https://github.com/rust-lang/crates.io-index" 914 914 + checksum = "b9d782e804c2f632e395708e99a94275910eb9100b2114651e04744e9b125006" 915 915 + 916 916 + [[package]] 917 917 + name = "windows_i686_gnu" 918 918 + version = "0.52.6" 919 919 + source = "registry+https://github.com/rust-lang/crates.io-index" 920 920 + checksum = "8e9b5ad5ab802e97eb8e295ac6720e509ee4c243f69d781394014ebfe8bbfa0b" 921 921 + 922 922 + [[package]] 923 923 + name = "windows_i686_gnu" 924 924 + version = "0.53.1" 925 925 + source = "registry+https://github.com/rust-lang/crates.io-index" 926 926 + checksum = "960e6da069d81e09becb0ca57a65220ddff016ff2d6af6a223cf372a506593a3" 927 927 + 928 928 + [[package]] 929 929 + name = "windows_i686_gnullvm" 930 930 + version = "0.52.6" 931 931 + source = "registry+https://github.com/rust-lang/crates.io-index" 932 932 + checksum = "0eee52d38c090b3caa76c563b86c3a4bd71ef1a819287c19d586d7334ae8ed66" 933 933 + 934 934 + [[package]] 935 935 + name = "windows_i686_gnullvm" 936 936 + version = "0.53.1" 937 937 + source = "registry+https://github.com/rust-lang/crates.io-index" 938 938 + checksum = "fa7359d10048f68ab8b09fa71c3daccfb0e9b559aed648a8f95469c27057180c" 939 939 + 940 940 + [[package]] 941 941 + name = "windows_i686_msvc" 942 942 + version = "0.52.6" 943 943 + source = "registry+https://github.com/rust-lang/crates.io-index" 944 944 + checksum = "240948bc05c5e7c6dabba28bf89d89ffce3e303022809e73deaefe4f6ec56c66" 945 945 + 946 946 + [[package]] 947 947 + name = "windows_i686_msvc" 948 948 + version = "0.53.1" 949 949 + source = "registry+https://github.com/rust-lang/crates.io-index" 950 950 + checksum = "1e7ac75179f18232fe9c285163565a57ef8d3c89254a30685b57d83a38d326c2" 951 951 + 952 952 + [[package]] 953 953 + name = "windows_x86_64_gnu" 954 954 + version = "0.52.6" 955 955 + source = "registry+https://github.com/rust-lang/crates.io-index" 956 956 + checksum = "147a5c80aabfbf0c7d901cb5895d1de30ef2907eb21fbbab29ca94c5b08b1a78" 957 957 + 958 958 + [[package]] 959 959 + name = "windows_x86_64_gnu" 960 960 + version = "0.53.1" 961 961 + source = "registry+https://github.com/rust-lang/crates.io-index" 962 962 + checksum = "9c3842cdd74a865a8066ab39c8a7a473c0778a3f29370b5fd6b4b9aa7df4a499" 963 963 + 964 964 + [[package]] 965 965 + name = "windows_x86_64_gnullvm" 966 966 + version = "0.52.6" 967 967 + source = "registry+https://github.com/rust-lang/crates.io-index" 968 968 + checksum = "24d5b23dc417412679681396f2b49f3de8c1473deb516bd34410872eff51ed0d" 969 969 + 970 970 + [[package]] 971 971 + name = "windows_x86_64_gnullvm" 972 972 + version = "0.53.1" 973 973 + source = "registry+https://github.com/rust-lang/crates.io-index" 974 974 + checksum = "0ffa179e2d07eee8ad8f57493436566c7cc30ac536a3379fdf008f47f6bb7ae1" 975 975 + 976 976 + [[package]] 977 977 + name = "windows_x86_64_msvc" 978 978 + version = "0.52.6" 979 979 + source = "registry+https://github.com/rust-lang/crates.io-index" 980 980 + checksum = "589f6da84c646204747d1270a2a5661ea66ed1cced2631d546fdfb155959f9ec" 981 981 + 982 982 + [[package]] 983 983 + name = "windows_x86_64_msvc" 984 984 + version = "0.53.1" 985 985 + source = "registry+https://github.com/rust-lang/crates.io-index" 986 986 + checksum = "d6bbff5f0aada427a1e5a6da5f1f98158182f26556f345ac9e04d36d0ebed650" 987 987 + 988 988 + [[package]] 989 989 + name = "zerocopy" 990 990 + version = "0.8.31" 991 991 + source = "registry+https://github.com/rust-lang/crates.io-index" 992 992 + checksum = "fd74ec98b9250adb3ca554bdde269adf631549f51d8a8f8f0a10b50f1cb298c3" 993 993 + dependencies = [ 994 994 + "zerocopy-derive", 995 995 + ] 996 996 + 997 997 + [[package]] 998 998 + name = "zerocopy-derive" 999 999 + version = "0.8.31" 1000 1000 + source = "registry+https://github.com/rust-lang/crates.io-index" 1001 1001 + checksum = "d8a8d209fdf45cf5138cbb5a506f6b52522a25afccc534d1475dad8e31105c6a" 1002 1002 + dependencies = [ 1003 1003 + "proc-macro2", 1004 1004 + "quote", 1005 1005 + "syn", 1006 1006 + ] 1007 1007 + 1008 1008 + [[package]] 1009 1009 + name = "zmij" 1010 1010 + version = "1.0.4" 1011 1011 + source = "registry+https://github.com/rust-lang/crates.io-index" 1012 1012 + checksum = "77cc0158b0d3103d58e9e82bdbe9cf9289d80dbcf4e686ff16730eb9e5814d1a"

+21

bench/hyper/Cargo.toml

reviewed

··· 1 1 + [package] 2 2 + name = "bench-hyper" 3 3 + version = "0.1.0" 4 4 + edition = "2021" 5 5 + 6 6 + [dependencies] 7 7 + hyper = { version = "1.0", features = ["server", "http1", "http2"] } 8 8 + hyper-util = { version = "0.1", features = ["tokio", "server-auto"] } 9 9 + http-body-util = "0.1" 10 10 + httpdate = "1" 11 11 + tokio = { version = "1", features = ["full"] } 12 12 + serde = { version = "1", features = ["derive"] } 13 13 + serde_json = "1" 14 14 + clap = { version = "4", features = ["derive"] } 15 15 + socket2 = { version = "0.5", features = ["all"] } 16 16 + fastwebsockets = { version = "0.8", features = ["upgrade"] } 17 17 + 18 18 + [profile.release] 19 19 + opt-level = 3 20 20 + lto = true 21 21 + codegen-units = 1

+223

bench/hyper/src/main.rs

reviewed

··· 1 1 + use std::convert::Infallible; 2 2 + use std::net::{Ipv4Addr, SocketAddr}; 3 3 + use std::sync::atomic::{AtomicU64, Ordering}; 4 4 + use std::sync::RwLock; 5 5 + use std::{io, thread}; 6 6 + use std::time::{SystemTime, UNIX_EPOCH}; 7 7 + 8 8 + use clap::Parser; 9 9 + use fastwebsockets::{upgrade, FragmentCollector, Frame, OpCode}; 10 10 + use httpdate::HttpDate; 11 11 + use http_body_util::combinators::BoxBody; 12 12 + use http_body_util::{BodyExt, Empty, Full}; 13 13 + use hyper::body::Bytes; 14 14 + use hyper::header::{HeaderValue, CONTENT_LENGTH, CONTENT_TYPE, DATE, SERVER}; 15 15 + use hyper::service::service_fn; 16 16 + use hyper::{Request, Response, StatusCode}; 17 17 + use hyper_util::rt::{TokioExecutor, TokioIo}; 18 18 + use hyper_util::server::conn::auto::Builder; 19 19 + use serde::Serialize; 20 20 + use socket2::{Domain, SockAddr, Socket, Type}; 21 21 + use tokio::net::TcpListener; 22 22 + use tokio::runtime; 23 23 + 24 24 + static SERVER_HEADER: HeaderValue = HeaderValue::from_static("hyper"); 25 25 + static TEXT_PLAIN: HeaderValue = HeaderValue::from_static("text/plain"); 26 26 + static APPLICATION_JSON: HeaderValue = HeaderValue::from_static("application/json"); 27 27 + static PLAINTEXT_BODY: &[u8] = b"Hello, World!"; 28 28 + 29 29 + static DATE_CACHE_SECS: AtomicU64 = AtomicU64::new(0); 30 30 + static DATE_CACHE: RwLock<String> = RwLock::new(String::new()); 31 31 + 32 32 + fn get_cached_date() -> HeaderValue { 33 33 + let now = SystemTime::now() 34 34 + .duration_since(UNIX_EPOCH) 35 35 + .unwrap() 36 36 + .as_secs(); 37 37 + let cached_secs = DATE_CACHE_SECS.load(Ordering::Relaxed); 38 38 + 39 39 + if now != cached_secs { 40 40 + let date_str = HttpDate::from(SystemTime::now()).to_string(); 41 41 + if let Ok(mut cache) = DATE_CACHE.write() { 42 42 + *cache = date_str; 43 43 + DATE_CACHE_SECS.store(now, Ordering::Relaxed); 44 44 + } 45 45 + } 46 46 + 47 47 + let cache = DATE_CACHE.read().unwrap(); 48 48 + HeaderValue::from_str(&cache).unwrap_or_else(|_| HeaderValue::from_static("")) 49 49 + } 50 50 + 51 51 + #[derive(Serialize)] 52 52 + struct JsonMessage { 53 53 + message: &'static str, 54 54 + } 55 55 + 56 56 + #[derive(Debug, Parser)] 57 57 + #[command(name = "bench-hyper")] 58 58 + #[command(about = "TechEmpower benchmark server using Hyper (HTTP/1.1 + HTTP/2 h2c + WebSocket)")] 59 59 + struct Args { 60 60 + #[arg(short, long, default_value_t = 8080)] 61 61 + port: u16, 62 62 + 63 63 + #[arg(short, long, default_value_t = 1)] 64 64 + threads: usize, 65 65 + } 66 66 + 67 67 + fn main() -> io::Result<()> { 68 68 + let args = Args::parse(); 69 69 + 70 70 + println!("Starting Hyper server on port {} with {} threads (HTTP/1.1 + h2c + WebSocket)", args.port, args.threads); 71 71 + 72 72 + let handles: Vec<_> = (0..args.threads) 73 73 + .map(|_| { 74 74 + let port = args.port; 75 75 + thread::spawn(move || { 76 76 + let rt = runtime::Builder::new_current_thread() 77 77 + .enable_all() 78 78 + .build() 79 79 + .expect("Failed to create runtime"); 80 80 + rt.block_on(run_server(port)).expect("Server error"); 81 81 + }) 82 82 + }) 83 83 + .collect(); 84 84 + 85 85 + for handle in handles { 86 86 + handle.join().expect("Worker thread panicked"); 87 87 + } 88 88 + 89 89 + Ok(()) 90 90 + } 91 91 + 92 92 + async fn run_server(port: u16) -> io::Result<()> { 93 93 + let addr = SocketAddr::from((Ipv4Addr::UNSPECIFIED, port)); 94 94 + let socket = create_reusable_socket(addr)?; 95 95 + let listener = TcpListener::from_std(socket.into())?; 96 96 + 97 97 + loop { 98 98 + let (stream, _) = listener.accept().await?; 99 99 + let io = TokioIo::new(stream); 100 100 + 101 101 + tokio::spawn(async move { 102 102 + let builder = Builder::new(TokioExecutor::new()); 103 103 + let service = service_fn(router); 104 104 + let _ = builder.serve_connection_with_upgrades(io, service).await; 105 105 + }); 106 106 + } 107 107 + } 108 108 + 109 109 + fn create_reusable_socket(addr: SocketAddr) -> io::Result<Socket> { 110 110 + let domain = match addr { 111 111 + SocketAddr::V4(_) => Domain::IPV4, 112 112 + SocketAddr::V6(_) => Domain::IPV6, 113 113 + }; 114 114 + 115 115 + let socket = Socket::new(domain, Type::STREAM, None)?; 116 116 + 117 117 + #[cfg(unix)] 118 118 + socket.set_reuse_port(true)?; 119 119 + socket.set_reuse_address(true)?; 120 120 + socket.set_nodelay(true)?; 121 121 + socket.set_nonblocking(true)?; 122 122 + 123 123 + socket.bind(&SockAddr::from(addr))?; 124 124 + socket.listen(4096)?; 125 125 + 126 126 + Ok(socket) 127 127 + } 128 128 + 129 129 + async fn router(req: Request<hyper::body::Incoming>) -> Result<Response<BoxBody<Bytes, Infallible>>, Infallible> { 130 130 + match req.uri().path() { 131 131 + "/plaintext" => Ok(plaintext()), 132 132 + "/json" => Ok(json()), 133 133 + "/ws" => Ok(websocket_upgrade(req).await), 134 134 + _ => Ok(not_found()), 135 135 + } 136 136 + } 137 137 + 138 138 + fn plaintext() -> Response<BoxBody<Bytes, Infallible>> { 139 139 + Response::builder() 140 140 + .header(SERVER, SERVER_HEADER.clone()) 141 141 + .header(DATE, get_cached_date()) 142 142 + .header(CONTENT_TYPE, TEXT_PLAIN.clone()) 143 143 + .header(CONTENT_LENGTH, PLAINTEXT_BODY.len()) 144 144 + .body(Full::from(PLAINTEXT_BODY).boxed()) 145 145 + .unwrap() 146 146 + } 147 147 + 148 148 + fn json() -> Response<BoxBody<Bytes, Infallible>> { 149 149 + let msg = JsonMessage { message: "Hello, World!" }; 150 150 + let body = serde_json::to_vec(&msg).unwrap(); 151 151 + let len = body.len(); 152 152 + 153 153 + Response::builder() 154 154 + .header(SERVER, SERVER_HEADER.clone()) 155 155 + .header(DATE, get_cached_date()) 156 156 + .header(CONTENT_TYPE, APPLICATION_JSON.clone()) 157 157 + .header(CONTENT_LENGTH, len) 158 158 + .body(Full::from(body).boxed()) 159 159 + .unwrap() 160 160 + } 161 161 + 162 162 + fn not_found() -> Response<BoxBody<Bytes, Infallible>> { 163 163 + Response::builder() 164 164 + .status(StatusCode::NOT_FOUND) 165 165 + .header(SERVER, SERVER_HEADER.clone()) 166 166 + .header(DATE, get_cached_date()) 167 167 + .body(Empty::new().boxed()) 168 168 + .unwrap() 169 169 + } 170 170 + 171 171 + async fn websocket_upgrade(mut req: Request<hyper::body::Incoming>) -> Response<BoxBody<Bytes, Infallible>> { 172 172 + if !upgrade::is_upgrade_request(&req) { 173 173 + return Response::builder() 174 174 + .status(StatusCode::BAD_REQUEST) 175 175 + .header(SERVER, SERVER_HEADER.clone()) 176 176 + .header(DATE, get_cached_date()) 177 177 + .body(Full::from("Not a WebSocket upgrade request").boxed()) 178 178 + .unwrap(); 179 179 + } 180 180 + 181 181 + let (response, fut) = match upgrade::upgrade(&mut req) { 182 182 + Ok(r) => r, 183 183 + Err(_) => { 184 184 + return Response::builder() 185 185 + .status(StatusCode::BAD_REQUEST) 186 186 + .header(SERVER, SERVER_HEADER.clone()) 187 187 + .header(DATE, get_cached_date()) 188 188 + .body(Full::from("WebSocket upgrade failed").boxed()) 189 189 + .unwrap(); 190 190 + } 191 191 + }; 192 192 + 193 193 + tokio::spawn(async move { 194 194 + if let Err(e) = handle_websocket(fut).await { 195 195 + eprintln!("WebSocket error: {}", e); 196 196 + } 197 197 + }); 198 198 + 199 199 + let (parts, _) = response.into_parts(); 200 200 + Response::from_parts(parts, Empty::new().boxed()) 201 201 + } 202 202 + 203 203 + async fn handle_websocket(fut: upgrade::UpgradeFut) -> Result<(), fastwebsockets::WebSocketError> { 204 204 + let mut ws = fut.await?; 205 205 + ws.set_auto_pong(true); 206 206 + ws.set_auto_close(true); 207 207 + let mut ws = FragmentCollector::new(ws); 208 208 + 209 209 + loop { 210 210 + let frame = ws.read_frame().await?; 211 211 + 212 212 + match frame.opcode { 213 213 + OpCode::Close => break, 214 214 + OpCode::Text | OpCode::Binary => { 215 215 + let echo_frame = Frame::new(true, frame.opcode, None, frame.payload); 216 216 + ws.write_frame(echo_frame).await?; 217 217 + } 218 218 + _ => {} 219 219 + } 220 220 + } 221 221 + 222 222 + Ok(()) 223 223 + }

+10

bench/nethttp/go.mod

reviewed

··· 1 1 + module github.com/hcs/bench-nethttp 2 2 + 3 3 + go 1.21 4 4 + 5 5 + require golang.org/x/net v0.34.0 6 6 + 7 7 + require ( 8 8 + github.com/gorilla/websocket v1.5.3 // indirect 9 9 + golang.org/x/text v0.21.0 // indirect 10 10 + )

+6

bench/nethttp/go.sum

reviewed

··· 1 1 + github.com/gorilla/websocket v1.5.3 h1:saDtZ6Pbx/0u+bgYQ3q96pZgCzfhKXGPqt7kZ72aNNg= 2 2 + github.com/gorilla/websocket v1.5.3/go.mod h1:YR8l580nyteQvAITg2hZ9XVh4b55+EU/adAjf1fMHhE= 3 3 + golang.org/x/net v0.34.0 h1:Mb7Mrk043xzHgnRM88suvJFwzVrRfHEHJEl5/71CKw0= 4 4 + golang.org/x/net v0.34.0/go.mod h1:di0qlW3YNM5oh6GqDGQr92MyTozJPmybPK4Ev/Gm31k= 5 5 + golang.org/x/text v0.21.0 h1:zyQAAkrwaneQ066sspRyJaG9VNi/YJ1NfzcGB3hZ/qo= 6 6 + golang.org/x/text v0.21.0/go.mod h1:4IBbMaMmOPCJ8SecivzSH54+73PCFmPWxNTLm+vZkEQ=

+138

bench/nethttp/main.go

reviewed

··· 1 1 + package main 2 2 + 3 3 + import ( 4 4 + "encoding/json" 5 5 + "flag" 6 6 + "fmt" 7 7 + "log" 8 8 + "net" 9 9 + "net/http" 10 10 + "runtime" 11 11 + "sync" 12 12 + "sync/atomic" 13 13 + "time" 14 14 + 15 15 + "github.com/gorilla/websocket" 16 16 + "golang.org/x/net/http2" 17 17 + "golang.org/x/net/http2/h2c" 18 18 + ) 19 19 + 20 20 + const ( 21 21 + helloWorldStr = "Hello, World!" 22 22 + contentTypeJSON = "application/json" 23 23 + contentTypeText = "text/plain" 24 24 + serverName = "go-nethttp" 25 25 + ) 26 26 + 27 27 + type Message struct { 28 28 + Message string `json:"message"` 29 29 + } 30 30 + 31 31 + var ( 32 32 + port int 33 33 + threads int 34 34 + ) 35 35 + 36 36 + var ( 37 37 + dateCacheMu sync.RWMutex 38 38 + dateCacheTime int64 39 39 + dateCacheVal string 40 40 + ) 41 41 + 42 42 + func getCachedDate() string { 43 43 + now := time.Now().Unix() 44 44 + cached := atomic.LoadInt64(&dateCacheTime) 45 45 + 46 46 + if now != cached { 47 47 + dateCacheMu.Lock() 48 48 + if atomic.LoadInt64(&dateCacheTime) != now { 49 49 + dateCacheVal = time.Now().UTC().Format(http.TimeFormat) 50 50 + atomic.StoreInt64(&dateCacheTime, now) 51 51 + } 52 52 + dateCacheMu.Unlock() 53 53 + } 54 54 + 55 55 + dateCacheMu.RLock() 56 56 + defer dateCacheMu.RUnlock() 57 57 + return dateCacheVal 58 58 + } 59 59 + 60 60 + var jsonBody []byte 61 61 + 62 62 + func init() { 63 63 + flag.IntVar(&port, "port", 8080, "Port to listen on") 64 64 + flag.IntVar(&threads, "threads", 1, "Number of threads (GOMAXPROCS)") 65 65 + 66 66 + msg := Message{Message: helloWorldStr} 67 67 + jsonBody, _ = json.Marshal(msg) 68 68 + } 69 69 + 70 70 + func main() { 71 71 + flag.Parse() 72 72 + runtime.GOMAXPROCS(threads) 73 73 + 74 74 + mux := http.NewServeMux() 75 75 + mux.HandleFunc("/plaintext", plaintextHandler) 76 76 + mux.HandleFunc("/json", jsonHandler) 77 77 + mux.HandleFunc("/ws", wsHandler) 78 78 + 79 79 + h2s := &http2.Server{} 80 80 + handler := h2c.NewHandler(mux, h2s) 81 81 + 82 82 + server := &http.Server{ 83 83 + Addr: fmt.Sprintf(":%d", port), 84 84 + Handler: handler, 85 85 + } 86 86 + 87 87 + ln, err := net.Listen("tcp", server.Addr) 88 88 + if err != nil { 89 89 + log.Fatalf("Failed to listen: %v", err) 90 90 + } 91 91 + 92 92 + fmt.Printf("Starting Go net/http server on port %d with %d threads (HTTP/1.1 + h2c + WebSocket)\n", port, threads) 93 93 + 94 94 + if err := server.Serve(ln); err != nil { 95 95 + log.Fatalf("Server error: %v", err) 96 96 + } 97 97 + } 98 98 + 99 99 + func plaintextHandler(w http.ResponseWriter, r *http.Request) { 100 100 + h := w.Header() 101 101 + h.Set("Server", serverName) 102 102 + h.Set("Date", getCachedDate()) 103 103 + h.Set("Content-Type", contentTypeText) 104 104 + w.Write([]byte(helloWorldStr)) 105 105 + } 106 106 + 107 107 + func jsonHandler(w http.ResponseWriter, r *http.Request) { 108 108 + h := w.Header() 109 109 + h.Set("Server", serverName) 110 110 + h.Set("Date", getCachedDate()) 111 111 + h.Set("Content-Type", contentTypeJSON) 112 112 + w.Write(jsonBody) 113 113 + } 114 114 + 115 115 + var upgrader = websocket.Upgrader{ 116 116 + ReadBufferSize: 1024, 117 117 + WriteBufferSize: 1024, 118 118 + CheckOrigin: func(r *http.Request) bool { return true }, 119 119 + } 120 120 + 121 121 + func wsHandler(w http.ResponseWriter, r *http.Request) { 122 122 + conn, err := upgrader.Upgrade(w, r, nil) 123 123 + if err != nil { 124 124 + log.Printf("WebSocket upgrade error: %v", err) 125 125 + return 126 126 + } 127 127 + defer conn.Close() 128 128 + 129 129 + for { 130 130 + messageType, message, err := conn.ReadMessage() 131 131 + if err != nil { 132 132 + break 133 133 + } 134 134 + if err := conn.WriteMessage(messageType, message); err != nil { 135 135 + break 136 136 + } 137 137 + } 138 138 + }

+118

bench/piaf/bench_server_piaf.ml

reviewed

··· 1 1 + module Date_cache = struct 2 2 + let day_names = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] 3 3 + 4 4 + let month_names = 5 5 + [| 6 6 + "Jan"; 7 7 + "Feb"; 8 8 + "Mar"; 9 9 + "Apr"; 10 10 + "May"; 11 11 + "Jun"; 12 12 + "Jul"; 13 13 + "Aug"; 14 14 + "Sep"; 15 15 + "Oct"; 16 16 + "Nov"; 17 17 + "Dec"; 18 18 + |] 19 19 + 20 20 + let cached_date = Atomic.make "" 21 21 + let cached_time = Atomic.make 0. 22 22 + 23 23 + let format_date () = 24 24 + let t = Unix.gettimeofday () in 25 25 + let tm = Unix.gmtime t in 26 26 + Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" 27 27 + day_names.(tm.Unix.tm_wday) 28 28 + tm.Unix.tm_mday 29 29 + month_names.(tm.Unix.tm_mon) 30 30 + (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 31 31 + 32 32 + let[@inline] get () = 33 33 + let now = Unix.gettimeofday () in 34 34 + let last = Atomic.get cached_time in 35 35 + if now -. last >= 1.0 then begin 36 36 + let date = format_date () in 37 37 + Atomic.set cached_date date; 38 38 + Atomic.set cached_time now; 39 39 + date 40 40 + end 41 41 + else Atomic.get cached_date 42 42 + end 43 43 + 44 44 + type json_message = { message : string } 45 45 + 46 46 + let serialize_json () = 47 47 + let msg = { message = "Hello, World!" } in 48 48 + let json = `Assoc [ ("message", `String msg.message) ] in 49 49 + Yojson.Basic.to_string json 50 50 + 51 51 + let plaintext_body = "Hello, World!" 52 52 + 53 53 + let plaintext_headers () = 54 54 + Piaf.Headers.of_list 55 55 + [ 56 56 + ("content-type", "text/plain"); 57 57 + ("server", "piaf"); 58 58 + ("date", Date_cache.get ()); 59 59 + ("content-length", string_of_int (String.length plaintext_body)); 60 60 + ] 61 61 + 62 62 + let notfound_headers () = 63 63 + Piaf.Headers.of_list 64 64 + [ ("server", "piaf"); ("date", Date_cache.get ()); ("content-length", "9") ] 65 65 + 66 66 + let request_handler (ctx : Piaf.Request_info.t Piaf.Server.ctx) = 67 67 + let target = ctx.request.target in 68 68 + match target with 69 69 + | "/plaintext" -> 70 70 + Piaf.Response.create ~headers:(plaintext_headers ()) 71 71 + ~body:(Piaf.Body.of_string plaintext_body) 72 72 + `OK 73 73 + | "/json" -> 74 74 + let body = serialize_json () in 75 75 + let json_headers = 76 76 + Piaf.Headers.of_list 77 77 + [ 78 78 + ("content-type", "application/json"); 79 79 + ("server", "piaf"); 80 80 + ("date", Date_cache.get ()); 81 81 + ("content-length", string_of_int (String.length body)); 82 82 + ] 83 83 + in 84 84 + Piaf.Response.create ~headers:json_headers 85 85 + ~body:(Piaf.Body.of_string body) `OK 86 86 + | _ -> 87 87 + Piaf.Response.create ~headers:(notfound_headers ()) 88 88 + ~body:(Piaf.Body.of_string "Not Found") 89 89 + `Not_found 90 90 + 91 91 + let command = 92 92 + Climate.Command.singleton ~doc:"TechEmpower benchmark server using Piaf" 93 93 + @@ 94 94 + let open Climate.Arg_parser in 95 95 + let+ port = 96 96 + named_with_default [ "p"; "port" ] int ~default:8080 97 97 + ~doc:"Port to listen on" 98 98 + and+ domains = 99 99 + named_with_default [ "d"; "domains" ] int ~default:1 100 100 + ~doc:"Number of domains (CPUs) to use" 101 101 + in 102 102 + 103 103 + Printf.printf "Starting Piaf server on port %d with %d domains\n%!" port 104 104 + domains; 105 105 + 106 106 + Eio_main.run @@ fun env -> 107 107 + Eio.Switch.run @@ fun sw -> 108 108 + let address = `Tcp (Eio.Net.Ipaddr.V4.any, port) in 109 109 + (* Optimize: higher backlog (default is 128), larger buffers *) 110 110 + let config = 111 111 + Piaf.Server.Config.create ~domains ~backlog:4096 ~buffer_size:16384 112 112 + ~body_buffer_size:16384 address 113 113 + in 114 114 + let server = Piaf.Server.create ~config request_handler in 115 115 + let _command = Piaf.Server.Command.start ~sw env server in 116 116 + () 117 117 + 118 118 + let () = Climate.Command.run command

+4

bench/piaf/dune

reviewed

··· 1 1 + (executable 2 2 + (name bench_server_piaf) 3 3 + (public_name bench-piaf) 4 4 + (libraries piaf eio_main yojson climate))

+531

bench/scripts/run_benchmark.sh

reviewed

··· 1 1 + #!/usr/bin/env bash 2 2 + # Multi-Protocol Benchmark Runner 3 3 + # 4 4 + # Benchmarks all servers: HCS (OCaml), Hyper (Rust), Go net/http 5 5 + # Tests HTTP/1.1, HTTP/2 (h2c), and WebSocket protocols 6 6 + # Includes memory profiling (RSS per server) 7 7 + # 8 8 + # Usage: ./run_benchmark.sh [options] 9 9 + # -d, --duration Test duration in seconds (default: 10) 10 10 + # -c, --concurrency Number of concurrent connections (default: 50) 11 11 + # -w, --warmup Warmup duration in seconds (default: 2) 12 12 + # -o, --output Output directory for results (default: ./results) 13 13 + # -s, --server Run only specific server: hcs|hyper|go (default: all) 14 14 + # -p, --protocol Run only specific protocol: h1|h2|ws (default: all) 15 15 + # -t, --threads Number of server threads/domains (default: 4) 16 16 + # -h, --help Show this help message 17 17 + # 18 18 + # Requirements: 19 19 + # - h2load (from nghttp2) for HTTP/2 benchmarks 20 20 + # - curl for health checks 21 21 + # - Built servers in expected locations 22 22 + 23 23 + set -euo pipefail 24 24 + 25 25 + # Default configuration 26 26 + DURATION=10 27 27 + CONCURRENCY=50 28 28 + WARMUP=2 29 29 + OUTPUT_DIR="./results" 30 30 + SERVER_FILTER="all" 31 31 + PROTOCOL_FILTER="all" 32 32 + THREADS=4 33 33 + 34 34 + # Colors for output 35 35 + RED='\033[0;31m' 36 36 + GREEN='\033[0;32m' 37 37 + YELLOW='\033[1;33m' 38 38 + BLUE='\033[0;34m' 39 39 + CYAN='\033[0;36m' 40 40 + BOLD='\033[1m' 41 41 + NC='\033[0m' # No Color 42 42 + 43 43 + # Parse arguments 44 44 + while [[ $# -gt 0 ]]; do 45 45 + case $1 in 46 46 + -d|--duration) DURATION="$2"; shift 2 ;; 47 47 + -c|--concurrency) CONCURRENCY="$2"; shift 2 ;; 48 48 + -w|--warmup) WARMUP="$2"; shift 2 ;; 49 49 + -o|--output) OUTPUT_DIR="$2"; shift 2 ;; 50 50 + -s|--server) SERVER_FILTER="$2"; shift 2 ;; 51 51 + -p|--protocol) PROTOCOL_FILTER="$2"; shift 2 ;; 52 52 + -t|--threads) THREADS="$2"; shift 2 ;; 53 53 + -h|--help) 54 54 + head -20 "$0" | tail -16 55 55 + exit 0 56 56 + ;; 57 57 + *) echo "Unknown option: $1"; exit 1 ;; 58 58 + esac 59 59 + done 60 60 + 61 61 + # Directory setup 62 62 + SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" 63 63 + BENCH_DIR="$(dirname "$SCRIPT_DIR")" 64 64 + PROJECT_DIR="$(dirname "$BENCH_DIR")" 65 65 + TIMESTAMP=$(date +%Y%m%d_%H%M%S) 66 66 + RESULT_FILE="$OUTPUT_DIR/benchmark_$TIMESTAMP.txt" 67 67 + JSON_FILE="$OUTPUT_DIR/benchmark_$TIMESTAMP.json" 68 68 + 69 69 + mkdir -p "$OUTPUT_DIR" 70 70 + 71 71 + # Server configurations 72 72 + declare -A SERVER_CMDS 73 73 + declare -A SERVER_PORTS 74 74 + declare -A SERVER_WS_PATHS 75 75 + 76 76 + SERVER_CMDS["hcs"]="$PROJECT_DIR/_build/default/bench/hcs/bench_server_unified.exe -p PORT -d $THREADS" 77 77 + SERVER_PORTS["hcs"]=8080 78 78 + SERVER_WS_PATHS["hcs"]="/" 79 79 + 80 80 + SERVER_CMDS["hyper"]="$BENCH_DIR/hyper/target/release/bench-hyper -p PORT -t $THREADS" 81 81 + SERVER_PORTS["hyper"]=8081 82 82 + SERVER_WS_PATHS["hyper"]="/ws" 83 83 + 84 84 + SERVER_CMDS["go"]="$BENCH_DIR/nethttp/bench-nethttp -port PORT -threads $THREADS" 85 85 + SERVER_PORTS["go"]=8082 86 86 + SERVER_WS_PATHS["go"]="/ws" 87 87 + 88 88 + SERVER_CMDS["piaf"]="$PROJECT_DIR/_build/default/bench/piaf/bench_server_piaf.exe -p PORT -d $THREADS" 89 89 + SERVER_PORTS["piaf"]=8083 90 90 + SERVER_WS_PATHS["piaf"]="" 91 91 + 92 92 + SERVER_CMDS["fasthttp"]="$BENCH_DIR/fasthttp/bench-fasthttp -port PORT" 93 93 + SERVER_PORTS["fasthttp"]=8084 94 94 + SERVER_WS_PATHS["fasthttp"]="" 95 95 + 96 96 + # Logging functions 97 97 + log() { echo -e "${BLUE}[INFO]${NC} $1"; } 98 98 + success() { echo -e "${GREEN}[OK]${NC} $1"; } 99 99 + warn() { echo -e "${YELLOW}[WARN]${NC} $1"; } 100 100 + error() { echo -e "${RED}[ERROR]${NC} $1"; } 101 101 + header() { echo -e "\n${BOLD}${CYAN}=== $1 ===${NC}"; } 102 102 + 103 103 + # Check dependencies 104 104 + check_deps() { 105 105 + local missing=() 106 106 + 107 107 + if ! command -v h2load &> /dev/null; then 108 108 + missing+=("h2load (install nghttp2)") 109 109 + fi 110 110 + 111 111 + if ! command -v curl &> /dev/null; then 112 112 + missing+=("curl") 113 113 + fi 114 114 + 115 115 + if [[ ${#missing[@]} -gt 0 ]]; then 116 116 + error "Missing dependencies: ${missing[*]}" 117 117 + exit 1 118 118 + fi 119 119 + } 120 120 + 121 121 + # Build all servers 122 122 + build_servers() { 123 123 + header "Building servers" 124 124 + 125 125 + if [[ "$SERVER_FILTER" == "all" || "$SERVER_FILTER" == "hcs" ]]; then 126 126 + log "Building HCS server..." 127 127 + if (cd "$PROJECT_DIR" && dune build bench/hcs/bench_server_unified.exe bench/client/bench_client.exe 2>&1); then 128 128 + success "HCS built" 129 129 + else 130 130 + error "HCS build failed" 131 131 + return 1 132 132 + fi 133 133 + fi 134 134 + 135 135 + if [[ "$SERVER_FILTER" == "all" || "$SERVER_FILTER" == "hyper" ]]; then 136 136 + log "Building Hyper server..." 137 137 + if (cd "$BENCH_DIR/hyper" && cargo build --release 2>&1 | tail -5); then 138 138 + success "Hyper built" 139 139 + else 140 140 + error "Hyper build failed" 141 141 + return 1 142 142 + fi 143 143 + fi 144 144 + 145 145 + if [[ "$SERVER_FILTER" == "all" || "$SERVER_FILTER" == "go" ]]; then 146 146 + log "Building Go net/http server..." 147 147 + if (cd "$BENCH_DIR/nethttp" && go build -o bench-nethttp . 2>&1); then 148 148 + success "Go server built" 149 149 + else 150 150 + error "Go build failed" 151 151 + return 1 152 152 + fi 153 153 + fi 154 154 + 155 155 + if [[ "$SERVER_FILTER" == "all" || "$SERVER_FILTER" == "piaf" ]]; then 156 156 + log "Building Piaf server..." 157 157 + if (cd "$PROJECT_DIR" && dune build bench/piaf/bench_server_piaf.exe 2>&1); then 158 158 + success "Piaf built" 159 159 + else 160 160 + error "Piaf build failed" 161 161 + return 1 162 162 + fi 163 163 + fi 164 164 + 165 165 + if [[ "$SERVER_FILTER" == "all" || "$SERVER_FILTER" == "fasthttp" ]]; then 166 166 + log "Building fasthttp server..." 167 167 + if (cd "$BENCH_DIR/fasthttp" && go build -o bench-fasthttp . 2>&1); then 168 168 + success "fasthttp built" 169 169 + else 170 170 + error "fasthttp build failed" 171 171 + return 1 172 172 + fi 173 173 + fi 174 174 + } 175 175 + 176 176 + # Get memory usage (RSS in KB) for a PID 177 177 + get_rss_kb() { 178 178 + local pid=$1 179 179 + if [[ -f "/proc/$pid/status" ]]; then 180 180 + grep VmRSS "/proc/$pid/status" 2>/dev/null | awk '{print $2}' || echo "0" 181 181 + else 182 182 + # macOS fallback 183 183 + ps -o rss= -p "$pid" 2>/dev/null | tr -d ' ' || echo "0" 184 184 + fi 185 185 + } 186 186 + 187 187 + # Check if systemd-run with cgroup memory tracking is available 188 188 + CGROUP_AVAILABLE=false 189 189 + # Disabled: systemd-run --scope has issues in non-interactive shells 190 190 + # if command -v systemd-run &> /dev/null; then 191 191 + # if systemd-run --user --scope -p MemoryAccounting=yes true 2>/dev/null; then 192 192 + # CGROUP_AVAILABLE=true 193 193 + # fi 194 194 + # fi 195 195 + 196 196 + # Get cgroup path for a scope 197 197 + get_cgroup_path() { 198 198 + local scope_name=$1 199 199 + echo "/sys/fs/cgroup/user.slice/user-$(id -u).slice/user@$(id -u).service/app.slice/${scope_name}.scope" 200 200 + } 201 201 + 202 202 + # Get peak memory from cgroup (in KB) 203 203 + get_peak_memory_kb() { 204 204 + local cgroup_path=$1 205 205 + if [[ -f "$cgroup_path/memory.peak" ]]; then 206 206 + local bytes=$(cat "$cgroup_path/memory.peak" 2>/dev/null || echo "0") 207 207 + echo $((bytes / 1024)) 208 208 + else 209 209 + echo "0" 210 210 + fi 211 211 + } 212 212 + 213 213 + # Get current memory from cgroup (in KB) 214 214 + get_current_memory_kb() { 215 215 + local cgroup_path=$1 216 216 + if [[ -f "$cgroup_path/memory.current" ]]; then 217 217 + local bytes=$(cat "$cgroup_path/memory.current" 2>/dev/null || echo "0") 218 218 + echo $((bytes / 1024)) 219 219 + else 220 220 + echo "0" 221 221 + fi 222 222 + } 223 223 + 224 224 + start_memory_tracker() { 225 225 + local pid=$1 226 226 + local output_file=$2 227 227 + local pid_file=$3 228 228 + local interval=${4:-0.1} 229 229 + 230 230 + echo "0" > "$output_file" 231 231 + 232 232 + ( 233 233 + peak=0 234 234 + while kill -0 "$pid" 2>/dev/null; do 235 235 + if [[ -f "/proc/$pid/status" ]]; then 236 236 + current=$(grep VmRSS "/proc/$pid/status" 2>/dev/null | awk '{print $2}') 237 237 + if [[ -n "$current" && "$current" -gt "$peak" ]] 2>/dev/null; then 238 238 + peak=$current 239 239 + echo "$peak" > "$output_file" 240 240 + fi 241 241 + fi 242 242 + sleep "$interval" 243 243 + done 244 244 + echo "$peak" > "$output_file" 245 245 + ) & 246 246 + echo $! > "$pid_file" 247 247 + } 248 248 + 249 249 + stop_memory_tracker() { 250 250 + local pid_file=$1 251 251 + local output_file=$2 252 252 + 253 253 + if [[ -f "$pid_file" ]]; then 254 254 + local tracker_pid=$(cat "$pid_file") 255 255 + rm -f "$pid_file" 256 256 + sleep 0.2 257 257 + kill "$tracker_pid" 2>/dev/null || true 258 258 + wait "$tracker_pid" 2>/dev/null || true 259 259 + fi 260 260 + 261 261 + if [[ -f "$output_file" ]]; then 262 262 + cat "$output_file" 263 263 + rm -f "$output_file" 264 264 + else 265 265 + echo "0" 266 266 + fi 267 267 + } 268 268 + 269 269 + # Wait for server to be ready 270 270 + wait_for_server() { 271 271 + local port=$1 272 272 + local max_attempts=50 273 273 + local attempt=0 274 274 + 275 275 + while ! curl -s "http://127.0.0.1:$port/plaintext" > /dev/null 2>&1; do 276 276 + attempt=$((attempt + 1)) 277 277 + if [[ $attempt -ge $max_attempts ]]; then 278 278 + error "Server on port $port failed to start" 279 279 + return 1 280 280 + fi 281 281 + sleep 0.1 282 282 + done 283 283 + return 0 284 284 + } 285 285 + 286 286 + cleanup_ports() { 287 287 + for port in 8080 8081 8082 8083 8084; do 288 288 + pkill -9 -f "port.*$port" 2>/dev/null || true 289 289 + pkill -9 -f "\-p.*$port" 2>/dev/null || true 290 290 + done 291 291 + sleep 0.5 292 292 + } 293 293 + 294 294 + strip_ansi() { 295 295 + sed 's/\x1b\[[0-9;]*m//g' 296 296 + } 297 297 + 298 298 + benchmark_h1() { 299 299 + local name=$1 300 300 + local port=$2 301 301 + local endpoint=$3 302 302 + 303 303 + log "HTTP/1.1 $endpoint..." 304 304 + "$PROJECT_DIR/_build/default/bench/client/bench_client.exe" \ 305 305 + -p h1 \ 306 306 + -u "http://127.0.0.1:$port$endpoint" \ 307 307 + -c "$CONCURRENCY" \ 308 308 + -d "$DURATION" 2>&1 || true 309 309 + } 310 310 + 311 311 + # Run HTTP/2 benchmark using h2load 312 312 + benchmark_h2() { 313 313 + local name=$1 314 314 + local port=$2 315 315 + local endpoint=$3 316 316 + local requests=$((CONCURRENCY * DURATION * 1000)) # Estimate based on expected throughput 317 317 + 318 318 + log "HTTP/2 (h2c) $endpoint..." 319 319 + h2load -n "$requests" -c "$CONCURRENCY" -t 4 \ 320 320 + "http://127.0.0.1:$port$endpoint" 2>&1 || true 321 321 + } 322 322 + 323 323 + # Run WebSocket benchmark 324 324 + benchmark_ws() { 325 325 + local name=$1 326 326 + local port=$2 327 327 + local ws_path=$3 328 328 + local ws_timeout=$((DURATION + 5)) 329 329 + 330 330 + log "WebSocket $ws_path..." 331 331 + # Use timeout to prevent hanging (known issue with some WS servers) 332 332 + timeout "$ws_timeout" "$PROJECT_DIR/_build/default/bench/client/bench_client.exe" \ 333 333 + -p ws \ 334 334 + -u "ws://127.0.0.1:$port$ws_path" \ 335 335 + -c 10 \ 336 336 + -d "$DURATION" \ 337 337 + --msg-size 128 2>&1 || { 338 338 + local exit_code=$? 339 339 + if [[ $exit_code -eq 124 ]]; then 340 340 + warn "WebSocket benchmark timed out (known issue with HCS server)" 341 341 + fi 342 342 + true 343 343 + } 344 344 + } 345 345 + 346 346 + # Run all benchmarks for a server 347 347 + benchmark_server() { 348 348 + local name=$1 349 349 + local cmd_template=${SERVER_CMDS[$name]} 350 350 + local port=${SERVER_PORTS[$name]} 351 351 + local ws_path=${SERVER_WS_PATHS[$name]} 352 352 + 353 353 + local cmd="${cmd_template//PORT/$port}" 354 354 + 355 355 + header "$name (port $port)" 356 356 + 357 357 + log "Starting $name server..." 358 358 + eval "$cmd" & 359 359 + local server_pid=$! 360 360 + 361 361 + if ! wait_for_server "$port"; then 362 362 + kill "$server_pid" 2>/dev/null || true 363 363 + return 1 364 364 + fi 365 365 + 366 366 + success "$name server ready (PID: $server_pid)" 367 367 + 368 368 + local rss_start=$(get_rss_kb "$server_pid") 369 369 + log "Initial RSS: ${rss_start} KB" 370 370 + 371 371 + local peak_tracker_file="/tmp/bench_peak_${name}_$$.txt" 372 372 + local tracker_pid_file="/tmp/bench_tracker_pid_${name}_$$.txt" 373 373 + start_memory_tracker "$server_pid" "$peak_tracker_file" "$tracker_pid_file" 0.05 374 374 + 375 375 + log "Warming up for ${WARMUP}s..." 376 376 + "$PROJECT_DIR/_build/default/bench/client/bench_client.exe" \ 377 377 + -p h1 \ 378 378 + -u "http://127.0.0.1:$port/plaintext" \ 379 379 + -c "$CONCURRENCY" \ 380 380 + -d "$WARMUP" > /dev/null 2>&1 || true 381 381 + 382 382 + { 383 383 + echo "" 384 384 + echo "==========================================" 385 385 + echo " $name" 386 386 + echo "==========================================" 387 387 + echo "Port: $port, Threads: $THREADS" 388 388 + echo "" 389 389 + } >> "$RESULT_FILE" 390 390 + 391 391 + local tmp_out="/tmp/bench_out_$$.txt" 392 392 + 393 393 + if [[ "$PROTOCOL_FILTER" == "all" || "$PROTOCOL_FILTER" == "h1" ]]; then 394 394 + echo "--- HTTP/1.1 ---" >> "$RESULT_FILE" 395 395 + benchmark_h1 "$name" "$port" "/plaintext" > "$tmp_out" 2>&1 396 396 + cat "$tmp_out" 397 397 + strip_ansi < "$tmp_out" >> "$RESULT_FILE" 398 398 + echo "" >> "$RESULT_FILE" 399 399 + benchmark_h1 "$name" "$port" "/json" > "$tmp_out" 2>&1 400 400 + cat "$tmp_out" 401 401 + strip_ansi < "$tmp_out" >> "$RESULT_FILE" 402 402 + echo "" >> "$RESULT_FILE" 403 403 + fi 404 404 + 405 405 + if [[ "$PROTOCOL_FILTER" == "all" || "$PROTOCOL_FILTER" == "h2" ]]; then 406 406 + echo "--- HTTP/2 (h2c) ---" >> "$RESULT_FILE" 407 407 + benchmark_h2 "$name" "$port" "/plaintext" > "$tmp_out" 2>&1 408 408 + cat "$tmp_out" 409 409 + strip_ansi < "$tmp_out" >> "$RESULT_FILE" 410 410 + echo "" >> "$RESULT_FILE" 411 411 + benchmark_h2 "$name" "$port" "/json" > "$tmp_out" 2>&1 412 412 + cat "$tmp_out" 413 413 + strip_ansi < "$tmp_out" >> "$RESULT_FILE" 414 414 + echo "" >> "$RESULT_FILE" 415 415 + fi 416 416 + 417 417 + if [[ "$PROTOCOL_FILTER" == "all" || "$PROTOCOL_FILTER" == "ws" ]]; then 418 418 + echo "--- WebSocket ---" >> "$RESULT_FILE" 419 419 + benchmark_ws "$name" "$port" "$ws_path" > "$tmp_out" 2>&1 420 420 + cat "$tmp_out" 421 421 + strip_ansi < "$tmp_out" >> "$RESULT_FILE" 422 422 + echo "" >> "$RESULT_FILE" 423 423 + fi 424 424 + 425 425 + rm -f "$tmp_out" 426 426 + 427 427 + local rss_end=$(get_rss_kb "$server_pid") 428 428 + 429 429 + kill "$server_pid" 2>/dev/null || true 430 430 + wait "$server_pid" 2>/dev/null || true 431 431 + 432 432 + local peak_rss=$(stop_memory_tracker "$tracker_pid_file" "$peak_tracker_file") 433 433 + 434 434 + log "Memory - Initial: ${rss_start} KB, Final: ${rss_end} KB, Peak: ${peak_rss} KB" 435 435 + 436 436 + { 437 437 + echo "--- Memory ---" 438 438 + echo "Initial RSS: ${rss_start} KB" 439 439 + echo "Final RSS: ${rss_end} KB" 440 440 + echo "Peak RSS: ${peak_rss} KB" 441 441 + echo "Peak RSS (MB): $((peak_rss / 1024)) MB" 442 442 + echo "" 443 443 + } >> "$RESULT_FILE" 444 444 + 445 445 + success "$name benchmark complete" 446 446 + sleep 1 447 447 + } 448 448 + 449 449 + # Generate summary comparison 450 450 + generate_summary() { 451 451 + header "Summary" 452 452 + 453 453 + { 454 454 + echo "" 455 455 + echo "==========================================" 456 456 + echo " BENCHMARK SUMMARY" 457 457 + echo "==========================================" 458 458 + echo "Date: $(date)" 459 459 + echo "Duration: ${DURATION}s per test" 460 460 + echo "Concurrency: $CONCURRENCY connections" 461 461 + echo "Threads: $THREADS per server" 462 462 + echo "" 463 463 + echo "For detailed req/s and latency metrics," 464 464 + echo "see individual server sections above." 465 465 + echo "" 466 466 + echo "Note: HTTP/2 uses h2load, HTTP/1.1 and WS use bench-client" 467 467 + echo "" 468 468 + } >> "$RESULT_FILE" 469 469 + 470 470 + log "Results saved to: $RESULT_FILE" 471 471 + } 472 472 + 473 473 + # Main execution 474 474 + main() { 475 475 + echo "" 476 476 + echo -e "${BOLD}╔════════════════════════════════════════════╗${NC}" 477 477 + echo -e "${BOLD}║ Multi-Protocol Benchmark Suite ║${NC}" 478 478 + echo -e "${BOLD}╚════════════════════════════════════════════╝${NC}" 479 479 + echo "" 480 480 + echo " Duration: ${DURATION}s" 481 481 + echo " Concurrency: $CONCURRENCY" 482 482 + echo " Warmup: ${WARMUP}s" 483 483 + echo " Threads: $THREADS" 484 484 + echo " Servers: $SERVER_FILTER" 485 485 + echo " Protocols: $PROTOCOL_FILTER" 486 486 + echo " Output: $RESULT_FILE" 487 487 + echo -e " Memory: ${GREEN}peak RSS tracking enabled${NC}" 488 488 + echo "" 489 489 + 490 490 + check_deps 491 491 + 492 492 + # Write header to results file 493 493 + { 494 494 + echo "Multi-Protocol Benchmark Results" 495 495 + echo "================================" 496 496 + echo "Date: $(date)" 497 497 + echo "Duration: ${DURATION}s, Concurrency: $CONCURRENCY, Threads: $THREADS" 498 498 + echo "System: $(uname -a)" 499 499 + echo "CPU: $(grep 'model name' /proc/cpuinfo 2>/dev/null | head -1 | cut -d: -f2 | xargs || sysctl -n machdep.cpu.brand_string 2>/dev/null || echo 'unknown')" 500 500 + echo "" 501 501 + } > "$RESULT_FILE" 502 502 + 503 503 + build_servers 504 504 + cleanup_ports 505 505 + 506 506 + # Run benchmarks for selected servers 507 507 + local servers=() 508 508 + if [[ "$SERVER_FILTER" == "all" ]]; then 509 509 + servers=("hcs" "piaf" "hyper" "go" "fasthttp") 510 510 + else 511 511 + servers=("$SERVER_FILTER") 512 512 + fi 513 513 + 514 514 + for server in "${servers[@]}"; do 515 515 + if [[ -n "${SERVER_CMDS[$server]:-}" ]]; then 516 516 + benchmark_server "$server" 517 517 + else 518 518 + warn "Unknown server: $server" 519 519 + fi 520 520 + done 521 521 + 522 522 + generate_summary 523 523 + cleanup_ports 524 524 + 525 525 + echo "" 526 526 + echo -e "${BOLD}${GREEN}✓ All benchmarks complete!${NC}" 527 527 + echo " Results: $RESULT_FILE" 528 528 + echo "" 529 529 + } 530 530 + 531 531 + main "$@"

+11

bin/dune

reviewed

··· 1 1 + (executable 2 2 + (public_name hc) 3 3 + (package hcs) 4 4 + (name hc) 5 5 + (libraries hcs eio_main mirage-crypto-rng.unix climate)) 6 6 + 7 7 + (executable 8 8 + (public_name hs) 9 9 + (package hcs) 10 10 + (name hs) 11 11 + (libraries hcs eio_main climate))

+223

bin/hc.ml

reviewed

··· 1 1 + (** hc - HTTP client using HCS. 2 2 + 3 3 + Supports HTTP/1.1, HTTP/2, WebSocket, TLS verification, and common HTTP 4 4 + methods. *) 5 5 + 6 6 + open Hcs 7 7 + 8 8 + (** Parse a header string "Name: Value" into a tuple *) 9 9 + let parse_header s = 10 10 + match String.index_opt s ':' with 11 11 + | Some i -> 12 12 + let name = String.trim (String.sub s 0 i) in 13 13 + let value = 14 14 + String.trim (String.sub s (i + 1) (String.length s - i - 1)) 15 15 + in 16 16 + (name, value) 17 17 + | None -> failwith (Printf.sprintf "Invalid header format: %s" s) 18 18 + 19 19 + (** Protocol to string *) 20 20 + let protocol_to_string = function 21 21 + | Client.HTTP_1_1 -> "HTTP/1.1" 22 22 + | Client.HTTP_2 -> "HTTP/2" 23 23 + 24 24 + (** Print response headers *) 25 25 + let print_headers status protocol headers = 26 26 + Printf.printf "< %s %d\n" (protocol_to_string protocol) status; 27 27 + List.iter (fun (name, value) -> Printf.printf "< %s: %s\n" name value) headers; 28 28 + print_newline () 29 29 + 30 30 + (** Handle WebSocket connection *) 31 31 + let handle_websocket ~sw ~net ~tls_config ~url ~ws_message ~verbose:_ = 32 32 + Printf.printf "> Connecting to WebSocket: %s\n%!" url; 33 33 + match Websocket.connect ~sw ~net ~tls_config url with 34 34 + | Error err -> 35 35 + let msg = 36 36 + match err with 37 37 + | Websocket.Connection_closed -> "Connection closed" 38 38 + | Websocket.Protocol_error s -> "Protocol error: " ^ s 39 39 + | Websocket.Io_error s -> "IO error: " ^ s 40 40 + in 41 41 + Printf.eprintf "WebSocket error: %s\n" msg; 42 42 + exit 1 43 43 + | Ok ws -> 44 44 + Printf.printf "< Connected!\n%!"; 45 45 + (* Send message if provided *) 46 46 + (match ws_message with 47 47 + | Some msg -> ( 48 48 + Printf.printf "> Sending: %s\n%!" msg; 49 49 + match Websocket.send_text ws msg with 50 50 + | Ok () -> () 51 51 + | Error _ -> 52 52 + Printf.eprintf "Failed to send message\n"; 53 53 + exit 1) 54 54 + | None -> ()); 55 55 + (* Receive messages *) 56 56 + let rec recv_loop () = 57 57 + match Websocket.recv_message ws with 58 58 + | Ok (Websocket.Opcode.Text, content) -> 59 59 + Printf.printf "< Text: %s\n%!" content; 60 60 + recv_loop () 61 61 + | Ok (Websocket.Opcode.Binary, content) -> 62 62 + Printf.printf "< Binary: %d bytes\n%!" (String.length content); 63 63 + recv_loop () 64 64 + | Ok _ -> recv_loop () 65 65 + | Error Websocket.Connection_closed -> 66 66 + Printf.printf "< Connection closed\n%!" 67 67 + | Error (Websocket.Protocol_error s) -> 68 68 + Printf.eprintf "Protocol error: %s\n" s 69 69 + | Error (Websocket.Io_error s) -> Printf.eprintf "IO error: %s\n" s 70 70 + in 71 71 + (* Only enter receive loop if we sent a message (otherwise just test connection) *) 72 72 + if Option.is_some ws_message then recv_loop (); 73 73 + Websocket.close ws 74 74 + 75 75 + (** Handle HTTP request *) 76 76 + let handle_http ~sw ~net ~clock ~url ~method_ ~headers ~data ~http2 ~http1 77 77 + ~insecure ~verbose ~head_only ~follow_redirects ~output_file = 78 78 + (* Build client config *) 79 79 + let config = 80 80 + let base = Client.default_config in 81 81 + let config = if insecure then Client.with_insecure_tls base else base in 82 82 + let config = 83 83 + if http2 then Client.with_http2 config 84 84 + else if http1 then Client.with_http11 config 85 85 + else config 86 86 + in 87 87 + if follow_redirects then config else Client.without_redirects config 88 88 + in 89 89 + 90 90 + (* Determine actual method *) 91 91 + let method_ = if head_only then "HEAD" else method_ in 92 92 + let method_ = 93 93 + if Option.is_some data && method_ = "GET" then "POST" else method_ 94 94 + in 95 95 + 96 96 + (* Print request info in verbose mode *) 97 97 + if verbose then begin 98 98 + Printf.printf "> %s %s\n" method_ url; 99 99 + List.iter 100 100 + (fun (name, value) -> Printf.printf "> %s: %s\n" name value) 101 101 + headers; 102 102 + (match data with Some d -> Printf.printf "> Body: %s\n" d | None -> ()); 103 103 + print_newline () 104 104 + end; 105 105 + 106 106 + (* Make request based on method *) 107 107 + let result = 108 108 + match (method_, data) with 109 109 + | "GET", None -> Client.get ~sw ~net ~clock ~config url 110 110 + | "HEAD", None -> Client.get ~sw ~net ~clock ~config url 111 111 + | "POST", Some body -> Client.post ~sw ~net ~clock ~config url ~body 112 112 + | "POST", None -> Client.post ~sw ~net ~clock ~config url ~body:"" 113 113 + | "PUT", Some body -> Client.post ~sw ~net ~clock ~config url ~body 114 114 + | "PUT", None -> Client.post ~sw ~net ~clock ~config url ~body:"" 115 115 + | "DELETE", _ -> Client.get ~sw ~net ~clock ~config url 116 116 + | "OPTIONS", _ -> Client.get ~sw ~net ~clock ~config url 117 117 + | meth, _ -> 118 118 + Printf.eprintf "Method %s not fully supported yet, using GET\n" meth; 119 119 + Client.get ~sw ~net ~clock ~config url 120 120 + in 121 121 + 122 122 + match result with 123 123 + | Error err -> 124 124 + let msg = 125 125 + match err with 126 126 + | Client.Connection_failed s -> "Connection failed: " ^ s 127 127 + | Client.Tls_error s -> "TLS error: " ^ s 128 128 + | Client.Protocol_error s -> "Protocol error: " ^ s 129 129 + | Client.Timeout -> "Request timed out" 130 130 + | Client.Invalid_response s -> "Invalid response: " ^ s 131 131 + | Client.Too_many_redirects -> "Too many redirects" 132 132 + in 133 133 + Printf.eprintf "Error: %s\n" msg; 134 134 + exit 1 135 135 + | Ok resp -> 136 136 + (* Print headers in verbose mode or for HEAD requests *) 137 137 + if verbose || head_only then 138 138 + print_headers resp.status resp.protocol resp.headers; 139 139 + 140 140 + (* Output body *) 141 141 + if not head_only then begin 142 142 + match output_file with 143 143 + | Some file -> 144 144 + let oc = open_out file in 145 145 + output_string oc resp.body; 146 146 + close_out oc; 147 147 + if verbose then 148 148 + Printf.printf "Wrote %d bytes to %s\n" (String.length resp.body) 149 149 + file 150 150 + | None -> print_string resp.body 151 151 + end 152 152 + 153 153 + let command = 154 154 + let open Climate in 155 155 + Command.singleton 156 156 + ~doc:"HTTP client supporting HTTP/1.1, HTTP/2, WebSocket, and TLS" 157 157 + @@ 158 158 + let open Arg_parser in 159 159 + let+ url = pos_req 0 string ~doc:"URL to request" 160 160 + and+ method_ = 161 161 + named_opt [ "X"; "request" ] string ~doc:"HTTP method" ~value_name:"METHOD" 162 162 + and+ header_strs = 163 163 + named_multi [ "H"; "header" ] string 164 164 + ~doc:"Add header (format: \"Name: Value\")" 165 165 + and+ data = 166 166 + named_opt [ "d"; "data" ] string ~doc:"Request body data" ~value_name:"DATA" 167 167 + and+ http2 = flag [ "2"; "http2" ] ~doc:"Force HTTP/2" 168 168 + and+ http1 = flag [ "1"; "http1" ] ~doc:"Force HTTP/1.1" 169 169 + and+ insecure = 170 170 + flag [ "k"; "insecure" ] ~doc:"Skip TLS certificate verification" 171 171 + and+ verbose = flag [ "v"; "verbose" ] ~doc:"Verbose output (show headers)" 172 172 + and+ head_only = flag [ "I"; "head" ] ~doc:"HEAD request (show headers only)" 173 173 + and+ follow_redirects_flag = 174 174 + flag [ "L"; "location" ] ~doc:"Follow redirects (default: enabled)" 175 175 + and+ no_follow_redirects = 176 176 + flag [ "no-location" ] ~doc:"Do not follow redirects" 177 177 + and+ output_file = 178 178 + named_opt [ "o"; "output" ] string ~doc:"Write output to file" 179 179 + ~value_name:"FILE" 180 180 + and+ websocket = flag [ "w"; "websocket" ] ~doc:"WebSocket mode" 181 181 + and+ ws_message = 182 182 + named_opt [ "ws-message" ] string ~doc:"Message to send in WebSocket mode" 183 183 + ~value_name:"MSG" 184 184 + in 185 185 + 186 186 + (* Parse headers from strings *) 187 187 + let headers = List.map parse_header header_strs in 188 188 + 189 189 + (* Compute actual values *) 190 190 + let method_ = Option.value method_ ~default:"GET" |> String.uppercase_ascii in 191 191 + let follow_redirects = 192 192 + if no_follow_redirects then false 193 193 + else if follow_redirects_flag then true 194 194 + else true (* default *) 195 195 + in 196 196 + 197 197 + (* Initialize RNG for TLS *) 198 198 + Mirage_crypto_rng_unix.use_default (); 199 199 + 200 200 + Eio_main.run @@ fun env -> 201 201 + Eio.Switch.run @@ fun sw -> 202 202 + let net = Eio.Stdenv.net env in 203 203 + let clock = Eio.Stdenv.clock env in 204 204 + 205 205 + (* Determine if this is a WebSocket URL *) 206 206 + let is_ws = 207 207 + websocket 208 208 + || String.length url >= 5 209 209 + && (String.sub url 0 5 = "ws://" 210 210 + || (String.length url >= 6 && String.sub url 0 6 = "wss://")) 211 211 + in 212 212 + 213 213 + if is_ws then begin 214 214 + let tls_config = 215 215 + if insecure then Tls_config.Client.insecure else Tls_config.Client.default 216 216 + in 217 217 + handle_websocket ~sw ~net ~tls_config ~url ~ws_message ~verbose 218 218 + end 219 219 + else 220 220 + handle_http ~sw ~net ~clock ~url ~method_ ~headers ~data ~http2 ~http1 221 221 + ~insecure ~verbose ~head_only ~follow_redirects ~output_file 222 222 + 223 223 + let () = Climate.Command.run command

+360

bin/hs.ml

reviewed

··· 1 1 + (** hs - HTTP file server using HCS. 2 2 + 3 3 + Serves files from a directory over HTTP/1.1 and HTTP/2. *) 4 4 + 5 5 + open Hcs 6 6 + 7 7 + (** MIME type mapping *) 8 8 + let mime_type_of_extension ext = 9 9 + match String.lowercase_ascii ext with 10 10 + | ".html" | ".htm" -> "text/html; charset=utf-8" 11 11 + | ".css" -> "text/css; charset=utf-8" 12 12 + | ".js" | ".mjs" -> "application/javascript; charset=utf-8" 13 13 + | ".json" -> "application/json" 14 14 + | ".xml" -> "application/xml" 15 15 + | ".txt" -> "text/plain; charset=utf-8" 16 16 + | ".md" -> "text/markdown; charset=utf-8" 17 17 + | ".png" -> "image/png" 18 18 + | ".jpg" | ".jpeg" -> "image/jpeg" 19 19 + | ".gif" -> "image/gif" 20 20 + | ".svg" -> "image/svg+xml" 21 21 + | ".ico" -> "image/x-icon" 22 22 + | ".webp" -> "image/webp" 23 23 + | ".avif" -> "image/avif" 24 24 + | ".woff" -> "font/woff" 25 25 + | ".woff2" -> "font/woff2" 26 26 + | ".ttf" -> "font/ttf" 27 27 + | ".otf" -> "font/otf" 28 28 + | ".eot" -> "application/vnd.ms-fontobject" 29 29 + | ".pdf" -> "application/pdf" 30 30 + | ".zip" -> "application/zip" 31 31 + | ".gz" -> "application/gzip" 32 32 + | ".tar" -> "application/x-tar" 33 33 + | ".mp3" -> "audio/mpeg" 34 34 + | ".ogg" -> "audio/ogg" 35 35 + | ".wav" -> "audio/wav" 36 36 + | ".mp4" -> "video/mp4" 37 37 + | ".webm" -> "video/webm" 38 38 + | ".avi" -> "video/x-msvideo" 39 39 + | ".wasm" -> "application/wasm" 40 40 + | ".map" -> "application/json" 41 41 + | _ -> "application/octet-stream" 42 42 + 43 43 + (** Get file extension from path *) 44 44 + let extension path = 45 45 + match String.rindex_opt path '.' with 46 46 + | Some i -> String.sub path i (String.length path - i) 47 47 + | None -> "" 48 48 + 49 49 + (** Normalize and validate path to prevent directory traversal *) 50 50 + let normalize_path path = 51 51 + (* Remove leading slash *) 52 52 + let path = 53 53 + if String.length path > 0 && path.[0] = '/' then 54 54 + String.sub path 1 (String.length path - 1) 55 55 + else path 56 56 + in 57 57 + (* Remove query string *) 58 58 + let path = 59 59 + match String.index_opt path '?' with 60 60 + | Some i -> String.sub path 0 i 61 61 + | None -> path 62 62 + in 63 63 + (* Remove fragment *) 64 64 + let path = 65 65 + match String.index_opt path '#' with 66 66 + | Some i -> String.sub path 0 i 67 67 + | None -> path 68 68 + in 69 69 + (* Check for directory traversal attempts *) 70 70 + let segments = String.split_on_char '/' path in 71 71 + let rec check_segments acc = function 72 72 + | [] -> Some (String.concat "/" (List.rev acc)) 73 73 + | ".." :: _ -> None (* Reject any path with .. *) 74 74 + | "." :: rest -> check_segments acc rest 75 75 + | "" :: rest -> check_segments acc rest 76 76 + | seg :: rest -> 77 77 + if String.contains seg '\x00' then None 78 78 + else check_segments (seg :: acc) rest 79 79 + in 80 80 + check_segments [] segments 81 81 + 82 82 + (** HTML escape for directory listing *) 83 83 + let html_escape s = 84 84 + let buf = Buffer.create (String.length s) in 85 85 + String.iter 86 86 + (function 87 87 + | '<' -> Buffer.add_string buf "&lt;" 88 88 + | '>' -> Buffer.add_string buf "&gt;" 89 89 + | '&' -> Buffer.add_string buf "&amp;" 90 90 + | '"' -> Buffer.add_string buf "&quot;" 91 91 + | c -> Buffer.add_char buf c) 92 92 + s; 93 93 + Buffer.contents buf 94 94 + 95 95 + (** Generate directory listing HTML *) 96 96 + let directory_listing ~path entries = 97 97 + let buf = Buffer.create 4096 in 98 98 + Buffer.add_string buf "<!DOCTYPE html>\n<html>\n<head>\n"; 99 99 + Buffer.add_string buf "<meta charset=\"utf-8\">\n"; 100 100 + Buffer.add_string buf 101 101 + "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n"; 102 102 + Printf.bprintf buf "<title>Index of /%s</title>\n" (html_escape path); 103 103 + Buffer.add_string buf "<style>\n"; 104 104 + Buffer.add_string buf 105 105 + "body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', \ 106 106 + Roboto, sans-serif; margin: 2em; }\n"; 107 107 + Buffer.add_string buf "h1 { font-weight: normal; }\n"; 108 108 + Buffer.add_string buf 109 109 + "table { border-collapse: collapse; width: 100%; max-width: 800px; }\n"; 110 110 + Buffer.add_string buf "th, td { text-align: left; padding: 0.5em 1em; }\n"; 111 111 + Buffer.add_string buf "th { border-bottom: 2px solid #333; }\n"; 112 112 + Buffer.add_string buf "tr:hover { background: #f5f5f5; }\n"; 113 113 + Buffer.add_string buf "a { color: #0066cc; text-decoration: none; }\n"; 114 114 + Buffer.add_string buf "a:hover { text-decoration: underline; }\n"; 115 115 + Buffer.add_string buf ".size { color: #666; }\n"; 116 116 + Buffer.add_string buf "</style>\n</head>\n<body>\n"; 117 117 + Printf.bprintf buf "<h1>Index of /%s</h1>\n" (html_escape path); 118 118 + Buffer.add_string buf "<table>\n<thead>\n<tr>"; 119 119 + Buffer.add_string buf "<th>Name</th><th>Size</th>"; 120 120 + Buffer.add_string buf "</tr>\n</thead>\n<tbody>\n"; 121 121 + 122 122 + (* Parent directory link *) 123 123 + if path <> "" then begin 124 124 + Buffer.add_string buf "<tr><td><a href=\"../\">..</a></td><td>-</td></tr>\n" 125 125 + end; 126 126 + 127 127 + (* Sort entries: directories first, then files *) 128 128 + let sorted = 129 129 + List.sort 130 130 + (fun (a, a_is_dir) (b, b_is_dir) -> 131 131 + match (a_is_dir, b_is_dir) with 132 132 + | true, false -> -1 133 133 + | false, true -> 1 134 134 + | _ -> String.compare a b) 135 135 + entries 136 136 + in 137 137 + 138 138 + List.iter 139 139 + (fun (name, is_dir) -> 140 140 + let display_name = if is_dir then name ^ "/" else name in 141 141 + let href = if is_dir then name ^ "/" else name in 142 142 + let size = if is_dir then "-" else "" in 143 143 + Printf.bprintf buf 144 144 + "<tr><td><a href=\"%s\">%s</a></td><td class=\"size\">%s</td></tr>\n" 145 145 + (html_escape href) (html_escape display_name) size) 146 146 + sorted; 147 147 + 148 148 + Buffer.add_string buf "</tbody>\n</table>\n"; 149 149 + Buffer.add_string buf "<hr>\n<p><em>Served by hs (HCS)</em></p>\n"; 150 150 + Buffer.add_string buf "</body>\n</html>\n"; 151 151 + Buffer.contents buf 152 152 + 153 153 + (** Create the file server handler *) 154 154 + let make_handler ~fs ~root ~index_file ~enable_listing ~enable_cors ~verbose = 155 155 + fun (req : Server.request) -> 156 156 + let start_time = Unix.gettimeofday () in 157 157 + let target = req.target in 158 158 + 159 159 + (* Normalize path *) 160 160 + let path = normalize_path target in 161 161 + 162 162 + let response = 163 163 + match path with 164 164 + | None -> 165 165 + (* Invalid path (directory traversal attempt) *) 166 166 + Server.respond ~status:`Forbidden "Forbidden" 167 167 + | Some path -> ( 168 168 + let full_path = Eio.Path.(fs / root / path) in 169 169 + try 170 170 + (* Try to get file info *) 171 171 + let stat = Eio.Path.stat ~follow:true full_path in 172 172 + match stat.kind with 173 173 + | `Directory -> ( 174 174 + (* Try index file first *) 175 175 + let index_result = 176 176 + match index_file with 177 177 + | Some idx -> ( 178 178 + try 179 179 + let idx_path = Eio.Path.(full_path / idx) in 180 180 + let content = Eio.Path.load idx_path in 181 181 + let content_type = 182 182 + mime_type_of_extension (extension idx) 183 183 + in 184 184 + Some 185 185 + { 186 186 + Server.status = `OK; 187 187 + headers = 188 188 + [ 189 189 + ("Content-Type", content_type); 190 190 + ( "Content-Length", 191 191 + string_of_int (String.length content) ); 192 192 + ]; 193 193 + body = Server.Body_string content; 194 194 + } 195 195 + with _ -> None) 196 196 + | None -> None 197 197 + in 198 198 + match index_result with 199 199 + | Some resp -> resp 200 200 + | None -> 201 201 + if enable_listing then begin 202 202 + (* Generate directory listing *) 203 203 + let entries = 204 204 + Eio.Path.read_dir full_path 205 205 + |> List.filter_map (fun name -> 206 206 + try 207 207 + let child_path = Eio.Path.(full_path / name) in 208 208 + let child_stat = 209 209 + Eio.Path.stat ~follow:true child_path 210 210 + in 211 211 + let is_dir = child_stat.kind = `Directory in 212 212 + Some (name, is_dir) 213 213 + with _ -> None) 214 214 + in 215 215 + let html = directory_listing ~path entries in 216 216 + { 217 217 + Server.status = `OK; 218 218 + headers = 219 219 + [ 220 220 + ("Content-Type", "text/html; charset=utf-8"); 221 221 + ("Content-Length", string_of_int (String.length html)); 222 222 + ]; 223 223 + body = Server.Body_string html; 224 224 + } 225 225 + end 226 226 + else 227 227 + Server.respond ~status:`Forbidden 228 228 + "Directory listing disabled") 229 229 + | `Regular_file -> 230 230 + (* Serve the file *) 231 231 + let content = Eio.Path.load full_path in 232 232 + let content_type = mime_type_of_extension (extension path) in 233 233 + { 234 234 + Server.status = `OK; 235 235 + headers = 236 236 + [ 237 237 + ("Content-Type", content_type); 238 238 + ("Content-Length", string_of_int (String.length content)); 239 239 + ]; 240 240 + body = Server.Body_string content; 241 241 + } 242 242 + | _ -> Server.respond ~status:`Forbidden "Not a file" 243 243 + with 244 244 + | Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> 245 245 + Server.respond ~status:`Not_found "Not Found" 246 246 + | Eio.Io (Eio.Fs.E (Eio.Fs.Permission_denied _), _) -> 247 247 + Server.respond ~status:`Forbidden "Permission Denied" 248 248 + | exn -> 249 249 + if verbose then 250 250 + Printf.eprintf "Error serving %s: %s\n%!" target 251 251 + (Printexc.to_string exn); 252 252 + Server.respond ~status:`Internal_server_error 253 253 + "Internal Server Error") 254 254 + in 255 255 + 256 256 + (* Add CORS headers if enabled *) 257 257 + let response = 258 258 + if enable_cors then 259 259 + { 260 260 + response with 261 261 + headers = 262 262 + ("Access-Control-Allow-Origin", "*") 263 263 + :: ("Access-Control-Allow-Methods", "GET, HEAD, OPTIONS") 264 264 + :: ("Access-Control-Allow-Headers", "*") 265 265 + :: response.headers; 266 266 + } 267 267 + else response 268 268 + in 269 269 + 270 270 + (* Log request if verbose *) 271 271 + if verbose then begin 272 272 + let duration = (Unix.gettimeofday () -. start_time) *. 1000.0 in 273 273 + let status_code = H1.Status.to_code response.status in 274 274 + Printf.printf "%s %s -> %d (%.2fms)\n%!" 275 275 + (H1.Method.to_string req.meth) 276 276 + target status_code duration 277 277 + end; 278 278 + 279 279 + response 280 280 + 281 281 + let command = 282 282 + Climate.Command.singleton 283 283 + ~doc:"HTTP file server using HCS - serves files over HTTP/1.1 and HTTP/2" 284 284 + @@ 285 285 + let open Climate.Arg_parser in 286 286 + let+ directory = 287 287 + pos_with_default 0 string ~default:"." ~value_name:"DIRECTORY" 288 288 + ~doc:"Directory to serve" 289 289 + and+ port = 290 290 + named_opt [ "p"; "port" ] int ~value_name:"PORT" 291 291 + ~doc:"Port to listen on (default: 8080)" 292 292 + and+ bind_address = 293 293 + named_opt [ "b"; "bind" ] string ~value_name:"ADDRESS" 294 294 + ~doc:"Address to bind to (default: 0.0.0.0)" 295 295 + and+ domains = 296 296 + named_opt [ "d"; "domains" ] int ~value_name:"N" 297 297 + ~doc:"Number of domains/threads (default: CPU count)" 298 298 + and+ http1 = flag [ "1"; "http1" ] ~doc:"HTTP/1.1 only (fastest)" 299 299 + and+ http2 = flag [ "2"; "http2" ] ~doc:"HTTP/2 only" 300 300 + and+ index_opt = 301 301 + named_opt [ "index" ] string ~value_name:"FILE" 302 302 + ~doc:"Index file for directories (default: index.html)" 303 303 + and+ no_index = flag [ "no-index" ] ~doc:"Disable index file lookup" 304 304 + and+ enable_listing = flag [ "list" ] ~doc:"Enable directory listing" 305 305 + and+ enable_cors = flag [ "cors" ] ~doc:"Enable CORS headers" 306 306 + and+ verbose = flag [ "v"; "verbose" ] ~doc:"Verbose logging" in 307 307 + 308 308 + let port = Option.value port ~default:8080 in 309 309 + let bind_address = Option.value bind_address ~default:"0.0.0.0" in 310 310 + let domains = 311 311 + Option.value domains ~default:(Domain.recommended_domain_count ()) 312 312 + in 313 313 + let index_file = 314 314 + if no_index then None 315 315 + else Some (Option.value index_opt ~default:"index.html") 316 316 + in 317 317 + 318 318 + if not (Sys.file_exists directory && Sys.is_directory directory) then begin 319 319 + Printf.eprintf "Error: Directory '%s' does not exist\n" directory; 320 320 + exit 1 321 321 + end; 322 322 + 323 323 + let protocol = 324 324 + if http1 then Server.Http1_only 325 325 + else if http2 then Server.Http2_only 326 326 + else Server.Http1_only 327 327 + in 328 328 + 329 329 + Printf.printf "Serving %s on http://%s:%d\n%!" 330 330 + (if directory = "." then "current directory" else directory) 331 331 + bind_address port; 332 332 + Printf.printf "Protocol: %s, Domains: %d\n%!" 333 333 + (match protocol with 334 334 + | Server.Http1_only -> "HTTP/1.1" 335 335 + | Server.Http2_only -> "HTTP/2" 336 336 + | Server.Auto -> "Auto" 337 337 + | Server.Auto_websocket -> "Auto+WebSocket") 338 338 + domains; 339 339 + if enable_listing then Printf.printf "Directory listing: enabled\n%!"; 340 340 + if enable_cors then Printf.printf "CORS: enabled\n%!"; 341 341 + Printf.printf "Press Ctrl+C to stop\n%!\n"; 342 342 + 343 343 + Eio_main.run @@ fun env -> 344 344 + Eio.Switch.run @@ fun sw -> 345 345 + let net = Eio.Stdenv.net env in 346 346 + let fs = Eio.Stdenv.fs env in 347 347 + let domain_mgr = Eio.Stdenv.domain_mgr env in 348 348 + 349 349 + let handler = 350 350 + make_handler ~fs ~root:directory ~index_file ~enable_listing ~enable_cors 351 351 + ~verbose 352 352 + in 353 353 + 354 354 + let config = 355 355 + { Server.default_config with port; domain_count = domains; protocol } 356 356 + in 357 357 + 358 358 + Server.run_parallel ~sw ~net ~domain_mgr ~config handler 359 359 + 360 360 + let () = Climate.Command.run command

+48

dune-project

reviewed

··· 1 1 + (lang dune 3.20) 2 2 + 3 3 + (name hcs) 4 4 + 5 5 + (generate_opam_files true) 6 6 + 7 7 + (source 8 8 + ; (tangled @gdiazlo.tngl.sh/hcs) 9 9 + (uri https://tangled.org/gdiazlo.tngl.sh/hcs)) 10 10 + 11 11 + (authors "Gabriel Díaz") 12 12 + 13 13 + (maintainers "Gabriel Díaz") 14 14 + 15 15 + (license ISC) 16 16 + (homepage https://tangled.org/gdiazlo.tngl.sh/hcs) 17 17 + (bug_reports https://tangled.org/gdiazlo.tngl.sh/hcs/issues) 18 18 + (documentation https://tangled.org/gdiazlo.tngl.sh/hcs) 19 19 + 20 20 + (package 21 21 + (name hcs) 22 22 + (synopsis "Eio based HTTP client/server library for OCaml 5+") 23 23 + (description 24 24 + "HCS is a HTTP client/server library for OCaml 5+ supporting HTTP/1.1, HTTP/2, and WebSocket. Built on Eio.") 25 25 + (depends 26 26 + (ocaml (>= 5.4)) 27 27 + (dune (>= 3.20)) 28 28 + (eio (>= 1.2)) 29 29 + (eio_main (>= 1.2)) 30 30 + (h1 (>= 1.0)) 31 31 + (h2 (>= 0.13)) 32 32 + (tls (>= 2.0)) 33 33 + (tls-eio (>= 2.0)) 34 34 + (ca-certs (>= 1.0)) 35 35 + (x509 (>= 1.0)) 36 36 + (mirage-crypto-rng (>= 1.0)) 37 37 + (uri (>= 4.4)) 38 38 + (ptime (>= 1.2)) 39 39 + (cstruct (>= 6.2)) 40 40 + (digestif (>= 1.2)) 41 41 + (base64 (>= 3.5)) 42 42 + (bigstringaf (>= 0.10)) 43 43 + (faraday (>= 0.8)) 44 44 + (climate (>= 0.9)) 45 45 + (alcotest (and (>= 1.9) :with-test)) 46 46 + (qcheck (and (>= 0.21) :with-test)) 47 47 + (qcheck-alcotest (and (>= 0.21) :with-test)) 48 48 + (yojson :with-test)))

+50

hcs.opam

reviewed

··· 1 1 + # This file is generated by dune, edit dune-project instead 2 2 + opam-version: "2.0" 3 3 + synopsis: "Eio based HTTP client/server library for OCaml 5+" 4 4 + description: 5 5 + "HCS is a HTTP client/server library for OCaml 5+ supporting HTTP/1.1, HTTP/2, and WebSocket. Built on Eio." 6 6 + maintainer: ["Gabriel Díaz"] 7 7 + authors: ["Gabriel Díaz"] 8 8 + license: "ISC" 9 9 + depends: [ 10 10 + "ocaml" {>= "5.4"} 11 11 + "dune" {>= "3.20" & >= "3.20"} 12 12 + "eio" {>= "1.2"} 13 13 + "eio_main" {>= "1.2"} 14 14 + "h1" {>= "1.0"} 15 15 + "h2" {>= "0.13"} 16 16 + "tls" {>= "2.0"} 17 17 + "tls-eio" {>= "2.0"} 18 18 + "ca-certs" {>= "1.0"} 19 19 + "x509" {>= "1.0"} 20 20 + "mirage-crypto-rng" {>= "1.0"} 21 21 + "uri" {>= "4.4"} 22 22 + "ptime" {>= "1.2"} 23 23 + "cstruct" {>= "6.2"} 24 24 + "digestif" {>= "1.2"} 25 25 + "base64" {>= "3.5"} 26 26 + "bigstringaf" {>= "0.10"} 27 27 + "faraday" {>= "0.8"} 28 28 + "climate" {>= "0.9"} 29 29 + "alcotest" {>= "1.9" & with-test} 30 30 + "qcheck" {>= "0.21" & with-test} 31 31 + "qcheck-alcotest" {>= "0.21" & with-test} 32 32 + "yojson" {with-test} 33 33 + "odoc" {with-doc} 34 34 + ] 35 35 + build: [ 36 36 + ["dune" "subst"] {dev} 37 37 + [ 38 38 + "dune" 39 39 + "build" 40 40 + "-p" 41 41 + name 42 42 + "-j" 43 43 + jobs 44 44 + "@install" 45 45 + "@runtest" {with-test} 46 46 + "@doc" {with-doc} 47 47 + ] 48 48 + ] 49 49 + dev-repo: "https://tangled.org/gdiazlo.tngl.sh/hcs" 50 50 + x-maintenance-intent: ["(latest)"]

+220

lib/client.ml

reviewed

··· 1 1 + (** Unified HTTP Client supporting HTTP/1.1 and HTTP/2. 2 2 + 3 3 + This module provides a high-level HTTP client that automatically selects the 4 4 + appropriate protocol based on ALPN negotiation or configuration. *) 5 5 + 6 6 + (** {1 Types} *) 7 7 + 8 8 + (** Protocol version *) 9 9 + type protocol = HTTP_1_1 | HTTP_2 10 10 + 11 11 + type config = { 12 12 + (* Timeouts *) 13 13 + connect_timeout : float; (** Connection timeout in seconds. Default: 30.0 *) 14 14 + read_timeout : float; (** Read timeout in seconds. Default: 30.0 *) 15 15 + write_timeout : float; (** Write timeout in seconds. Default: 30.0 *) 16 16 + (* Behavior *) 17 17 + follow_redirects : int option; 18 18 + (** Max redirects to follow. None = don't follow. Default: Some 10 *) 19 19 + preferred_protocol : protocol option; 20 20 + (** Preferred protocol. None = auto-detect via ALPN. Default: None *) 21 21 + (* Buffers *) 22 22 + buffer_size : int; (** Read buffer size. Default: 16384 *) 23 23 + max_response_body : int64 option; 24 24 + (** Max response body size. None = unlimited. Default: None *) 25 25 + (* TLS *) 26 26 + tls : Tls_config.Client.t; (** TLS configuration for HTTP/1.1 *) 27 27 + (* Headers *) 28 28 + default_headers : (string * string) list; 29 29 + (** Headers to add to every request *) 30 30 + } 31 31 + (** Client configuration *) 32 32 + 33 33 + let default_config = 34 34 + { 35 35 + connect_timeout = 30.0; 36 36 + read_timeout = 30.0; 37 37 + write_timeout = 30.0; 38 38 + follow_redirects = Some 10; 39 39 + preferred_protocol = Some HTTP_1_1; 40 40 + (* Default to HTTP/1.1 for broader compatibility *) 41 41 + buffer_size = 16384; 42 42 + max_response_body = None; 43 43 + tls = Tls_config.Client.default; 44 44 + (* HTTP/1.1 ALPN *) 45 45 + default_headers = [ ("User-Agent", "hcs/0.1.0") ]; 46 46 + } 47 47 + 48 48 + (** {2 Config builders} *) 49 49 + 50 50 + let with_timeout timeout config = 51 51 + { config with connect_timeout = timeout; read_timeout = timeout } 52 52 + 53 53 + let with_connect_timeout timeout config = 54 54 + { config with connect_timeout = timeout } 55 55 + 56 56 + let with_read_timeout timeout config = { config with read_timeout = timeout } 57 57 + let with_write_timeout timeout config = { config with write_timeout = timeout } 58 58 + 59 59 + let with_redirects max_redirects config = 60 60 + { config with follow_redirects = Some max_redirects } 61 61 + 62 62 + let without_redirects config = { config with follow_redirects = None } 63 63 + let with_buffer_size size config = { config with buffer_size = size } 64 64 + 65 65 + let with_max_response_body max_size config = 66 66 + { config with max_response_body = Some max_size } 67 67 + 68 68 + let with_tls tls config = { config with tls } 69 69 + let with_insecure_tls config = { config with tls = Tls_config.Client.insecure } 70 70 + 71 71 + let with_http2 config = 72 72 + { config with preferred_protocol = Some HTTP_2; tls = Tls_config.Client.h2 } 73 73 + 74 74 + let with_http11 config = 75 75 + { 76 76 + config with 77 77 + preferred_protocol = Some HTTP_1_1; 78 78 + tls = Tls_config.Client.default; 79 79 + } 80 80 + 81 81 + let with_default_header name value config = 82 82 + { config with default_headers = (name, value) :: config.default_headers } 83 83 + 84 84 + let with_default_headers headers config = 85 85 + { config with default_headers = headers @ config.default_headers } 86 86 + 87 87 + (** Error type for client operations *) 88 88 + type error = 89 89 + | Connection_failed of string 90 90 + | Tls_error of string 91 91 + | Protocol_error of string 92 92 + | Timeout 93 93 + | Invalid_response of string 94 94 + | Too_many_redirects 95 95 + 96 96 + type response = { 97 97 + status : int; 98 98 + headers : (string * string) list; 99 99 + body : string; 100 100 + protocol : protocol; 101 101 + } 102 102 + (** Response type - unified across protocols *) 103 103 + 104 104 + (** {1 Internal helpers} *) 105 105 + 106 106 + let h1_status_to_int status = H1.Status.to_code status 107 107 + let h2_status_to_int status = H2.Status.to_code status 108 108 + 109 109 + let h1_headers_to_list headers = 110 110 + let result = ref [] in 111 111 + H1.Headers.iter 112 112 + ~f:(fun name value -> result := (name, value) :: !result) 113 113 + headers; 114 114 + List.rev !result 115 115 + 116 116 + let h2_headers_to_list headers = 117 117 + let result = ref [] in 118 118 + H2.Headers.iter 119 119 + ~f:(fun name value -> result := (name, value) :: !result) 120 120 + headers; 121 121 + List.rev !result 122 122 + 123 123 + (** {1 Public API} *) 124 124 + 125 125 + (** Perform an HTTP GET request. The protocol is selected based on: 1. 126 126 + config.preferred_protocol if set 2. ALPN negotiation if using HTTPS 3. 127 127 + HTTP/1.1 for plain HTTP *) 128 128 + let get ~sw ~net ~clock ?(config = default_config) url = 129 129 + let uri = Uri.of_string url in 130 130 + let scheme = Uri.scheme uri |> Option.value ~default:"http" in 131 131 + let is_https = String.equal scheme "https" in 132 132 + 133 133 + let use_h2 = 134 134 + match config.preferred_protocol with 135 135 + | Some HTTP_2 -> true 136 136 + | Some HTTP_1_1 -> false 137 137 + | None -> ( 138 138 + is_https 139 139 + && 140 140 + match config.tls.alpn_protocols with 141 141 + | Some protos -> List.mem Tls_config.alpn_h2 protos 142 142 + | None -> false) 143 143 + in 144 144 + 145 145 + if use_h2 then 146 146 + (* Use HTTP/2 *) 147 147 + match H2_client.get ~sw ~net ~clock url with 148 148 + | Ok resp -> 149 149 + Ok 150 150 + { 151 151 + status = h2_status_to_int resp.H2_client.status; 152 152 + headers = h2_headers_to_list resp.headers; 153 153 + body = resp.body; 154 154 + protocol = HTTP_2; 155 155 + } 156 156 + | Error (H2_client.Connection_failed msg) -> Error (Connection_failed msg) 157 157 + | Error (H2_client.Tls_error msg) -> Error (Tls_error msg) 158 158 + | Error (H2_client.Protocol_error msg) -> Error (Protocol_error msg) 159 159 + | Error H2_client.Timeout -> Error Timeout 160 160 + | Error (H2_client.Invalid_response msg) -> Error (Invalid_response msg) 161 161 + else 162 162 + (* Use HTTP/1.1 *) 163 163 + let h1_config : H1_client.config = 164 164 + { 165 165 + connect_timeout = config.connect_timeout; 166 166 + read_timeout = config.read_timeout; 167 167 + write_timeout = config.write_timeout; 168 168 + follow_redirects = config.follow_redirects; 169 169 + buffer_size = config.buffer_size; 170 170 + max_response_body = config.max_response_body; 171 171 + tls = config.tls; 172 172 + default_headers = config.default_headers; 173 173 + } 174 174 + in 175 175 + match H1_client.get ~sw ~net ~clock ~config:h1_config url with 176 176 + | Ok resp -> 177 177 + Ok 178 178 + { 179 179 + status = h1_status_to_int resp.H1_client.status; 180 180 + headers = h1_headers_to_list resp.headers; 181 181 + body = resp.body; 182 182 + protocol = HTTP_1_1; 183 183 + } 184 184 + | Error (H1_client.Connection_failed msg) -> Error (Connection_failed msg) 185 185 + | Error (H1_client.Tls_error msg) -> Error (Tls_error msg) 186 186 + | Error H1_client.Timeout -> Error Timeout 187 187 + | Error (H1_client.Invalid_response msg) -> Error (Invalid_response msg) 188 188 + | Error H1_client.Too_many_redirects -> Error Too_many_redirects 189 189 + 190 190 + (** Perform an HTTP POST request *) 191 191 + let post ~sw ~net ~clock ?(config = default_config) url ~body:request_body = 192 192 + (* For now, POST only uses HTTP/1.1 - H2 POST can be added later *) 193 193 + let h1_config : H1_client.config = 194 194 + { 195 195 + connect_timeout = config.connect_timeout; 196 196 + read_timeout = config.read_timeout; 197 197 + write_timeout = config.write_timeout; 198 198 + follow_redirects = config.follow_redirects; 199 199 + buffer_size = config.buffer_size; 200 200 + max_response_body = config.max_response_body; 201 201 + tls = config.tls; 202 202 + default_headers = config.default_headers; 203 203 + } 204 204 + in 205 205 + match 206 206 + H1_client.post ~sw ~net ~clock ~config:h1_config url ~body:request_body 207 207 + with 208 208 + | Ok resp -> 209 209 + Ok 210 210 + { 211 211 + status = h1_status_to_int resp.H1_client.status; 212 212 + headers = h1_headers_to_list resp.headers; 213 213 + body = resp.body; 214 214 + protocol = HTTP_1_1; 215 215 + } 216 216 + | Error (H1_client.Connection_failed msg) -> Error (Connection_failed msg) 217 217 + | Error (H1_client.Tls_error msg) -> Error (Tls_error msg) 218 218 + | Error H1_client.Timeout -> Error Timeout 219 219 + | Error (H1_client.Invalid_response msg) -> Error (Invalid_response msg) 220 220 + | Error H1_client.Too_many_redirects -> Error Too_many_redirects

+206

lib/codec.ml

reviewed

··· 1 1 + (** CODEC module for type-safe serialization/deserialization. 2 2 + 3 3 + This module provides a signature for codecs that can encode and decode 4 4 + values to/from binary buffers. Users implement this signature with their 5 5 + preferred serialization library (yojson, jsonm, msgpck, etc.). 6 6 + 7 7 + The library itself does not depend on any specific serialization library. *) 8 8 + 9 9 + (** {1 CODEC Signature} *) 10 10 + 11 11 + (** Module signature for codecs. 12 12 + 13 13 + Codecs provide encoding/decoding between OCaml values and binary buffers. 14 14 + The Cstruct.t type is used for efficient zero-copy binary handling. *) 15 15 + module type CODEC = sig 16 16 + type 'a encoder 17 17 + (** Encoder for type 'a - converts values to binary format *) 18 18 + 19 19 + type 'a decoder 20 20 + (** Decoder for type 'a - parses values from binary format *) 21 21 + 22 22 + val content_type : string 23 23 + (** Content-Type header value for this codec. Examples: "application/json", 24 24 + "application/msgpack", "application/cbor" *) 25 25 + 26 26 + val encode : 'a encoder -> 'a -> (Cstruct.t, string) result 27 27 + (** Encode a value to a buffer. Returns Error with message on encoding 28 28 + failure. *) 29 29 + 30 30 + val decode : 'a decoder -> Cstruct.t -> ('a, string) result 31 31 + (** Decode a value from a buffer. Returns Error with message on decoding 32 32 + failure. *) 33 33 + 34 34 + val encode_stream : 'a encoder -> 'a -> Cstruct.t Seq.t option 35 35 + (** Optional: Streaming encode for large payloads. Returns None if streaming 36 36 + is not supported. *) 37 37 + 38 38 + val decode_stream : 39 39 + 'a decoder -> Cstruct.t Seq.t -> ('a, string) result option 40 40 + (** Optional: Streaming decode for large payloads. Returns None if streaming 41 41 + is not supported. *) 42 42 + end 43 43 + 44 44 + (** {1 With_codec Functor} *) 45 45 + 46 46 + (** Error type for codec operations *) 47 47 + type codec_error = 48 48 + | Encode_error of string 49 49 + | Decode_error of string 50 50 + | Unsupported_body_type 51 51 + 52 52 + let codec_error_to_string = function 53 53 + | Encode_error msg -> "Encode error: " ^ msg 54 54 + | Decode_error msg -> "Decode error: " ^ msg 55 55 + | Unsupported_body_type -> "Unsupported body type for codec operation" 56 56 + 57 57 + (** Functor that provides helpers for working with a specific codec. 58 58 + 59 59 + This functor generates request/response helpers that automatically set 60 60 + Content-Type headers and handle encoding/decoding. *) 61 61 + module With_codec (C : CODEC) = struct 62 62 + (** Encode a value to a string body *) 63 63 + let encode_body encoder value = 64 64 + match C.encode encoder value with 65 65 + | Ok buf -> Ok (Cstruct.to_string buf) 66 66 + | Error msg -> Error (Encode_error msg) 67 67 + 68 68 + (** Decode a string body to a value *) 69 69 + let decode_body decoder body_str = 70 70 + let buf = Cstruct.of_string body_str in 71 71 + match C.decode decoder buf with 72 72 + | Ok value -> Ok value 73 73 + | Error msg -> Error (Decode_error msg) 74 74 + 75 75 + (** Encode a value directly to Cstruct *) 76 76 + let encode encoder value = 77 77 + match C.encode encoder value with 78 78 + | Ok buf -> Ok buf 79 79 + | Error msg -> Error (Encode_error msg) 80 80 + 81 81 + (** Decode a Cstruct to a value *) 82 82 + let decode decoder buf = 83 83 + match C.decode decoder buf with 84 84 + | Ok value -> Ok value 85 85 + | Error msg -> Error (Decode_error msg) 86 86 + 87 87 + (** Get the content type for this codec *) 88 88 + let content_type = C.content_type 89 89 + end 90 90 + 91 91 + (** {1 Example Implementations} 92 92 + 93 93 + These are examples showing how to implement codecs. Users should implement 94 94 + their own codecs with their preferred libraries. 95 95 + 96 96 + {2 JSON Example} 97 97 + 98 98 + {[ 99 99 + module Json_codec : Hcs.Codec.CODEC = struct 100 100 + (* Using yojson as an example *) 101 101 + type 'a encoder = 'a -> Yojson.Safe.t 102 102 + type 'a decoder = Yojson.Safe.t -> ('a, string) result 103 103 + 104 104 + let content_type = "application/json" 105 105 + 106 106 + let encode enc value = 107 107 + try Ok (Cstruct.of_string (Yojson.Safe.to_string (enc value))) 108 108 + with exn -> Error (Printexc.to_string exn) 109 109 + 110 110 + let decode dec buf = 111 111 + try 112 112 + let json = Yojson.Safe.from_string (Cstruct.to_string buf) in 113 113 + dec json 114 114 + with exn -> Error (Printexc.to_string exn) 115 115 + 116 116 + let encode_stream _ _ = None 117 117 + let decode_stream _ _ = None 118 118 + end 119 119 + ]} 120 120 + 121 121 + {2 MessagePack Example} 122 122 + 123 123 + {[ 124 124 + module Msgpack_codec : Hcs.Codec.CODEC = struct 125 125 + type 'a encoder = 'a -> Msgpck.t 126 126 + type 'a decoder = Msgpck.t -> ('a, string) result 127 127 + 128 128 + let content_type = "application/msgpack" 129 129 + 130 130 + let encode enc value = 131 131 + try 132 132 + let packed = 133 133 + Msgpck.Bytes.to_string (Msgpck.Bytes.of_msgpck (enc value)) 134 134 + in 135 135 + Ok (Cstruct.of_string packed) 136 136 + with exn -> Error (Printexc.to_string exn) 137 137 + 138 138 + let decode dec buf = 139 139 + try 140 140 + match 141 141 + Msgpck.Bytes.read (Bytes.of_string (Cstruct.to_string buf)) 142 142 + with 143 143 + | Some (msgpack, _) -> dec msgpack 144 144 + | None -> Error "Failed to parse msgpack" 145 145 + with exn -> Error (Printexc.to_string exn) 146 146 + 147 147 + let encode_stream _ _ = None 148 148 + let decode_stream _ _ = None 149 149 + end 150 150 + ]} 151 151 + 152 152 + {2 Plain Text Codec} 153 153 + 154 154 + {[ 155 155 + module Text_codec : Hcs.Codec.CODEC = struct 156 156 + type 'a encoder = 'a -> string 157 157 + type 'a decoder = string -> ('a, string) result 158 158 + 159 159 + let content_type = "text/plain; charset=utf-8" 160 160 + let encode enc value = Ok (Cstruct.of_string (enc value)) 161 161 + let decode dec buf = dec (Cstruct.to_string buf) 162 162 + let encode_stream _ _ = None 163 163 + let decode_stream _ _ = None 164 164 + end 165 165 + ]} *) 166 166 + 167 167 + (** {1 Built-in Identity Codec} 168 168 + 169 169 + A simple pass-through codec for raw binary data. *) 170 170 + module Identity_codec : 171 171 + CODEC 172 172 + with type 'a encoder = 'a -> Cstruct.t 173 173 + and type 'a decoder = Cstruct.t -> ('a, string) result = struct 174 174 + type 'a encoder = 'a -> Cstruct.t 175 175 + type 'a decoder = Cstruct.t -> ('a, string) result 176 176 + 177 177 + let content_type = "application/octet-stream" 178 178 + 179 179 + let encode enc value = 180 180 + try Ok (enc value) with exn -> Error (Printexc.to_string exn) 181 181 + 182 182 + let decode dec buf = dec buf 183 183 + let encode_stream _ _ = None 184 184 + let decode_stream _ _ = None 185 185 + end 186 186 + 187 187 + (** {1 Built-in String Codec} 188 188 + 189 189 + A simple codec for UTF-8 text. *) 190 190 + module String_codec : 191 191 + CODEC 192 192 + with type 'a encoder = 'a -> string 193 193 + and type 'a decoder = string -> ('a, string) result = struct 194 194 + type 'a encoder = 'a -> string 195 195 + type 'a decoder = string -> ('a, string) result 196 196 + 197 197 + let content_type = "text/plain; charset=utf-8" 198 198 + 199 199 + let encode enc value = 200 200 + try Ok (Cstruct.of_string (enc value)) 201 201 + with exn -> Error (Printexc.to_string exn) 202 202 + 203 203 + let decode dec buf = dec (Cstruct.to_string buf) 204 204 + let encode_stream _ _ = None 205 205 + let decode_stream _ _ = None 206 206 + end

+166

lib/control.ml

reviewed

··· 1 1 + (** Control flow combinators for HCS. 2 2 + 3 3 + This module provides runtime-agnostic control flow patterns: 4 4 + - Retry with backoff 5 5 + - Circuit breaker 6 6 + - Rate limiting state 7 7 + 8 8 + Time and sleep operations are passed as parameters to keep this module pure 9 9 + and compatible with any runtime (Eio, Lwt). *) 10 10 + 11 11 + (** Backoff strategies *) 12 12 + module Backoff = struct 13 13 + (** Constant delay between retries *) 14 14 + let constant delay _attempt = delay 15 15 + 16 16 + (** Exponential backoff: base * 2^attempt *) 17 17 + let exponential ~base attempt = base *. Float.pow 2.0 (Float.of_int attempt) 18 18 + 19 19 + (** Exponential backoff with jitter *) 20 20 + let exponential_jitter ~base ~jitter attempt = 21 21 + let delay = exponential ~base attempt in 22 22 + let jitter_amount = delay *. jitter *. (Random.float 2.0 -. 1.0) in 23 23 + max 0.0 (delay +. jitter_amount) 24 24 + 25 25 + (** Linear backoff: base * attempt *) 26 26 + let linear ~base attempt = base *. Float.of_int (attempt + 1) 27 27 + 28 28 + (** Capped backoff: applies cap to any strategy *) 29 29 + let capped ~max_delay strategy attempt = min max_delay (strategy attempt) 30 30 + end 31 31 + 32 32 + type retry_config = { 33 33 + max_attempts : int; 34 34 + backoff : int -> float; (** attempt -> delay in seconds *) 35 35 + should_retry : exn -> bool; (** Which exceptions to retry *) 36 36 + } 37 37 + (** Retry configuration *) 38 38 + 39 39 + let default_retry_config = 40 40 + { 41 41 + max_attempts = 3; 42 42 + backoff = Backoff.exponential ~base:1.0; 43 43 + should_retry = (fun _ -> true); 44 44 + } 45 45 + 46 46 + (** Retry with backoff. [sleep] is provided by the runtime (e.g., 47 47 + Eio.Time.sleep) *) 48 48 + let with_retry ~sleep ~config f = 49 49 + let rec loop attempt = 50 50 + match f () with 51 51 + | result -> Ok result 52 52 + | exception exn 53 53 + when config.should_retry exn && attempt < config.max_attempts -> 54 54 + let delay = config.backoff attempt in 55 55 + sleep delay; 56 56 + loop (attempt + 1) 57 57 + | exception exn -> Error exn 58 58 + in 59 59 + loop 0 60 60 + 61 61 + (** Circuit breaker states *) 62 62 + type circuit_state = 63 63 + | Closed (** Normal operation *) 64 64 + | Open of float (** Failing, timestamp when opened *) 65 65 + | Half_open (** Testing if recovered *) 66 66 + 67 67 + type circuit_breaker = { 68 68 + mutable state : circuit_state; 69 69 + mutable failure_count : int; 70 70 + failure_threshold : int; 71 71 + reset_timeout : float; (** Seconds before trying again *) 72 72 + mutable success_count : int; (** Successes needed to close from half-open *) 73 73 + success_threshold : int; 74 74 + } 75 75 + (** Circuit breaker *) 76 76 + 77 77 + (** Create a circuit breaker *) 78 78 + let create_breaker ?(failure_threshold = 5) ?(reset_timeout = 30.0) 79 79 + ?(success_threshold = 2) () = 80 80 + { 81 81 + state = Closed; 82 82 + failure_count = 0; 83 83 + failure_threshold; 84 84 + reset_timeout; 85 85 + success_count = 0; 86 86 + success_threshold; 87 87 + } 88 88 + 89 89 + (** Check if circuit allows requests. [now] is current time in seconds (provided 90 90 + by runtime) *) 91 91 + let circuit_allow breaker ~now = 92 92 + match breaker.state with 93 93 + | Closed -> true 94 94 + | Open opened_at -> 95 95 + if now -. opened_at >= breaker.reset_timeout then begin 96 96 + breaker.state <- Half_open; 97 97 + breaker.success_count <- 0; 98 98 + true 99 99 + end 100 100 + else false 101 101 + | Half_open -> true 102 102 + 103 103 + (** Record a successful call *) 104 104 + let circuit_success breaker = 105 105 + match breaker.state with 106 106 + | Closed -> breaker.failure_count <- 0 107 107 + | Half_open -> 108 108 + breaker.success_count <- breaker.success_count + 1; 109 109 + if breaker.success_count >= breaker.success_threshold then begin 110 110 + breaker.state <- Closed; 111 111 + breaker.failure_count <- 0 112 112 + end 113 113 + | Open _ -> () 114 114 + 115 115 + (** Record a failed call. [now] is current time (provided by runtime) *) 116 116 + let circuit_failure breaker ~now = 117 117 + match breaker.state with 118 118 + | Closed -> 119 119 + breaker.failure_count <- breaker.failure_count + 1; 120 120 + if breaker.failure_count >= breaker.failure_threshold then 121 121 + breaker.state <- Open now 122 122 + | Half_open -> breaker.state <- Open now 123 123 + | Open _ -> () 124 124 + 125 125 + (** Execute with circuit breaker. [now] provides current time, [on_open] called 126 126 + when circuit is open *) 127 127 + let with_circuit_breaker ~now ~on_open breaker f = 128 128 + if not (circuit_allow breaker ~now) then on_open () 129 129 + else 130 130 + match f () with 131 131 + | result -> 132 132 + circuit_success breaker; 133 133 + Ok result 134 134 + | exception exn -> 135 135 + circuit_failure breaker ~now; 136 136 + Error exn 137 137 + 138 138 + type rate_limiter = { 139 139 + mutable tokens : float; 140 140 + mutable last_update : float; 141 141 + rate : float; (** Tokens per second *) 142 142 + capacity : float; (** Max tokens *) 143 143 + } 144 144 + (** Rate limiter state (token bucket) *) 145 145 + 146 146 + (** Create a rate limiter *) 147 147 + let create_rate_limiter ~rate ~capacity = 148 148 + { tokens = capacity; last_update = 0.0; rate; capacity } 149 149 + 150 150 + (** Try to acquire a token. [now] is current time in seconds *) 151 151 + let rate_limit_acquire limiter ~now = 152 152 + (* Refill tokens based on elapsed time *) 153 153 + let elapsed = now -. limiter.last_update in 154 154 + limiter.tokens <- 155 155 + min limiter.capacity (limiter.tokens +. (elapsed *. limiter.rate)); 156 156 + limiter.last_update <- now; 157 157 + 158 158 + if limiter.tokens >= 1.0 then begin 159 159 + limiter.tokens <- limiter.tokens -. 1.0; 160 160 + true 161 161 + end 162 162 + else false 163 163 + 164 164 + (** Calculate wait time until a token is available *) 165 165 + let rate_limit_wait_time limiter = 166 166 + if limiter.tokens >= 1.0 then 0.0 else (1.0 -. limiter.tokens) /. limiter.rate

+4

lib/dune

reviewed

··· 1 1 + (library 2 2 + (name hcs) 3 3 + (public_name hcs) 4 4 + (libraries eio eio.unix h1 h2 tls-eio tls ca-certs x509 ptime ptime.clock.os cstruct uri digestif base64 bigstringaf faraday))

+324

lib/h1_client.ml

reviewed

··· 1 1 + (** HTTP/1.1 Client implementation using h1. 2 2 + 3 3 + This module provides HTTP/1.1 client functionality built on Eio. *) 4 4 + 5 5 + (** {1 Configuration} *) 6 6 + 7 7 + type config = { 8 8 + (* Timeouts *) 9 9 + connect_timeout : float; (** Connection timeout in seconds. Default: 30.0 *) 10 10 + read_timeout : float; (** Read timeout in seconds. Default: 30.0 *) 11 11 + write_timeout : float; (** Write timeout in seconds. Default: 30.0 *) 12 12 + (* Behavior *) 13 13 + follow_redirects : int option; 14 14 + (** Max redirects to follow. None = don't follow. Default: Some 10 *) 15 15 + (* Buffers *) 16 16 + buffer_size : int; (** Read buffer size. Default: 16384 *) 17 17 + max_response_body : int64 option; 18 18 + (** Max response body size. None = unlimited. Default: None *) 19 19 + (* TLS *) 20 20 + tls : Tls_config.Client.t; (** TLS configuration *) 21 21 + (* Headers *) 22 22 + default_headers : (string * string) list; 23 23 + (** Headers to add to every request *) 24 24 + } 25 25 + (** Client configuration *) 26 26 + 27 27 + let default_config = 28 28 + { 29 29 + connect_timeout = 30.0; 30 30 + read_timeout = 30.0; 31 31 + write_timeout = 30.0; 32 32 + follow_redirects = Some 10; 33 33 + buffer_size = 16384; 34 34 + max_response_body = None; 35 35 + tls = Tls_config.Client.default; 36 36 + default_headers = [ ("User-Agent", "hcs/0.1.0") ]; 37 37 + } 38 38 + 39 39 + (** {2 Config builders} *) 40 40 + 41 41 + let with_timeout timeout config = 42 42 + { config with connect_timeout = timeout; read_timeout = timeout } 43 43 + 44 44 + let with_connect_timeout timeout config = 45 45 + { config with connect_timeout = timeout } 46 46 + 47 47 + let with_read_timeout timeout config = { config with read_timeout = timeout } 48 48 + let with_write_timeout timeout config = { config with write_timeout = timeout } 49 49 + 50 50 + let with_redirects max_redirects config = 51 51 + { config with follow_redirects = Some max_redirects } 52 52 + 53 53 + let without_redirects config = { config with follow_redirects = None } 54 54 + let with_buffer_size size config = { config with buffer_size = size } 55 55 + 56 56 + let with_max_response_body max_size config = 57 57 + { config with max_response_body = Some max_size } 58 58 + 59 59 + let with_tls tls config = { config with tls } 60 60 + let with_insecure_tls config = { config with tls = Tls_config.Client.insecure } 61 61 + 62 62 + let with_default_header name value config = 63 63 + { config with default_headers = (name, value) :: config.default_headers } 64 64 + 65 65 + let with_default_headers headers config = 66 66 + { config with default_headers = headers @ config.default_headers } 67 67 + 68 68 + (** Error type for client operations *) 69 69 + type error = 70 70 + | Connection_failed of string 71 71 + | Tls_error of string 72 72 + | Timeout 73 73 + | Invalid_response of string 74 74 + | Too_many_redirects 75 75 + 76 76 + type response = { status : H1.Status.t; headers : H1.Headers.t; body : string } 77 77 + (** Response type *) 78 78 + 79 79 + (** Write all IOVecs to the flow *) 80 80 + let write_iovecs flow iovecs = 81 81 + let cstructs = 82 82 + List.map 83 83 + (fun iov -> 84 84 + Cstruct.of_bigarray ~off:iov.Httpun_types.IOVec.off 85 85 + ~len:iov.Httpun_types.IOVec.len iov.Httpun_types.IOVec.buffer) 86 86 + iovecs 87 87 + in 88 88 + Eio.Flow.write flow cstructs 89 89 + 90 90 + (** Read from flow into bigstring buffer *) 91 91 + let read_into_bigstring flow buf ~off ~len = 92 92 + let cs = Cstruct.of_bigarray ~off ~len buf in 93 93 + try 94 94 + let n = Eio.Flow.single_read flow cs in 95 95 + `Ok n 96 96 + with End_of_file -> `Eof 97 97 + 98 98 + (** Resolve hostname to IP address *) 99 99 + let resolve_host net host = 100 100 + let addrs = Eio.Net.getaddrinfo_stream net host in 101 101 + match addrs with addr :: _ -> Some addr | [] -> None 102 102 + 103 103 + (** Perform an HTTP/1.1 request on a connected flow *) 104 104 + let do_request ?(request_body = "") flow req = 105 105 + (* Set up response handling *) 106 106 + let response_received = Eio.Promise.create () in 107 107 + let body_buffer = Buffer.create 4096 in 108 108 + let resolved = ref false in 109 109 + 110 110 + let resolve_once result = 111 111 + if not !resolved then begin 112 112 + resolved := true; 113 113 + Eio.Promise.resolve (snd response_received) result 114 114 + end 115 115 + in 116 116 + 117 117 + let response_handler resp body_reader = 118 118 + let rec read_body () = 119 119 + H1.Body.Reader.schedule_read body_reader 120 120 + ~on_eof:(fun () -> 121 121 + let body = Buffer.contents body_buffer in 122 122 + resolve_once 123 123 + (Ok 124 124 + { 125 125 + status = resp.H1.Response.status; 126 126 + headers = resp.headers; 127 127 + body; 128 128 + })) 129 129 + ~on_read:(fun buf ~off ~len -> 130 130 + Buffer.add_string body_buffer (Bigstringaf.substring buf ~off ~len); 131 131 + read_body ()) 132 132 + in 133 133 + read_body () 134 134 + in 135 135 + 136 136 + let error_handler err = 137 137 + let msg = 138 138 + match err with 139 139 + | `Malformed_response s -> s 140 140 + | `Invalid_response_body_length _ -> "Invalid response body length" 141 141 + | `Exn exn -> Printexc.to_string exn 142 142 + in 143 143 + resolve_once (Error (Invalid_response msg)) 144 144 + in 145 145 + 146 146 + (* Create the client connection *) 147 147 + let body_writer, conn = 148 148 + H1.Client_connection.request req ~error_handler ~response_handler 149 149 + in 150 150 + 151 151 + (* Write request body if provided, then close *) 152 152 + if String.length request_body > 0 then begin 153 153 + H1.Body.Writer.write_string body_writer request_body; 154 154 + H1.Body.Writer.flush body_writer (fun () -> ()) 155 155 + end; 156 156 + H1.Body.Writer.close body_writer; 157 157 + 158 158 + (* Buffer for reading - track unconsumed bytes between reads *) 159 159 + let read_buffer_size = 0x4000 in 160 160 + let read_buffer = Bigstringaf.create read_buffer_size in 161 161 + let unconsumed = ref 0 in 162 162 + 163 163 + (* Connection loop - handle both read and write operations *) 164 164 + let rec loop () = 165 165 + (* First, handle any pending writes *) 166 166 + let write_done = 167 167 + match H1.Client_connection.next_write_operation conn with 168 168 + | `Write iovecs -> 169 169 + write_iovecs flow iovecs; 170 170 + let len = 171 171 + List.fold_left 172 172 + (fun acc iov -> acc + iov.Httpun_types.IOVec.len) 173 173 + 0 iovecs 174 174 + in 175 175 + H1.Client_connection.report_write_result conn (`Ok len); 176 176 + false 177 177 + | `Yield -> true 178 178 + | `Close _ -> true 179 179 + in 180 180 + 181 181 + (* Then handle reads *) 182 182 + let read_done = 183 183 + match H1.Client_connection.next_read_operation conn with 184 184 + | `Read -> ( 185 185 + let available = read_buffer_size - !unconsumed in 186 186 + match 187 187 + read_into_bigstring flow read_buffer ~off:!unconsumed ~len:available 188 188 + with 189 189 + | `Ok n -> 190 190 + let total = !unconsumed + n in 191 191 + let consumed = 192 192 + H1.Client_connection.read conn read_buffer ~off:0 ~len:total 193 193 + in 194 194 + (* Shift unconsumed bytes to start of buffer *) 195 195 + let remaining = total - consumed in 196 196 + if remaining > 0 && consumed > 0 then 197 197 + Bigstringaf.blit read_buffer ~src_off:consumed read_buffer 198 198 + ~dst_off:0 ~len:remaining; 199 199 + unconsumed := remaining; 200 200 + false 201 201 + | `Eof -> 202 202 + let _ = 203 203 + H1.Client_connection.read_eof conn read_buffer ~off:0 204 204 + ~len:!unconsumed 205 205 + in 206 206 + true) 207 207 + | `Close -> true 208 208 + in 209 209 + 210 210 + (* Continue until both read and write are done *) 211 211 + if not (write_done && read_done) then loop () 212 212 + in 213 213 + 214 214 + loop (); 215 215 + Eio.Promise.await (fst response_received) 216 216 + 217 217 + (** Wrap flow with TLS if needed, returns the flow to use *) 218 218 + let maybe_wrap_tls ~config ~host ~is_https flow = 219 219 + if is_https then 220 220 + match Tls_config.Client.to_tls_config config.tls ~host with 221 221 + | Error msg -> Error (Tls_error msg) 222 222 + | Ok tls_config -> ( 223 223 + try 224 224 + (* Parse host as domain name for SNI *) 225 225 + let host_domain = 226 226 + match Domain_name.of_string host with 227 227 + | Ok dn -> ( 228 228 + match Domain_name.host dn with 229 229 + | Ok h -> Some h 230 230 + | Error _ -> None) 231 231 + | Error _ -> None 232 232 + in 233 233 + let tls_flow = 234 234 + Tls_eio.client_of_flow tls_config ?host:host_domain flow 235 235 + in 236 236 + Ok (tls_flow :> Eio.Flow.two_way_ty Eio.Std.r) 237 237 + with 238 238 + | Tls_eio.Tls_failure failure -> 239 239 + Error (Tls_error (Tls_config.failure_to_string failure)) 240 240 + | exn -> Error (Tls_error (Printexc.to_string exn))) 241 241 + else Ok (flow :> Eio.Flow.two_way_ty Eio.Std.r) 242 242 + 243 243 + (** Perform a GET request *) 244 244 + let get ~sw ~net ~clock ?(config = default_config) url = 245 245 + let uri = Uri.of_string url in 246 246 + let scheme = Uri.scheme uri |> Option.value ~default:"http" in 247 247 + let is_https = String.equal scheme "https" in 248 248 + let host = Uri.host uri |> Option.value ~default:"localhost" in 249 249 + let default_port = if is_https then 443 else 80 in 250 250 + let port = Uri.port uri |> Option.value ~default:default_port in 251 251 + let path = Uri.path_and_query uri in 252 252 + let path = if path = "" then "/" else path in 253 253 + 254 254 + (* Wrap in timeout - use with_timeout_exn and catch the exception *) 255 255 + let total_timeout = config.connect_timeout +. config.read_timeout in 256 256 + try 257 257 + Eio.Time.with_timeout_exn clock total_timeout @@ fun () -> 258 258 + match resolve_host net host with 259 259 + | None -> Error (Connection_failed ("Cannot resolve host: " ^ host)) 260 260 + | Some addr_info -> ( 261 261 + let addr = 262 262 + match addr_info with 263 263 + | `Tcp (ip, _) -> `Tcp (ip, port) 264 264 + | `Unix _ -> failwith "Unix sockets not supported" 265 265 + in 266 266 + let tcp_flow = Eio.Net.connect ~sw net addr in 267 267 + 268 268 + (* Wrap with TLS if HTTPS *) 269 269 + match maybe_wrap_tls ~config ~host ~is_https tcp_flow with 270 270 + | Error e -> Error e 271 271 + | Ok flow -> 272 272 + let req = 273 273 + H1.Request.create 274 274 + ~headers: 275 275 + (H1.Headers.of_list 276 276 + [ ("Host", host); ("Connection", "keep-alive") ]) 277 277 + `GET path 278 278 + in 279 279 + do_request flow req) 280 280 + with Eio.Time.Timeout -> Error Timeout 281 281 + 282 282 + (** Perform a POST request with body *) 283 283 + let post ~sw ~net ~clock ?(config = default_config) url ~body:request_body = 284 284 + let uri = Uri.of_string url in 285 285 + let scheme = Uri.scheme uri |> Option.value ~default:"http" in 286 286 + let is_https = String.equal scheme "https" in 287 287 + let host = Uri.host uri |> Option.value ~default:"localhost" in 288 288 + let default_port = if is_https then 443 else 80 in 289 289 + let port = Uri.port uri |> Option.value ~default:default_port in 290 290 + let path = Uri.path_and_query uri in 291 291 + let path = if path = "" then "/" else path in 292 292 + 293 293 + (* Wrap in timeout *) 294 294 + let total_timeout = config.connect_timeout +. config.read_timeout in 295 295 + try 296 296 + Eio.Time.with_timeout_exn clock total_timeout @@ fun () -> 297 297 + match resolve_host net host with 298 298 + | None -> Error (Connection_failed ("Cannot resolve host: " ^ host)) 299 299 + | Some addr_info -> ( 300 300 + let addr = 301 301 + match addr_info with 302 302 + | `Tcp (ip, _) -> `Tcp (ip, port) 303 303 + | `Unix _ -> failwith "Unix sockets not supported" 304 304 + in 305 305 + let tcp_flow = Eio.Net.connect ~sw net addr in 306 306 + 307 307 + (* Wrap with TLS if HTTPS *) 308 308 + match maybe_wrap_tls ~config ~host ~is_https tcp_flow with 309 309 + | Error e -> Error e 310 310 + | Ok flow -> 311 311 + let content_length = String.length request_body in 312 312 + let req = 313 313 + H1.Request.create 314 314 + ~headers: 315 315 + (H1.Headers.of_list 316 316 + [ 317 317 + ("Host", host); 318 318 + ("Connection", "keep-alive"); 319 319 + ("Content-Length", string_of_int content_length); 320 320 + ]) 321 321 + `POST path 322 322 + in 323 323 + do_request ~request_body flow req) 324 324 + with Eio.Time.Timeout -> Error Timeout

+588

lib/h1_server.ml

reviewed

··· 1 1 + (** HTTP/1.1 Server implementation using h1. 2 2 + 3 3 + This module provides HTTP/1.1 server functionality built on Eio. 4 4 + 5 5 + Features: 6 6 + - Lazy body reading: request body is not read until accessed 7 7 + - Zero-copy responses: bigstring bodies avoid copying 8 8 + - Streaming responses: write large responses without buffering 9 9 + - Connection pooling via buffer reuse *) 10 10 + 11 11 + open Eio.Std 12 12 + 13 13 + (** {1 Read Buffer Pool} *) 14 14 + 15 15 + module Read_buffer_pool : sig 16 16 + val acquire : unit -> Bigstringaf.t * Cstruct.t 17 17 + val release : Bigstringaf.t -> unit 18 18 + end = struct 19 19 + let buffer_size = 0x4000 20 20 + 21 21 + let acquire () = 22 22 + let buf = Bigstringaf.create buffer_size in 23 23 + (buf, Cstruct.of_bigarray buf ~off:0 ~len:buffer_size) 24 24 + 25 25 + let release _ = () 26 26 + end 27 27 + 28 28 + (** {1 Configuration} *) 29 29 + 30 30 + type config = { 31 31 + (* Network *) 32 32 + host : string; (** Bind address. Default: "0.0.0.0" *) 33 33 + port : int; (** Listen port. Default: 8080 *) 34 34 + backlog : int; (** Listen backlog. Default: 2048 *) 35 35 + max_connections : int; (** Max concurrent connections. Default: 10000 *) 36 36 + (* Parallelism *) 37 37 + domain_count : int; (** Number of domains (CPUs) to use. Default: 1 *) 38 38 + (* Timeouts *) 39 39 + read_timeout : float; (** Read timeout in seconds. Default: 60.0 *) 40 40 + write_timeout : float; (** Write timeout in seconds. Default: 60.0 *) 41 41 + idle_timeout : float; (** Idle connection timeout. Default: 120.0 *) 42 42 + request_timeout : float; (** Request processing timeout. Default: 30.0 *) 43 43 + (* Limits *) 44 44 + max_header_size : int; (** Max header size in bytes. Default: 8192 *) 45 45 + max_body_size : int64 option; 46 46 + (** Max body size. None = unlimited. Default: None *) 47 47 + (* Buffers *) 48 48 + buffer_size : int; (** Read buffer size. Default: 16384 *) 49 49 + (* TLS *) 50 50 + tls : Tls_config.Server.t option; (** TLS config. None = plain HTTP *) 51 51 + (* Socket options *) 52 52 + tcp_nodelay : bool; (** Enable TCP_NODELAY (disable Nagle). Default: true *) 53 53 + reuse_addr : bool; (** Enable SO_REUSEADDR. Default: true *) 54 54 + reuse_port : bool; 55 55 + (** Enable SO_REUSEPORT for multi-process scaling. Default: true *) 56 56 + } 57 57 + (** Server configuration *) 58 58 + 59 59 + let default_config = 60 60 + { 61 61 + host = "0.0.0.0"; 62 62 + port = 8080; 63 63 + backlog = 2048; 64 64 + max_connections = 10000; 65 65 + domain_count = 1; 66 66 + read_timeout = 60.0; 67 67 + write_timeout = 60.0; 68 68 + idle_timeout = 120.0; 69 69 + request_timeout = 30.0; 70 70 + max_header_size = 8192; 71 71 + max_body_size = None; 72 72 + buffer_size = 16384; 73 73 + tls = None; 74 74 + tcp_nodelay = true; 75 75 + reuse_addr = true; 76 76 + reuse_port = true; 77 77 + } 78 78 + 79 79 + (** {2 Config builders} *) 80 80 + 81 81 + let with_port port config = { config with port } 82 82 + let with_host host config = { config with host } 83 83 + let with_backlog backlog config = { config with backlog } 84 84 + let with_max_connections max config = { config with max_connections = max } 85 85 + let with_read_timeout timeout config = { config with read_timeout = timeout } 86 86 + let with_write_timeout timeout config = { config with write_timeout = timeout } 87 87 + let with_idle_timeout timeout config = { config with idle_timeout = timeout } 88 88 + 89 89 + let with_request_timeout timeout config = 90 90 + { config with request_timeout = timeout } 91 91 + 92 92 + let with_domain_count count config = { config with domain_count = count } 93 93 + let with_max_header_size size config = { config with max_header_size = size } 94 94 + let with_max_body_size size config = { config with max_body_size = Some size } 95 95 + let with_buffer_size size config = { config with buffer_size = size } 96 96 + let with_tls tls config = { config with tls = Some tls } 97 97 + let with_tcp_nodelay enabled config = { config with tcp_nodelay = enabled } 98 98 + let with_reuse_addr enabled config = { config with reuse_addr = enabled } 99 99 + let with_reuse_port enabled config = { config with reuse_port = enabled } 100 100 + 101 101 + (** {1 GC Tuning} *) 102 102 + 103 103 + type gc_config = { 104 104 + minor_heap_size : int; 105 105 + major_heap_increment : int; 106 106 + space_overhead : int; 107 107 + max_overhead : int; 108 108 + } 109 109 + 110 110 + let default_gc_config = 111 111 + { 112 112 + minor_heap_size = 64 * 1024 * 1024; 113 113 + major_heap_increment = 16 * 1024 * 1024; 114 114 + space_overhead = 120; 115 115 + max_overhead = 500; 116 116 + } 117 117 + 118 118 + let tune_gc ?(config = default_gc_config) () = 119 119 + let ctrl = Gc.get () in 120 120 + Gc.set 121 121 + { 122 122 + ctrl with 123 123 + minor_heap_size = config.minor_heap_size / (Sys.word_size / 8); 124 124 + major_heap_increment = config.major_heap_increment / (Sys.word_size / 8); 125 125 + space_overhead = config.space_overhead; 126 126 + max_overhead = config.max_overhead; 127 127 + } 128 128 + 129 129 + let gc_tuned = ref false 130 130 + 131 131 + let ensure_gc_tuned () = 132 132 + if not !gc_tuned then begin 133 133 + tune_gc (); 134 134 + gc_tuned := true 135 135 + end 136 136 + 137 137 + (** {1 Cached Date Header} *) 138 138 + 139 139 + module Date_cache : sig 140 140 + val get : unit -> string 141 141 + end = struct 142 142 + let day_names = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] 143 143 + 144 144 + let month_names = 145 145 + [| 146 146 + "Jan"; 147 147 + "Feb"; 148 148 + "Mar"; 149 149 + "Apr"; 150 150 + "May"; 151 151 + "Jun"; 152 152 + "Jul"; 153 153 + "Aug"; 154 154 + "Sep"; 155 155 + "Oct"; 156 156 + "Nov"; 157 157 + "Dec"; 158 158 + |] 159 159 + 160 160 + let cached_date = Atomic.make "" 161 161 + let cached_time = Atomic.make 0. 162 162 + 163 163 + let format_date () = 164 164 + let t = Unix.gettimeofday () in 165 165 + let tm = Unix.gmtime t in 166 166 + Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" 167 167 + day_names.(tm.Unix.tm_wday) 168 168 + tm.Unix.tm_mday 169 169 + month_names.(tm.Unix.tm_mon) 170 170 + (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 171 171 + 172 172 + let get () = 173 173 + let now = Unix.gettimeofday () in 174 174 + let last = Atomic.get cached_time in 175 175 + if now -. last >= 1.0 then begin 176 176 + let date = format_date () in 177 177 + Atomic.set cached_date date; 178 178 + Atomic.set cached_time now; 179 179 + date 180 180 + end 181 181 + else Atomic.get cached_date 182 182 + end 183 183 + 184 184 + (** {1 Cached Prebuilt Response} *) 185 185 + 186 186 + type cached_prebuilt = { 187 187 + base_response : H1.Response.t; 188 188 + body : Bigstringaf.t; 189 189 + cached_response : H1.Response.t Atomic.t; 190 190 + cached_second : int Atomic.t; 191 191 + } 192 192 + 193 193 + let make_cached_prebuilt h1_response body = 194 194 + let now = int_of_float (Unix.gettimeofday ()) in 195 195 + let headers = 196 196 + H1.Headers.add h1_response.H1.Response.headers "Date" (Date_cache.get ()) 197 197 + in 198 198 + let resp = H1.Response.create ~headers h1_response.H1.Response.status in 199 199 + { 200 200 + base_response = h1_response; 201 201 + body; 202 202 + cached_response = Atomic.make resp; 203 203 + cached_second = Atomic.make now; 204 204 + } 205 205 + 206 206 + let[@inline] get_cached_response cached = 207 207 + let now = int_of_float (Unix.gettimeofday ()) in 208 208 + let last = Atomic.get cached.cached_second in 209 209 + if now <> last then begin 210 210 + let headers = 211 211 + H1.Headers.add cached.base_response.H1.Response.headers "Date" 212 212 + (Date_cache.get ()) 213 213 + in 214 214 + let resp = 215 215 + H1.Response.create ~headers cached.base_response.H1.Response.status 216 216 + in 217 217 + Atomic.set cached.cached_response resp; 218 218 + Atomic.set cached.cached_second now 219 219 + end; 220 220 + Atomic.get cached.cached_response 221 221 + 222 222 + (** {1 Socket Helpers} *) 223 223 + 224 224 + let set_tcp_nodelay flow = 225 225 + match Eio_unix.Resource.fd_opt flow with 226 226 + | None -> () 227 227 + | Some fd -> 228 228 + Eio_unix.Fd.use_exn "set_tcp_nodelay" fd (fun unix_fd -> 229 229 + Unix.setsockopt unix_fd Unix.TCP_NODELAY true) 230 230 + 231 231 + (** {1 Body Types} *) 232 232 + 233 233 + type body_reader = { 234 234 + read : unit -> string; 235 235 + (** Read the entire body as a string. Can only be called once. *) 236 236 + read_stream : unit -> Cstruct.t option; 237 237 + (** Read body in chunks. Returns None when done. *) 238 238 + close : unit -> unit; (** Close the body reader without reading. *) 239 239 + } 240 240 + (** Lazy body reader - body is only read when [read] is called *) 241 241 + 242 242 + (** Response body - supports string, bigstring, streaming, and pre-built *) 243 243 + type response_body = 244 244 + | Body_string of string 245 245 + | Body_bigstring of Bigstringaf.t 246 246 + | Body_prebuilt of { h1_response : H1.Response.t; body : Bigstringaf.t } 247 247 + | Body_cached_prebuilt of cached_prebuilt 248 248 + | Body_stream of { 249 249 + content_length : int64 option; 250 250 + next : unit -> Cstruct.t option; 251 251 + } 252 252 + 253 253 + (** {1 Request and Response Types} *) 254 254 + 255 255 + type request = { 256 256 + meth : H1.Method.t; 257 257 + target : string; 258 258 + headers : H1.Headers.t; 259 259 + body_reader : body_reader; 260 260 + (** Lazy body reader - call [body_reader.read ()] to get the body *) 261 261 + } 262 262 + (** Request type with lazy body reading *) 263 263 + 264 264 + (** Read the request body as a string (convenience function) *) 265 265 + let read_body req = req.body_reader.read () 266 266 + 267 267 + (** Read the request body as a stream (for large bodies) *) 268 268 + let read_body_stream req = req.body_reader.read_stream 269 269 + 270 270 + (** Close the request body without reading (for ignored bodies) *) 271 271 + let close_body req = req.body_reader.close () 272 272 + 273 273 + type response = { 274 274 + status : H1.Status.t; 275 275 + headers : (string * string) list; 276 276 + response_body : response_body; 277 277 + } 278 278 + (** Response type with optimized body variants *) 279 279 + 280 280 + type handler = request -> response 281 281 + (** Handler type *) 282 282 + 283 283 + let respond ?(status = `OK) ?(headers = []) body = 284 284 + { status; headers; response_body = Body_string body } 285 285 + 286 286 + let respond_bigstring ?(status = `OK) ?(headers = []) bstr = 287 287 + { status; headers; response_body = Body_bigstring bstr } 288 288 + 289 289 + let respond_stream ?(status = `OK) ?(headers = []) ?content_length next = 290 290 + { status; headers; response_body = Body_stream { content_length; next } } 291 291 + 292 292 + let respond_prebuilt h1_response body = 293 293 + { 294 294 + status = `OK; 295 295 + headers = []; 296 296 + response_body = Body_prebuilt { h1_response; body }; 297 297 + } 298 298 + 299 299 + let respond_cached_prebuilt cached = 300 300 + { status = `OK; headers = []; response_body = Body_cached_prebuilt cached } 301 301 + 302 302 + type static_response = response 303 303 + 304 304 + let make_static_response cached : static_response = 305 305 + { status = `OK; headers = []; response_body = Body_cached_prebuilt cached } 306 306 + 307 307 + let[@inline always] respond_static (r : static_response) : response = r 308 308 + let make_h1_headers headers_list = H1.Headers.of_list headers_list 309 309 + 310 310 + let make_h1_response ?(status = `OK) headers = 311 311 + H1.Response.create ~headers status 312 312 + 313 313 + (** {1 Internal Helpers} *) 314 314 + 315 315 + (** Write all IOVecs to the flow - optimized version *) 316 316 + let write_iovecs flow iovecs = 317 317 + match iovecs with 318 318 + | [] -> () 319 319 + | [ iov ] -> 320 320 + (* Fast path for single iovec - common case *) 321 321 + let cs = 322 322 + Cstruct.of_bigarray ~off:iov.Httpun_types.IOVec.off 323 323 + ~len:iov.Httpun_types.IOVec.len iov.Httpun_types.IOVec.buffer 324 324 + in 325 325 + Eio.Flow.write flow [ cs ] 326 326 + | _ -> 327 327 + (* Multiple iovecs - build list directly *) 328 328 + let cstructs = 329 329 + List.map 330 330 + (fun iov -> 331 331 + Cstruct.of_bigarray ~off:iov.Httpun_types.IOVec.off 332 332 + ~len:iov.Httpun_types.IOVec.len iov.Httpun_types.IOVec.buffer) 333 333 + iovecs 334 334 + in 335 335 + Eio.Flow.write flow cstructs 336 336 + 337 337 + (** Check if method typically has no body *) 338 338 + let[@inline] method_has_no_body = function 339 339 + | `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> true 340 340 + | `POST | `PUT | `PATCH | `Other _ -> false 341 341 + 342 342 + (** Create a lazy body reader from H1's body reader *) 343 343 + let make_body_reader (h1_body : H1.Body.Reader.t) : body_reader = 344 344 + let read_called = ref false in 345 345 + let closed = ref false in 346 346 + let chunks = ref [] in 347 347 + let done_promise, done_resolver = Eio.Promise.create () in 348 348 + 349 349 + (* Start reading in background - will block until first chunk or EOF *) 350 350 + let rec schedule_read () = 351 351 + if not !closed then 352 352 + H1.Body.Reader.schedule_read h1_body 353 353 + ~on_eof:(fun () -> Eio.Promise.resolve done_resolver ()) 354 354 + ~on_read:(fun buf ~off ~len -> 355 355 + (* Store chunk as Cstruct to avoid copying bigstring *) 356 356 + let chunk = Cstruct.of_bigarray ~off ~len buf |> Cstruct.to_string in 357 357 + chunks := chunk :: !chunks; 358 358 + schedule_read ()) 359 359 + in 360 360 + 361 361 + { 362 362 + read = 363 363 + (fun () -> 364 364 + if !read_called then failwith "Body already read" 365 365 + else begin 366 366 + read_called := true; 367 367 + if !closed then "" 368 368 + else begin 369 369 + schedule_read (); 370 370 + Eio.Promise.await done_promise; 371 371 + String.concat "" (List.rev !chunks) 372 372 + end 373 373 + end); 374 374 + read_stream = 375 375 + (fun () -> 376 376 + (* For streaming, we read one chunk at a time *) 377 377 + if !closed then None 378 378 + else begin 379 379 + let chunk_promise, chunk_resolver = Eio.Promise.create () in 380 380 + let got_chunk = ref false in 381 381 + H1.Body.Reader.schedule_read h1_body 382 382 + ~on_eof:(fun () -> 383 383 + if not !got_chunk then Eio.Promise.resolve chunk_resolver None) 384 384 + ~on_read:(fun buf ~off ~len -> 385 385 + got_chunk := true; 386 386 + let cs = Cstruct.of_bigarray ~off ~len buf in 387 387 + Eio.Promise.resolve chunk_resolver (Some cs)); 388 388 + Eio.Promise.await chunk_promise 389 389 + end); 390 390 + close = 391 391 + (fun () -> 392 392 + if not !closed then begin 393 393 + closed := true; 394 394 + H1.Body.Reader.close h1_body 395 395 + end); 396 396 + } 397 397 + 398 398 + (** Create a no-op body reader for methods without bodies *) 399 399 + let empty_body_reader () : body_reader = 400 400 + { 401 401 + read = (fun () -> ""); 402 402 + read_stream = (fun () -> None); 403 403 + close = (fun () -> ()); 404 404 + } 405 405 + 406 406 + let handle_connection handler flow = 407 407 + let read_buffer, read_cstruct = Read_buffer_pool.acquire () in 408 408 + Fun.protect ~finally:(fun () -> Read_buffer_pool.release read_buffer) 409 409 + @@ fun () -> 410 410 + let request_handler reqd = 411 411 + let req = H1.Reqd.request reqd in 412 412 + let h1_body = H1.Reqd.request_body reqd in 413 413 + 414 414 + (* Create lazy body reader *) 415 415 + let body_reader = 416 416 + if method_has_no_body req.H1.Request.meth then begin 417 417 + H1.Body.Reader.close h1_body; 418 418 + empty_body_reader () 419 419 + end 420 420 + else make_body_reader h1_body 421 421 + in 422 422 + 423 423 + (* Build request with lazy body *) 424 424 + let request = 425 425 + { 426 426 + meth = req.H1.Request.meth; 427 427 + target = req.target; 428 428 + headers = req.headers; 429 429 + body_reader; 430 430 + } 431 431 + in 432 432 + 433 433 + (* Call user handler *) 434 434 + let response = handler request in 435 435 + 436 436 + (* Ensure body is closed if not read *) 437 437 + body_reader.close (); 438 438 + 439 439 + let date_header = ("Date", Date_cache.get ()) in 440 440 + let filter_reserved headers = 441 441 + List.filter 442 442 + (fun (k, _) -> 443 443 + let lk = String.lowercase_ascii k in 444 444 + lk <> "content-length" && lk <> "date") 445 445 + headers 446 446 + in 447 447 + 448 448 + match response.response_body with 449 449 + | Body_string body -> 450 450 + let content_length = String.length body in 451 451 + let headers = 452 452 + H1.Headers.of_list 453 453 + (date_header 454 454 + :: ("Content-Length", string_of_int content_length) 455 455 + :: filter_reserved response.headers) 456 456 + in 457 457 + let resp = H1.Response.create ~headers response.status in 458 458 + H1.Reqd.respond_with_string reqd resp body 459 459 + | Body_bigstring bstr -> 460 460 + let content_length = Bigstringaf.length bstr in 461 461 + let headers = 462 462 + H1.Headers.of_list 463 463 + (date_header 464 464 + :: ("Content-Length", string_of_int content_length) 465 465 + :: filter_reserved response.headers) 466 466 + in 467 467 + let resp = H1.Response.create ~headers response.status in 468 468 + H1.Reqd.respond_with_bigstring reqd resp bstr 469 469 + | Body_prebuilt { h1_response; body } -> 470 470 + let headers = 471 471 + H1.Headers.add h1_response.headers "Date" (Date_cache.get ()) 472 472 + in 473 473 + let resp = { h1_response with H1.Response.headers } in 474 474 + H1.Reqd.respond_with_bigstring reqd resp body 475 475 + | Body_cached_prebuilt cached -> 476 476 + let resp = get_cached_response cached in 477 477 + H1.Reqd.respond_with_bigstring reqd resp cached.body 478 478 + | Body_stream { content_length; next } -> 479 479 + let headers = 480 480 + match content_length with 481 481 + | Some len -> 482 482 + H1.Headers.of_list 483 483 + (date_header 484 484 + :: ("Content-Length", Int64.to_string len) 485 485 + :: filter_reserved response.headers) 486 486 + | None -> 487 487 + H1.Headers.of_list 488 488 + (date_header 489 489 + :: ("Transfer-Encoding", "chunked") 490 490 + :: filter_reserved response.headers) 491 491 + in 492 492 + let resp = H1.Response.create ~headers response.status in 493 493 + let body_writer = H1.Reqd.respond_with_streaming reqd resp in 494 494 + (* Write chunks *) 495 495 + let rec write_chunks () = 496 496 + match next () with 497 497 + | None -> H1.Body.Writer.close body_writer 498 498 + | Some cs -> 499 499 + H1.Body.Writer.write_bigstring body_writer ~off:0 500 500 + ~len:(Cstruct.length cs) (Cstruct.to_bigarray cs); 501 501 + write_chunks () 502 502 + in 503 503 + write_chunks () 504 504 + in 505 505 + 506 506 + let error_handler ?request:_ _error start_response = 507 507 + let resp_body = start_response H1.Headers.empty in 508 508 + H1.Body.Writer.write_string resp_body "Internal Server Error"; 509 509 + H1.Body.Writer.close resp_body 510 510 + in 511 511 + 512 512 + let conn = H1.Server_connection.create ~error_handler request_handler in 513 513 + 514 514 + let shutdown = ref false in 515 515 + 516 516 + let rec read_loop () = 517 517 + if not !shutdown then 518 518 + match H1.Server_connection.next_read_operation conn with 519 519 + | `Read -> ( 520 520 + try 521 521 + let n = Eio.Flow.single_read flow read_cstruct in 522 522 + let _ = H1.Server_connection.read conn read_buffer ~off:0 ~len:n in 523 523 + read_loop () 524 524 + with End_of_file -> 525 525 + let _ = 526 526 + H1.Server_connection.read_eof conn read_buffer ~off:0 ~len:0 527 527 + in 528 528 + shutdown := true) 529 529 + | `Yield -> H1.Server_connection.yield_reader conn read_loop 530 530 + | `Close | `Upgrade -> shutdown := true 531 531 + in 532 532 + 533 533 + let rec write_loop () = 534 534 + if not !shutdown then 535 535 + match H1.Server_connection.next_write_operation conn with 536 536 + | `Write iovecs -> 537 537 + write_iovecs flow iovecs; 538 538 + let len = 539 539 + List.fold_left 540 540 + (fun acc iov -> acc + iov.Httpun_types.IOVec.len) 541 541 + 0 iovecs 542 542 + in 543 543 + H1.Server_connection.report_write_result conn (`Ok len); 544 544 + write_loop () 545 545 + | `Yield -> H1.Server_connection.yield_writer conn write_loop 546 546 + | `Upgrade -> shutdown := true 547 547 + | `Close _ -> shutdown := true 548 548 + in 549 549 + 550 550 + Fiber.both read_loop write_loop 551 551 + 552 552 + let run ~sw ~net ?(config = default_config) handler = 553 553 + ensure_gc_tuned (); 554 554 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 555 555 + let socket = 556 556 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 557 557 + ~reuse_port:config.reuse_port net addr 558 558 + in 559 559 + traceln "Server listening on port %d" config.port; 560 560 + let connection_handler flow _addr = 561 561 + if config.tcp_nodelay then set_tcp_nodelay flow; 562 562 + handle_connection handler flow 563 563 + in 564 564 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 565 565 + Eio.Net.run_server socket connection_handler 566 566 + ~max_connections:config.max_connections ~on_error 567 567 + 568 568 + let run_parallel ~sw ~net ~domain_mgr ?(config = default_config) handler = 569 569 + ensure_gc_tuned (); 570 570 + let domain_count = max 1 config.domain_count in 571 571 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 572 572 + let socket = 573 573 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 574 574 + ~reuse_port:config.reuse_port net addr 575 575 + in 576 576 + traceln "Server listening on port %d (%d domains)" config.port domain_count; 577 577 + let connection_handler flow _addr = 578 578 + if config.tcp_nodelay then set_tcp_nodelay flow; 579 579 + handle_connection handler flow 580 580 + in 581 581 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 582 582 + if domain_count <= 1 then 583 583 + Eio.Net.run_server socket connection_handler 584 584 + ~max_connections:config.max_connections ~on_error 585 585 + else 586 586 + Eio.Net.run_server socket connection_handler 587 587 + ~max_connections:config.max_connections ~on_error 588 588 + ~additional_domains:(domain_mgr, domain_count - 1)

+316

lib/h2_client.ml

reviewed

··· 1 1 + (** HTTP/2 Client implementation using h2. 2 2 + 3 3 + This module provides HTTP/2 client functionality built on the h2 library 4 4 + with Eio for structured concurrency. *) 5 5 + 6 6 + open Eio.Std 7 7 + 8 8 + (** {1 Types} *) 9 9 + 10 10 + type error = 11 11 + | Connection_failed of string 12 12 + | Tls_error of string 13 13 + | Protocol_error of string 14 14 + | Timeout 15 15 + | Invalid_response of string 16 16 + 17 17 + type response = { status : H2.Status.t; headers : H2.Headers.t; body : string } 18 18 + 19 19 + (** {1 Internal helpers} *) 20 20 + 21 21 + (** Write IOVecs to the flow, returns bytes written or `Closed *) 22 22 + let writev flow iovecs = 23 23 + let lenv, cstructs = 24 24 + List.fold_left_map 25 25 + (fun acc iov -> 26 26 + let len = iov.H2.IOVec.len in 27 27 + let cs = 28 28 + Cstruct.of_bigarray ~off:iov.H2.IOVec.off ~len iov.H2.IOVec.buffer 29 29 + in 30 30 + (acc + len, cs)) 31 31 + 0 iovecs 32 32 + in 33 33 + match Eio.Flow.write flow cstructs with 34 34 + | () -> `Ok lenv 35 35 + | exception End_of_file -> `Closed 36 36 + 37 37 + (** Shutdown flow in specified direction *) 38 38 + let shutdown flow cmd = 39 39 + try Eio.Flow.shutdown flow cmd with 40 40 + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () 41 41 + | Eio.Io (Eio.Net.E (Eio.Net.Connection_reset _), _) -> () 42 42 + 43 43 + (** Simple read buffer that tracks unconsumed data. This is necessary because 44 44 + angstrom (used by h2) tracks uncommitted bytes and will fail if the buffer 45 45 + appears to shrink. Based on Gluten.Buffer pattern. *) 46 46 + module Read_buffer : sig 47 47 + type t 48 48 + 49 49 + val create : int -> t 50 50 + 51 51 + val read : t -> _ Eio.Flow.source -> int 52 52 + (** Read data from flow into the buffer. Returns bytes read. *) 53 53 + 54 54 + val get : t -> f:(Bigstringaf.t -> off:int -> len:int -> int) -> int 55 55 + (** Feed buffered data to consumer. Returns bytes consumed. *) 56 56 + end = struct 57 57 + type t = { 58 58 + buffer : Bigstringaf.t; 59 59 + mutable off : int; (* Start of unconsumed data *) 60 60 + mutable len : int; (* Length of unconsumed data *) 61 61 + cap : int; 62 62 + } 63 63 + 64 64 + let create size = 65 65 + { buffer = Bigstringaf.create size; off = 0; len = 0; cap = size } 66 66 + 67 67 + let compress t = 68 68 + if t.len = 0 then begin 69 69 + t.off <- 0; 70 70 + t.len <- 0 71 71 + end 72 72 + else if t.off > 0 then begin 73 73 + Bigstringaf.blit t.buffer ~src_off:t.off t.buffer ~dst_off:0 ~len:t.len; 74 74 + t.off <- 0 75 75 + end 76 76 + 77 77 + let read t flow = 78 78 + compress t; 79 79 + let off = t.off + t.len in 80 80 + let available = t.cap - t.len - t.off in 81 81 + if available > 0 then begin 82 82 + let cs = Cstruct.of_bigarray t.buffer ~off ~len:available in 83 83 + let n = Eio.Flow.single_read flow cs in 84 84 + t.len <- t.len + n; 85 85 + n 86 86 + end 87 87 + else 0 88 88 + 89 89 + let get t ~f = 90 90 + let n = f t.buffer ~off:t.off ~len:t.len in 91 91 + t.off <- t.off + n; 92 92 + t.len <- t.len - n; 93 93 + if t.len = 0 then t.off <- 0; 94 94 + n 95 95 + end 96 96 + 97 97 + (** {1 Connection handling} *) 98 98 + 99 99 + (** Perform an HTTP/2 request on a connected flow. 100 100 + 101 101 + HTTP/2 requires interleaved read/write handling because: 1. The server may 102 102 + send SETTINGS frames immediately after connection 2. We need to send the 103 103 + client preface and request while receiving 3. Flow control (WINDOW_UPDATE) 104 104 + must be processed promptly 105 105 + 106 106 + Note: We use a single-threaded interleaved approach rather than Fiber.both 107 107 + because TLS flows are not safe for concurrent read/write operations. *) 108 108 + let do_request flow req = 109 109 + let response_received = Eio.Promise.create () in 110 110 + let body_buffer = Buffer.create 4096 in 111 111 + let resolved = ref false in 112 112 + 113 113 + let resolve_once result = 114 114 + if not !resolved then begin 115 115 + resolved := true; 116 116 + Eio.Promise.resolve (snd response_received) result 117 117 + end 118 118 + in 119 119 + 120 120 + let response_handler resp body_reader = 121 121 + let rec read_body () = 122 122 + H2.Body.Reader.schedule_read body_reader 123 123 + ~on_eof:(fun () -> 124 124 + let body = Buffer.contents body_buffer in 125 125 + resolve_once 126 126 + (Ok 127 127 + { 128 128 + status = resp.H2.Response.status; 129 129 + headers = resp.headers; 130 130 + body; 131 131 + })) 132 132 + ~on_read:(fun buf ~off ~len -> 133 133 + Buffer.add_string body_buffer (Bigstringaf.substring buf ~off ~len); 134 134 + read_body ()) 135 135 + in 136 136 + read_body () 137 137 + in 138 138 + 139 139 + let error_handler err = 140 140 + let msg = 141 141 + match err with 142 142 + | `Malformed_response s -> "Malformed response: " ^ s 143 143 + | `Invalid_response_body_length _ -> "Invalid response body length" 144 144 + | `Protocol_error (code, msg) -> 145 145 + Printf.sprintf "Protocol error %s: %s" 146 146 + (H2.Error_code.to_string code) 147 147 + msg 148 148 + | `Exn exn -> Printexc.to_string exn 149 149 + in 150 150 + resolve_once (Error (Invalid_response msg)) 151 151 + in 152 152 + 153 153 + (* Create the HTTP/2 client connection *) 154 154 + let conn = H2.Client_connection.create ~error_handler () in 155 155 + 156 156 + (* We'll queue the request after writing the connection preface *) 157 157 + let request_sent = ref false in 158 158 + let send_request () = 159 159 + if not !request_sent then begin 160 160 + request_sent := true; 161 161 + (* Send the request and immediately close the body to signal END_STREAM. 162 162 + For GET requests, the body writer should be closed immediately which 163 163 + sets the END_STREAM flag on the HEADERS frame. *) 164 164 + let body_writer = 165 165 + H2.Client_connection.request conn req 166 166 + ~flush_headers_immediately:true (* Send HEADERS right away *) 167 167 + ~error_handler ~response_handler 168 168 + in 169 169 + (* Close immediately for requests with no body *) 170 170 + H2.Body.Writer.close body_writer 171 171 + end 172 172 + in 173 173 + 174 174 + (* Buffer for reading - tracks unconsumed data properly *) 175 175 + let read_buffer = Read_buffer.create 0x4000 in 176 176 + 177 177 + (* Flag to track if we've sent the request *) 178 178 + let request_queued = ref false in 179 179 + 180 180 + (* Read loop - runs concurrently with write loop. 181 181 + Uses the gluten pattern: read from network first, then feed to h2. *) 182 182 + let read_loop () = 183 183 + let rec read_loop_step () = 184 184 + match H2.Client_connection.next_read_operation conn with 185 185 + | `Read -> ( 186 186 + match Read_buffer.read read_buffer flow with 187 187 + | _n -> 188 188 + (* Feed buffered data to h2 - separate from network read *) 189 189 + let _consumed = 190 190 + Read_buffer.get read_buffer ~f:(fun buf ~off ~len -> 191 191 + H2.Client_connection.read conn buf ~off ~len) 192 192 + in 193 193 + read_loop_step () 194 194 + | exception End_of_file -> 195 195 + (* Feed any remaining buffered data as EOF *) 196 196 + let _ = 197 197 + Read_buffer.get read_buffer ~f:(fun buf ~off ~len -> 198 198 + H2.Client_connection.read_eof conn buf ~off ~len) 199 199 + in 200 200 + ()) 201 201 + | `Yield -> 202 202 + let p, u = Eio.Promise.create () in 203 203 + H2.Client_connection.yield_reader conn (fun () -> 204 204 + Eio.Promise.resolve u ()); 205 205 + Eio.Promise.await p; 206 206 + read_loop_step () 207 207 + | `Close -> shutdown flow `Receive 208 208 + in 209 209 + try read_loop_step () with exn -> H2.Client_connection.report_exn conn exn 210 210 + in 211 211 + 212 212 + (* Write loop - runs concurrently with read loop *) 213 213 + let write_loop () = 214 214 + let rec loop () = 215 215 + match H2.Client_connection.next_write_operation conn with 216 216 + | `Write iovecs -> ( 217 217 + match writev flow iovecs with 218 218 + | `Ok len -> 219 219 + H2.Client_connection.report_write_result conn (`Ok len); 220 220 + (* After first write (connection preface), queue the request *) 221 221 + if not !request_queued then begin 222 222 + request_queued := true; 223 223 + send_request () 224 224 + end; 225 225 + loop () 226 226 + | `Closed -> H2.Client_connection.report_write_result conn `Closed) 227 227 + | `Yield -> 228 228 + let p, u = Eio.Promise.create () in 229 229 + H2.Client_connection.yield_writer conn (fun () -> 230 230 + Eio.Promise.resolve u ()); 231 231 + Eio.Promise.await p; 232 232 + loop () 233 233 + | `Close _ -> shutdown flow `Send 234 234 + in 235 235 + try loop () with exn -> H2.Client_connection.report_exn conn exn 236 236 + in 237 237 + 238 238 + (* Run read and write loops concurrently until response is received. 239 239 + For a single request, we use Fiber.any to exit when response arrives. *) 240 240 + let io_loops () = 241 241 + Eio.Fiber.both read_loop write_loop; 242 242 + (* If loops exit naturally (connection closed), return error *) 243 243 + Error (Protocol_error "Connection closed before response") 244 244 + in 245 245 + 246 246 + let wait_for_response () = 247 247 + let result = Eio.Promise.await (fst response_received) in 248 248 + (* After getting response, shutdown the connection to exit loops *) 249 249 + H2.Client_connection.shutdown conn; 250 250 + result 251 251 + in 252 252 + 253 253 + Eio.Fiber.any [ io_loops; wait_for_response ] 254 254 + 255 255 + (** {1 Public API} *) 256 256 + 257 257 + (** Perform an HTTP/2 GET request. Note: HTTP/2 requires TLS with ALPN 258 258 + negotiation in most cases. *) 259 259 + let get ~sw ~net ~clock:_ ?config:_ url = 260 260 + let uri = Uri.of_string url in 261 261 + let scheme = Uri.scheme uri |> Option.value ~default:"https" in 262 262 + let is_https = String.equal scheme "https" in 263 263 + let host = Uri.host uri |> Option.value ~default:"localhost" in 264 264 + let default_port = if is_https then 443 else 80 in 265 265 + let port = Uri.port uri |> Option.value ~default:default_port in 266 266 + let path = Uri.path_and_query uri in 267 267 + let path = if path = "" then "/" else path in 268 268 + 269 269 + (* Resolve and connect *) 270 270 + let addrs = Eio.Net.getaddrinfo_stream net host in 271 271 + match addrs with 272 272 + | [] -> Error (Connection_failed ("Cannot resolve host: " ^ host)) 273 273 + | addr_info :: _ -> 274 274 + let addr = 275 275 + match addr_info with 276 276 + | `Tcp (ip, _) -> `Tcp (ip, port) 277 277 + | `Unix _ -> failwith "Unix sockets not supported" 278 278 + in 279 279 + let tcp_flow = Eio.Net.connect ~sw net addr in 280 280 + 281 281 + (* HTTP/2 requires TLS with ALPN advertising h2 *) 282 282 + if is_https then 283 283 + (* Force h2 ALPN for HTTP/2 *) 284 284 + let h2_tls = Tls_config.Client.h2 in 285 285 + match Tls_config.Client.to_tls_config h2_tls ~host with 286 286 + | Error msg -> Error (Tls_error msg) 287 287 + | Ok tls_config -> ( 288 288 + try 289 289 + let host_domain = 290 290 + match Domain_name.of_string host with 291 291 + | Ok dn -> ( 292 292 + match Domain_name.host dn with 293 293 + | Ok h -> Some h 294 294 + | Error _ -> None) 295 295 + | Error _ -> None 296 296 + in 297 297 + let tls_flow = 298 298 + Tls_eio.client_of_flow tls_config ?host:host_domain tcp_flow 299 299 + in 300 300 + let flow = (tls_flow :> Eio.Flow.two_way_ty r) in 301 301 + 302 302 + (* Build HTTP/2 request - h2 handles pseudo-headers automatically *) 303 303 + let headers = H2.Headers.of_list [ (":authority", host) ] in 304 304 + let req = H2.Request.create ~headers ~scheme `GET path in 305 305 + 306 306 + do_request flow req 307 307 + with 308 308 + | Tls_eio.Tls_failure failure -> 309 309 + Error (Tls_error (Tls_config.failure_to_string failure)) 310 310 + | exn -> Error (Tls_error (Printexc.to_string exn))) 311 311 + else 312 312 + (* HTTP/2 over cleartext (h2c) - less common *) 313 313 + let flow = (tcp_flow :> Eio.Flow.two_way_ty r) in 314 314 + let headers = H2.Headers.of_list [ (":authority", host) ] in 315 315 + let req = H2.Request.create ~headers ~scheme `GET path in 316 316 + do_request flow req

+280

lib/h2_server.ml

reviewed

··· 1 1 + (** HTTP/2 Server implementation using h2. 2 2 + 3 3 + This module provides HTTP/2 server functionality built on the h2 library 4 4 + with Eio for structured concurrency. *) 5 5 + 6 6 + open Eio.Std 7 7 + 8 8 + (** {1 Types} *) 9 9 + 10 10 + type request = { 11 11 + meth : H2.Method.t; 12 12 + target : string; 13 13 + headers : H2.Headers.t; 14 14 + body : string; 15 15 + } 16 16 + (** Request type exposed to handlers - same as Server.request for compatibility 17 17 + *) 18 18 + 19 19 + (** {1 Response Types} *) 20 20 + 21 21 + (** Response body - supports string, bigstring, streaming, and pre-built *) 22 22 + type response_body = 23 23 + | Body_string of string 24 24 + | Body_bigstring of Bigstringaf.t 25 25 + | Body_prebuilt of { h2_response : H2.Response.t; body : Bigstringaf.t } 26 26 + | Body_stream of { 27 27 + content_length : int64 option; 28 28 + next : unit -> Cstruct.t option; 29 29 + } 30 30 + 31 31 + type response = { 32 32 + status : H2.Status.t; 33 33 + headers : (string * string) list; 34 34 + response_body : response_body; 35 35 + } 36 36 + (** Response type with body variants *) 37 37 + 38 38 + type handler = request -> response 39 39 + 40 40 + (** {2 Optimized Response Constructors} *) 41 41 + 42 42 + let respond_opt ?(status = `OK) ?(headers = []) body = 43 43 + { status; headers; response_body = Body_string body } 44 44 + 45 45 + let respond_bigstring ?(status = `OK) ?(headers = []) bstr = 46 46 + { status; headers; response_body = Body_bigstring bstr } 47 47 + 48 48 + let respond_stream ?(status = `OK) ?(headers = []) ?content_length next = 49 49 + { status; headers; response_body = Body_stream { content_length; next } } 50 50 + 51 51 + let respond_prebuilt h2_response body = 52 52 + { 53 53 + status = `OK; 54 54 + headers = []; 55 55 + response_body = Body_prebuilt { h2_response; body }; 56 56 + } 57 57 + 58 58 + let make_h2_headers headers_list = H2.Headers.of_list headers_list 59 59 + 60 60 + let make_h2_response ?(status = `OK) headers = 61 61 + H2.Response.create ~headers status 62 62 + 63 63 + (** {1 Internal helpers} *) 64 64 + 65 65 + let set_tcp_nodelay flow = 66 66 + match Eio_unix.Resource.fd_opt flow with 67 67 + | None -> () 68 68 + | Some fd -> 69 69 + Eio_unix.Fd.use_exn "set_tcp_nodelay" fd (fun unix_fd -> 70 70 + Unix.setsockopt unix_fd Unix.TCP_NODELAY true) 71 71 + 72 72 + let write_iovecs flow iovecs = 73 73 + let cstructs = 74 74 + List.map 75 75 + (fun iov -> 76 76 + Cstruct.of_bigarray ~off:iov.H2.IOVec.off ~len:iov.H2.IOVec.len 77 77 + iov.H2.IOVec.buffer) 78 78 + iovecs 79 79 + in 80 80 + Eio.Flow.write flow cstructs 81 81 + 82 82 + (** {1 Connection handling} *) 83 83 + 84 84 + let handle_connection handler flow = 85 85 + let read_buffer_size = 0x4000 in 86 86 + let read_buffer = Bigstringaf.create read_buffer_size in 87 87 + 88 88 + let request_handler reqd = 89 89 + let req = H2.Reqd.request reqd in 90 90 + let body_reader = H2.Reqd.request_body reqd in 91 91 + 92 92 + let body = 93 93 + match req.meth with 94 94 + | `GET | `HEAD -> 95 95 + H2.Body.Reader.close body_reader; 96 96 + "" 97 97 + | `POST | `PUT | `DELETE | `CONNECT | `OPTIONS | `TRACE | `Other _ -> 98 98 + let body_buffer = Buffer.create 4096 in 99 99 + let body_done_promise, body_done_resolver = Eio.Promise.create () in 100 100 + let rec read_body () = 101 101 + H2.Body.Reader.schedule_read body_reader 102 102 + ~on_eof:(fun () -> Eio.Promise.resolve body_done_resolver ()) 103 103 + ~on_read:(fun buf ~off ~len -> 104 104 + Buffer.add_string body_buffer 105 105 + (Bigstringaf.substring buf ~off ~len); 106 106 + read_body ()) 107 107 + in 108 108 + read_body (); 109 109 + Eio.Promise.await body_done_promise; 110 110 + Buffer.contents body_buffer 111 111 + in 112 112 + 113 113 + let target = 114 114 + match H2.Headers.get req.headers ":path" with Some p -> p | None -> "/" 115 115 + in 116 116 + 117 117 + let request = { meth = req.meth; target; headers = req.headers; body } in 118 118 + let response = handler request in 119 119 + 120 120 + match response.response_body with 121 121 + | Body_string body -> 122 122 + let headers = 123 123 + H2.Headers.of_list 124 124 + (("content-length", string_of_int (String.length body)) 125 125 + :: response.headers) 126 126 + in 127 127 + let resp = H2.Response.create ~headers response.status in 128 128 + H2.Reqd.respond_with_string reqd resp body 129 129 + | Body_bigstring bstr -> 130 130 + let headers = 131 131 + H2.Headers.of_list 132 132 + (("content-length", string_of_int (Bigstringaf.length bstr)) 133 133 + :: response.headers) 134 134 + in 135 135 + let resp = H2.Response.create ~headers response.status in 136 136 + H2.Reqd.respond_with_bigstring reqd resp bstr 137 137 + | Body_prebuilt { h2_response; body } -> 138 138 + H2.Reqd.respond_with_bigstring reqd h2_response body 139 139 + | Body_stream { content_length; next } -> 140 140 + let headers = 141 141 + match content_length with 142 142 + | Some len -> 143 143 + H2.Headers.of_list 144 144 + (("content-length", Int64.to_string len) :: response.headers) 145 145 + | None -> H2.Headers.of_list response.headers 146 146 + in 147 147 + let resp = H2.Response.create ~headers response.status in 148 148 + let body_writer = H2.Reqd.respond_with_streaming reqd resp in 149 149 + let rec write_chunks () = 150 150 + match next () with 151 151 + | None -> H2.Body.Writer.close body_writer 152 152 + | Some cs -> 153 153 + H2.Body.Writer.write_bigstring body_writer ~off:0 154 154 + ~len:(Cstruct.length cs) (Cstruct.to_bigarray cs); 155 155 + write_chunks () 156 156 + in 157 157 + write_chunks () 158 158 + in 159 159 + 160 160 + let error_handler ?request:_ _error start_response = 161 161 + let resp_body = start_response H2.Headers.empty in 162 162 + H2.Body.Writer.write_string resp_body "Internal Server Error"; 163 163 + H2.Body.Writer.close resp_body 164 164 + in 165 165 + 166 166 + let conn = H2.Server_connection.create ~error_handler request_handler in 167 167 + 168 168 + let shutdown = ref false in 169 169 + 170 170 + let read_loop () = 171 171 + let rec loop () = 172 172 + if not !shutdown then 173 173 + match H2.Server_connection.next_read_operation conn with 174 174 + | `Read -> ( 175 175 + let cs = 176 176 + Cstruct.of_bigarray read_buffer ~off:0 ~len:read_buffer_size 177 177 + in 178 178 + try 179 179 + let n = Eio.Flow.single_read flow cs in 180 180 + let _ = 181 181 + H2.Server_connection.read conn read_buffer ~off:0 ~len:n 182 182 + in 183 183 + loop () 184 184 + with End_of_file -> 185 185 + let _ = 186 186 + H2.Server_connection.read_eof conn read_buffer ~off:0 ~len:0 187 187 + in 188 188 + shutdown := true) 189 189 + | `Close -> shutdown := true 190 190 + in 191 191 + loop () 192 192 + in 193 193 + 194 194 + let write_loop () = 195 195 + let rec loop () = 196 196 + if not !shutdown then 197 197 + match H2.Server_connection.next_write_operation conn with 198 198 + | `Write iovecs -> 199 199 + write_iovecs flow iovecs; 200 200 + let len = 201 201 + List.fold_left (fun acc iov -> acc + iov.H2.IOVec.len) 0 iovecs 202 202 + in 203 203 + H2.Server_connection.report_write_result conn (`Ok len); 204 204 + loop () 205 205 + | `Yield -> 206 206 + let continue = Eio.Promise.create () in 207 207 + H2.Server_connection.yield_writer conn (fun () -> 208 208 + Eio.Promise.resolve (snd continue) ()); 209 209 + Eio.Promise.await (fst continue); 210 210 + loop () 211 211 + | `Close _ -> shutdown := true 212 212 + in 213 213 + loop () 214 214 + in 215 215 + 216 216 + Fiber.both read_loop write_loop 217 217 + 218 218 + (** {1 Public API} *) 219 219 + 220 220 + let run ~sw ~net ?(config = H1_server.default_config) handler = 221 221 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 222 222 + let socket = 223 223 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 224 224 + ~reuse_port:config.reuse_port net addr 225 225 + in 226 226 + traceln "HTTP/2 Server listening on port %d" config.port; 227 227 + let connection_handler flow _addr = 228 228 + if config.tcp_nodelay then set_tcp_nodelay flow; 229 229 + handle_connection handler flow 230 230 + in 231 231 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 232 232 + Eio.Net.run_server socket connection_handler 233 233 + ~max_connections:config.max_connections ~on_error 234 234 + 235 235 + let run_tls ~sw ~net ?(config = H1_server.default_config) ~tls_config handler = 236 236 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 237 237 + let socket = 238 238 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 239 239 + ~reuse_port:config.reuse_port net addr 240 240 + in 241 241 + traceln "HTTP/2 Server (TLS) listening on port %d" config.port; 242 242 + let connection_handler flow _addr = 243 243 + if config.tcp_nodelay then set_tcp_nodelay flow; 244 244 + match Tls_config.Server.to_tls_config tls_config with 245 245 + | Error (`Msg msg) -> traceln "TLS config error: %s" msg 246 246 + | Ok tls_cfg -> ( 247 247 + try 248 248 + let tls_flow = Tls_eio.server_of_flow tls_cfg flow in 249 249 + handle_connection handler tls_flow 250 250 + with 251 251 + | Tls_eio.Tls_failure failure -> 252 252 + traceln "TLS error: %s" (Tls_config.failure_to_string failure) 253 253 + | exn -> traceln "TLS error: %s" (Printexc.to_string exn)) 254 254 + in 255 255 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 256 256 + Eio.Net.run_server socket connection_handler 257 257 + ~max_connections:config.max_connections ~on_error 258 258 + 259 259 + let run_parallel ~sw ~net ~domain_mgr ?(config = H1_server.default_config) 260 260 + handler = 261 261 + let domain_count = max 1 config.domain_count in 262 262 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 263 263 + let socket = 264 264 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 265 265 + ~reuse_port:config.reuse_port net addr 266 266 + in 267 267 + traceln "HTTP/2 Server listening on port %d (%d domains)" config.port 268 268 + domain_count; 269 269 + let connection_handler flow _addr = 270 270 + if config.tcp_nodelay then set_tcp_nodelay flow; 271 271 + handle_connection handler flow 272 272 + in 273 273 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 274 274 + if domain_count <= 1 then 275 275 + Eio.Net.run_server socket connection_handler 276 276 + ~max_connections:config.max_connections ~on_error 277 277 + else 278 278 + Eio.Net.run_server socket connection_handler 279 279 + ~max_connections:config.max_connections ~on_error 280 280 + ~additional_domains:(domain_mgr, domain_count - 1)

+73

lib/hcs.ml

reviewed

··· 1 1 + (** HCS - High-performance HTTP library for OCaml 5+. 2 2 + 3 3 + Built on Eio for structured concurrency, using h1 for HTTP/1.1 and h2 for 4 4 + HTTP/2 protocol handling. 5 5 + 6 6 + The library is designed with runtime abstraction in mind, making future Lwt 7 7 + support possible without major rewrites. *) 8 8 + 9 9 + module Client = Client 10 10 + (** HTTP Client *) 11 11 + 12 12 + module Server = Server 13 13 + (** HTTP Server *) 14 14 + 15 15 + module Router = Router 16 16 + (** Router with radix trie *) 17 17 + 18 18 + module Middleware = Middleware 19 19 + (** Middleware combinators *) 20 20 + 21 21 + module Middleware_eio = Middleware_eio 22 22 + (** Eio-specific middleware (logging, timeout, rate limiting, static files) *) 23 23 + 24 24 + module Control = Control 25 25 + (** Control flow: retry, circuit breaker, rate limiting *) 26 26 + 27 27 + module Pool = Pool 28 28 + (** Connection pool *) 29 29 + 30 30 + module Pooled_client = Pooled_client 31 31 + (** HTTP Client with connection pooling *) 32 32 + 33 33 + module Tls_config = Tls_config 34 34 + (** TLS configuration *) 35 35 + 36 36 + module Request = Request 37 37 + (** Request helpers *) 38 38 + 39 39 + module Response = Response 40 40 + (** Response helpers *) 41 41 + 42 42 + module H1_client = H1_client 43 43 + (** HTTP/1.1 Client *) 44 44 + 45 45 + module H2_client = H2_client 46 46 + (** HTTP/2 Client *) 47 47 + 48 48 + module H1_server = H1_server 49 49 + (** HTTP/1.1 Server (low-level, optimized) *) 50 50 + 51 51 + module H2_server = H2_server 52 52 + (** HTTP/2 Server *) 53 53 + 54 54 + module Websocket = Websocket 55 55 + (** WebSocket support *) 56 56 + 57 57 + module Codec = Codec 58 58 + (** Codec system for serialization/deserialization *) 59 59 + 60 60 + module Log = Log 61 61 + (** Logging system *) 62 62 + 63 63 + module Stream = Stream 64 64 + (** Streaming abstractions *) 65 65 + 66 66 + module Http = Http 67 67 + (** HTTP Request builder DSL *) 68 68 + 69 69 + module Method = H1.Method 70 70 + (** Re-exports for convenience *) 71 71 + 72 72 + module Status = H1.Status 73 73 + module Headers = H1.Headers

+261

lib/http.ml

reviewed

··· 1 1 + (** HTTP Request Builder DSL. 2 2 + 3 3 + This module provides a fluent API for building HTTP requests. It's designed 4 4 + to be used with the Client module for a high-level HTTP client experience. 5 5 + 6 6 + {1 Usage} 7 7 + 8 8 + {[ 9 9 + open Hcs.Http 10 10 + 11 11 + (* Simple GET request *) 12 12 + let req = get "https://api.example.com/users" |> build 13 13 + 14 14 + (* POST with JSON body *) 15 15 + let req = 16 16 + post "https://api.example.com/users" 17 17 + |> content_type "application/json" 18 18 + |> body_string {|{"name": "Alice"}|} 19 19 + |> build 20 20 + 21 21 + (* GET with query params and auth *) 22 22 + let req = 23 23 + get "https://api.example.com/search" 24 24 + |> query "q" "ocaml" |> query "limit" "10" |> bearer "my-token" |> build 25 25 + ]} *) 26 26 + 27 27 + (** {1 Types} *) 28 28 + 29 29 + (** HTTP method *) 30 30 + type meth = 31 31 + | GET 32 32 + | POST 33 33 + | PUT 34 34 + | DELETE 35 35 + | PATCH 36 36 + | HEAD 37 37 + | OPTIONS 38 38 + | CONNECT 39 39 + | TRACE 40 40 + | Other of string 41 41 + 42 42 + (** Body content *) 43 43 + type body = Empty | String of string | Form of (string * string) list 44 44 + 45 45 + type builder = { 46 46 + meth : meth; 47 47 + uri : Uri.t; 48 48 + headers : (string * string) list; 49 49 + body : body; 50 50 + } 51 51 + (** Request builder - accumulates request parameters *) 52 52 + 53 53 + type request = { 54 54 + req_meth : meth; 55 55 + req_uri : Uri.t; 56 56 + req_headers : (string * string) list; 57 57 + req_body : body; 58 58 + } 59 59 + (** Built request ready for execution *) 60 60 + 61 61 + (** {1 Method to H1.Method conversion} *) 62 62 + 63 63 + let meth_to_h1 = function 64 64 + | GET -> `GET 65 65 + | POST -> `POST 66 66 + | PUT -> `PUT 67 67 + | DELETE -> `DELETE 68 68 + | PATCH -> `Other "PATCH" 69 69 + | HEAD -> `HEAD 70 70 + | OPTIONS -> `OPTIONS 71 71 + | CONNECT -> `CONNECT 72 72 + | TRACE -> `TRACE 73 73 + | Other s -> `Other s 74 74 + 75 75 + let meth_of_string = function 76 76 + | "GET" -> GET 77 77 + | "POST" -> POST 78 78 + | "PUT" -> PUT 79 79 + | "DELETE" -> DELETE 80 80 + | "PATCH" -> PATCH 81 81 + | "HEAD" -> HEAD 82 82 + | "OPTIONS" -> OPTIONS 83 83 + | "CONNECT" -> CONNECT 84 84 + | "TRACE" -> TRACE 85 85 + | s -> Other s 86 86 + 87 87 + let meth_to_string = function 88 88 + | GET -> "GET" 89 89 + | POST -> "POST" 90 90 + | PUT -> "PUT" 91 91 + | DELETE -> "DELETE" 92 92 + | PATCH -> "PATCH" 93 93 + | HEAD -> "HEAD" 94 94 + | OPTIONS -> "OPTIONS" 95 95 + | CONNECT -> "CONNECT" 96 96 + | TRACE -> "TRACE" 97 97 + | Other s -> s 98 98 + 99 99 + (** {1 Request Builders} *) 100 100 + 101 101 + (** Create a builder with the given method and URL *) 102 102 + let create meth url = 103 103 + let uri = Uri.of_string url in 104 104 + { meth; uri; headers = []; body = Empty } 105 105 + 106 106 + (** Create a GET request builder *) 107 107 + let get url = create GET url 108 108 + 109 109 + (** Create a POST request builder *) 110 110 + let post url = create POST url 111 111 + 112 112 + (** Create a PUT request builder *) 113 113 + let put url = create PUT url 114 114 + 115 115 + (** Create a DELETE request builder *) 116 116 + let delete url = create DELETE url 117 117 + 118 118 + (** Create a PATCH request builder *) 119 119 + let patch url = create PATCH url 120 120 + 121 121 + (** Create a HEAD request builder *) 122 122 + let head url = create HEAD url 123 123 + 124 124 + (** Create an OPTIONS request builder *) 125 125 + let options url = create OPTIONS url 126 126 + 127 127 + (** Create a request builder from a Uri *) 128 128 + let of_uri meth uri = { meth; uri; headers = []; body = Empty } 129 129 + 130 130 + (** {2 Headers} *) 131 131 + 132 132 + (** Add a header to the request *) 133 133 + let header name value builder = 134 134 + { builder with headers = (name, value) :: builder.headers } 135 135 + 136 136 + (** Add multiple headers to the request *) 137 137 + let headers hdrs builder = 138 138 + { builder with headers = List.rev_append hdrs builder.headers } 139 139 + 140 140 + (** Set the Content-Type header *) 141 141 + let content_type ct builder = header "Content-Type" ct builder 142 142 + 143 143 + (** Set the Accept header *) 144 144 + let accept ct builder = header "Accept" ct builder 145 145 + 146 146 + (** Set the User-Agent header *) 147 147 + let user_agent ua builder = header "User-Agent" ua builder 148 148 + 149 149 + (** Set Bearer authentication *) 150 150 + let bearer token builder = header "Authorization" ("Bearer " ^ token) builder 151 151 + 152 152 + (** Set Basic authentication *) 153 153 + let basic_auth ~user ~pass builder = 154 154 + let credentials = Base64.encode_string (user ^ ":" ^ pass) in 155 155 + header "Authorization" ("Basic " ^ credentials) builder 156 156 + 157 157 + (** Set a cookie header *) 158 158 + let cookie name value builder = 159 159 + let existing = 160 160 + List.find_opt (fun (n, _) -> String.equal n "Cookie") builder.headers 161 161 + in 162 162 + let new_cookie = 163 163 + match existing with 164 164 + | Some (_, v) -> v ^ "; " ^ name ^ "=" ^ value 165 165 + | None -> name ^ "=" ^ value 166 166 + in 167 167 + let headers = 168 168 + List.filter (fun (n, _) -> not (String.equal n "Cookie")) builder.headers 169 169 + in 170 170 + { builder with headers = ("Cookie", new_cookie) :: headers } 171 171 + 172 172 + (** Set cookies from a list *) 173 173 + let cookies cs builder = 174 174 + List.fold_left (fun b (n, v) -> cookie n v b) builder cs 175 175 + 176 176 + (** {2 Query Parameters} *) 177 177 + 178 178 + (** Add a query parameter *) 179 179 + let query name value builder = 180 180 + let uri = Uri.add_query_param' builder.uri (name, value) in 181 181 + { builder with uri } 182 182 + 183 183 + (** Add multiple query parameters *) 184 184 + let queries qs builder = 185 185 + let uri = 186 186 + List.fold_left 187 187 + (fun u (n, v) -> Uri.add_query_param' u (n, v)) 188 188 + builder.uri qs 189 189 + in 190 190 + { builder with uri } 191 191 + 192 192 + (** {2 Body} *) 193 193 + 194 194 + (** Set the request body *) 195 195 + let body b builder = { builder with body = b } 196 196 + 197 197 + (** Set the body as a string with optional content type *) 198 198 + let body_string ?content_type:ct str builder = 199 199 + let builder = { builder with body = String str } in 200 200 + match ct with Some ct -> content_type ct builder | None -> builder 201 201 + 202 202 + (** Set the body as a JSON string *) 203 203 + let body_json json builder = 204 204 + builder |> body_string ~content_type:"application/json" json 205 205 + 206 206 + (** Set the body as form data *) 207 207 + let form fields builder = 208 208 + { builder with body = Form fields } 209 209 + |> content_type "application/x-www-form-urlencoded" 210 210 + 211 211 + (** {1 Building} *) 212 212 + 213 213 + (** Build the final request *) 214 214 + let build builder = 215 215 + { 216 216 + req_meth = builder.meth; 217 217 + req_uri = builder.uri; 218 218 + req_headers = List.rev builder.headers; 219 219 + req_body = builder.body; 220 220 + } 221 221 + 222 222 + (** Get the URL as a string *) 223 223 + let url request = Uri.to_string request.req_uri 224 224 + 225 225 + (** Get the host from the request *) 226 226 + let host request = Uri.host request.req_uri |> Option.value ~default:"localhost" 227 227 + 228 228 + (** Get the port from the request *) 229 229 + let port request = 230 230 + match Uri.port request.req_uri with 231 231 + | Some p -> p 232 232 + | None -> ( 233 233 + match Uri.scheme request.req_uri with Some "https" -> 443 | _ -> 80) 234 234 + 235 235 + (** Get the path from the request *) 236 236 + let path request = 237 237 + let p = Uri.path request.req_uri in 238 238 + if p = "" then "/" else p 239 239 + 240 240 + (** Get the path and query from the request *) 241 241 + let path_and_query request = Uri.path_and_query request.req_uri 242 242 + 243 243 + (** Check if the request is HTTPS *) 244 244 + let is_https request = 245 245 + match Uri.scheme request.req_uri with Some "https" -> true | _ -> false 246 246 + 247 247 + (** {1 Body Encoding} *) 248 248 + 249 249 + (** Encode form data as URL-encoded string *) 250 250 + let encode_form fields = 251 251 + String.concat "&" 252 252 + (List.map (fun (k, v) -> Uri.pct_encode k ^ "=" ^ Uri.pct_encode v) fields) 253 253 + 254 254 + (** Get the body as a string *) 255 255 + let body_to_string = function 256 256 + | Empty -> "" 257 257 + | String s -> s 258 258 + | Form fields -> encode_form fields 259 259 + 260 260 + (** Get the Content-Length for the body *) 261 261 + let body_length body = String.length (body_to_string body)

+311

lib/log.ml

reviewed

··· 1 1 + (** Logging module for HCS HTTP library. 2 2 + 3 3 + Provides structured logging for HTTP events including requests, responses, 4 4 + connections, and errors. The module is runtime-agnostic and uses a 5 5 + callback-based approach for flexibility. 6 6 + 7 7 + {1 Usage} 8 8 + 9 9 + {[ 10 10 + (* Use built-in stderr logger *) 11 11 + let logger = Hcs.Log.stderr () 12 12 + 13 13 + (* Use null logger (no output) *) 14 14 + let logger = Hcs.Log.null 15 15 + 16 16 + (* Use custom logger *) 17 17 + let logger = 18 18 + Hcs.Log.custom (fun level msg -> 19 19 + match level with 20 20 + | Hcs.Log.Error -> Printf.eprintf "[ERROR] %s\n%!" msg 21 21 + | _ -> 22 22 + Printf.printf "[%s] %s\n%!" (Hcs.Log.level_to_string level) msg) 23 23 + ]} *) 24 24 + 25 25 + (** {1 Types} *) 26 26 + 27 27 + (** Log levels *) 28 28 + type level = 29 29 + | Debug (** Detailed debugging information *) 30 30 + | Info (** General information about operations *) 31 31 + | Warn (** Warning conditions *) 32 32 + | Error (** Error conditions *) 33 33 + 34 34 + (** HTTP method for logging (simplified) *) 35 35 + type http_method = 36 36 + | GET 37 37 + | POST 38 38 + | PUT 39 39 + | DELETE 40 40 + | PATCH 41 41 + | HEAD 42 42 + | OPTIONS 43 43 + | CONNECT 44 44 + | TRACE 45 45 + | Other of string 46 46 + 47 47 + (** Log events - structured events that can be logged *) 48 48 + type event = 49 49 + | Request_start of { 50 50 + id : string; 51 51 + meth : http_method; 52 52 + uri : string; 53 53 + headers : (string * string) list; 54 54 + } (** Request started *) 55 55 + | Request_end of { 56 56 + id : string; 57 57 + status : int; 58 58 + duration_ms : float; 59 59 + body_size : int option; 60 60 + } (** Request completed *) 61 61 + | Connection_open of { 62 62 + host : string; 63 63 + port : int; 64 64 + protocol : string; (** "http/1.1" or "h2" *) 65 65 + } (** Connection opened *) 66 66 + | Connection_close of { host : string; port : int; reason : string } 67 67 + (** Connection closed *) 68 68 + | Connection_reuse of { host : string; port : int } 69 69 + (** Connection reused from pool *) 70 70 + | Tls_handshake of { 71 71 + host : string; 72 72 + protocol : string; (** TLS version *) 73 73 + cipher : string option; 74 74 + } (** TLS handshake completed *) 75 75 + | Retry of { 76 76 + id : string; 77 77 + attempt : int; 78 78 + reason : string; 79 79 + delay_ms : float option; 80 80 + } (** Request retry *) 81 81 + | Redirect of { 82 82 + id : string; 83 83 + from_uri : string; 84 84 + to_uri : string; 85 85 + status : int; 86 86 + } (** Following redirect *) 87 87 + | Error of { id : string option; error : string; context : string option } 88 88 + (** Error occurred *) 89 89 + | Custom of { name : string; data : (string * string) list } 90 90 + (** Custom event *) 91 91 + 92 92 + type logger = level -> event -> unit 93 93 + (** Logger function type *) 94 94 + 95 95 + (** {1 Level operations} *) 96 96 + 97 97 + (** Convert level to string *) 98 98 + let level_to_string = function 99 99 + | Debug -> "DEBUG" 100 100 + | Info -> "INFO" 101 101 + | Warn -> "WARN" 102 102 + | Error -> "ERROR" 103 103 + 104 104 + (** Parse level from string *) 105 105 + let level_of_string = function 106 106 + | "DEBUG" | "debug" -> Some Debug 107 107 + | "INFO" | "info" -> Some Info 108 108 + | "WARN" | "warn" | "WARNING" | "warning" -> Some Warn 109 109 + | "ERROR" | "error" -> Some Error 110 110 + | _ -> None 111 111 + 112 112 + (** Compare log levels (for filtering) *) 113 113 + let level_to_int = function Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 114 114 + 115 115 + let level_gte l1 l2 = level_to_int l1 >= level_to_int l2 116 116 + 117 117 + (** {1 HTTP method operations} *) 118 118 + 119 119 + let method_to_string = function 120 120 + | GET -> "GET" 121 121 + | POST -> "POST" 122 122 + | PUT -> "PUT" 123 123 + | DELETE -> "DELETE" 124 124 + | PATCH -> "PATCH" 125 125 + | HEAD -> "HEAD" 126 126 + | OPTIONS -> "OPTIONS" 127 127 + | CONNECT -> "CONNECT" 128 128 + | TRACE -> "TRACE" 129 129 + | Other s -> s 130 130 + 131 131 + let method_of_h1 (m : Httpun_types.Method.t) : http_method = 132 132 + match m with 133 133 + | `GET -> GET 134 134 + | `POST -> POST 135 135 + | `PUT -> PUT 136 136 + | `DELETE -> DELETE 137 137 + | `HEAD -> HEAD 138 138 + | `OPTIONS -> OPTIONS 139 139 + | `CONNECT -> CONNECT 140 140 + | `TRACE -> TRACE 141 141 + | `Other s -> Other s 142 142 + 143 143 + (** {1 Event formatting} *) 144 144 + 145 145 + (** Format event as a human-readable string *) 146 146 + let event_to_string = function 147 147 + | Request_start { id; meth; uri; headers = _ } -> 148 148 + Printf.sprintf "Request[%s] %s %s" id (method_to_string meth) uri 149 149 + | Request_end { id; status; duration_ms; body_size } -> 150 150 + let size_str = 151 151 + match body_size with 152 152 + | Some s -> Printf.sprintf ", %d bytes" s 153 153 + | None -> "" 154 154 + in 155 155 + Printf.sprintf "Request[%s] completed: status=%d, duration=%.2fms%s" id 156 156 + status duration_ms size_str 157 157 + | Connection_open { host; port; protocol } -> 158 158 + Printf.sprintf "Connection opened: %s:%d (%s)" host port protocol 159 159 + | Connection_close { host; port; reason } -> 160 160 + Printf.sprintf "Connection closed: %s:%d (%s)" host port reason 161 161 + | Connection_reuse { host; port } -> 162 162 + Printf.sprintf "Connection reused: %s:%d" host port 163 163 + | Tls_handshake { host; protocol; cipher } -> 164 164 + let cipher_str = 165 165 + match cipher with Some c -> ", cipher=" ^ c | None -> "" 166 166 + in 167 167 + Printf.sprintf "TLS handshake: %s (%s%s)" host protocol cipher_str 168 168 + | Retry { id; attempt; reason; delay_ms } -> 169 169 + let delay_str = 170 170 + match delay_ms with 171 171 + | Some d -> Printf.sprintf ", delay=%.0fms" d 172 172 + | None -> "" 173 173 + in 174 174 + Printf.sprintf "Request[%s] retry #%d: %s%s" id attempt reason delay_str 175 175 + | Redirect { id; from_uri; to_uri; status } -> 176 176 + Printf.sprintf "Request[%s] redirect %d: %s -> %s" id status from_uri 177 177 + to_uri 178 178 + | Error { id; error; context } -> 179 179 + let id_str = 180 180 + match id with Some i -> Printf.sprintf "[%s] " i | None -> "" 181 181 + in 182 182 + let ctx_str = 183 183 + match context with Some c -> " (" ^ c ^ ")" | None -> "" 184 184 + in 185 185 + Printf.sprintf "Error%s: %s%s" id_str error ctx_str 186 186 + | Custom { name; data } -> 187 187 + let data_str = 188 188 + String.concat ", " 189 189 + (List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) data) 190 190 + in 191 191 + Printf.sprintf "Custom[%s]: %s" name data_str 192 192 + 193 193 + (** Format event as JSON string *) 194 194 + let event_to_json = function 195 195 + | Request_start { id; meth; uri; headers } -> 196 196 + let headers_json = 197 197 + String.concat "," 198 198 + (List.map (fun (k, v) -> Printf.sprintf {|"%s":"%s"|} k v) headers) 199 199 + in 200 200 + Printf.sprintf 201 201 + {|{"event":"request_start","id":"%s","method":"%s","uri":"%s","headers":{%s}}|} 202 202 + id (method_to_string meth) uri headers_json 203 203 + | Request_end { id; status; duration_ms; body_size } -> 204 204 + let size_json = 205 205 + match body_size with 206 206 + | Some s -> Printf.sprintf {|,"body_size":%d|} s 207 207 + | None -> "" 208 208 + in 209 209 + Printf.sprintf 210 210 + {|{"event":"request_end","id":"%s","status":%d,"duration_ms":%.2f%s}|} 211 211 + id status duration_ms size_json 212 212 + | Connection_open { host; port; protocol } -> 213 213 + Printf.sprintf 214 214 + {|{"event":"connection_open","host":"%s","port":%d,"protocol":"%s"}|} 215 215 + host port protocol 216 216 + | Connection_close { host; port; reason } -> 217 217 + Printf.sprintf 218 218 + {|{"event":"connection_close","host":"%s","port":%d,"reason":"%s"}|} 219 219 + host port reason 220 220 + | Connection_reuse { host; port } -> 221 221 + Printf.sprintf {|{"event":"connection_reuse","host":"%s","port":%d}|} host 222 222 + port 223 223 + | Tls_handshake { host; protocol; cipher } -> 224 224 + let cipher_json = 225 225 + match cipher with 226 226 + | Some c -> Printf.sprintf {|,"cipher":"%s"|} c 227 227 + | None -> "" 228 228 + in 229 229 + Printf.sprintf {|{"event":"tls_handshake","host":"%s","protocol":"%s"%s}|} 230 230 + host protocol cipher_json 231 231 + | Retry { id; attempt; reason; delay_ms } -> 232 232 + let delay_json = 233 233 + match delay_ms with 234 234 + | Some d -> Printf.sprintf {|,"delay_ms":%.0f|} d 235 235 + | None -> "" 236 236 + in 237 237 + Printf.sprintf 238 238 + {|{"event":"retry","id":"%s","attempt":%d,"reason":"%s"%s}|} id attempt 239 239 + reason delay_json 240 240 + | Redirect { id; from_uri; to_uri; status } -> 241 241 + Printf.sprintf 242 242 + {|{"event":"redirect","id":"%s","from":"%s","to":"%s","status":%d}|} id 243 243 + from_uri to_uri status 244 244 + | Error { id; error; context } -> 245 245 + let id_json = 246 246 + match id with Some i -> Printf.sprintf {|"id":"%s",|} i | None -> "" 247 247 + in 248 248 + let ctx_json = 249 249 + match context with 250 250 + | Some c -> Printf.sprintf {|,"context":"%s"|} c 251 251 + | None -> "" 252 252 + in 253 253 + Printf.sprintf {|{"event":"error",%s"error":"%s"%s}|} id_json error 254 254 + ctx_json 255 255 + | Custom { name; data } -> 256 256 + let data_json = 257 257 + String.concat "," 258 258 + (List.map (fun (k, v) -> Printf.sprintf {|"%s":"%s"|} k v) data) 259 259 + in 260 260 + Printf.sprintf {|{"event":"custom","name":"%s","data":{%s}}|} name 261 261 + data_json 262 262 + 263 263 + (** {1 Built-in Loggers} *) 264 264 + 265 265 + (** Null logger - discards all events *) 266 266 + let null : logger = fun _ _ -> () 267 267 + 268 268 + (** Stderr logger with optional minimum level filter *) 269 269 + let stderr ?(min_level = Debug) ?(json = false) () : logger = 270 270 + fun level event -> 271 271 + if level_gte level min_level then 272 272 + let formatted = 273 273 + if json then event_to_json event else event_to_string event 274 274 + in 275 275 + Printf.eprintf "[%s] %s\n%!" (level_to_string level) formatted 276 276 + 277 277 + (** Stdout logger with optional minimum level filter *) 278 278 + let stdout ?(min_level = Debug) ?(json = false) () : logger = 279 279 + fun level event -> 280 280 + if level_gte level min_level then 281 281 + let formatted = 282 282 + if json then event_to_json event else event_to_string event 283 283 + in 284 284 + Printf.printf "[%s] %s\n%!" (level_to_string level) formatted 285 285 + 286 286 + (** Custom logger from a simple callback *) 287 287 + let custom (f : level -> string -> unit) : logger = 288 288 + fun level event -> f level (event_to_string event) 289 289 + 290 290 + (** Custom logger with JSON output *) 291 291 + let custom_json (f : level -> string -> unit) : logger = 292 292 + fun level event -> f level (event_to_json event) 293 293 + 294 294 + (** Combine multiple loggers *) 295 295 + let combine (loggers : logger list) : logger = 296 296 + fun level event -> List.iter (fun logger -> logger level event) loggers 297 297 + 298 298 + (** Filter logger by minimum level *) 299 299 + let with_min_level (min_level : level) (logger : logger) : logger = 300 300 + fun level event -> if level_gte level min_level then logger level event 301 301 + 302 302 + (** {1 Request ID generation} *) 303 303 + 304 304 + (** Counter for unique request IDs *) 305 305 + let request_id_counter = ref 0 306 306 + 307 307 + (** Generate a unique request ID *) 308 308 + let generate_request_id () = 309 309 + incr request_id_counter; 310 310 + let random = Random.int 0xFFFF in 311 311 + Printf.sprintf "req-%06d-%04x" !request_id_counter random

+53

lib/middleware.ml

reviewed

··· 1 1 + (** Middleware support for HCS HTTP server. 2 2 + 3 3 + Middleware wraps request handlers to add cross-cutting concerns like 4 4 + logging, authentication, CORS, etc. *) 5 5 + 6 6 + type ('req, 'resp) t = ('req -> 'resp) -> 'req -> 'resp 7 7 + (** Middleware type - wraps a handler *) 8 8 + 9 9 + (** Identity middleware - does nothing *) 10 10 + let identity : ('req, 'resp) t = fun handler req -> handler req 11 11 + 12 12 + (** Compose two middleware: m1 runs before m2 *) 13 13 + let compose (m1 : ('req, 'resp) t) (m2 : ('req, 'resp) t) : ('req, 'resp) t = 14 14 + fun handler -> m1 (m2 handler) 15 15 + 16 16 + (** Compose a list of middleware *) 17 17 + let compose_all middlewares = List.fold_right compose middlewares identity 18 18 + 19 19 + (** Infix operator for middleware composition *) 20 20 + let ( @> ) = compose 21 21 + 22 22 + (** Apply middleware to a handler *) 23 23 + let apply middleware handler = middleware handler 24 24 + 25 25 + (** Logging middleware - logs requests (generic version) *) 26 26 + let logging ~log : ('req, 'resp) t = 27 27 + fun handler req -> 28 28 + log "Request received"; 29 29 + let resp = handler req in 30 30 + log "Response sent"; 31 31 + resp 32 32 + 33 33 + (** Timing middleware - measures request duration *) 34 34 + let timing ~on_complete : ('req, 'resp) t = 35 35 + fun handler req -> 36 36 + let start = Unix.gettimeofday () in 37 37 + let resp = handler req in 38 38 + let duration = Unix.gettimeofday () -. start in 39 39 + on_complete duration; 40 40 + resp 41 41 + 42 42 + (** Exception recovery middleware *) 43 43 + let recover ~on_error : ('req, 'resp) t = 44 44 + fun handler req -> try handler req with exn -> on_error exn 45 45 + 46 46 + (** Conditional middleware - only applies if predicate is true *) 47 47 + let when_ predicate middleware : ('req, 'resp) t = 48 48 + fun handler req -> 49 49 + if predicate req then middleware handler req else handler req 50 50 + 51 51 + (** Skip middleware for certain requests *) 52 52 + let unless predicate middleware = 53 53 + when_ (fun req -> not (predicate req)) middleware

+349

lib/middleware_eio.ml

reviewed

··· 1 1 + (** Eio-specific middleware implementations. 2 2 + 3 3 + These middleware require Eio runtime features like clocks, filesystem 4 4 + access, and structured concurrency. 5 5 + 6 6 + {1 Usage} 7 7 + 8 8 + {[ 9 9 + open Hcs.Middleware_eio 10 10 + 11 11 + (* Add logging with timing *) 12 12 + let handler = 13 13 + handler 14 14 + |> Middleware.apply (logging ~clock (Log.stderr ())) 15 15 + |> Middleware.apply (timeout ~clock 30.0) 16 16 + ]} *) 17 17 + 18 18 + (** {1 String Helpers} *) 19 19 + 20 20 + (** Check if string starts with prefix *) 21 21 + let string_starts_with ~prefix s = 22 22 + let plen = String.length prefix in 23 23 + let slen = String.length s in 24 24 + plen <= slen && String.sub s 0 plen = prefix 25 25 + 26 26 + (** Check if substring exists in string *) 27 27 + let string_contains_substring ~substring s = 28 28 + let rec check i = 29 29 + if i + String.length substring > String.length s then false 30 30 + else if String.sub s i (String.length substring) = substring then true 31 31 + else check (i + 1) 32 32 + in 33 33 + check 0 34 34 + 35 35 + (** {1 Types} *) 36 36 + 37 37 + type request = Server.request 38 38 + (** Server request type (simplified for middleware) *) 39 39 + 40 40 + type response = Server.response 41 41 + (** Server response type *) 42 42 + 43 43 + type middleware = (request -> response) -> request -> response 44 44 + (** Middleware type matching Server.handler *) 45 45 + 46 46 + (** {1 Response Helpers} *) 47 47 + 48 48 + (** Get the body size from a response, if known *) 49 49 + let response_body_size (resp : response) : int option = 50 50 + match resp.Server.body with 51 51 + | Server.Body_empty -> Some 0 52 52 + | Server.Body_string s -> Some (String.length s) 53 53 + | Server.Body_bigstring b -> Some (Bigstringaf.length b) 54 54 + | Server.Body_prebuilt p -> Some (Bigstringaf.length p.Server.Prebuilt.body) 55 55 + | Server.Body_stream _ -> None 56 56 + 57 57 + let response_body_string (resp : response) : string = 58 58 + match resp.Server.body with 59 59 + | Server.Body_empty -> "" 60 60 + | Server.Body_string s -> s 61 61 + | Server.Body_bigstring b -> Bigstringaf.to_string b 62 62 + | Server.Body_prebuilt p -> Bigstringaf.to_string p.Server.Prebuilt.body 63 63 + | Server.Body_stream _ -> "" 64 64 + 65 65 + (** {1 Logging Middleware} *) 66 66 + 67 67 + (** Logging middleware that records request timing and details. 68 68 + 69 69 + Uses the Log module for structured event logging. *) 70 70 + let logging ~(clock : _ Eio.Time.clock) (logger : Log.logger) : middleware = 71 71 + fun handler req -> 72 72 + let id = Log.generate_request_id () in 73 73 + let start = Eio.Time.now clock in 74 74 + let meth = Log.method_of_h1 req.Server.meth in 75 75 + logger Log.Info 76 76 + (Log.Request_start { id; meth; uri = req.target; headers = req.headers }); 77 77 + let resp = handler req in 78 78 + let duration_ms = (Eio.Time.now clock -. start) *. 1000.0 in 79 79 + let status = H1.Status.to_code resp.Server.status in 80 80 + let body_size = response_body_size resp in 81 81 + logger Log.Info (Log.Request_end { id; status; duration_ms; body_size }); 82 82 + resp 83 83 + 84 84 + (** {1 Timeout Middleware} *) 85 85 + 86 86 + (** Timeout middleware that cancels requests exceeding the time limit. 87 87 + 88 88 + Returns a 504 Gateway Timeout response if the handler takes too long. *) 89 89 + let timeout ~(clock : _ Eio.Time.clock) (seconds : float) : middleware = 90 90 + fun handler req -> 91 91 + let timeout_response () = 92 92 + Eio.Time.sleep clock seconds; 93 93 + Server.respond ~status:`Gateway_timeout "Request timed out" 94 94 + in 95 95 + Eio.Fiber.first (fun () -> handler req) timeout_response 96 96 + 97 97 + (** {1 Rate Limiting} *) 98 98 + 99 99 + (** Simple in-memory rate limiter state *) 100 100 + module Rate_limit_state = struct 101 101 + type t = { 102 102 + mutable requests : int; 103 103 + mutable window_start : float; 104 104 + window_seconds : float; 105 105 + max_requests : int; 106 106 + } 107 107 + 108 108 + let create ~max_requests ~window_seconds = 109 109 + { requests = 0; window_start = 0.0; window_seconds; max_requests } 110 110 + 111 111 + let check_and_increment t now = 112 112 + if now -. t.window_start >= t.window_seconds then begin 113 113 + t.window_start <- now; 114 114 + t.requests <- 1; 115 115 + true 116 116 + end 117 117 + else if t.requests < t.max_requests then begin 118 118 + t.requests <- t.requests + 1; 119 119 + true 120 120 + end 121 121 + else false 122 122 + 123 123 + let remaining t = max 0 (t.max_requests - t.requests) 124 124 + let reset_at t = t.window_start +. t.window_seconds 125 125 + end 126 126 + 127 127 + (** Rate limiting middleware. 128 128 + 129 129 + Limits requests per time window, keyed by a function (e.g., by IP, by user). 130 130 + Returns 429 Too Many Requests when the limit is exceeded. *) 131 131 + let rate_limit ~(clock : _ Eio.Time.clock) ~(key : request -> string) 132 132 + ~(requests : int) ~(per : float) : middleware = 133 133 + let states : (string, Rate_limit_state.t) Hashtbl.t = Hashtbl.create 256 in 134 134 + let mutex = Eio.Mutex.create () in 135 135 + fun handler req -> 136 136 + let k = key req in 137 137 + let now = Eio.Time.now clock in 138 138 + let allowed, remaining, reset_at = 139 139 + Eio.Mutex.use_rw ~protect:true mutex (fun () -> 140 140 + let state = 141 141 + match Hashtbl.find_opt states k with 142 142 + | Some s -> s 143 143 + | None -> 144 144 + let s = 145 145 + Rate_limit_state.create ~max_requests:requests 146 146 + ~window_seconds:per 147 147 + in 148 148 + Hashtbl.add states k s; 149 149 + s 150 150 + in 151 151 + let allowed = Rate_limit_state.check_and_increment state now in 152 152 + ( allowed, 153 153 + Rate_limit_state.remaining state, 154 154 + Rate_limit_state.reset_at state )) 155 155 + in 156 156 + if allowed then handler req 157 157 + else 158 158 + let headers = 159 159 + [ 160 160 + ("X-RateLimit-Limit", string_of_int requests); 161 161 + ("X-RateLimit-Remaining", string_of_int remaining); 162 162 + ("X-RateLimit-Reset", string_of_int (int_of_float reset_at)); 163 163 + ("Retry-After", string_of_int (int_of_float (reset_at -. now))); 164 164 + ] 165 165 + in 166 166 + { 167 167 + Server.status = `Code 429; 168 168 + headers; 169 169 + body = Server.Body_string "Too Many Requests"; 170 170 + } 171 171 + 172 172 + (** {1 ETag and Caching} *) 173 173 + 174 174 + (** Generate ETag from response body using MD5 hash *) 175 175 + let generate_etag body = 176 176 + let hash = Digestif.MD5.digest_string body in 177 177 + "\"" ^ Digestif.MD5.to_hex hash ^ "\"" 178 178 + 179 179 + let etag : middleware = 180 180 + fun handler req -> 181 181 + let resp = handler req in 182 182 + let body_str = response_body_string resp in 183 183 + let etag_value = generate_etag body_str in 184 184 + let if_none_match = 185 185 + List.find_opt 186 186 + (fun (n, _) -> String.lowercase_ascii n = "if-none-match") 187 187 + req.headers 188 188 + |> Option.map snd 189 189 + in 190 190 + match if_none_match with 191 191 + | Some client_etag when String.equal client_etag etag_value -> 192 192 + { 193 193 + status = `Code 304; 194 194 + headers = [ ("ETag", etag_value) ]; 195 195 + body = Server.Body_empty; 196 196 + } 197 197 + | _ -> { resp with headers = ("ETag", etag_value) :: resp.headers } 198 198 + 199 199 + (** Cache-Control middleware - adds Cache-Control header *) 200 200 + let cache_control (directive : string) : middleware = 201 201 + fun handler req -> 202 202 + let resp = handler req in 203 203 + { resp with headers = ("Cache-Control", directive) :: resp.headers } 204 204 + 205 205 + (** {1 Static Files} *) 206 206 + 207 207 + (** MIME type mapping for common file extensions *) 208 208 + let mime_type_of_extension ext = 209 209 + match String.lowercase_ascii ext with 210 210 + | ".html" | ".htm" -> "text/html; charset=utf-8" 211 211 + | ".css" -> "text/css; charset=utf-8" 212 212 + | ".js" -> "application/javascript; charset=utf-8" 213 213 + | ".json" -> "application/json" 214 214 + | ".xml" -> "application/xml" 215 215 + | ".txt" -> "text/plain; charset=utf-8" 216 216 + | ".png" -> "image/png" 217 217 + | ".jpg" | ".jpeg" -> "image/jpeg" 218 218 + | ".gif" -> "image/gif" 219 219 + | ".svg" -> "image/svg+xml" 220 220 + | ".ico" -> "image/x-icon" 221 221 + | ".webp" -> "image/webp" 222 222 + | ".woff" -> "font/woff" 223 223 + | ".woff2" -> "font/woff2" 224 224 + | ".ttf" -> "font/ttf" 225 225 + | ".otf" -> "font/otf" 226 226 + | ".pdf" -> "application/pdf" 227 227 + | ".zip" -> "application/zip" 228 228 + | ".gz" -> "application/gzip" 229 229 + | ".mp3" -> "audio/mpeg" 230 230 + | ".mp4" -> "video/mp4" 231 231 + | ".webm" -> "video/webm" 232 232 + | _ -> "application/octet-stream" 233 233 + 234 234 + (** Get file extension from path *) 235 235 + let extension path = 236 236 + match String.rindex_opt path '.' with 237 237 + | Some i -> String.sub path i (String.length path - i) 238 238 + | None -> "" 239 239 + 240 240 + (** Static file middleware - serves files from a directory. 241 241 + 242 242 + @param fs The Eio filesystem to use 243 243 + @param root The root directory path for static files 244 244 + @param index 245 245 + Index files to try for directory requests (default: ["index.html"]) 246 246 + @param with_etag Whether to add ETag headers (default: true) *) 247 247 + let static ~(fs : _ Eio.Path.t) ?(index = [ "index.html" ]) ?(with_etag = true) 248 248 + (root : string) : middleware = 249 249 + fun handler req -> 250 250 + (* Only handle GET and HEAD *) 251 251 + match req.meth with 252 252 + | `GET | `HEAD -> ( 253 253 + (* Normalize and validate path to prevent directory traversal *) 254 254 + let path = req.target in 255 255 + let path = 256 256 + if String.length path > 0 && path.[0] = '/' then 257 257 + String.sub path 1 (String.length path - 1) 258 258 + else path 259 259 + in 260 260 + (* Remove query string *) 261 261 + let path = 262 262 + match String.index_opt path '?' with 263 263 + | Some i -> String.sub path 0 i 264 264 + | None -> path 265 265 + in 266 266 + (* Check for directory traversal *) 267 267 + if String.contains path '\x00' || string_starts_with ~prefix:".." path 268 268 + then handler req (* Pass to next handler *) 269 269 + else 270 270 + let full_path = Eio.Path.(fs / root / path) in 271 271 + try 272 272 + (* Try to read the file *) 273 273 + let content = Eio.Path.load full_path in 274 274 + let content_type = mime_type_of_extension (extension path) in 275 275 + let headers = 276 276 + [ 277 277 + ("Content-Type", content_type); 278 278 + ("Content-Length", string_of_int (String.length content)); 279 279 + ] 280 280 + in 281 281 + let headers = 282 282 + if with_etag then ("ETag", generate_etag content) :: headers 283 283 + else headers 284 284 + in 285 285 + (* Handle If-None-Match *) 286 286 + let if_none_match = 287 287 + List.find_opt 288 288 + (fun (n, _) -> String.lowercase_ascii n = "if-none-match") 289 289 + req.headers 290 290 + |> Option.map snd 291 291 + in 292 292 + let etag_value = generate_etag content in 293 293 + match if_none_match with 294 294 + | Some client_etag when String.equal client_etag etag_value -> 295 295 + { 296 296 + status = `Code 304; 297 297 + headers = [ ("ETag", etag_value) ]; 298 298 + body = Server.Body_empty; 299 299 + } 300 300 + | _ -> 301 301 + let body = 302 302 + if req.meth = `HEAD then Server.Body_empty 303 303 + else Server.Body_string content 304 304 + in 305 305 + { status = `OK; headers; body } 306 306 + with 307 307 + | Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> ( 308 308 + (* Try index files if path looks like a directory *) 309 309 + let try_index () = 310 310 + List.find_map 311 311 + (fun idx -> 312 312 + try 313 313 + let idx_path = Eio.Path.(fs / root / path / idx) in 314 314 + let content = Eio.Path.load idx_path in 315 315 + Some (idx, content) 316 316 + with _ -> None) 317 317 + index 318 318 + in 319 319 + match try_index () with 320 320 + | Some (idx, content) -> 321 321 + let content_type = mime_type_of_extension (extension idx) in 322 322 + let headers = 323 323 + [ 324 324 + ("Content-Type", content_type); 325 325 + ("Content-Length", string_of_int (String.length content)); 326 326 + ] 327 327 + in 328 328 + let body = 329 329 + if req.meth = `HEAD then Server.Body_empty 330 330 + else Server.Body_string content 331 331 + in 332 332 + { status = `OK; headers; body } 333 333 + | None -> handler req) 334 334 + | _ -> handler req) 335 335 + | _ -> handler req 336 336 + 337 337 + (** {1 Compression} *) 338 338 + 339 339 + (** Note: Compression middleware would require a compression library like 340 340 + camlzip or decompress. For now, we provide a placeholder that can be 341 341 + implemented when those dependencies are available. *) 342 342 + 343 343 + (** Check if client accepts gzip encoding *) 344 344 + let accepts_gzip (req : request) = 345 345 + List.exists 346 346 + (fun (n, v) -> 347 347 + String.lowercase_ascii n = "accept-encoding" 348 348 + && string_contains_substring ~substring:"gzip" v) 349 349 + req.headers

+159

lib/pool.ml

reviewed

··· 1 1 + (** Connection pool for HTTP client. 2 2 + 3 3 + This module provides a runtime-agnostic connection pool structure. The 4 4 + actual connection management is done by the runtime-specific code. *) 5 5 + 6 6 + type config = { 7 7 + max_connections_per_host : int; (** Max connections per host:port *) 8 8 + max_total_connections : int; (** Max total connections *) 9 9 + idle_timeout : float; (** Seconds before closing idle connection *) 10 10 + connection_timeout : float; (** Seconds to wait for connection *) 11 11 + } 12 12 + (** Pool configuration *) 13 13 + 14 14 + let default_config = 15 15 + { 16 16 + max_connections_per_host = 10; 17 17 + max_total_connections = 100; 18 18 + idle_timeout = 60.0; 19 19 + connection_timeout = 30.0; 20 20 + } 21 21 + 22 22 + type key = { host : string; port : int; tls : bool } 23 23 + (** Connection key - identifies a connection target *) 24 24 + 25 25 + let make_key ~host ~port ~tls = { host; port; tls } 26 26 + 27 27 + type 'conn entry = { 28 28 + conn : 'conn; 29 29 + created_at : float; 30 30 + mutable last_used : float; 31 31 + mutable in_use : bool; 32 32 + } 33 33 + (** Connection state *) 34 34 + 35 35 + type 'conn t = { 36 36 + config : config; 37 37 + mutable connections : (key * 'conn entry list) list; 38 38 + mutable total_count : int; 39 39 + } 40 40 + (** Connection pool - parameterized by connection type *) 41 41 + 42 42 + (** Create a new pool *) 43 43 + let create ?(config = default_config) () = 44 44 + { config; connections = []; total_count = 0 } 45 45 + 46 46 + (** Get connections for a key *) 47 47 + let get_entries pool key = 48 48 + List.assoc_opt key pool.connections |> Option.value ~default:[] 49 49 + 50 50 + (** Update connections for a key *) 51 51 + let set_entries pool key entries = 52 52 + let others = List.remove_assoc key pool.connections in 53 53 + if entries = [] then pool.connections <- others 54 54 + else pool.connections <- (key, entries) :: others 55 55 + 56 56 + (** Count connections for a key *) 57 57 + let count_for_key pool key = get_entries pool key |> List.length 58 58 + 59 59 + (** Try to acquire an idle connection. [now] is current time in seconds *) 60 60 + let acquire pool key ~now = 61 61 + let entries = get_entries pool key in 62 62 + let rec find_idle = function 63 63 + | [] -> None 64 64 + | entry :: rest -> 65 65 + if 66 66 + (not entry.in_use) 67 67 + && now -. entry.last_used < pool.config.idle_timeout 68 68 + then begin 69 69 + entry.in_use <- true; 70 70 + entry.last_used <- now; 71 71 + Some entry.conn 72 72 + end 73 73 + else find_idle rest 74 74 + in 75 75 + find_idle entries 76 76 + 77 77 + (** Release a connection back to the pool. [now] is current time *) 78 78 + let release pool key conn ~now = 79 79 + let entries = get_entries pool key in 80 80 + let entries = 81 81 + List.map 82 82 + (fun entry -> 83 83 + if entry.conn == conn then 84 84 + { entry with in_use = false; last_used = now } 85 85 + else entry) 86 86 + entries 87 87 + in 88 88 + set_entries pool key entries 89 89 + 90 90 + (** Add a new connection to the pool. Returns false if pool is at capacity *) 91 91 + let add pool key conn ~now = 92 92 + if pool.total_count >= pool.config.max_total_connections then false 93 93 + else if count_for_key pool key >= pool.config.max_connections_per_host then 94 94 + false 95 95 + else begin 96 96 + let entry = { conn; created_at = now; last_used = now; in_use = true } in 97 97 + let entries = get_entries pool key in 98 98 + set_entries pool key (entry :: entries); 99 99 + pool.total_count <- pool.total_count + 1; 100 100 + true 101 101 + end 102 102 + 103 103 + (** Remove a connection from the pool *) 104 104 + let remove pool key conn = 105 105 + let entries = get_entries pool key in 106 106 + let entries = List.filter (fun entry -> entry.conn != conn) entries in 107 107 + let removed = List.length (get_entries pool key) - List.length entries in 108 108 + set_entries pool key entries; 109 109 + pool.total_count <- pool.total_count - removed 110 110 + 111 111 + (** Close idle connections older than idle_timeout. [now] is current time, 112 112 + [close] is the connection close function *) 113 113 + let evict_idle pool ~now ~close = 114 114 + pool.connections <- 115 115 + List.filter_map 116 116 + (fun (key, entries) -> 117 117 + let kept, evicted = 118 118 + List.partition 119 119 + (fun entry -> 120 120 + entry.in_use || now -. entry.last_used < pool.config.idle_timeout) 121 121 + entries 122 122 + in 123 123 + List.iter (fun entry -> close entry.conn) evicted; 124 124 + pool.total_count <- pool.total_count - List.length evicted; 125 125 + if kept = [] then None else Some (key, kept)) 126 126 + pool.connections 127 127 + 128 128 + (** Close all connections *) 129 129 + let close_all pool ~close = 130 130 + List.iter 131 131 + (fun (_, entries) -> List.iter (fun entry -> close entry.conn) entries) 132 132 + pool.connections; 133 133 + pool.connections <- []; 134 134 + pool.total_count <- 0 135 135 + 136 136 + type stats = { 137 137 + total_connections : int; 138 138 + idle_connections : int; 139 139 + in_use_connections : int; 140 140 + hosts : int; 141 141 + } 142 142 + (** Get pool statistics *) 143 143 + 144 144 + let stats pool = 145 145 + let idle, in_use = 146 146 + List.fold_left 147 147 + (fun (idle, in_use) (_, entries) -> 148 148 + List.fold_left 149 149 + (fun (idle, in_use) entry -> 150 150 + if entry.in_use then (idle, in_use + 1) else (idle + 1, in_use)) 151 151 + (idle, in_use) entries) 152 152 + (0, 0) pool.connections 153 153 + in 154 154 + { 155 155 + total_connections = pool.total_count; 156 156 + idle_connections = idle; 157 157 + in_use_connections = in_use; 158 158 + hosts = List.length pool.connections; 159 159 + }

+422

lib/pooled_client.ml

reviewed

··· 1 1 + (** High-performance HTTP client with connection pooling. 2 2 + 3 3 + This module provides an HTTP client optimized for making many requests to 4 4 + the same host. For best performance: 5 5 + 6 6 + 1. Parse the URI once and reuse it 2. Create a pool for the target host and 7 7 + pass it to requests 8 8 + 9 9 + Example: 10 10 + {[ 11 11 + let uri = Uri.of_string "http://localhost:8080/api" in 12 12 + let pool = Pooled_client.create_pool ~sw ~net ~clock uri in 13 13 + (* All requests reuse the same connection *) 14 14 + for _ = 1 to 1000 do 15 15 + let _ = Pooled_client.get ~sw ~net ~clock ~pool uri in 16 16 + () 17 17 + done 18 18 + ]} 19 19 + 20 20 + For one-off requests, omit the pool: 21 21 + {[ 22 22 + let uri = Uri.of_string "http://example.com/api" in 23 23 + let _ = Pooled_client.get ~sw ~net ~clock uri in 24 24 + () 25 25 + ]} *) 26 26 + 27 27 + (** {1 Types} *) 28 28 + 29 29 + (** Read buffer size for HTTP responses *) 30 30 + let read_buffer_size = 0x1000 31 31 + 32 32 + type conn = { 33 33 + flow : Eio.Flow.two_way_ty Eio.Std.r; 34 34 + mutable alive : bool; 35 35 + read_buffer : Bigstringaf.t; 36 36 + } 37 37 + (** Internal connection state *) 38 38 + 39 39 + type pool = { 40 40 + host : string; 41 41 + port : int; 42 42 + path : string; (* Pre-extracted path for fast access *) 43 43 + is_https : bool; 44 44 + tls_config : Tls.Config.client option; 45 45 + addr : Eio.Net.Sockaddr.stream option; (* Cached resolved address *) 46 46 + mutable conn : conn option; 47 47 + mutex : Eio.Mutex.t; 48 48 + } 49 49 + (** Connection pool for a single host. Thread-safe via mutex. *) 50 50 + 51 51 + type error = H1_client.error 52 52 + (** Error type alias *) 53 53 + 54 54 + (** {1 Connection Management} *) 55 55 + 56 56 + (** Close a connection safely *) 57 57 + let close_conn c = 58 58 + if c.alive then begin 59 59 + c.alive <- false; 60 60 + try Eio.Resource.close (Obj.magic c.flow) with _ -> () 61 61 + end 62 62 + 63 63 + (** Resolve hostname to IP address *) 64 64 + let resolve_host ~net host = 65 65 + match Eio.Net.getaddrinfo_stream net host with 66 66 + | addr :: _ -> Some addr 67 67 + | [] -> None 68 68 + 69 69 + (** Create a new TCP connection using cached or resolved address *) 70 70 + let connect_tcp pool ~sw ~net = 71 71 + let addr = 72 72 + match pool.addr with 73 73 + | Some a -> Some a 74 74 + | None -> ( 75 75 + (* Resolve if not cached *) 76 76 + match resolve_host ~net pool.host with 77 77 + | Some (`Tcp (ip, _)) -> Some (`Tcp (ip, pool.port)) 78 78 + | _ -> None) 79 79 + in 80 80 + match addr with 81 81 + | None -> 82 82 + Error (H1_client.Connection_failed ("Cannot resolve host: " ^ pool.host)) 83 83 + | Some a -> Ok (Eio.Net.connect ~sw net a) 84 84 + 85 85 + (** Create a new connection to the pool's target *) 86 86 + let create_conn pool ~sw ~net = 87 87 + match connect_tcp pool ~sw ~net with 88 88 + | Error e -> Error e 89 89 + | Ok tcp_flow -> 90 90 + if pool.is_https then 91 91 + match pool.tls_config with 92 92 + | None -> Error (H1_client.Tls_error "TLS not configured") 93 93 + | Some tls_config -> ( 94 94 + try 95 95 + let host_domain = 96 96 + match Domain_name.of_string pool.host with 97 97 + | Ok dn -> ( 98 98 + match Domain_name.host dn with 99 99 + | Ok h -> Some h 100 100 + | Error _ -> None) 101 101 + | Error _ -> None 102 102 + in 103 103 + let tls_flow = 104 104 + Tls_eio.client_of_flow tls_config ?host:host_domain tcp_flow 105 105 + in 106 106 + Ok 107 107 + { 108 108 + flow = (tls_flow :> Eio.Flow.two_way_ty Eio.Std.r); 109 109 + alive = true; 110 110 + read_buffer = Bigstringaf.create read_buffer_size; 111 111 + } 112 112 + with 113 113 + | Tls_eio.Tls_failure failure -> 114 114 + Error 115 115 + (H1_client.Tls_error (Tls_config.failure_to_string failure)) 116 116 + | exn -> Error (H1_client.Tls_error (Printexc.to_string exn))) 117 117 + else 118 118 + Ok 119 119 + { 120 120 + flow = (tcp_flow :> Eio.Flow.two_way_ty Eio.Std.r); 121 121 + alive = true; 122 122 + read_buffer = Bigstringaf.create read_buffer_size; 123 123 + } 124 124 + 125 125 + (** {1 Pool Creation} *) 126 126 + 127 127 + (** Create a connection pool for a URI. 128 128 + 129 129 + The pool maintains a single persistent connection to the target host. Pass 130 130 + this pool to [get] and [post] to reuse the connection. 131 131 + 132 132 + @param net 133 133 + Network for DNS resolution (optional, resolves lazily if not provided) 134 134 + @param tls 135 135 + TLS configuration for HTTPS. Uses system defaults if not provided. *) 136 136 + let create_pool ?net ?(tls = Tls_config.Client.default) uri = 137 137 + let scheme = Uri.scheme uri |> Option.value ~default:"http" in 138 138 + let is_https = String.equal scheme "https" in 139 139 + let host = Uri.host uri |> Option.value ~default:"localhost" in 140 140 + let port = 141 141 + match Uri.port uri with Some p -> p | None -> if is_https then 443 else 80 142 142 + in 143 143 + let path = 144 144 + let p = Uri.path_and_query uri in 145 145 + if p = "" then "/" else p 146 146 + in 147 147 + let tls_config = 148 148 + if is_https then 149 149 + match Tls_config.Client.to_tls_config tls ~host with 150 150 + | Ok c -> Some c 151 151 + | Error _ -> None 152 152 + else None 153 153 + in 154 154 + (* Pre-resolve DNS if net is provided *) 155 155 + let addr = 156 156 + match net with 157 157 + | Some n -> ( 158 158 + match Eio.Net.getaddrinfo_stream n host with 159 159 + | addr_info :: _ -> ( 160 160 + match addr_info with 161 161 + | `Tcp (ip, _) -> Some (`Tcp (ip, port)) 162 162 + | `Unix _ -> None) 163 163 + | [] -> None) 164 164 + | None -> None 165 165 + in 166 166 + { 167 167 + host; 168 168 + port; 169 169 + path; 170 170 + is_https; 171 171 + tls_config; 172 172 + addr; 173 173 + conn = None; 174 174 + mutex = Eio.Mutex.create (); 175 175 + } 176 176 + 177 177 + (** Close all connections in the pool *) 178 178 + let close_pool pool = 179 179 + Eio.Mutex.use_rw ~protect:true pool.mutex (fun () -> 180 180 + Option.iter close_conn pool.conn; 181 181 + pool.conn <- None) 182 182 + 183 183 + (** {1 Internal Request Handling} *) 184 184 + 185 185 + (** Write IOVecs to flow *) 186 186 + let write_iovecs flow iovecs = 187 187 + let cstructs = 188 188 + List.map 189 189 + (fun iov -> 190 190 + Cstruct.of_bigarray ~off:iov.Httpun_types.IOVec.off 191 191 + ~len:iov.Httpun_types.IOVec.len iov.Httpun_types.IOVec.buffer) 192 192 + iovecs 193 193 + in 194 194 + Eio.Flow.write flow cstructs 195 195 + 196 196 + (** Read into bigstring *) 197 197 + let read_into flow buf ~off ~len = 198 198 + let cs = Cstruct.of_bigarray ~off ~len buf in 199 199 + try `Ok (Eio.Flow.single_read flow cs) with End_of_file -> `Eof 200 200 + 201 201 + (** Perform HTTP request on connection. Returns (response, keep_alive) *) 202 202 + let do_request ?(body = "") conn req = 203 203 + let flow = conn.flow in 204 204 + let read_buffer = conn.read_buffer in 205 205 + let response_received = Eio.Promise.create () in 206 206 + let body_chunks = ref [] in 207 207 + (* Collect chunks, concat at end - faster than Buffer *) 208 208 + let resolved = ref false in 209 209 + let keep_alive = ref true in 210 210 + 211 211 + let resolve_once result = 212 212 + if not !resolved then begin 213 213 + resolved := true; 214 214 + Eio.Promise.resolve (snd response_received) result 215 215 + end 216 216 + in 217 217 + 218 218 + let response_handler resp body_reader = 219 219 + (* Check Connection header *) 220 220 + (match H1.Headers.get resp.H1.Response.headers "connection" with 221 221 + | Some v when String.lowercase_ascii v = "close" -> keep_alive := false 222 222 + | _ -> ()); 223 223 + 224 224 + let rec read_body () = 225 225 + H1.Body.Reader.schedule_read body_reader 226 226 + ~on_eof:(fun () -> 227 227 + let response_body = String.concat "" (List.rev !body_chunks) in 228 228 + resolve_once 229 229 + (Ok 230 230 + ( { 231 231 + H1_client.status = resp.H1.Response.status; 232 232 + headers = resp.headers; 233 233 + body = response_body; 234 234 + }, 235 235 + !keep_alive ))) 236 236 + ~on_read:(fun buf ~off ~len -> 237 237 + body_chunks := Bigstringaf.substring buf ~off ~len :: !body_chunks; 238 238 + read_body ()) 239 239 + in 240 240 + read_body () 241 241 + in 242 242 + 243 243 + let error_handler err = 244 244 + keep_alive := false; 245 245 + conn.alive <- false; 246 246 + let msg = 247 247 + match err with 248 248 + | `Malformed_response s -> s 249 249 + | `Invalid_response_body_length _ -> "Invalid body length" 250 250 + | `Exn exn -> Printexc.to_string exn 251 251 + in 252 252 + resolve_once (Error (H1_client.Invalid_response msg)) 253 253 + in 254 254 + 255 255 + let body_writer, h1_conn = 256 256 + H1.Client_connection.request req ~error_handler ~response_handler 257 257 + in 258 258 + 259 259 + if String.length body > 0 then begin 260 260 + H1.Body.Writer.write_string body_writer body; 261 261 + H1.Body.Writer.flush body_writer (fun () -> ()) 262 262 + end; 263 263 + H1.Body.Writer.close body_writer; 264 264 + 265 265 + (* I/O loop *) 266 266 + let rec loop () = 267 267 + let write_done = 268 268 + match H1.Client_connection.next_write_operation h1_conn with 269 269 + | `Write iovecs -> 270 270 + write_iovecs flow iovecs; 271 271 + let len = 272 272 + List.fold_left 273 273 + (fun acc iov -> acc + iov.Httpun_types.IOVec.len) 274 274 + 0 iovecs 275 275 + in 276 276 + H1.Client_connection.report_write_result h1_conn (`Ok len); 277 277 + false 278 278 + | `Yield -> true 279 279 + | `Close _ -> true 280 280 + in 281 281 + let read_done = 282 282 + match H1.Client_connection.next_read_operation h1_conn with 283 283 + | `Read -> ( 284 284 + match read_into flow read_buffer ~off:0 ~len:read_buffer_size with 285 285 + | `Ok n -> 286 286 + let _ = 287 287 + H1.Client_connection.read h1_conn read_buffer ~off:0 ~len:n 288 288 + in 289 289 + false 290 290 + | `Eof -> 291 291 + conn.alive <- false; 292 292 + let _ = 293 293 + H1.Client_connection.read_eof h1_conn read_buffer ~off:0 ~len:0 294 294 + in 295 295 + true) 296 296 + | `Close -> true 297 297 + in 298 298 + if not (write_done && read_done) then loop () 299 299 + in 300 300 + 301 301 + (try loop () with _ -> conn.alive <- false); 302 302 + Eio.Promise.await (fst response_received) 303 303 + 304 304 + (** Acquire connection from pool or create new *) 305 305 + let acquire_conn pool ~sw ~net = 306 306 + Eio.Mutex.use_rw ~protect:true pool.mutex (fun () -> 307 307 + match pool.conn with 308 308 + | Some c when c.alive -> Ok c 309 309 + | _ -> ( 310 310 + (* Create new connection *) 311 311 + match create_conn pool ~sw ~net with 312 312 + | Ok c -> 313 313 + pool.conn <- Some c; 314 314 + Ok c 315 315 + | Error e -> Error e)) 316 316 + 317 317 + (** Release connection back to pool *) 318 318 + let release_conn pool conn ~keep_alive = 319 319 + if not keep_alive then 320 320 + Eio.Mutex.use_rw ~protect:true pool.mutex (fun () -> 321 321 + close_conn conn; 322 322 + pool.conn <- None) 323 323 + 324 324 + (** {1 HTTP Methods} *) 325 325 + 326 326 + (** Perform a GET request. 327 327 + 328 328 + @param pool 329 329 + Optional connection pool. If provided, reuses connections (fast path). If 330 330 + omitted, creates a one-shot connection. *) 331 331 + let get ?pool ~sw ~net ~clock:_ uri = 332 332 + match pool with 333 333 + | Some p -> ( 334 334 + (* Fast path: use cached host/path from pool *) 335 335 + let headers = 336 336 + H1.Headers.of_list [ ("Host", p.host); ("Connection", "keep-alive") ] 337 337 + in 338 338 + let req = H1.Request.create ~headers `GET p.path in 339 339 + match acquire_conn p ~sw ~net with 340 340 + | Error e -> Error e 341 341 + | Ok conn -> ( 342 342 + let result = do_request conn req in 343 343 + match result with 344 344 + | Ok (resp, keep_alive) -> 345 345 + release_conn p conn ~keep_alive; 346 346 + Ok resp 347 347 + | Error e -> 348 348 + release_conn p conn ~keep_alive:false; 349 349 + Error e)) 350 350 + | None -> ( 351 351 + (* Slow path: parse URI for one-shot connection *) 352 352 + let host = Uri.host uri |> Option.value ~default:"localhost" in 353 353 + let path = 354 354 + let p = Uri.path_and_query uri in 355 355 + if p = "" then "/" else p 356 356 + in 357 357 + let headers = 358 358 + H1.Headers.of_list [ ("Host", host); ("Connection", "close") ] 359 359 + in 360 360 + let req = H1.Request.create ~headers `GET path in 361 361 + let temp_pool = create_pool uri in 362 362 + match acquire_conn temp_pool ~sw ~net with 363 363 + | Error e -> Error e 364 364 + | Ok conn -> 365 365 + let result = do_request conn req in 366 366 + close_conn conn; 367 367 + Result.map fst result) 368 368 + 369 369 + (** Perform a POST request. 370 370 + 371 371 + @param pool 372 372 + Optional connection pool. If provided, reuses connections (fast path). If 373 373 + omitted, creates a one-shot connection. 374 374 + @param body Request body *) 375 375 + let post ?pool ~sw ~net ~clock:_ uri ~body = 376 376 + let content_length = String.length body in 377 377 + match pool with 378 378 + | Some p -> ( 379 379 + (* Fast path: use cached host/path from pool *) 380 380 + let headers = 381 381 + H1.Headers.of_list 382 382 + [ 383 383 + ("Host", p.host); 384 384 + ("Connection", "keep-alive"); 385 385 + ("Content-Length", string_of_int content_length); 386 386 + ] 387 387 + in 388 388 + let req = H1.Request.create ~headers `POST p.path in 389 389 + match acquire_conn p ~sw ~net with 390 390 + | Error e -> Error e 391 391 + | Ok conn -> ( 392 392 + let result = do_request ~body conn req in 393 393 + match result with 394 394 + | Ok (resp, keep_alive) -> 395 395 + release_conn p conn ~keep_alive; 396 396 + Ok resp 397 397 + | Error e -> 398 398 + release_conn p conn ~keep_alive:false; 399 399 + Error e)) 400 400 + | None -> ( 401 401 + (* Slow path: parse URI for one-shot connection *) 402 402 + let host = Uri.host uri |> Option.value ~default:"localhost" in 403 403 + let path = 404 404 + let p = Uri.path_and_query uri in 405 405 + if p = "" then "/" else p 406 406 + in 407 407 + let headers = 408 408 + H1.Headers.of_list 409 409 + [ 410 410 + ("Host", host); 411 411 + ("Connection", "close"); 412 412 + ("Content-Length", string_of_int content_length); 413 413 + ] 414 414 + in 415 415 + let req = H1.Request.create ~headers `POST path in 416 416 + let temp_pool = create_pool uri in 417 417 + match acquire_conn temp_pool ~sw ~net with 418 418 + | Error e -> Error e 419 419 + | Ok conn -> 420 420 + let result = do_request ~body conn req in 421 421 + close_conn conn; 422 422 + Result.map fst result)

+173

lib/request.ml

reviewed

··· 1 1 + (** Request helper functions. 2 2 + 3 3 + This module provides utility functions for working with HTTP requests, 4 4 + including header access, query parameter parsing, and body handling. *) 5 5 + 6 6 + (** {1 Internal helpers} *) 7 7 + 8 8 + let string_contains haystack pattern = 9 9 + let plen = String.length pattern in 10 10 + let hlen = String.length haystack in 11 11 + if plen > hlen then false 12 12 + else 13 13 + let rec check i = 14 14 + if i > hlen - plen then false 15 15 + else if String.sub haystack i plen = pattern then true 16 16 + else check (i + 1) 17 17 + in 18 18 + check 0 19 19 + 20 20 + (** {1 Types} *) 21 21 + 22 22 + type t = H1_server.request 23 23 + (** Request type - re-exported from H1_server for convenience *) 24 24 + 25 25 + (** {1 Basic accessors} *) 26 26 + 27 27 + let meth (req : t) = req.meth 28 28 + let target (req : t) = req.target 29 29 + let headers (req : t) = req.headers 30 30 + 31 31 + (** Read the request body as a string (reads lazily on first call) *) 32 32 + let body (req : t) = H1_server.read_body req 33 33 + 34 34 + (** Get the body reader for streaming access *) 35 35 + let body_reader (req : t) = req.body_reader 36 36 + 37 37 + (** {1 Path and Query} *) 38 38 + 39 39 + (** Get the path component (without query string) *) 40 40 + let path (req : t) = 41 41 + match String.index_opt req.target '?' with 42 42 + | Some i -> String.sub req.target 0 i 43 43 + | None -> req.target 44 44 + 45 45 + (** Get the query string (without leading ?) *) 46 46 + let query_string (req : t) = 47 47 + match String.index_opt req.target '?' with 48 48 + | Some i -> 49 49 + Some (String.sub req.target (i + 1) (String.length req.target - i - 1)) 50 50 + | None -> None 51 51 + 52 52 + (** Parse query string into key-value pairs *) 53 53 + let query_params (req : t) = 54 54 + match query_string req with 55 55 + | None -> [] 56 56 + | Some qs -> 57 57 + let pairs = String.split_on_char '&' qs in 58 58 + List.filter_map 59 59 + (fun pair -> 60 60 + match String.index_opt pair '=' with 61 61 + | Some i -> 62 62 + let key = String.sub pair 0 i in 63 63 + let value = 64 64 + String.sub pair (i + 1) (String.length pair - i - 1) 65 65 + in 66 66 + (* URL decode *) 67 67 + Some (Uri.pct_decode key, Uri.pct_decode value) 68 68 + | None -> Some (Uri.pct_decode pair, "")) 69 69 + pairs 70 70 + 71 71 + (** Get a single query parameter value *) 72 72 + let query key req = List.assoc_opt key (query_params req) 73 73 + 74 74 + (** Get all values for a query parameter *) 75 75 + let query_all key req = 76 76 + List.filter_map 77 77 + (fun (k, v) -> if String.equal k key then Some v else None) 78 78 + (query_params req) 79 79 + 80 80 + (** {1 Header accessors} *) 81 81 + 82 82 + (** Get a header value (case-insensitive) *) 83 83 + let header name (req : t) = H1.Headers.get req.headers name 84 84 + 85 85 + (** Get all values for a header *) 86 86 + let header_all name (req : t) = H1.Headers.get_multi req.headers name 87 87 + 88 88 + (** Check if header exists *) 89 89 + let has_header name (req : t) = 90 90 + match H1.Headers.get req.headers name with Some _ -> true | None -> false 91 91 + 92 92 + (** {1 Common header helpers} *) 93 93 + 94 94 + (** Get Content-Type header *) 95 95 + let content_type req = header "content-type" req 96 96 + 97 97 + (** Get Content-Length header as int64 *) 98 98 + let content_length req = 99 99 + match header "content-length" req with 100 100 + | Some s -> Int64.of_string_opt s 101 101 + | None -> None 102 102 + 103 103 + (** Check if request is keep-alive *) 104 104 + let is_keep_alive (req : t) = 105 105 + match header "connection" req with 106 106 + | Some v -> String.lowercase_ascii v = "keep-alive" 107 107 + | None -> true (* HTTP/1.1 default is keep-alive *) 108 108 + 109 109 + (** Get Host header *) 110 110 + let host req = header "host" req 111 111 + 112 112 + (** Get Accept header *) 113 113 + let accept req = header "accept" req 114 114 + 115 115 + (** Get Authorization header *) 116 116 + let authorization req = header "authorization" req 117 117 + 118 118 + (** Check if request accepts JSON *) 119 119 + let accepts_json req = 120 120 + match accept req with 121 121 + | Some v -> string_contains v "application/json" || string_contains v "*/*" 122 122 + | None -> false 123 123 + 124 124 + (** Check if request accepts HTML *) 125 125 + let accepts_html req = 126 126 + match accept req with 127 127 + | Some v -> string_contains v "text/html" || string_contains v "*/*" 128 128 + | None -> false 129 129 + 130 130 + (** {1 Method helpers} *) 131 131 + 132 132 + let is_get (req : t) = req.meth = `GET 133 133 + let is_post (req : t) = req.meth = `POST 134 134 + let is_put (req : t) = req.meth = `PUT 135 135 + let is_delete (req : t) = req.meth = `DELETE 136 136 + let is_patch (req : t) = req.meth = `Other "PATCH" 137 137 + let is_head (req : t) = req.meth = `HEAD 138 138 + let is_options (req : t) = req.meth = `OPTIONS 139 139 + 140 140 + (** Check if method is safe (GET, HEAD, OPTIONS) *) 141 141 + let is_safe (req : t) = 142 142 + match req.meth with `GET | `HEAD | `OPTIONS -> true | _ -> false 143 143 + 144 144 + (** Check if method is idempotent (GET, HEAD, PUT, DELETE, OPTIONS) *) 145 145 + let is_idempotent (req : t) = 146 146 + match req.meth with 147 147 + | `GET | `HEAD | `PUT | `DELETE | `OPTIONS -> true 148 148 + | _ -> false 149 149 + 150 150 + (** {1 Body helpers} *) 151 151 + 152 152 + let body_string (req : t) = body req 153 153 + let body_length (req : t) = String.length (body req) 154 154 + let has_body (req : t) = String.length (body req) > 0 155 155 + 156 156 + (** {1 Form data parsing} *) 157 157 + 158 158 + let form_data (req : t) = 159 159 + let b = body req in 160 160 + if String.length b = 0 then [] 161 161 + else 162 162 + let pairs = String.split_on_char '&' b in 163 163 + List.filter_map 164 164 + (fun pair -> 165 165 + match String.index_opt pair '=' with 166 166 + | Some i -> 167 167 + let key = String.sub pair 0 i in 168 168 + let value = String.sub pair (i + 1) (String.length pair - i - 1) in 169 169 + Some (Uri.pct_decode key, Uri.pct_decode value) 170 170 + | None -> Some (Uri.pct_decode pair, "")) 171 171 + pairs 172 172 + 173 173 + let form_field key req = List.assoc_opt key (form_data req)

+249

lib/response.ml

reviewed

··· 1 1 + (** Response helper functions. 2 2 + 3 3 + This module provides utility functions for creating and modifying HTTP 4 4 + responses, including status shortcuts, body helpers, and header 5 5 + manipulation. *) 6 6 + 7 7 + (** {1 Types} *) 8 8 + 9 9 + type t = H1_server.response 10 10 + 11 11 + let make ?(status = `OK) ?(headers = []) body : t = 12 12 + { status; headers; response_body = H1_server.Body_string body } 13 13 + 14 14 + let empty ?(status = `OK) ?(headers = []) () : t = 15 15 + { status; headers; response_body = H1_server.Body_string "" } 16 16 + 17 17 + (** {1 Status shortcuts - 2xx Success} *) 18 18 + 19 19 + let ok ?(headers = []) body : t = 20 20 + { status = `OK; headers; response_body = H1_server.Body_string body } 21 21 + 22 22 + let created ?(headers = []) ?location body : t = 23 23 + let headers = 24 24 + match location with 25 25 + | Some loc -> ("Location", loc) :: headers 26 26 + | None -> headers 27 27 + in 28 28 + { status = `Created; headers; response_body = H1_server.Body_string body } 29 29 + 30 30 + let accepted ?(headers = []) body : t = 31 31 + { status = `Accepted; headers; response_body = H1_server.Body_string body } 32 32 + 33 33 + let no_content ?(headers = []) () : t = 34 34 + { status = `No_content; headers; response_body = H1_server.Body_string "" } 35 35 + 36 36 + (** {1 Status shortcuts - 3xx Redirection} *) 37 37 + 38 38 + let redirect ?(permanent = false) ?(headers = []) location : t = 39 39 + let status = if permanent then `Moved_permanently else `Found in 40 40 + { 41 41 + status; 42 42 + headers = ("Location", location) :: headers; 43 43 + response_body = H1_server.Body_string ""; 44 44 + } 45 45 + 46 46 + let moved_permanently ?(headers = []) location : t = 47 47 + redirect ~permanent:true ~headers location 48 48 + 49 49 + let found ?(headers = []) location : t = 50 50 + redirect ~permanent:false ~headers location 51 51 + 52 52 + let see_other ?(headers = []) location : t = 53 53 + { 54 54 + status = `See_other; 55 55 + headers = ("Location", location) :: headers; 56 56 + response_body = H1_server.Body_string ""; 57 57 + } 58 58 + 59 59 + let temporary_redirect ?(headers = []) location : t = 60 60 + { 61 61 + status = `Temporary_redirect; 62 62 + headers = ("Location", location) :: headers; 63 63 + response_body = H1_server.Body_string ""; 64 64 + } 65 65 + 66 66 + let not_modified ?(headers = []) () : t = 67 67 + { status = `Not_modified; headers; response_body = H1_server.Body_string "" } 68 68 + 69 69 + (** {1 Status shortcuts - 4xx Client Errors} *) 70 70 + 71 71 + let bad_request ?(headers = []) ?(body = "Bad Request") () : t = 72 72 + { status = `Bad_request; headers; response_body = H1_server.Body_string body } 73 73 + 74 74 + let unauthorized ?(headers = []) ?www_authenticate () : t = 75 75 + let headers = 76 76 + match www_authenticate with 77 77 + | Some auth -> ("WWW-Authenticate", auth) :: headers 78 78 + | None -> headers 79 79 + in 80 80 + { 81 81 + status = `Unauthorized; 82 82 + headers; 83 83 + response_body = H1_server.Body_string "Unauthorized"; 84 84 + } 85 85 + 86 86 + let forbidden ?(headers = []) ?(body = "Forbidden") () : t = 87 87 + { status = `Forbidden; headers; response_body = H1_server.Body_string body } 88 88 + 89 89 + let not_found ?(headers = []) ?(body = "Not Found") () : t = 90 90 + { status = `Not_found; headers; response_body = H1_server.Body_string body } 91 91 + 92 92 + let method_not_allowed ?(headers = []) ~allowed () : t = 93 93 + let allow_header = 94 94 + String.concat ", " (List.map H1.Method.to_string allowed) 95 95 + in 96 96 + { 97 97 + status = `Method_not_allowed; 98 98 + headers = ("Allow", allow_header) :: headers; 99 99 + response_body = H1_server.Body_string "Method Not Allowed"; 100 100 + } 101 101 + 102 102 + let conflict ?(headers = []) ?(body = "Conflict") () : t = 103 103 + { status = `Conflict; headers; response_body = H1_server.Body_string body } 104 104 + 105 105 + let gone ?(headers = []) ?(body = "Gone") () : t = 106 106 + { status = `Gone; headers; response_body = H1_server.Body_string body } 107 107 + 108 108 + let unprocessable_entity ?(headers = []) ?(body = "Unprocessable Entity") () : t 109 109 + = 110 110 + { status = `Code 422; headers; response_body = H1_server.Body_string body } 111 111 + 112 112 + let too_many_requests ?(headers = []) ?retry_after () : t = 113 113 + let headers = 114 114 + match retry_after with 115 115 + | Some secs -> ("Retry-After", string_of_int secs) :: headers 116 116 + | None -> headers 117 117 + in 118 118 + { 119 119 + status = `Code 429; 120 120 + headers; 121 121 + response_body = H1_server.Body_string "Too Many Requests"; 122 122 + } 123 123 + 124 124 + (** {1 Status shortcuts - 5xx Server Errors} *) 125 125 + 126 126 + let internal_error ?(headers = []) ?(body = "Internal Server Error") () : t = 127 127 + { 128 128 + status = `Internal_server_error; 129 129 + headers; 130 130 + response_body = H1_server.Body_string body; 131 131 + } 132 132 + 133 133 + let not_implemented ?(headers = []) ?(body = "Not Implemented") () : t = 134 134 + { 135 135 + status = `Not_implemented; 136 136 + headers; 137 137 + response_body = H1_server.Body_string body; 138 138 + } 139 139 + 140 140 + let bad_gateway ?(headers = []) ?(body = "Bad Gateway") () : t = 141 141 + { status = `Bad_gateway; headers; response_body = H1_server.Body_string body } 142 142 + 143 143 + let service_unavailable ?(headers = []) ?retry_after () : t = 144 144 + let headers = 145 145 + match retry_after with 146 146 + | Some secs -> ("Retry-After", string_of_int secs) :: headers 147 147 + | None -> headers 148 148 + in 149 149 + { 150 150 + status = `Service_unavailable; 151 151 + headers; 152 152 + response_body = H1_server.Body_string "Service Unavailable"; 153 153 + } 154 154 + 155 155 + let gateway_timeout ?(headers = []) ?(body = "Gateway Timeout") () : t = 156 156 + { 157 157 + status = `Gateway_timeout; 158 158 + headers; 159 159 + response_body = H1_server.Body_string body; 160 160 + } 161 161 + 162 162 + (** {1 Content-Type helpers} *) 163 163 + 164 164 + let text ?(status = `OK) body : t = 165 165 + { 166 166 + status; 167 167 + headers = [ ("Content-Type", "text/plain; charset=utf-8") ]; 168 168 + response_body = H1_server.Body_string body; 169 169 + } 170 170 + 171 171 + let html ?(status = `OK) body : t = 172 172 + { 173 173 + status; 174 174 + headers = [ ("Content-Type", "text/html; charset=utf-8") ]; 175 175 + response_body = H1_server.Body_string body; 176 176 + } 177 177 + 178 178 + let json ?(status = `OK) body : t = 179 179 + { 180 180 + status; 181 181 + headers = [ ("Content-Type", "application/json; charset=utf-8") ]; 182 182 + response_body = H1_server.Body_string body; 183 183 + } 184 184 + 185 185 + let xml ?(status = `OK) body : t = 186 186 + { 187 187 + status; 188 188 + headers = [ ("Content-Type", "application/xml; charset=utf-8") ]; 189 189 + response_body = H1_server.Body_string body; 190 190 + } 191 191 + 192 192 + (** {1 Response modifiers} *) 193 193 + 194 194 + (** Add a header to the response *) 195 195 + let with_header name value (resp : t) : t = 196 196 + { resp with headers = (name, value) :: resp.headers } 197 197 + 198 198 + (** Add multiple headers to the response *) 199 199 + let with_headers headers (resp : t) : t = 200 200 + { resp with headers = headers @ resp.headers } 201 201 + 202 202 + (** Replace the response body *) 203 203 + let with_body body (resp : t) : t = 204 204 + { resp with response_body = H1_server.Body_string body } 205 205 + 206 206 + (** Replace the response status *) 207 207 + let with_status status (resp : t) : t = { resp with status } 208 208 + 209 209 + (** Set Content-Type header *) 210 210 + let with_content_type content_type resp = 211 211 + with_header "Content-Type" content_type resp 212 212 + 213 213 + (** Set Cache-Control header *) 214 214 + let with_cache_control directive resp = 215 215 + with_header "Cache-Control" directive resp 216 216 + 217 217 + (** Set no-cache headers *) 218 218 + let with_no_cache resp = 219 219 + resp 220 220 + |> with_header "Cache-Control" "no-store, no-cache, must-revalidate" 221 221 + |> with_header "Pragma" "no-cache" 222 222 + 223 223 + (** Set CORS headers for all origins *) 224 224 + let with_cors ?(origin = "*") ?(methods = "GET, POST, PUT, DELETE, OPTIONS") 225 225 + ?(headers = "Content-Type, Authorization") resp = 226 226 + resp 227 227 + |> with_header "Access-Control-Allow-Origin" origin 228 228 + |> with_header "Access-Control-Allow-Methods" methods 229 229 + |> with_header "Access-Control-Allow-Headers" headers 230 230 + 231 231 + (** {1 Cookie helpers} *) 232 232 + 233 233 + (** Set a cookie *) 234 234 + let with_cookie ?(path = "/") ?(http_only = true) ?(secure = false) 235 235 + ?(same_site = "Lax") ?max_age name value resp = 236 236 + let parts = [ Printf.sprintf "%s=%s" name value; "Path=" ^ path ] in 237 237 + let parts = if http_only then parts @ [ "HttpOnly" ] else parts in 238 238 + let parts = if secure then parts @ [ "Secure" ] else parts in 239 239 + let parts = parts @ [ "SameSite=" ^ same_site ] in 240 240 + let parts = 241 241 + match max_age with 242 242 + | Some age -> parts @ [ Printf.sprintf "Max-Age=%d" age ] 243 243 + | None -> parts 244 244 + in 245 245 + with_header "Set-Cookie" (String.concat "; " parts) resp 246 246 + 247 247 + (** Clear a cookie *) 248 248 + let clear_cookie ?(path = "/") name resp = 249 249 + with_cookie ~path ~max_age:0 name "" resp

+176

lib/router.ml

reviewed

··· 1 1 + (** Type-safe router with radix trie for efficient path matching. 2 2 + 3 3 + This module provides: 4 4 + - Type-safe path patterns with parameter extraction 5 5 + - Radix trie for O(path_length) route lookup 6 6 + - Hashtbl for O(1) literal segment matching 7 7 + - Middleware support 8 8 + - Route scoping/grouping *) 9 9 + 10 10 + (** Path segment types *) 11 11 + type segment = 12 12 + | Literal of string (** Exact match *) 13 13 + | Param of string (** Named parameter capture *) 14 14 + | Wildcard (** Match rest of path *) 15 15 + 16 16 + type params = (string * string) list 17 17 + (** Parsed path parameters *) 18 18 + 19 19 + type 'a route = { 20 20 + method_ : H1.Method.t option; (** None = match any method *) 21 21 + segments : segment list; 22 22 + handler : 'a; 23 23 + } 24 24 + (** A route definition *) 25 25 + 26 26 + type 'a trie_node = { 27 27 + mutable handlers : (H1.Method.t option * 'a) list; 28 28 + (** Handlers at this node *) 29 29 + literal_children : (string, 'a trie_node) Hashtbl.t; 30 30 + (** O(1) lookup for literal segments *) 31 31 + mutable param_child : (string * 'a trie_node) option; 32 32 + (** Single param child (with param name) *) 33 33 + mutable wildcard_child : 'a trie_node option; (** Single wildcard child *) 34 34 + } 35 35 + (** Radix trie node with optimized child storage *) 36 36 + 37 37 + type 'a t = { root : 'a trie_node } 38 38 + (** Compiled router *) 39 39 + 40 40 + (** Create empty trie node *) 41 41 + let empty_node () = 42 42 + { 43 43 + handlers = []; 44 44 + literal_children = Hashtbl.create 8; 45 45 + param_child = None; 46 46 + wildcard_child = None; 47 47 + } 48 48 + 49 49 + (** Create empty router *) 50 50 + let empty () = { root = empty_node () } 51 51 + 52 52 + (** Parse path string into segments *) 53 53 + let parse_path path = 54 54 + let path = 55 55 + if String.length path > 0 && path.[0] = '/' then 56 56 + String.sub path 1 (String.length path - 1) 57 57 + else path 58 58 + in 59 59 + if path = "" then [] 60 60 + else 61 61 + String.split_on_char '/' path 62 62 + |> List.filter (fun s -> s <> "") 63 63 + |> List.map (fun s -> 64 64 + if String.length s > 0 && s.[0] = ':' then 65 65 + Param (String.sub s 1 (String.length s - 1)) 66 66 + else if s = "*" then Wildcard 67 67 + else Literal s) 68 68 + 69 69 + (** Find or create child node for segment *) 70 70 + let find_or_create_child node seg = 71 71 + match seg with 72 72 + | Literal s -> ( 73 73 + match Hashtbl.find_opt node.literal_children s with 74 74 + | Some child -> child 75 75 + | None -> 76 76 + let child = empty_node () in 77 77 + Hashtbl.add node.literal_children s child; 78 78 + child) 79 79 + | Param name -> ( 80 80 + match node.param_child with 81 81 + | Some (_, child) -> child 82 82 + | None -> 83 83 + let child = empty_node () in 84 84 + node.param_child <- Some (name, child); 85 85 + child) 86 86 + | Wildcard -> ( 87 87 + match node.wildcard_child with 88 88 + | Some child -> child 89 89 + | None -> 90 90 + let child = empty_node () in 91 91 + node.wildcard_child <- Some child; 92 92 + child) 93 93 + 94 94 + (** Add a route to the trie *) 95 95 + let add_route router ~method_ ~path ~handler = 96 96 + let segments = parse_path path in 97 97 + let rec insert node = function 98 98 + | [] -> node.handlers <- (method_, handler) :: node.handlers 99 99 + | seg :: rest -> 100 100 + let child = find_or_create_child node seg in 101 101 + insert child rest 102 102 + in 103 103 + insert router.root segments 104 104 + 105 105 + (** Lookup a path in the trie - optimized with index-based parsing *) 106 106 + let lookup router ~method_ ~path = 107 107 + let len = String.length path in 108 108 + let start = if len > 0 && path.[0] = '/' then 1 else 0 in 109 109 + 110 110 + let rec search node pos params = 111 111 + if pos >= len then 112 112 + List.find_opt 113 113 + (fun (m, _) -> match m with None -> true | Some m' -> m' = method_) 114 114 + node.handlers 115 115 + |> Option.map (fun (_, handler) -> (handler, params)) 116 116 + else 117 117 + let seg_end = 118 118 + try String.index_from path pos '/' with Not_found -> len 119 119 + in 120 120 + if seg_end = pos then search node (pos + 1) params 121 121 + else 122 122 + let seg = String.sub path pos (seg_end - pos) in 123 123 + let next_pos = if seg_end < len then seg_end + 1 else len in 124 124 + match Hashtbl.find_opt node.literal_children seg with 125 125 + | Some child -> search child next_pos params 126 126 + | None -> ( 127 127 + match node.param_child with 128 128 + | Some (name, child) -> search child next_pos ((name, seg) :: params) 129 129 + | None -> ( 130 130 + match node.wildcard_child with 131 131 + | Some child -> 132 132 + let rest_path = String.sub path pos (len - pos) in 133 133 + search child len (("*", rest_path) :: params) 134 134 + | None -> None)) 135 135 + in 136 136 + search router.root start [] 137 137 + 138 138 + (** Route builder DSL *) 139 139 + module Route = struct 140 140 + type 'a t = { method_ : H1.Method.t option; path : string; handler : 'a } 141 141 + 142 142 + let get path handler = { method_ = Some `GET; path; handler } 143 143 + let post path handler = { method_ = Some `POST; path; handler } 144 144 + let put path handler = { method_ = Some `PUT; path; handler } 145 145 + let delete path handler = { method_ = Some `DELETE; path; handler } 146 146 + let patch path handler = { method_ = Some (`Other "PATCH"); path; handler } 147 147 + let head path handler = { method_ = Some `HEAD; path; handler } 148 148 + let options path handler = { method_ = Some `OPTIONS; path; handler } 149 149 + let any path handler = { method_ = None; path; handler } 150 150 + end 151 151 + 152 152 + (** Compile routes into a router *) 153 153 + let compile routes = 154 154 + let router = empty () in 155 155 + List.iter 156 156 + (fun r -> 157 157 + add_route router ~method_:r.Route.method_ ~path:r.path ~handler:r.handler) 158 158 + routes; 159 159 + router 160 160 + 161 161 + (** Get parameter from params list *) 162 162 + let param name params = List.assoc_opt name params 163 163 + 164 164 + (** Get parameter with default *) 165 165 + let param_or name ~default params = 166 166 + match List.assoc_opt name params with Some v -> v | None -> default 167 167 + 168 168 + (** Get parameter as int *) 169 169 + let param_int name params = 170 170 + match List.assoc_opt name params with 171 171 + | Some v -> int_of_string_opt v 172 172 + | None -> None 173 173 + 174 174 + (** Get parameter as int with default *) 175 175 + let param_int_or name ~default params = 176 176 + match param_int name params with Some v -> v | None -> default

+1195

lib/server.ml

reviewed

··· 1 1 + (** Unified HTTP Server - High-performance server supporting HTTP/1.1, HTTP/2, 2 2 + and WebSocket. 3 3 + 4 4 + This module consolidates all server functionality into a single, 5 5 + high-performance implementation. Protocol detection overhead is optional and 6 6 + controlled via the [protocol] configuration. 7 7 + 8 8 + {2 Protocol Modes} 9 9 + 10 10 + - [Http1_only]: Fastest path. No protocol detection, direct HTTP/1.1 11 11 + handling. 12 12 + - [Http2_only]: HTTP/2 only. h2c (cleartext) or h2 (over TLS). 13 13 + - [Auto]: Auto-detect protocol via connection preface peek (h2c) or ALPN 14 14 + (TLS). 15 15 + - [Auto_websocket]: Auto-detect with WebSocket upgrade support. 16 16 + 17 17 + {2 Performance Features} 18 18 + 19 19 + - GC tuning for high-throughput scenarios 20 20 + - Cached Date headers (1-second resolution) 21 21 + - Pre-built responses for zero-allocation hot paths 22 22 + - Zero-copy bigstring responses 23 23 + - Streaming response support 24 24 + - Multi-domain parallelism via Eio 25 25 + 26 26 + {2 Example} 27 27 + 28 28 + {[ 29 29 + (* Fastest HTTP/1.1 server *) 30 30 + let handler req = Server.respond "Hello, World!" in 31 31 + Server.run ~sw ~net handler 32 32 + 33 33 + (* Multi-protocol with auto-detection *) 34 34 + let config = Server.{ default_config with protocol = Auto } in 35 35 + Server.run ~sw ~net ~config handler 36 36 + ]} *) 37 37 + 38 38 + open Eio.Std 39 39 + 40 40 + (** {1 Protocol Configuration} *) 41 41 + 42 42 + (** Protocol mode controls detection overhead and supported protocols. *) 43 43 + type protocol = 44 44 + | Http1_only 45 45 + (** Fastest: No protocol detection, direct HTTP/1.1 handling. With TLS: 46 46 + HTTP/1.1 over TLS (no ALPN negotiation). *) 47 47 + | Http2_only 48 48 + (** HTTP/2 only. Without TLS: h2c (HTTP/2 cleartext). With TLS: h2 with 49 49 + ALPN advertising only "h2". *) 50 50 + | Auto 51 51 + (** Auto-detect protocol. Without TLS: Peek for "PRI " preface (h2c), 52 52 + fallback to HTTP/1.1. With TLS: ALPN negotiation. *) 53 53 + | Auto_websocket 54 54 + (** Auto-detect with WebSocket support. Same as [Auto] but also handles 55 55 + WebSocket upgrade requests in HTTP/1.1 mode. *) 56 56 + 57 57 + (** {1 GC Tuning} *) 58 58 + 59 59 + module Gc_tune = struct 60 60 + type config = { 61 61 + minor_heap_size : int; (** Minor heap size in bytes. Default: 64MB *) 62 62 + major_heap_increment : int; 63 63 + (** Major heap increment in bytes. Default: 32MB *) 64 64 + space_overhead : int; (** Space overhead percentage. Default: 200 *) 65 65 + max_overhead : int; (** Max overhead percentage. Default: 500 *) 66 66 + } 67 67 + 68 68 + let default = 69 69 + { 70 70 + minor_heap_size = 64 * 1024 * 1024; 71 71 + major_heap_increment = 32 * 1024 * 1024; 72 72 + space_overhead = 200; 73 73 + max_overhead = 500; 74 74 + } 75 75 + 76 76 + let aggressive = 77 77 + { 78 78 + minor_heap_size = 128 * 1024 * 1024; 79 79 + major_heap_increment = 64 * 1024 * 1024; 80 80 + space_overhead = 400; 81 81 + max_overhead = 1000; 82 82 + } 83 83 + 84 84 + let tuned = ref false 85 85 + 86 86 + let apply ?(config = default) () = 87 87 + if not !tuned then begin 88 88 + let ctrl = Gc.get () in 89 89 + Gc.set 90 90 + { 91 91 + ctrl with 92 92 + minor_heap_size = config.minor_heap_size / (Sys.word_size / 8); 93 93 + major_heap_increment = 94 94 + config.major_heap_increment / (Sys.word_size / 8); 95 95 + space_overhead = config.space_overhead; 96 96 + max_overhead = config.max_overhead; 97 97 + }; 98 98 + tuned := true 99 99 + end 100 100 + end 101 101 + 102 102 + (** {1 Date Header Cache} *) 103 103 + 104 104 + module Date_cache = struct 105 105 + let day_names = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] 106 106 + 107 107 + let month_names = 108 108 + [| 109 109 + "Jan"; 110 110 + "Feb"; 111 111 + "Mar"; 112 112 + "Apr"; 113 113 + "May"; 114 114 + "Jun"; 115 115 + "Jul"; 116 116 + "Aug"; 117 117 + "Sep"; 118 118 + "Oct"; 119 119 + "Nov"; 120 120 + "Dec"; 121 121 + |] 122 122 + 123 123 + let cached_date = Atomic.make "" 124 124 + let cached_time = Atomic.make 0. 125 125 + 126 126 + let format_date () = 127 127 + let t = Unix.gettimeofday () in 128 128 + let tm = Unix.gmtime t in 129 129 + Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" 130 130 + day_names.(tm.Unix.tm_wday) 131 131 + tm.Unix.tm_mday 132 132 + month_names.(tm.Unix.tm_mon) 133 133 + (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec 134 134 + 135 135 + let[@inline] get () = 136 136 + let now = Unix.gettimeofday () in 137 137 + let last = Atomic.get cached_time in 138 138 + if now -. last >= 1.0 then begin 139 139 + let date = format_date () in 140 140 + Atomic.set cached_date date; 141 141 + Atomic.set cached_time now; 142 142 + date 143 143 + end 144 144 + else Atomic.get cached_date 145 145 + end 146 146 + 147 147 + (** {1 Pre-built Responses} *) 148 148 + 149 149 + (** Pre-built response for zero-allocation hot paths. Create once at startup, 150 150 + respond many times without allocation. *) 151 151 + module Prebuilt = struct 152 152 + type t = { 153 153 + status : H1.Status.t; 154 154 + headers : H1.Headers.t; 155 155 + body : Bigstringaf.t; 156 156 + (* Cached H1 response with date header - regenerated per-second (thread-safe) *) 157 157 + cached_h1_response : H1.Response.t Atomic.t; 158 158 + cached_second : int Atomic.t; 159 159 + } 160 160 + 161 161 + (** Create a pre-built response from a string body. *) 162 162 + let create ~status ?(headers = []) body = 163 163 + let body_bstr = 164 164 + Bigstringaf.of_string ~off:0 ~len:(String.length body) body 165 165 + in 166 166 + let body_len = Bigstringaf.length body_bstr in 167 167 + let all_headers = ("content-length", string_of_int body_len) :: headers in 168 168 + let h1_headers = H1.Headers.of_list all_headers in 169 169 + let now = int_of_float (Unix.gettimeofday ()) in 170 170 + let headers_with_date = 171 171 + H1.Headers.add h1_headers "date" (Date_cache.get ()) 172 172 + in 173 173 + let cached_resp = H1.Response.create ~headers:headers_with_date status in 174 174 + { 175 175 + status; 176 176 + headers = h1_headers; 177 177 + body = body_bstr; 178 178 + cached_h1_response = Atomic.make cached_resp; 179 179 + cached_second = Atomic.make now; 180 180 + } 181 181 + 182 182 + (** Create a pre-built response from a bigstring body. *) 183 183 + let create_bigstring ~status ?(headers = []) body = 184 184 + let body_len = Bigstringaf.length body in 185 185 + let all_headers = ("content-length", string_of_int body_len) :: headers in 186 186 + let h1_headers = H1.Headers.of_list all_headers in 187 187 + let now = int_of_float (Unix.gettimeofday ()) in 188 188 + let headers_with_date = 189 189 + H1.Headers.add h1_headers "date" (Date_cache.get ()) 190 190 + in 191 191 + let cached_resp = H1.Response.create ~headers:headers_with_date status in 192 192 + { 193 193 + status; 194 194 + headers = h1_headers; 195 195 + body; 196 196 + cached_h1_response = Atomic.make cached_resp; 197 197 + cached_second = Atomic.make now; 198 198 + } 199 199 + 200 200 + (** Get cached H1 response, regenerating if second has changed. *) 201 201 + let[@inline] get_cached_h1_response t = 202 202 + let now = int_of_float (Unix.gettimeofday ()) in 203 203 + let last = Atomic.get t.cached_second in 204 204 + if now <> last then begin 205 205 + let headers = H1.Headers.add t.headers "date" (Date_cache.get ()) in 206 206 + let resp = H1.Response.create ~headers t.status in 207 207 + Atomic.set t.cached_h1_response resp; 208 208 + Atomic.set t.cached_second now 209 209 + end; 210 210 + Atomic.get t.cached_h1_response 211 211 + 212 212 + (** Respond to an H1 request descriptor with a pre-built response. Uses cached 213 213 + response that only regenerates when the second changes. *) 214 214 + let[@inline] respond_h1 reqd t = 215 215 + let response = get_cached_h1_response t in 216 216 + H1.Reqd.respond_with_bigstring reqd response t.body 217 217 + 218 218 + (** Respond to an H2 request descriptor with a pre-built response. *) 219 219 + let[@inline] respond_h2 reqd t = 220 220 + let result = ref [] in 221 221 + H1.Headers.iter 222 222 + ~f:(fun name value -> result := (name, value) :: !result) 223 223 + t.headers; 224 224 + let h2_headers = H2.Headers.of_list (List.rev !result) in 225 225 + let h2_status = (t.status :> H2.Status.t) in 226 226 + let response = H2.Response.create ~headers:h2_headers h2_status in 227 227 + H2.Reqd.respond_with_bigstring reqd response t.body 228 228 + end 229 229 + 230 230 + (** {1 Types} *) 231 231 + 232 232 + type config = { 233 233 + (* Network *) 234 234 + host : string; (** Bind address. Default: "0.0.0.0" *) 235 235 + port : int; (** Listen port. Default: 8080 *) 236 236 + backlog : int; (** Listen backlog. Default: 4096 *) 237 237 + max_connections : int; (** Max concurrent connections. Default: 100000 *) 238 238 + (* Parallelism *) 239 239 + domain_count : int; (** Number of domains (CPUs) to use. Default: 1 *) 240 240 + (* Protocol *) 241 241 + protocol : protocol; (** Protocol mode. Default: Http1_only *) 242 242 + (* Timeouts *) 243 243 + read_timeout : float; (** Read timeout in seconds. Default: 60.0 *) 244 244 + write_timeout : float; (** Write timeout in seconds. Default: 60.0 *) 245 245 + idle_timeout : float; (** Idle connection timeout. Default: 120.0 *) 246 246 + request_timeout : float; (** Request processing timeout. Default: 30.0 *) 247 247 + (* Limits *) 248 248 + max_header_size : int; (** Max header size in bytes. Default: 8192 *) 249 249 + max_body_size : int64 option; 250 250 + (** Max body size. None = unlimited. Default: None *) 251 251 + (* Buffers *) 252 252 + buffer_size : int; (** Read buffer size. Default: 16384 *) 253 253 + (* Socket options *) 254 254 + tcp_nodelay : bool; (** Set TCP_NODELAY on connections. Default: true *) 255 255 + reuse_addr : bool; (** Set SO_REUSEADDR on listener. Default: true *) 256 256 + reuse_port : bool; (** Set SO_REUSEPORT on listener. Default: true *) 257 257 + (* TLS *) 258 258 + tls : Tls_config.Server.t option; (** TLS config. None = plain HTTP *) 259 259 + (* Performance *) 260 260 + gc_tuning : Gc_tune.config option; 261 261 + (** GC tuning config. Some = apply tuning. Default: Some Gc_tune.default 262 262 + *) 263 263 + } 264 264 + (** Server configuration. *) 265 265 + 266 266 + (** Default configuration optimized for HTTP/1.1 performance. *) 267 267 + let default_config = 268 268 + { 269 269 + host = "0.0.0.0"; 270 270 + port = 8080; 271 271 + backlog = 4096; 272 272 + max_connections = 100000; 273 273 + domain_count = 1; 274 274 + protocol = Http1_only; 275 275 + read_timeout = 60.0; 276 276 + write_timeout = 60.0; 277 277 + idle_timeout = 120.0; 278 278 + request_timeout = 30.0; 279 279 + max_header_size = 8192; 280 280 + max_body_size = None; 281 281 + buffer_size = 16384; 282 282 + tcp_nodelay = true; 283 283 + reuse_addr = true; 284 284 + reuse_port = true; 285 285 + tls = None; 286 286 + gc_tuning = Some Gc_tune.default; 287 287 + } 288 288 + 289 289 + (** Configuration for auto-detection mode. *) 290 290 + let auto_config = { default_config with protocol = Auto } 291 291 + 292 292 + (** Configuration for WebSocket support. *) 293 293 + let websocket_config = { default_config with protocol = Auto_websocket } 294 294 + 295 295 + (** {2 Config Builders} *) 296 296 + 297 297 + let with_port port config = { config with port } 298 298 + let with_host host config = { config with host } 299 299 + let with_backlog backlog config = { config with backlog } 300 300 + let with_max_connections max config = { config with max_connections = max } 301 301 + let with_domain_count count config = { config with domain_count = count } 302 302 + let with_protocol protocol config = { config with protocol } 303 303 + let with_read_timeout timeout config = { config with read_timeout = timeout } 304 304 + let with_write_timeout timeout config = { config with write_timeout = timeout } 305 305 + let with_idle_timeout timeout config = { config with idle_timeout = timeout } 306 306 + 307 307 + let with_request_timeout timeout config = 308 308 + { config with request_timeout = timeout } 309 309 + 310 310 + let with_max_header_size size config = { config with max_header_size = size } 311 311 + let with_max_body_size size config = { config with max_body_size = Some size } 312 312 + let with_buffer_size size config = { config with buffer_size = size } 313 313 + let with_tcp_nodelay enabled config = { config with tcp_nodelay = enabled } 314 314 + let with_tls tls config = { config with tls = Some tls } 315 315 + let with_gc_tuning gc config = { config with gc_tuning = Some gc } 316 316 + let without_gc_tuning config = { config with gc_tuning = None } 317 317 + 318 318 + (** {1 Request/Response Types} *) 319 319 + 320 320 + (** Protocol version indicator. *) 321 321 + type protocol_version = HTTP_1_1 | HTTP_2 322 322 + 323 323 + type request = { 324 324 + meth : H1.Method.t; (** HTTP method *) 325 325 + target : string; (** Request target (path + query) *) 326 326 + headers : (string * string) list; (** Headers as association list *) 327 327 + body : string; (** Request body (empty for GET/HEAD) *) 328 328 + version : protocol_version; (** Protocol version *) 329 329 + } 330 330 + (** Request type exposed to handlers. *) 331 331 + 332 332 + (** Response body variants. *) 333 333 + type response_body = 334 334 + | Body_empty (** Empty body (for 204 No Content, etc.) *) 335 335 + | Body_string of string (** String body - will be copied *) 336 336 + | Body_bigstring of Bigstringaf.t (** Bigstring body - zero-copy *) 337 337 + | Body_prebuilt of Prebuilt.t (** Pre-built response - zero allocation *) 338 338 + | Body_stream of { 339 339 + content_length : int64 option; 340 340 + next : unit -> Cstruct.t option; 341 341 + } (** Streaming body *) 342 342 + 343 343 + type response = { 344 344 + status : H1.Status.t; 345 345 + headers : (string * string) list; 346 346 + body : response_body; 347 347 + } 348 348 + (** Response type. *) 349 349 + 350 350 + type handler = request -> response 351 351 + (** Handler type. *) 352 352 + 353 353 + type ws_handler = Websocket.t -> unit 354 354 + (** WebSocket handler type. *) 355 355 + 356 356 + (** {1 Response Helpers} *) 357 357 + 358 358 + (** Create a response with a string body. *) 359 359 + let respond ?(status = `OK) ?(headers = []) body = 360 360 + { status; headers; body = Body_string body } 361 361 + 362 362 + (** Create a response with a bigstring body (zero-copy). *) 363 363 + let respond_bigstring ?(status = `OK) ?(headers = []) body = 364 364 + { status; headers; body = Body_bigstring body } 365 365 + 366 366 + (** Create a response with a pre-built body (zero-allocation). *) 367 367 + let respond_prebuilt prebuilt = 368 368 + { 369 369 + status = prebuilt.Prebuilt.status; 370 370 + headers = []; 371 371 + body = Body_prebuilt prebuilt; 372 372 + } 373 373 + 374 374 + (** Create an empty response. *) 375 375 + let respond_empty ?(status = `No_content) ?(headers = []) () = 376 376 + { status; headers; body = Body_empty } 377 377 + 378 378 + (** Create a streaming response. *) 379 379 + let respond_stream ?(status = `OK) ?(headers = []) ?content_length next = 380 380 + { status; headers; body = Body_stream { content_length; next } } 381 381 + 382 382 + (** Create a plain text response. *) 383 383 + let respond_text ?(status = `OK) body = 384 384 + { 385 385 + status; 386 386 + headers = [ ("content-type", "text/plain; charset=utf-8") ]; 387 387 + body = Body_string body; 388 388 + } 389 389 + 390 390 + (** Create an HTML response. *) 391 391 + let respond_html ?(status = `OK) body = 392 392 + { 393 393 + status; 394 394 + headers = [ ("content-type", "text/html; charset=utf-8") ]; 395 395 + body = Body_string body; 396 396 + } 397 397 + 398 398 + (** Create a JSON response. *) 399 399 + let respond_json ?(status = `OK) body = 400 400 + { 401 401 + status; 402 402 + headers = [ ("content-type", "application/json") ]; 403 403 + body = Body_string body; 404 404 + } 405 405 + 406 406 + (** {1 Internal: Socket Helpers} *) 407 407 + 408 408 + let set_tcp_nodelay flow = 409 409 + match Eio_unix.Resource.fd_opt flow with 410 410 + | None -> () 411 411 + | Some fd -> 412 412 + Eio_unix.Fd.use_exn "set_tcp_nodelay" fd (fun unix_fd -> 413 413 + Unix.setsockopt unix_fd Unix.TCP_NODELAY true) 414 414 + 415 415 + let shutdown_flow flow cmd = 416 416 + try Eio.Flow.shutdown flow cmd with 417 417 + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () 418 418 + | Eio.Io (Eio.Exn.X (Eio_unix.Unix_error (Unix.ENOTCONN, _, _)), _) -> () 419 419 + 420 420 + let[@inline] writev flow iovecs = 421 421 + match iovecs with 422 422 + | [] -> `Ok 0 423 423 + | [ { Httpun_types.IOVec.buffer; off; len } ] -> ( 424 424 + let cs = Cstruct.of_bigarray buffer ~off ~len in 425 425 + match Eio.Flow.write flow [ cs ] with 426 426 + | () -> `Ok len 427 427 + | exception End_of_file -> `Closed) 428 428 + | _ -> ( 429 429 + let lenv, cstructs = 430 430 + List.fold_left_map 431 431 + (fun acc { Httpun_types.IOVec.buffer; off; len } -> 432 432 + (acc + len, Cstruct.of_bigarray buffer ~off ~len)) 433 433 + 0 iovecs 434 434 + in 435 435 + match Eio.Flow.write flow cstructs with 436 436 + | () -> `Ok lenv 437 437 + | exception End_of_file -> `Closed) 438 438 + 439 439 + (** {1 Internal: Header Conversion} *) 440 440 + 441 441 + let h1_headers_to_list headers = 442 442 + let result = ref [] in 443 443 + H1.Headers.iter 444 444 + ~f:(fun name value -> result := (name, value) :: !result) 445 445 + headers; 446 446 + List.rev !result 447 447 + 448 448 + let h2_headers_to_list headers = 449 449 + let result = ref [] in 450 450 + H2.Headers.iter 451 451 + ~f:(fun name value -> result := (name, value) :: !result) 452 452 + headers; 453 453 + List.rev !result 454 454 + 455 455 + (** {1 Internal: Protocol Detection} *) 456 456 + 457 457 + (** HTTP/2 connection preface starts with "PRI " *) 458 458 + let h2_preface_prefix = "PRI " 459 459 + 460 460 + let h2_preface_prefix_len = 4 461 461 + 462 462 + let peek_bytes flow n = 463 463 + let buf = Cstruct.create n in 464 464 + try 465 465 + let read = Eio.Flow.single_read flow buf in 466 466 + Ok (Cstruct.to_string (Cstruct.sub buf 0 read)) 467 467 + with 468 468 + | End_of_file -> Error `Eof 469 469 + | exn -> Error (`Exn exn) 470 470 + 471 471 + let is_h2_preface data = 472 472 + String.length data >= h2_preface_prefix_len 473 473 + && String.sub data 0 h2_preface_prefix_len = h2_preface_prefix 474 474 + 475 475 + (** {1 Internal: HTTP/1.1 Connection Handler} *) 476 476 + 477 477 + module H1_handler = struct 478 478 + let handle ~handler ~ws_handler ~initial_data flow = 479 479 + let buffer_size = 16384 in 480 480 + let read_buffer = Bigstringaf.create buffer_size in 481 481 + let read_cstruct = 482 482 + Cstruct.of_bigarray read_buffer ~off:0 ~len:buffer_size 483 483 + in 484 484 + 485 485 + let pending_data = ref initial_data in 486 486 + let ws_upgrade = ref None in 487 487 + 488 488 + let request_handler reqd = 489 489 + let req = H1.Reqd.request reqd in 490 490 + let h1_body = H1.Reqd.request_body reqd in 491 491 + 492 492 + (* Check for WebSocket upgrade *) 493 493 + if Option.is_some ws_handler && Websocket.is_upgrade_request req.headers 494 494 + then begin 495 495 + match Websocket.get_websocket_key req.headers with 496 496 + | Some key -> 497 497 + ws_upgrade := Some key; 498 498 + H1.Body.Reader.close h1_body; 499 499 + let accept = Websocket.compute_accept_key key in 500 500 + let headers = 501 501 + H1.Headers.of_list 502 502 + [ 503 503 + ("upgrade", "websocket"); 504 504 + ("connection", "Upgrade"); 505 505 + ("sec-websocket-accept", accept); 506 506 + ] 507 507 + in 508 508 + H1.Reqd.respond_with_upgrade reqd headers 509 509 + | None -> 510 510 + H1.Body.Reader.close h1_body; 511 511 + let headers = 512 512 + H1.Headers.of_list 513 513 + [ ("date", Date_cache.get ()); ("content-length", "11") ] 514 514 + in 515 515 + let resp = H1.Response.create ~headers `Bad_request in 516 516 + H1.Reqd.respond_with_string reqd resp "Bad Request" 517 517 + end 518 518 + else begin 519 519 + (* Regular HTTP/1.1 request *) 520 520 + (* Read body for POST/PUT, skip for GET/HEAD *) 521 521 + let body = 522 522 + match req.meth with 523 523 + | `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> 524 524 + H1.Body.Reader.close h1_body; 525 525 + "" 526 526 + | `POST | `PUT | `Other _ -> 527 527 + let body_buffer = Buffer.create 4096 in 528 528 + let body_done, resolver = Eio.Promise.create () in 529 529 + let rec read_body () = 530 530 + H1.Body.Reader.schedule_read h1_body 531 531 + ~on_eof:(fun () -> Eio.Promise.resolve resolver ()) 532 532 + ~on_read:(fun buf ~off ~len -> 533 533 + Buffer.add_string body_buffer 534 534 + (Bigstringaf.substring buf ~off ~len); 535 535 + read_body ()) 536 536 + in 537 537 + read_body (); 538 538 + Eio.Promise.await body_done; 539 539 + Buffer.contents body_buffer 540 540 + in 541 541 + 542 542 + let request = 543 543 + { 544 544 + meth = req.meth; 545 545 + target = req.target; 546 546 + headers = h1_headers_to_list req.headers; 547 547 + body; 548 548 + version = HTTP_1_1; 549 549 + } 550 550 + in 551 551 + let response = handler request in 552 552 + 553 553 + (* Send response *) 554 554 + let date_header = ("date", Date_cache.get ()) in 555 555 + match response.body with 556 556 + | Body_prebuilt prebuilt -> Prebuilt.respond_h1 reqd prebuilt 557 557 + | Body_empty -> 558 558 + let headers = 559 559 + H1.Headers.of_list 560 560 + (date_header :: ("content-length", "0") :: response.headers) 561 561 + in 562 562 + let resp = H1.Response.create ~headers response.status in 563 563 + H1.Reqd.respond_with_string reqd resp "" 564 564 + | Body_string body -> 565 565 + let headers = 566 566 + H1.Headers.of_list 567 567 + (date_header 568 568 + :: ("content-length", string_of_int (String.length body)) 569 569 + :: response.headers) 570 570 + in 571 571 + let resp = H1.Response.create ~headers response.status in 572 572 + H1.Reqd.respond_with_string reqd resp body 573 573 + | Body_bigstring body -> 574 574 + let headers = 575 575 + H1.Headers.of_list 576 576 + (date_header 577 577 + :: ("content-length", string_of_int (Bigstringaf.length body)) 578 578 + :: response.headers) 579 579 + in 580 580 + let resp = H1.Response.create ~headers response.status in 581 581 + H1.Reqd.respond_with_bigstring reqd resp body 582 582 + | Body_stream { content_length; next } -> 583 583 + let headers = 584 584 + match content_length with 585 585 + | Some len -> 586 586 + H1.Headers.of_list 587 587 + (date_header 588 588 + :: ("content-length", Int64.to_string len) 589 589 + :: response.headers) 590 590 + | None -> 591 591 + H1.Headers.of_list 592 592 + (date_header 593 593 + :: ("transfer-encoding", "chunked") 594 594 + :: response.headers) 595 595 + in 596 596 + let resp = H1.Response.create ~headers response.status in 597 597 + let body_writer = H1.Reqd.respond_with_streaming reqd resp in 598 598 + let rec write_chunks () = 599 599 + match next () with 600 600 + | None -> H1.Body.Writer.close body_writer 601 601 + | Some cs -> 602 602 + H1.Body.Writer.write_bigstring body_writer ~off:0 603 603 + ~len:(Cstruct.length cs) (Cstruct.to_bigarray cs); 604 604 + write_chunks () 605 605 + in 606 606 + write_chunks () 607 607 + end 608 608 + in 609 609 + 610 610 + let error_handler ?request:_ _error start_response = 611 611 + let resp_body = start_response H1.Headers.empty in 612 612 + H1.Body.Writer.write_string resp_body "Internal Server Error"; 613 613 + H1.Body.Writer.close resp_body 614 614 + in 615 615 + 616 616 + let conn = H1.Server_connection.create ~error_handler request_handler in 617 617 + let shutdown = ref false in 618 618 + 619 619 + let rec read_loop () = 620 620 + if not !shutdown then 621 621 + match H1.Server_connection.next_read_operation conn with 622 622 + | `Read -> 623 623 + let socket_data = 624 624 + match Eio.Flow.single_read flow read_cstruct with 625 625 + | n -> Cstruct.to_string (Cstruct.sub read_cstruct 0 n) 626 626 + | exception End_of_file -> "" 627 627 + in 628 628 + let data = 629 629 + if String.length !pending_data > 0 then begin 630 630 + let combined = !pending_data ^ socket_data in 631 631 + pending_data := ""; 632 632 + combined 633 633 + end 634 634 + else socket_data 635 635 + in 636 636 + let len = String.length data in 637 637 + if len = 0 then begin 638 638 + let (_ : int) = 639 639 + H1.Server_connection.read_eof conn read_buffer ~off:0 ~len:0 640 640 + in 641 641 + shutdown := true 642 642 + end 643 643 + else begin 644 644 + Bigstringaf.blit_from_string data ~src_off:0 read_buffer 645 645 + ~dst_off:0 ~len; 646 646 + let (_ : int) = 647 647 + H1.Server_connection.read conn read_buffer ~off:0 ~len 648 648 + in 649 649 + read_loop () 650 650 + end 651 651 + | `Yield -> H1.Server_connection.yield_reader conn read_loop 652 652 + | `Close -> shutdown := true 653 653 + | `Upgrade -> shutdown := true 654 654 + in 655 655 + 656 656 + let rec write_loop () = 657 657 + if not !shutdown then 658 658 + match H1.Server_connection.next_write_operation conn with 659 659 + | `Write iovecs -> 660 660 + let write_result = writev flow iovecs in 661 661 + H1.Server_connection.report_write_result conn write_result; 662 662 + write_loop () 663 663 + | `Yield -> H1.Server_connection.yield_writer conn write_loop 664 664 + | `Close _ -> 665 665 + shutdown := true; 666 666 + shutdown_flow flow `Send 667 667 + | `Upgrade -> shutdown := true 668 668 + in 669 669 + 670 670 + Fiber.both read_loop write_loop; 671 671 + 672 672 + (* Handle WebSocket upgrade if requested *) 673 673 + match !ws_upgrade with 674 674 + | Some _key -> ( 675 675 + match ws_handler with 676 676 + | Some ws_h -> 677 677 + let ws = 678 678 + { 679 679 + Websocket.flow :> Eio.Flow.two_way_ty Eio.Std.r; 680 680 + closed = false; 681 681 + is_client = false; 682 682 + read_buf = Buffer.create 4096; 683 683 + } 684 684 + in 685 685 + (try ws_h ws with _ -> ()); 686 686 + if Websocket.is_open ws then Websocket.close ws 687 687 + | None -> ()) 688 688 + | None -> () 689 689 + 690 690 + (** Direct H1 handler - no protocol detection, no initial data buffering *) 691 691 + let handle_direct ~handler flow = 692 692 + let buffer_size = 16384 in 693 693 + let read_buffer = Bigstringaf.create buffer_size in 694 694 + let read_cstruct = 695 695 + Cstruct.of_bigarray read_buffer ~off:0 ~len:buffer_size 696 696 + in 697 697 + 698 698 + let request_handler reqd = 699 699 + let req = H1.Reqd.request reqd in 700 700 + let h1_body = H1.Reqd.request_body reqd in 701 701 + 702 702 + (* Read body for POST/PUT, skip for GET/HEAD *) 703 703 + let body = 704 704 + match req.meth with 705 705 + | `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> 706 706 + H1.Body.Reader.close h1_body; 707 707 + "" 708 708 + | `POST | `PUT | `Other _ -> 709 709 + let body_buffer = Buffer.create 4096 in 710 710 + let body_done, resolver = Eio.Promise.create () in 711 711 + let rec read_body () = 712 712 + H1.Body.Reader.schedule_read h1_body 713 713 + ~on_eof:(fun () -> Eio.Promise.resolve resolver ()) 714 714 + ~on_read:(fun buf ~off ~len -> 715 715 + Buffer.add_string body_buffer 716 716 + (Bigstringaf.substring buf ~off ~len); 717 717 + read_body ()) 718 718 + in 719 719 + read_body (); 720 720 + Eio.Promise.await body_done; 721 721 + Buffer.contents body_buffer 722 722 + in 723 723 + 724 724 + let request = 725 725 + { 726 726 + meth = req.meth; 727 727 + target = req.target; 728 728 + headers = h1_headers_to_list req.headers; 729 729 + body; 730 730 + version = HTTP_1_1; 731 731 + } 732 732 + in 733 733 + let response = handler request in 734 734 + 735 735 + (* Send response *) 736 736 + let date_header = ("date", Date_cache.get ()) in 737 737 + match response.body with 738 738 + | Body_prebuilt prebuilt -> Prebuilt.respond_h1 reqd prebuilt 739 739 + | Body_empty -> 740 740 + let headers = 741 741 + H1.Headers.of_list 742 742 + (date_header :: ("content-length", "0") :: response.headers) 743 743 + in 744 744 + let resp = H1.Response.create ~headers response.status in 745 745 + H1.Reqd.respond_with_string reqd resp "" 746 746 + | Body_string body -> 747 747 + let headers = 748 748 + H1.Headers.of_list 749 749 + (date_header 750 750 + :: ("content-length", string_of_int (String.length body)) 751 751 + :: response.headers) 752 752 + in 753 753 + let resp = H1.Response.create ~headers response.status in 754 754 + H1.Reqd.respond_with_string reqd resp body 755 755 + | Body_bigstring body -> 756 756 + let headers = 757 757 + H1.Headers.of_list 758 758 + (date_header 759 759 + :: ("content-length", string_of_int (Bigstringaf.length body)) 760 760 + :: response.headers) 761 761 + in 762 762 + let resp = H1.Response.create ~headers response.status in 763 763 + H1.Reqd.respond_with_bigstring reqd resp body 764 764 + | Body_stream { content_length; next } -> 765 765 + let headers = 766 766 + match content_length with 767 767 + | Some len -> 768 768 + H1.Headers.of_list 769 769 + (date_header 770 770 + :: ("content-length", Int64.to_string len) 771 771 + :: response.headers) 772 772 + | None -> 773 773 + H1.Headers.of_list 774 774 + (date_header 775 775 + :: ("transfer-encoding", "chunked") 776 776 + :: response.headers) 777 777 + in 778 778 + let resp = H1.Response.create ~headers response.status in 779 779 + let body_writer = H1.Reqd.respond_with_streaming reqd resp in 780 780 + let rec write_chunks () = 781 781 + match next () with 782 782 + | None -> H1.Body.Writer.close body_writer 783 783 + | Some cs -> 784 784 + H1.Body.Writer.write_bigstring body_writer ~off:0 785 785 + ~len:(Cstruct.length cs) (Cstruct.to_bigarray cs); 786 786 + write_chunks () 787 787 + in 788 788 + write_chunks () 789 789 + in 790 790 + 791 791 + let error_handler ?request:_ _error start_response = 792 792 + let resp_body = start_response H1.Headers.empty in 793 793 + H1.Body.Writer.write_string resp_body "Internal Server Error"; 794 794 + H1.Body.Writer.close resp_body 795 795 + in 796 796 + 797 797 + let conn = H1.Server_connection.create ~error_handler request_handler in 798 798 + let shutdown = ref false in 799 799 + 800 800 + let rec read_loop () = 801 801 + if not !shutdown then 802 802 + match H1.Server_connection.next_read_operation conn with 803 803 + | `Read -> ( 804 804 + match Eio.Flow.single_read flow read_cstruct with 805 805 + | n -> 806 806 + let (_ : int) = 807 807 + H1.Server_connection.read conn read_buffer ~off:0 ~len:n 808 808 + in 809 809 + read_loop () 810 810 + | exception End_of_file -> 811 811 + let (_ : int) = 812 812 + H1.Server_connection.read_eof conn read_buffer ~off:0 ~len:0 813 813 + in 814 814 + shutdown := true) 815 815 + | `Yield -> H1.Server_connection.yield_reader conn read_loop 816 816 + | `Close | `Upgrade -> shutdown := true 817 817 + in 818 818 + 819 819 + let rec write_loop () = 820 820 + if not !shutdown then 821 821 + match H1.Server_connection.next_write_operation conn with 822 822 + | `Write iovecs -> 823 823 + let write_result = writev flow iovecs in 824 824 + H1.Server_connection.report_write_result conn write_result; 825 825 + write_loop () 826 826 + | `Yield -> H1.Server_connection.yield_writer conn write_loop 827 827 + | `Close _ -> 828 828 + shutdown := true; 829 829 + shutdown_flow flow `Send 830 830 + | `Upgrade -> shutdown := true 831 831 + in 832 832 + 833 833 + Fiber.both read_loop write_loop 834 834 + end 835 835 + 836 836 + (** {1 Internal: HTTP/2 Connection Handler} *) 837 837 + 838 838 + module H2_handler = struct 839 839 + let handle ~handler ~initial_data flow = 840 840 + let read_buffer_size = 0x4000 in 841 841 + let read_buffer = Bigstringaf.create read_buffer_size in 842 842 + let pending_data = ref initial_data in 843 843 + 844 844 + let request_handler reqd = 845 845 + let req = H2.Reqd.request reqd in 846 846 + let body_reader = H2.Reqd.request_body reqd in 847 847 + 848 848 + let body = 849 849 + match req.meth with 850 850 + | `GET | `HEAD -> 851 851 + H2.Body.Reader.close body_reader; 852 852 + "" 853 853 + | _ -> 854 854 + let body_buffer = Buffer.create 4096 in 855 855 + let body_done, resolver = Eio.Promise.create () in 856 856 + let rec read_body () = 857 857 + H2.Body.Reader.schedule_read body_reader 858 858 + ~on_eof:(fun () -> Eio.Promise.resolve resolver ()) 859 859 + ~on_read:(fun buf ~off ~len -> 860 860 + Buffer.add_string body_buffer 861 861 + (Bigstringaf.substring buf ~off ~len); 862 862 + read_body ()) 863 863 + in 864 864 + read_body (); 865 865 + Eio.Promise.await body_done; 866 866 + Buffer.contents body_buffer 867 867 + in 868 868 + 869 869 + let target = 870 870 + match H2.Headers.get req.headers ":path" with 871 871 + | Some p -> p 872 872 + | None -> "/" 873 873 + in 874 874 + 875 875 + let request = 876 876 + { 877 877 + meth = req.meth; 878 878 + target; 879 879 + headers = h2_headers_to_list req.headers; 880 880 + body; 881 881 + version = HTTP_2; 882 882 + } 883 883 + in 884 884 + let response = handler request in 885 885 + 886 886 + (* Convert H1.Status to H2.Status - they're compatible *) 887 887 + let h2_status = (response.status :> H2.Status.t) in 888 888 + 889 889 + match response.body with 890 890 + | Body_prebuilt prebuilt -> Prebuilt.respond_h2 reqd prebuilt 891 891 + | Body_empty -> 892 892 + let headers = 893 893 + H2.Headers.of_list (("content-length", "0") :: response.headers) 894 894 + in 895 895 + let resp = H2.Response.create ~headers h2_status in 896 896 + H2.Reqd.respond_with_string reqd resp "" 897 897 + | Body_string body -> 898 898 + let headers = 899 899 + H2.Headers.of_list 900 900 + (("content-length", string_of_int (String.length body)) 901 901 + :: response.headers) 902 902 + in 903 903 + let resp = H2.Response.create ~headers h2_status in 904 904 + H2.Reqd.respond_with_string reqd resp body 905 905 + | Body_bigstring body -> 906 906 + let headers = 907 907 + H2.Headers.of_list 908 908 + (("content-length", string_of_int (Bigstringaf.length body)) 909 909 + :: response.headers) 910 910 + in 911 911 + let resp = H2.Response.create ~headers h2_status in 912 912 + H2.Reqd.respond_with_bigstring reqd resp body 913 913 + | Body_stream { content_length; next } -> 914 914 + let headers = 915 915 + match content_length with 916 916 + | Some len -> 917 917 + H2.Headers.of_list 918 918 + (("content-length", Int64.to_string len) :: response.headers) 919 919 + | None -> H2.Headers.of_list response.headers 920 920 + in 921 921 + let resp = H2.Response.create ~headers h2_status in 922 922 + let body_writer = H2.Reqd.respond_with_streaming reqd resp in 923 923 + let rec write_chunks () = 924 924 + match next () with 925 925 + | None -> H2.Body.Writer.close body_writer 926 926 + | Some cs -> 927 927 + H2.Body.Writer.write_bigstring body_writer ~off:0 928 928 + ~len:(Cstruct.length cs) (Cstruct.to_bigarray cs); 929 929 + write_chunks () 930 930 + in 931 931 + write_chunks () 932 932 + in 933 933 + 934 934 + let error_handler ?request:_ _error start_response = 935 935 + let resp_body = start_response H2.Headers.empty in 936 936 + H2.Body.Writer.write_string resp_body "Internal Server Error"; 937 937 + H2.Body.Writer.close resp_body 938 938 + in 939 939 + 940 940 + let conn = H2.Server_connection.create ~error_handler request_handler in 941 941 + let shutdown = ref false in 942 942 + 943 943 + let read_loop () = 944 944 + let rec loop () = 945 945 + if not !shutdown then 946 946 + match H2.Server_connection.next_read_operation conn with 947 947 + | `Read -> 948 948 + let cs = 949 949 + Cstruct.of_bigarray read_buffer ~off:0 ~len:read_buffer_size 950 950 + in 951 951 + let socket_data = 952 952 + try 953 953 + let n = Eio.Flow.single_read flow cs in 954 954 + Cstruct.to_string (Cstruct.sub cs 0 n) 955 955 + with End_of_file -> "" 956 956 + in 957 957 + let data = 958 958 + if String.length !pending_data > 0 then begin 959 959 + let combined = !pending_data ^ socket_data in 960 960 + pending_data := ""; 961 961 + combined 962 962 + end 963 963 + else socket_data 964 964 + in 965 965 + let len = String.length data in 966 966 + if len = 0 then begin 967 967 + let _ = 968 968 + H2.Server_connection.read_eof conn read_buffer ~off:0 ~len:0 969 969 + in 970 970 + shutdown := true 971 971 + end 972 972 + else begin 973 973 + Bigstringaf.blit_from_string data ~src_off:0 read_buffer 974 974 + ~dst_off:0 ~len; 975 975 + let _ = 976 976 + H2.Server_connection.read conn read_buffer ~off:0 ~len 977 977 + in 978 978 + loop () 979 979 + end 980 980 + | `Close -> shutdown := true 981 981 + in 982 982 + loop () 983 983 + in 984 984 + 985 985 + let write_loop () = 986 986 + let rec loop () = 987 987 + if not !shutdown then 988 988 + match H2.Server_connection.next_write_operation conn with 989 989 + | `Write iovecs -> 990 990 + let cstructs = 991 991 + List.map 992 992 + (fun iov -> 993 993 + Cstruct.of_bigarray ~off:iov.H2.IOVec.off 994 994 + ~len:iov.H2.IOVec.len iov.H2.IOVec.buffer) 995 995 + iovecs 996 996 + in 997 997 + Eio.Flow.write flow cstructs; 998 998 + let len = 999 999 + List.fold_left (fun acc iov -> acc + iov.H2.IOVec.len) 0 iovecs 1000 1000 + in 1001 1001 + H2.Server_connection.report_write_result conn (`Ok len); 1002 1002 + loop () 1003 1003 + | `Yield -> 1004 1004 + let continue = Eio.Promise.create () in 1005 1005 + H2.Server_connection.yield_writer conn (fun () -> 1006 1006 + Eio.Promise.resolve (snd continue) ()); 1007 1007 + Eio.Promise.await (fst continue); 1008 1008 + loop () 1009 1009 + | `Close _ -> shutdown := true 1010 1010 + in 1011 1011 + loop () 1012 1012 + in 1013 1013 + 1014 1014 + Fiber.both read_loop write_loop 1015 1015 + 1016 1016 + (** Direct H2 handler - no protocol detection *) 1017 1017 + let handle_direct ~handler flow = handle ~handler ~initial_data:"" flow 1018 1018 + end 1019 1019 + 1020 1020 + (** {1 Internal: TLS Connection Handler} *) 1021 1021 + 1022 1022 + module Tls_handler = struct 1023 1023 + let handle ~config ~handler ~ws_handler tls_cfg flow = 1024 1024 + try 1025 1025 + let tls_flow = Tls_eio.server_of_flow tls_cfg flow in 1026 1026 + match config.protocol with 1027 1027 + | Http1_only -> 1028 1028 + (* No ALPN check, direct H1 *) 1029 1029 + H1_handler.handle_direct ~handler tls_flow 1030 1030 + | Http2_only -> 1031 1031 + (* No ALPN check, direct H2 *) 1032 1032 + H2_handler.handle_direct ~handler tls_flow 1033 1033 + | Auto | Auto_websocket -> ( 1034 1034 + (* Check ALPN negotiated protocol *) 1035 1035 + match Tls_config.negotiated_protocol tls_flow with 1036 1036 + | Some Tls_config.HTTP_2 -> H2_handler.handle_direct ~handler tls_flow 1037 1037 + | Some Tls_config.HTTP_1_1 | None -> 1038 1038 + if config.protocol = Auto_websocket then 1039 1039 + H1_handler.handle ~handler ~ws_handler:(Some ws_handler) 1040 1040 + ~initial_data:"" tls_flow 1041 1041 + else H1_handler.handle_direct ~handler tls_flow) 1042 1042 + with 1043 1043 + | Tls_eio.Tls_failure failure -> 1044 1044 + traceln "TLS error: %s" (Tls_config.failure_to_string failure) 1045 1045 + | exn -> traceln "Connection error: %s" (Printexc.to_string exn) 1046 1046 + end 1047 1047 + 1048 1048 + (** {1 Internal: Connection Handler} *) 1049 1049 + 1050 1050 + let handle_connection ~config ~handler ~ws_handler flow = 1051 1051 + match config.protocol with 1052 1052 + | Http1_only -> 1053 1053 + (* Fastest path: direct H1, no detection *) 1054 1054 + H1_handler.handle_direct ~handler flow 1055 1055 + | Http2_only -> 1056 1056 + (* Direct H2 (h2c) *) 1057 1057 + H2_handler.handle_direct ~handler flow 1058 1058 + | Auto | Auto_websocket -> ( 1059 1059 + (* Peek to detect protocol *) 1060 1060 + match peek_bytes flow h2_preface_prefix_len with 1061 1061 + | Error `Eof -> () (* Client disconnected immediately *) 1062 1062 + | Error (`Exn exn) -> 1063 1063 + traceln "Connection error: %s" (Printexc.to_string exn) 1064 1064 + | Ok initial_data -> 1065 1065 + if is_h2_preface initial_data then 1066 1066 + H2_handler.handle ~handler ~initial_data flow 1067 1067 + else if config.protocol = Auto_websocket then 1068 1068 + H1_handler.handle ~handler ~ws_handler:(Some ws_handler) 1069 1069 + ~initial_data flow 1070 1070 + else H1_handler.handle ~handler ~ws_handler:None ~initial_data flow) 1071 1071 + 1072 1072 + (** {1 Public API} *) 1073 1073 + 1074 1074 + (** Run an HTTP server. 1075 1075 + 1076 1076 + @param sw Switch for resource management 1077 1077 + @param net Eio network capability 1078 1078 + @param config Server configuration (default: [default_config]) 1079 1079 + @param ws_handler WebSocket handler (required for [Auto_websocket] mode) 1080 1080 + @param handler Request handler *) 1081 1081 + let run ~sw ~net ?(config = default_config) ?ws_handler handler = 1082 1082 + (* Apply GC tuning if configured *) 1083 1083 + (match config.gc_tuning with 1084 1084 + | Some gc_config -> Gc_tune.apply ~config:gc_config () 1085 1085 + | None -> ()); 1086 1086 + 1087 1087 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 1088 1088 + let socket = 1089 1089 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 1090 1090 + ~reuse_port:config.reuse_port net addr 1091 1091 + in 1092 1092 + 1093 1093 + let protocol_str = 1094 1094 + match (config.protocol, config.tls) with 1095 1095 + | Http1_only, None -> "HTTP/1.1" 1096 1096 + | Http1_only, Some _ -> "HTTP/1.1 (TLS)" 1097 1097 + | Http2_only, None -> "HTTP/2 h2c" 1098 1098 + | Http2_only, Some _ -> "HTTP/2 (TLS)" 1099 1099 + | Auto, None -> "HTTP/1.1 + HTTP/2 h2c" 1100 1100 + | Auto, Some _ -> "HTTP/1.1 + HTTP/2 (TLS, ALPN)" 1101 1101 + | Auto_websocket, None -> "HTTP/1.1 + HTTP/2 h2c + WebSocket" 1102 1102 + | Auto_websocket, Some _ -> "HTTP/1.1 + HTTP/2 + WebSocket (TLS, ALPN)" 1103 1103 + in 1104 1104 + traceln "Server listening on port %d (%s)" config.port protocol_str; 1105 1105 + 1106 1106 + (* Validate ws_handler for Auto_websocket mode *) 1107 1107 + let ws_handler = 1108 1108 + match (config.protocol, ws_handler) with 1109 1109 + | Auto_websocket, None -> 1110 1110 + failwith "WebSocket handler required for Auto_websocket mode" 1111 1111 + | Auto_websocket, Some h -> h 1112 1112 + | _, _ -> fun _ -> () (* Dummy handler for non-WS modes *) 1113 1113 + in 1114 1114 + 1115 1115 + let connection_handler flow _addr = 1116 1116 + if config.tcp_nodelay then set_tcp_nodelay flow; 1117 1117 + match config.tls with 1118 1118 + | None -> handle_connection ~config ~handler ~ws_handler flow 1119 1119 + | Some tls_config -> ( 1120 1120 + match Tls_config.Server.to_tls_config tls_config with 1121 1121 + | Error (`Msg msg) -> traceln "TLS config error: %s" msg 1122 1122 + | Ok tls_cfg -> 1123 1123 + Tls_handler.handle ~config ~handler ~ws_handler tls_cfg flow) 1124 1124 + in 1125 1125 + 1126 1126 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 1127 1127 + 1128 1128 + Eio.Net.run_server socket connection_handler 1129 1129 + ~max_connections:config.max_connections ~on_error 1130 1130 + 1131 1131 + (** Run an HTTP server with multi-domain parallelism. 1132 1132 + 1133 1133 + @param sw Switch for resource management 1134 1134 + @param net Eio network capability 1135 1135 + @param domain_mgr Eio domain manager 1136 1136 + @param config Server configuration (default: [default_config]) 1137 1137 + @param ws_handler WebSocket handler (required for [Auto_websocket] mode) 1138 1138 + @param handler Request handler *) 1139 1139 + let run_parallel ~sw ~net ~domain_mgr ?(config = default_config) ?ws_handler 1140 1140 + handler = 1141 1141 + (* Apply GC tuning if configured *) 1142 1142 + (match config.gc_tuning with 1143 1143 + | Some gc_config -> Gc_tune.apply ~config:gc_config () 1144 1144 + | None -> ()); 1145 1145 + 1146 1146 + let domain_count = max 1 config.domain_count in 1147 1147 + let addr = `Tcp (Eio.Net.Ipaddr.V4.any, config.port) in 1148 1148 + let socket = 1149 1149 + Eio.Net.listen ~sw ~backlog:config.backlog ~reuse_addr:config.reuse_addr 1150 1150 + ~reuse_port:config.reuse_port net addr 1151 1151 + in 1152 1152 + 1153 1153 + let protocol_str = 1154 1154 + match (config.protocol, config.tls) with 1155 1155 + | Http1_only, None -> "HTTP/1.1" 1156 1156 + | Http1_only, Some _ -> "HTTP/1.1 (TLS)" 1157 1157 + | Http2_only, None -> "HTTP/2 h2c" 1158 1158 + | Http2_only, Some _ -> "HTTP/2 (TLS)" 1159 1159 + | Auto, None -> "HTTP/1.1 + HTTP/2 h2c" 1160 1160 + | Auto, Some _ -> "HTTP/1.1 + HTTP/2 (TLS, ALPN)" 1161 1161 + | Auto_websocket, None -> "HTTP/1.1 + HTTP/2 h2c + WebSocket" 1162 1162 + | Auto_websocket, Some _ -> "HTTP/1.1 + HTTP/2 + WebSocket (TLS, ALPN)" 1163 1163 + in 1164 1164 + traceln "Server listening on port %d (%s, %d domains)" config.port 1165 1165 + protocol_str domain_count; 1166 1166 + 1167 1167 + (* Validate ws_handler for Auto_websocket mode *) 1168 1168 + let ws_handler = 1169 1169 + match (config.protocol, ws_handler) with 1170 1170 + | Auto_websocket, None -> 1171 1171 + failwith "WebSocket handler required for Auto_websocket mode" 1172 1172 + | Auto_websocket, Some h -> h 1173 1173 + | _, _ -> fun _ -> () 1174 1174 + in 1175 1175 + 1176 1176 + let connection_handler flow _addr = 1177 1177 + if config.tcp_nodelay then set_tcp_nodelay flow; 1178 1178 + match config.tls with 1179 1179 + | None -> handle_connection ~config ~handler ~ws_handler flow 1180 1180 + | Some tls_config -> ( 1181 1181 + match Tls_config.Server.to_tls_config tls_config with 1182 1182 + | Error (`Msg msg) -> traceln "TLS config error: %s" msg 1183 1183 + | Ok tls_cfg -> 1184 1184 + Tls_handler.handle ~config ~handler ~ws_handler tls_cfg flow) 1185 1185 + in 1186 1186 + 1187 1187 + let on_error exn = traceln "Connection error: %s" (Printexc.to_string exn) in 1188 1188 + 1189 1189 + if domain_count <= 1 then 1190 1190 + Eio.Net.run_server socket connection_handler 1191 1191 + ~max_connections:config.max_connections ~on_error 1192 1192 + else 1193 1193 + Eio.Net.run_server socket connection_handler 1194 1194 + ~max_connections:config.max_connections ~on_error 1195 1195 + ~additional_domains:(domain_mgr, domain_count - 1)

+295

lib/stream.ml

reviewed

··· 1 1 + (** Streaming abstractions for HCS HTTP library. 2 2 + 3 3 + This module provides both synchronous and asynchronous stream types for 4 4 + handling large payloads efficiently with backpressure support. 5 5 + 6 6 + {1 Synchronous Streams} 7 7 + 8 8 + For simple, pull-based iteration without runtime dependencies. 9 9 + 10 10 + {1 Asynchronous Streams (Eio)} 11 11 + 12 12 + For streaming with Eio's structured concurrency, supporting flows, files, 13 13 + and chunked transfer encoding. *) 14 14 + 15 15 + (** {1 Synchronous Stream} 16 16 + 17 17 + A simple pull-based stream using OCaml's Seq. *) 18 18 + module Sync = struct 19 19 + type 'a t = 'a Seq.t 20 20 + (** A synchronous stream of values *) 21 21 + 22 22 + (** {2 Producers} *) 23 23 + 24 24 + let empty : 'a t = Seq.empty 25 25 + let singleton x : 'a t = Seq.return x 26 26 + let of_list l : 'a t = List.to_seq l 27 27 + let of_array a : 'a t = Array.to_seq a 28 28 + 29 29 + (** Create a stream from an unfolding function *) 30 30 + let unfold (f : 's -> ('a * 's) option) (init : 's) : 'a t = Seq.unfold f init 31 31 + 32 32 + (** Create a stream that repeats a value n times *) 33 33 + let repeat n x : 'a t = 34 34 + unfold (fun i -> if i > 0 then Some (x, i - 1) else None) n 35 35 + 36 36 + (** Create a stream from a generator function *) 37 37 + let generate (f : unit -> 'a option) : 'a t = 38 38 + let rec next () = 39 39 + match f () with Some x -> Seq.Cons (x, next) | None -> Seq.Nil 40 40 + in 41 41 + next 42 42 + 43 43 + (** {2 Transformers} *) 44 44 + 45 45 + let map f s : 'a t = Seq.map f s 46 46 + let filter p s : 'a t = Seq.filter p s 47 47 + let filter_map f s : 'a t = Seq.filter_map f s 48 48 + 49 49 + (** Take the first n elements *) 50 50 + let take n s : 'a t = Seq.take n s 51 51 + 52 52 + (** Drop the first n elements *) 53 53 + let drop n s : 'a t = Seq.drop n s 54 54 + 55 55 + (** Split stream into chunks of size n *) 56 56 + let chunks n s : 'a list t = 57 57 + let rec next acc count seq () = 58 58 + if count >= n then Seq.Cons (List.rev acc, next [] 0 seq) 59 59 + else 60 60 + match seq () with 61 61 + | Seq.Nil -> 62 62 + if acc = [] then Seq.Nil 63 63 + else Seq.Cons (List.rev acc, fun () -> Seq.Nil) 64 64 + | Seq.Cons (x, rest) -> next (x :: acc) (count + 1) rest () 65 65 + in 66 66 + next [] 0 s 67 67 + 68 68 + (** Flatten a stream of streams *) 69 69 + let flatten s : 'a t = Seq.flat_map Fun.id s 70 70 + 71 71 + (** Append two streams *) 72 72 + let append s1 s2 : 'a t = Seq.append s1 s2 73 73 + 74 74 + (** {2 Consumers} *) 75 75 + 76 76 + (** Fold over the stream *) 77 77 + let fold f init s = Seq.fold_left f init s 78 78 + 79 79 + (** Iterate over the stream for side effects *) 80 80 + let iter f s = Seq.iter f s 81 81 + 82 82 + (** Drain the stream, discarding all values *) 83 83 + let drain s = iter (fun _ -> ()) s 84 84 + 85 85 + (** Collect stream into a list *) 86 86 + let to_list s = List.of_seq s 87 87 + 88 88 + (** Collect stream into an array *) 89 89 + let to_array s = Array.of_seq s 90 90 + 91 91 + (** {2 Cstruct-specific operations} *) 92 92 + 93 93 + (** Concatenate a stream of Cstructs into a single string *) 94 94 + let cstructs_to_string (s : Cstruct.t t) : string = 95 95 + let bufs = to_list s in 96 96 + let total = List.fold_left (fun acc cs -> acc + Cstruct.length cs) 0 bufs in 97 97 + let result = Bytes.create total in 98 98 + let _ = 99 99 + List.fold_left 100 100 + (fun off cs -> 101 101 + let len = Cstruct.length cs in 102 102 + Cstruct.blit_to_bytes cs 0 result off len; 103 103 + off + len) 104 104 + 0 bufs 105 105 + in 106 106 + Bytes.to_string result 107 107 + 108 108 + (** Split a string into chunks of Cstructs *) 109 109 + let string_to_cstructs ?(chunk_size = 4096) (s : string) : Cstruct.t t = 110 110 + let len = String.length s in 111 111 + unfold 112 112 + (fun off -> 113 113 + if off >= len then None 114 114 + else 115 115 + let chunk_len = min chunk_size (len - off) in 116 116 + Some (Cstruct.of_string ~off ~len:chunk_len s, off + chunk_len)) 117 117 + 0 118 118 + end 119 119 + 120 120 + (** {1 Asynchronous Stream (Eio)} 121 121 + 122 122 + Streams that integrate with Eio's structured concurrency. *) 123 123 + module Async = struct 124 124 + type 'a t = unit -> 'a option 125 125 + (** An asynchronous stream that can be pulled from *) 126 126 + 127 127 + (** {2 Producers} *) 128 128 + 129 129 + let empty : 'a t = fun () -> None 130 130 + 131 131 + let singleton x : 'a t = 132 132 + let taken = ref false in 133 133 + fun () -> 134 134 + if !taken then None 135 135 + else begin 136 136 + taken := true; 137 137 + Some x 138 138 + end 139 139 + 140 140 + let of_list l : 'a t = 141 141 + let r = ref l in 142 142 + fun () -> 143 143 + match !r with 144 144 + | [] -> None 145 145 + | x :: rest -> 146 146 + r := rest; 147 147 + Some x 148 148 + 149 149 + let of_seq s : 'a t = 150 150 + let r = ref s in 151 151 + fun () -> 152 152 + match !r () with 153 153 + | Seq.Nil -> None 154 154 + | Seq.Cons (x, rest) -> 155 155 + r := rest; 156 156 + Some x 157 157 + 158 158 + (** Create a stream from an Eio flow (reads until EOF) *) 159 159 + let of_flow ?(buf_size = 4096) (flow : _ Eio.Flow.source) : Cstruct.t t = 160 160 + let buf = Cstruct.create buf_size in 161 161 + let finished = ref false in 162 162 + fun () -> 163 163 + if !finished then None 164 164 + else 165 165 + try 166 166 + let n = Eio.Flow.single_read flow buf in 167 167 + Some (Cstruct.sub buf 0 n) 168 168 + with End_of_file -> 169 169 + finished := true; 170 170 + None 171 171 + 172 172 + (** Create a stream that reads a file in chunks *) 173 173 + let of_file ?(buf_size = 4096) ~fs path : Cstruct.t t = 174 174 + let file = Eio.Path.open_in ~sw:(Eio.Switch.run Fun.id) (fs, path) in 175 175 + of_flow ~buf_size file 176 176 + 177 177 + (** {2 Transformers} *) 178 178 + 179 179 + let map f (s : 'a t) : 'b t = fun () -> Option.map f (s ()) 180 180 + 181 181 + let filter p (s : 'a t) : 'a t = 182 182 + let rec next () = 183 183 + match s () with None -> None | Some x -> if p x then Some x else next () 184 184 + in 185 185 + next 186 186 + 187 187 + let filter_map f (s : 'a t) : 'b t = 188 188 + let rec next () = 189 189 + match s () with 190 190 + | None -> None 191 191 + | Some x -> ( match f x with Some y -> Some y | None -> next ()) 192 192 + in 193 193 + next 194 194 + 195 195 + let take n (s : 'a t) : 'a t = 196 196 + let count = ref 0 in 197 197 + fun () -> 198 198 + if !count >= n then None 199 199 + else begin 200 200 + incr count; 201 201 + s () 202 202 + end 203 203 + 204 204 + (** {2 Consumers} *) 205 205 + 206 206 + (** Fold over the stream *) 207 207 + let fold f init (s : 'a t) = 208 208 + let rec loop acc = 209 209 + match s () with None -> acc | Some x -> loop (f acc x) 210 210 + in 211 211 + loop init 212 212 + 213 213 + (** Iterate over the stream *) 214 214 + let iter f (s : 'a t) = 215 215 + let rec loop () = 216 216 + match s () with 217 217 + | None -> () 218 218 + | Some x -> 219 219 + f x; 220 220 + loop () 221 221 + in 222 222 + loop () 223 223 + 224 224 + (** Drain the stream *) 225 225 + let drain s = iter (fun _ -> ()) s 226 226 + 227 227 + (** Collect into a list *) 228 228 + let to_list (s : 'a t) = List.rev (fold (fun acc x -> x :: acc) [] s) 229 229 + 230 230 + (** Write stream to an Eio flow *) 231 231 + let to_flow (flow : _ Eio.Flow.sink) (s : Cstruct.t t) = 232 232 + iter (fun cs -> Eio.Flow.write flow [ cs ]) s 233 233 + 234 234 + (** {2 Cstruct-specific operations} *) 235 235 + 236 236 + (** Concatenate a stream of Cstructs into a single string *) 237 237 + let cstructs_to_string (s : Cstruct.t t) : string = 238 238 + let bufs = to_list s in 239 239 + let total = List.fold_left (fun acc cs -> acc + Cstruct.length cs) 0 bufs in 240 240 + let result = Bytes.create total in 241 241 + let _ = 242 242 + List.fold_left 243 243 + (fun off cs -> 244 244 + let len = Cstruct.length cs in 245 245 + Cstruct.blit_to_bytes cs 0 result off len; 246 246 + off + len) 247 247 + 0 bufs 248 248 + in 249 249 + Bytes.to_string result 250 250 + 251 251 + (** Read entire stream into a Cstruct *) 252 252 + let cstructs_to_cstruct (s : Cstruct.t t) : Cstruct.t = 253 253 + let bufs = to_list s in 254 254 + let total = List.fold_left (fun acc cs -> acc + Cstruct.length cs) 0 bufs in 255 255 + let result = Cstruct.create total in 256 256 + let _ = 257 257 + List.fold_left 258 258 + (fun off cs -> 259 259 + let len = Cstruct.length cs in 260 260 + Cstruct.blit cs 0 result off len; 261 261 + off + len) 262 262 + 0 bufs 263 263 + in 264 264 + result 265 265 + end 266 266 + 267 267 + (** {1 Chunked Transfer Encoding} *) 268 268 + 269 269 + (** Helpers for HTTP chunked transfer encoding *) 270 270 + module Chunked = struct 271 271 + (** Encode chunks for chunked transfer encoding *) 272 272 + let encode (chunks : Cstruct.t Sync.t) : Cstruct.t Sync.t = 273 273 + let encode_chunk cs = 274 274 + let len = Cstruct.length cs in 275 275 + if len = 0 then Cstruct.of_string "0\r\n\r\n" 276 276 + else 277 277 + let header = Printf.sprintf "%x\r\n" len in 278 278 + let trailer = "\r\n" in 279 279 + let total = String.length header + len + String.length trailer in 280 280 + let buf = Cstruct.create total in 281 281 + Cstruct.blit_from_string header 0 buf 0 (String.length header); 282 282 + Cstruct.blit cs 0 buf (String.length header) len; 283 283 + Cstruct.blit_from_string trailer 0 buf 284 284 + (String.length header + len) 285 285 + (String.length trailer); 286 286 + buf 287 287 + in 288 288 + Seq.append 289 289 + (Seq.map encode_chunk chunks) 290 290 + (Seq.return (Cstruct.of_string "0\r\n\r\n")) 291 291 + 292 292 + (** Calculate content length from chunks (consumes the stream) *) 293 293 + let content_length (chunks : Cstruct.t Sync.t) : int = 294 294 + Sync.fold (fun acc cs -> acc + Cstruct.length cs) 0 chunks 295 295 + end

+150

lib/tls_config.ml

reviewed

··· 1 1 + (** TLS configuration and helpers for HCS. 2 2 + 3 3 + This module provides TLS configuration that works with tls-eio and ca-certs 4 4 + for system certificate loading. *) 5 5 + 6 6 + (** {1 ALPN Protocol Identifiers} *) 7 7 + 8 8 + (** HTTP/2 over TLS ALPN identifier *) 9 9 + let alpn_h2 = "h2" 10 10 + 11 11 + (** HTTP/1.1 ALPN identifier *) 12 12 + let alpn_http11 = "http/1.1" 13 13 + 14 14 + (** HTTP/2 cleartext (h2c) identifier - used in Upgrade header, not ALPN *) 15 15 + let alpn_h2c = "h2c" 16 16 + 17 17 + (** Protocol type for negotiation results *) 18 18 + type protocol = HTTP_1_1 | HTTP_2 19 19 + 20 20 + (** Convert ALPN string to protocol type *) 21 21 + let protocol_of_alpn = function 22 22 + | s when s = alpn_h2 -> Some HTTP_2 23 23 + | s when s = alpn_http11 -> Some HTTP_1_1 24 24 + | _ -> None 25 25 + 26 26 + (** Convert protocol to ALPN string *) 27 27 + let alpn_of_protocol = function HTTP_2 -> alpn_h2 | HTTP_1_1 -> alpn_http11 28 28 + 29 29 + (** Client TLS configuration *) 30 30 + module Client = struct 31 31 + (** Certificate verification mode *) 32 32 + type verification = 33 33 + | System_certs (** Use system CA certificates *) 34 34 + | No_verify (** Disable verification (INSECURE!) *) 35 35 + 36 36 + type t = { 37 37 + verification : verification; 38 38 + alpn_protocols : string list option; (** ALPN: ["h2"; "http/1.1"] *) 39 39 + } 40 40 + 41 41 + let default = 42 42 + { verification = System_certs; alpn_protocols = Some [ "http/1.1" ] } 43 43 + 44 44 + (** TLS config for HTTP/2 - advertises h2 protocol *) 45 45 + let h2 = { verification = System_certs; alpn_protocols = Some [ "h2" ] } 46 46 + 47 47 + (** TLS config that prefers HTTP/2 but falls back to HTTP/1.1 *) 48 48 + let h2_or_http11 = 49 49 + { verification = System_certs; alpn_protocols = Some [ "h2"; "http/1.1" ] } 50 50 + 51 51 + let with_alpn protocols config = 52 52 + { config with alpn_protocols = Some protocols } 53 53 + 54 54 + let insecure = 55 55 + { verification = No_verify; alpn_protocols = Some [ "http/1.1" ] } 56 56 + 57 57 + let insecure_h2 = { verification = No_verify; alpn_protocols = Some [ "h2" ] } 58 58 + 59 59 + (** Create tls-eio authenticator from config *) 60 60 + let make_authenticator config = 61 61 + match config.verification with 62 62 + | System_certs -> ( 63 63 + match Ca_certs.authenticator () with 64 64 + | Ok auth -> Ok auth 65 65 + | Error (`Msg msg) -> Error msg) 66 66 + | No_verify -> Ok (fun ?ip:_ ~host:_ _ -> Ok None) 67 67 + 68 68 + (** Create Tls.Config.client from our config *) 69 69 + let to_tls_config config ~host:_ = 70 70 + match make_authenticator config with 71 71 + | Error msg -> Error msg 72 72 + | Ok authenticator -> ( 73 73 + match 74 74 + Tls.Config.client ~authenticator ?alpn_protocols:config.alpn_protocols 75 75 + () 76 76 + with 77 77 + | Ok tls_config -> Ok tls_config 78 78 + | Error (`Msg msg) -> Error msg) 79 79 + end 80 80 + 81 81 + module Server = struct 82 82 + type t = { 83 83 + certificate : Tls.Config.own_cert; 84 84 + alpn_protocols : string list option; 85 85 + } 86 86 + 87 87 + let with_alpn protocols config = 88 88 + { config with alpn_protocols = Some protocols } 89 89 + 90 90 + let h1_only config = with_alpn [ alpn_http11 ] config 91 91 + let h2_only config = with_alpn [ alpn_h2 ] config 92 92 + let h2_or_http11 config = with_alpn [ alpn_h2; alpn_http11 ] config 93 93 + 94 94 + let of_pem ~cert_file ~key_file = 95 95 + try 96 96 + let cert_pem = In_channel.with_open_bin cert_file In_channel.input_all in 97 97 + let key_pem = In_channel.with_open_bin key_file In_channel.input_all in 98 98 + let certs = X509.Certificate.decode_pem_multiple cert_pem in 99 99 + let key = X509.Private_key.decode_pem key_pem in 100 100 + match (certs, key) with 101 101 + | Ok certs, Ok key -> 102 102 + Ok 103 103 + { 104 104 + certificate = `Single (certs, key); 105 105 + alpn_protocols = Some [ alpn_h2; alpn_http11 ]; 106 106 + } 107 107 + | Error (`Msg msg), _ -> Error ("Certificate error: " ^ msg) 108 108 + | _, Error (`Msg msg) -> Error ("Key error: " ^ msg) 109 109 + with Sys_error msg -> Error ("File error: " ^ msg) 110 110 + 111 111 + (** Create Tls.Config.server from our config *) 112 112 + let to_tls_config config = 113 113 + Tls.Config.server ~certificates:config.certificate 114 114 + ?alpn_protocols:config.alpn_protocols () 115 115 + end 116 116 + 117 117 + (** Convert TLS failure to string *) 118 118 + let failure_to_string failure = Tls.Engine.string_of_failure failure 119 119 + 120 120 + (** Wrap an Eio flow with TLS (client side) *) 121 121 + let client_wrap ~config flow = 122 122 + match Client.to_tls_config config ~host:"" with 123 123 + | Error msg -> Error msg 124 124 + | Ok tls_config -> ( 125 125 + try 126 126 + let tls_flow = Tls_eio.client_of_flow tls_config flow in 127 127 + Ok tls_flow 128 128 + with 129 129 + | Tls_eio.Tls_failure failure -> Error (failure_to_string failure) 130 130 + | exn -> Error (Printexc.to_string exn)) 131 131 + 132 132 + (** Wrap an Eio flow with TLS (server side) *) 133 133 + let server_wrap config flow = 134 134 + match Server.to_tls_config config with 135 135 + | Error (`Msg msg) -> Error msg 136 136 + | Ok tls_config -> ( 137 137 + try 138 138 + let tls_flow = Tls_eio.server_of_flow tls_config flow in 139 139 + Ok tls_flow 140 140 + with 141 141 + | Tls_eio.Tls_failure failure -> Error (failure_to_string failure) 142 142 + | exn -> Error (Printexc.to_string exn)) 143 143 + 144 144 + let negotiated_protocol (tls_flow : Tls_eio.t) : protocol option = 145 145 + match Tls_eio.epoch tls_flow with 146 146 + | Error () -> None 147 147 + | Ok epoch_data -> ( 148 148 + match epoch_data.Tls.Core.alpn_protocol with 149 149 + | None -> None 150 150 + | Some alpn -> protocol_of_alpn alpn)

+548

lib/websocket.ml

reviewed

··· 1 1 + (** WebSocket implementation for HCS (RFC 6455). 2 2 + 3 3 + This module provides WebSocket client and server functionality with Eio for 4 4 + structured concurrency. *) 5 5 + 6 6 + open Eio.Std 7 7 + 8 8 + (** {1 Constants} *) 9 9 + 10 10 + (** UUID used in WebSocket handshake per RFC 6455 *) 11 11 + let websocket_uuid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" 12 12 + 13 13 + (** {1 Types} *) 14 14 + 15 15 + (** WebSocket frame opcode *) 16 16 + module Opcode = struct 17 17 + type t = 18 18 + | Continuation (** 0x0 *) 19 19 + | Text (** 0x1 *) 20 20 + | Binary (** 0x2 *) 21 21 + | Close (** 0x8 *) 22 22 + | Ping (** 0x9 *) 23 23 + | Pong (** 0xA *) 24 24 + | Ctrl of int (** Other control opcodes *) 25 25 + | Nonctrl of int (** Other non-control opcodes *) 26 26 + 27 27 + let to_int = function 28 28 + | Continuation -> 0 29 29 + | Text -> 1 30 30 + | Binary -> 2 31 31 + | Close -> 8 32 32 + | Ping -> 9 33 33 + | Pong -> 10 34 34 + | Ctrl n -> n 35 35 + | Nonctrl n -> n 36 36 + 37 37 + let of_int = function 38 38 + | 0 -> Continuation 39 39 + | 1 -> Text 40 40 + | 2 -> Binary 41 41 + | 8 -> Close 42 42 + | 9 -> Ping 43 43 + | 10 -> Pong 44 44 + | n when n > 7 -> Ctrl n 45 45 + | n -> Nonctrl n 46 46 + 47 47 + let to_string = function 48 48 + | Continuation -> "continuation" 49 49 + | Text -> "text" 50 50 + | Binary -> "binary" 51 51 + | Close -> "close" 52 52 + | Ping -> "ping" 53 53 + | Pong -> "pong" 54 54 + | Ctrl n -> Printf.sprintf "ctrl(%d)" n 55 55 + | Nonctrl n -> Printf.sprintf "nonctrl(%d)" n 56 56 + 57 57 + let is_control = function Close | Ping | Pong | Ctrl _ -> true | _ -> false 58 58 + end 59 59 + 60 60 + type frame = { 61 61 + opcode : Opcode.t; 62 62 + extension : int; 63 63 + final : bool; 64 64 + content : string; 65 65 + } 66 66 + (** WebSocket frame *) 67 67 + 68 68 + let pp_frame fmt frame = 69 69 + Format.fprintf fmt "{opcode=%s; final=%b; len=%d}" 70 70 + (Opcode.to_string frame.opcode) 71 71 + frame.final 72 72 + (String.length frame.content) 73 73 + 74 74 + let make_frame ?(opcode = Opcode.Text) ?(extension = 0) ?(final = true) 75 75 + ?(content = "") () = 76 76 + { opcode; extension; final; content } 77 77 + 78 78 + let close_frame code = 79 79 + let content = 80 80 + if code < 0 then "" 81 81 + else 82 82 + let buf = Bytes.create 2 in 83 83 + Bytes.set buf 0 (Char.chr ((code lsr 8) land 0xff)); 84 84 + Bytes.set buf 1 (Char.chr (code land 0xff)); 85 85 + Bytes.to_string buf 86 86 + in 87 87 + { opcode = Close; extension = 0; final = true; content } 88 88 + 89 89 + type t = { 90 90 + flow : Eio.Flow.two_way_ty r; 91 91 + mutable closed : bool; 92 92 + is_client : bool; (** Client must mask frames *) 93 93 + read_buf : Buffer.t; 94 94 + } 95 95 + (** WebSocket connection *) 96 96 + 97 97 + (** Error type *) 98 98 + type error = Connection_closed | Protocol_error of string | Io_error of string 99 99 + 100 100 + (** {1 Cryptographic helpers} *) 101 101 + 102 102 + (** Compute SHA-1 hash and base64 encode *) 103 103 + let b64_encoded_sha1sum s = 104 104 + let hash = Digestif.SHA1.digest_string s in 105 105 + Base64.encode_exn (Digestif.SHA1.to_raw_string hash) 106 106 + 107 107 + (** Compute the Sec-WebSocket-Accept value *) 108 108 + let compute_accept_key key = b64_encoded_sha1sum (key ^ websocket_uuid) 109 109 + 110 110 + (** {1 Random number generation for masking} *) 111 111 + 112 112 + module Rng = struct 113 113 + let initialized = ref false 114 114 + 115 115 + let init () = 116 116 + if not !initialized then begin 117 117 + Random.self_init (); 118 118 + initialized := true 119 119 + end 120 120 + 121 121 + (** Generate n random bytes *) 122 122 + let generate n = 123 123 + init (); 124 124 + let buf = Bytes.create n in 125 125 + for i = 0 to n - 1 do 126 126 + Bytes.set buf i (Char.chr (Random.int 256)) 127 127 + done; 128 128 + Bytes.to_string buf 129 129 + end 130 130 + 131 131 + (** {1 Frame parsing/serialization} *) 132 132 + 133 133 + (** Apply XOR mask to data *) 134 134 + let xor_mask mask data = 135 135 + let len = String.length data in 136 136 + let result = Bytes.create len in 137 137 + for i = 0 to len - 1 do 138 138 + let mask_byte = Char.code mask.[i mod 4] in 139 139 + let data_byte = Char.code data.[i] in 140 140 + Bytes.set result i (Char.chr (data_byte lxor mask_byte)) 141 141 + done; 142 142 + Bytes.to_string result 143 143 + 144 144 + (** Serialize a frame to bytes. Client frames must be masked, server frames must 145 145 + not be masked. *) 146 146 + let write_frame_to_buf ~is_client buf frame = 147 147 + let mask = is_client in 148 148 + let opcode = Opcode.to_int frame.opcode in 149 149 + let fin = if frame.final then 0x80 else 0 in 150 150 + let rsv = (frame.extension land 0x7) lsl 4 in 151 151 + 152 152 + Buffer.add_char buf (Char.chr (fin lor rsv lor opcode)); 153 153 + 154 154 + let len = String.length frame.content in 155 155 + let mask_bit = if mask then 0x80 else 0 in 156 156 + 157 157 + (* Encode payload length *) 158 158 + if len < 126 then Buffer.add_char buf (Char.chr (mask_bit lor len)) 159 159 + else if len < 65536 then begin 160 160 + Buffer.add_char buf (Char.chr (mask_bit lor 126)); 161 161 + Buffer.add_char buf (Char.chr ((len lsr 8) land 0xff)); 162 162 + Buffer.add_char buf (Char.chr (len land 0xff)) 163 163 + end 164 164 + else begin 165 165 + Buffer.add_char buf (Char.chr (mask_bit lor 127)); 166 166 + (* 64-bit length, big-endian *) 167 167 + for i = 7 downto 0 do 168 168 + Buffer.add_char buf (Char.chr ((len lsr (i * 8)) land 0xff)) 169 169 + done 170 170 + end; 171 171 + 172 172 + (* Add mask and payload *) 173 173 + if mask then begin 174 174 + let mask_key = Rng.generate 4 in 175 175 + Buffer.add_string buf mask_key; 176 176 + Buffer.add_string buf (xor_mask mask_key frame.content) 177 177 + end 178 178 + else Buffer.add_string buf frame.content 179 179 + 180 180 + (** Read exactly n bytes from flow *) 181 181 + let read_exactly flow n = 182 182 + let buf = Cstruct.create n in 183 183 + let rec loop off = 184 184 + if off < n then begin 185 185 + let cs = Cstruct.sub buf off (n - off) in 186 186 + let read = Eio.Flow.single_read flow cs in 187 187 + loop (off + read) 188 188 + end 189 189 + in 190 190 + loop 0; 191 191 + Cstruct.to_string buf 192 192 + 193 193 + (** Parse a frame from flow *) 194 194 + let read_frame ~is_client flow = 195 195 + try 196 196 + (* Read first 2 bytes *) 197 197 + let header = read_exactly flow 2 in 198 198 + let b0 = Char.code header.[0] in 199 199 + let b1 = Char.code header.[1] in 200 200 + 201 201 + let final = b0 land 0x80 <> 0 in 202 202 + let extension = (b0 land 0x70) lsr 4 in 203 203 + let opcode = Opcode.of_int (b0 land 0x0f) in 204 204 + let masked = b1 land 0x80 <> 0 in 205 205 + let len0 = b1 land 0x7f in 206 206 + 207 207 + (* Server receiving from client: frames must be masked 208 208 + Client receiving from server: frames must not be masked *) 209 209 + if (not is_client) && not masked then 210 210 + Error (Protocol_error "Client frames must be masked") 211 211 + else if is_client && masked then 212 212 + Error (Protocol_error "Server frames must not be masked") 213 213 + else begin 214 214 + (* Read extended length if needed *) 215 215 + let len = 216 216 + if len0 < 126 then len0 217 217 + else if len0 = 126 then begin 218 218 + let ext = read_exactly flow 2 in 219 219 + (Char.code ext.[0] lsl 8) lor Char.code ext.[1] 220 220 + end 221 221 + else begin 222 222 + (* 64-bit length *) 223 223 + let ext = read_exactly flow 8 in 224 224 + let len = ref 0 in 225 225 + for i = 0 to 7 do 226 226 + len := (!len lsl 8) lor Char.code ext.[i] 227 227 + done; 228 228 + !len 229 229 + end 230 230 + in 231 231 + 232 232 + (* Control frames cannot be fragmented and max 125 bytes *) 233 233 + if Opcode.is_control opcode && ((not final) || len > 125) then 234 234 + Error (Protocol_error "Invalid control frame") 235 235 + else begin 236 236 + (* Read mask key if present *) 237 237 + let mask_key = if masked then Some (read_exactly flow 4) else None in 238 238 + 239 239 + (* Read payload *) 240 240 + let content = if len > 0 then read_exactly flow len else "" in 241 241 + let content = 242 242 + match mask_key with 243 243 + | Some key -> xor_mask key content 244 244 + | None -> content 245 245 + in 246 246 + 247 247 + Ok { opcode; extension; final; content } 248 248 + end 249 249 + end 250 250 + with 251 251 + | End_of_file -> Error Connection_closed 252 252 + | exn -> Error (Io_error (Printexc.to_string exn)) 253 253 + 254 254 + (** {1 Connection API} *) 255 255 + 256 256 + (** Check if connection is open *) 257 257 + let is_open t = not t.closed 258 258 + 259 259 + (** Send a frame *) 260 260 + let send t frame = 261 261 + if t.closed then Error Connection_closed 262 262 + else 263 263 + try 264 264 + let buf = Buffer.create 128 in 265 265 + write_frame_to_buf ~is_client:t.is_client buf frame; 266 266 + Eio.Flow.write t.flow [ Cstruct.of_string (Buffer.contents buf) ]; 267 267 + Ok () 268 268 + with exn -> Error (Io_error (Printexc.to_string exn)) 269 269 + 270 270 + (** Send a text message *) 271 271 + let send_text t content = send t (make_frame ~opcode:Text ~content ()) 272 272 + 273 273 + (** Send a binary message *) 274 274 + let send_binary t content = send t (make_frame ~opcode:Binary ~content ()) 275 275 + 276 276 + (** Send a ping *) 277 277 + let send_ping t ?(content = "") () = 278 278 + send t (make_frame ~opcode:Ping ~content ()) 279 279 + 280 280 + (** Send a pong *) 281 281 + let send_pong t ?(content = "") () = 282 282 + send t (make_frame ~opcode:Pong ~content ()) 283 283 + 284 284 + (** Receive a frame *) 285 285 + let recv t = 286 286 + if t.closed then Error Connection_closed 287 287 + else 288 288 + match read_frame ~is_client:t.is_client t.flow with 289 289 + | Ok frame -> 290 290 + (* Handle control frames *) 291 291 + (match frame.opcode with 292 292 + | Close -> 293 293 + t.closed <- true; 294 294 + (* Echo close frame back *) 295 295 + ignore (send t (close_frame (-1))) 296 296 + | Ping -> 297 297 + (* Auto-respond to pings with pong *) 298 298 + ignore (send_pong t ~content:frame.content ()) 299 299 + | _ -> ()); 300 300 + Ok frame 301 301 + | Error e -> 302 302 + t.closed <- true; 303 303 + Error e 304 304 + 305 305 + (** Receive a complete message (handles fragmentation) *) 306 306 + let recv_message t = 307 307 + let rec collect_fragments first_opcode buf = 308 308 + match recv t with 309 309 + | Error e -> Error e 310 310 + | Ok frame -> ( 311 311 + Buffer.add_string buf frame.content; 312 312 + if frame.final then Ok (first_opcode, Buffer.contents buf) 313 313 + else 314 314 + match frame.opcode with 315 315 + | Continuation -> collect_fragments first_opcode buf 316 316 + | _ -> Error (Protocol_error "Expected continuation frame")) 317 317 + in 318 318 + let rec loop () = 319 319 + match recv t with 320 320 + | Error e -> Error e 321 321 + | Ok frame -> ( 322 322 + match frame.opcode with 323 323 + | Text | Binary -> 324 324 + if frame.final then Ok (frame.opcode, frame.content) 325 325 + else begin 326 326 + let buf = Buffer.create 256 in 327 327 + Buffer.add_string buf frame.content; 328 328 + collect_fragments frame.opcode buf 329 329 + end 330 330 + | Close -> Error Connection_closed 331 331 + | Ping | Pong -> 332 332 + (* Control frames handled in recv, try again *) 333 333 + loop () 334 334 + | Continuation -> Error (Protocol_error "Unexpected continuation") 335 335 + | _ -> Error (Protocol_error "Unexpected opcode")) 336 336 + in 337 337 + loop () 338 338 + 339 339 + (** Close the connection *) 340 340 + let close ?(code = 1000) t = 341 341 + if not t.closed then begin 342 342 + t.closed <- true; 343 343 + ignore (send t (close_frame code)) 344 344 + end 345 345 + 346 346 + (** {1 Handshake helpers} *) 347 347 + 348 348 + (** Check if request headers indicate a WebSocket upgrade *) 349 349 + let is_upgrade_request headers = 350 350 + let upgrade = H1.Headers.get headers "upgrade" in 351 351 + let connection = H1.Headers.get headers "connection" in 352 352 + let key = H1.Headers.get headers "sec-websocket-key" in 353 353 + match (upgrade, connection, key) with 354 354 + | Some u, Some c, Some _ -> 355 355 + let u = String.lowercase_ascii u in 356 356 + let c = String.lowercase_ascii c in 357 357 + u = "websocket" && (c = "upgrade" || String.sub c 0 7 = "upgrade") 358 358 + | _ -> false 359 359 + 360 360 + (** Get the Sec-WebSocket-Key from request headers *) 361 361 + let get_websocket_key headers = H1.Headers.get headers "sec-websocket-key" 362 362 + 363 363 + (** Generate random base64-encoded key for client handshake *) 364 364 + let generate_key () = Base64.encode_exn (Rng.generate 16) 365 365 + 366 366 + (** {1 Client API} *) 367 367 + 368 368 + (** Connect to a WebSocket server *) 369 369 + let connect ~sw ~net ?(tls_config = Tls_config.Client.default) ?protocols url = 370 370 + let uri = Uri.of_string url in 371 371 + let scheme = Uri.scheme uri |> Option.value ~default:"ws" in 372 372 + let is_secure = scheme = "wss" in 373 373 + let host = Uri.host uri |> Option.value ~default:"localhost" in 374 374 + let default_port = if is_secure then 443 else 80 in 375 375 + let port = Uri.port uri |> Option.value ~default:default_port in 376 376 + let path = 377 377 + let p = Uri.path_and_query uri in 378 378 + if p = "" then "/" else p 379 379 + in 380 380 + 381 381 + (* Resolve and connect *) 382 382 + let addrs = Eio.Net.getaddrinfo_stream net host in 383 383 + match addrs with 384 384 + | [] -> Error (Io_error ("Cannot resolve host: " ^ host)) 385 385 + | addr_info :: _ -> ( 386 386 + let addr = 387 387 + match addr_info with 388 388 + | `Tcp (ip, _) -> `Tcp (ip, port) 389 389 + | `Unix _ -> failwith "Unix sockets not supported" 390 390 + in 391 391 + let tcp_flow = Eio.Net.connect ~sw net addr in 392 392 + 393 393 + (* Wrap with TLS if secure *) 394 394 + let flow_result = 395 395 + if is_secure then 396 396 + match Tls_config.Client.to_tls_config tls_config ~host with 397 397 + | Error msg -> Error (Io_error ("TLS error: " ^ msg)) 398 398 + | Ok tls_cfg -> ( 399 399 + try 400 400 + let host_domain = 401 401 + match Domain_name.of_string host with 402 402 + | Ok dn -> ( 403 403 + match Domain_name.host dn with 404 404 + | Ok h -> Some h 405 405 + | Error _ -> None) 406 406 + | Error _ -> None 407 407 + in 408 408 + let tls_flow = 409 409 + Tls_eio.client_of_flow tls_cfg ?host:host_domain tcp_flow 410 410 + in 411 411 + Ok (tls_flow :> Eio.Flow.two_way_ty r) 412 412 + with exn -> Error (Io_error (Printexc.to_string exn))) 413 413 + else Ok (tcp_flow :> Eio.Flow.two_way_ty r) 414 414 + in 415 415 + 416 416 + match flow_result with 417 417 + | Error e -> Error e 418 418 + | Ok flow -> ( 419 419 + (* Generate key and build upgrade request *) 420 420 + let key = generate_key () in 421 421 + let expected_accept = compute_accept_key key in 422 422 + 423 423 + let headers = 424 424 + [ 425 425 + ("Host", host); 426 426 + ("Upgrade", "websocket"); 427 427 + ("Connection", "Upgrade"); 428 428 + ("Sec-WebSocket-Key", key); 429 429 + ("Sec-WebSocket-Version", "13"); 430 430 + ] 431 431 + in 432 432 + let headers = 433 433 + match protocols with 434 434 + | Some ps -> 435 435 + ("Sec-WebSocket-Protocol", String.concat ", " ps) :: headers 436 436 + | None -> headers 437 437 + in 438 438 + 439 439 + (* Send HTTP upgrade request *) 440 440 + let buf = Buffer.create 256 in 441 441 + Buffer.add_string buf (Printf.sprintf "GET %s HTTP/1.1\r\n" path); 442 442 + List.iter 443 443 + (fun (k, v) -> 444 444 + Buffer.add_string buf (Printf.sprintf "%s: %s\r\n" k v)) 445 445 + headers; 446 446 + Buffer.add_string buf "\r\n"; 447 447 + 448 448 + try 449 449 + Eio.Flow.write flow [ Cstruct.of_string (Buffer.contents buf) ]; 450 450 + 451 451 + (* Read response headers *) 452 452 + let response_buf = Buffer.create 1024 in 453 453 + let rec read_until_crlf_crlf () = 454 454 + let byte = read_exactly flow 1 in 455 455 + Buffer.add_string response_buf byte; 456 456 + let len = Buffer.length response_buf in 457 457 + if 458 458 + len >= 4 459 459 + && Buffer.nth response_buf (len - 4) = '\r' 460 460 + && Buffer.nth response_buf (len - 3) = '\n' 461 461 + && Buffer.nth response_buf (len - 2) = '\r' 462 462 + && Buffer.nth response_buf (len - 1) = '\n' 463 463 + then () 464 464 + else read_until_crlf_crlf () 465 465 + in 466 466 + read_until_crlf_crlf (); 467 467 + 468 468 + (* Parse status line and headers *) 469 469 + let response_str = Buffer.contents response_buf in 470 470 + let lines = String.split_on_char '\n' response_str in 471 471 + 472 472 + (* Check status line *) 473 473 + match lines with 474 474 + | status_line :: header_lines -> ( 475 475 + let status_line = String.trim status_line in 476 476 + if 477 477 + not 478 478 + (String.length status_line >= 12 479 479 + && String.sub status_line 9 3 = "101") 480 480 + then Error (Protocol_error ("Bad status: " ^ status_line)) 481 481 + else 482 482 + (* Parse headers *) 483 483 + let headers = 484 484 + List.filter_map 485 485 + (fun line -> 486 486 + let line = String.trim line in 487 487 + if line = "" then None 488 488 + else 489 489 + match String.index_opt line ':' with 490 490 + | Some i -> 491 491 + let key = 492 492 + String.lowercase_ascii (String.sub line 0 i) 493 493 + in 494 494 + let value = 495 495 + String.trim 496 496 + (String.sub line (i + 1) 497 497 + (String.length line - i - 1)) 498 498 + in 499 499 + Some (key, value) 500 500 + | None -> None) 501 501 + header_lines 502 502 + in 503 503 + 504 504 + (* Validate accept key *) 505 505 + let accept = List.assoc_opt "sec-websocket-accept" headers in 506 506 + match accept with 507 507 + | Some a when a = expected_accept -> 508 508 + Ok 509 509 + { 510 510 + flow; 511 511 + closed = false; 512 512 + is_client = true; 513 513 + read_buf = Buffer.create 4096; 514 514 + } 515 515 + | Some a -> 516 516 + Error 517 517 + (Protocol_error 518 518 + (Printf.sprintf "Bad accept key: %s (expected %s)" a 519 519 + expected_accept)) 520 520 + | None -> Error (Protocol_error "Missing accept key")) 521 521 + | [] -> Error (Protocol_error "Empty response") 522 522 + with exn -> Error (Io_error (Printexc.to_string exn)))) 523 523 + 524 524 + (** {1 Server API} *) 525 525 + 526 526 + (** Accept a WebSocket upgrade from an HTTP connection. Returns a WebSocket 527 527 + connection after sending the upgrade response. *) 528 528 + let accept ~flow ~key = 529 529 + let accept = compute_accept_key key in 530 530 + let response = 531 531 + Printf.sprintf 532 532 + "HTTP/1.1 101 Switching Protocols\r\n\ 533 533 + Upgrade: websocket\r\n\ 534 534 + Connection: Upgrade\r\n\ 535 535 + Sec-WebSocket-Accept: %s\r\n\ 536 536 + \r\n" 537 537 + accept 538 538 + in 539 539 + try 540 540 + Eio.Flow.write flow [ Cstruct.of_string response ]; 541 541 + Ok 542 542 + { 543 543 + flow :> Eio.Flow.two_way_ty r; 544 544 + closed = false; 545 545 + is_client = false; 546 546 + read_buf = Buffer.create 4096; 547 547 + } 548 548 + with exn -> Error (Io_error (Printexc.to_string exn))

+43

opencode.json

reviewed

··· 1 1 + { 2 2 + "$schema": "https://opencode.ai/config.json", 3 3 + "snapshot": false, 4 4 + "lsp": { 5 5 + "ocaml-lsp": { 6 6 + "command": ["ocamllsp"], 7 7 + "extensions": [".ml", ".mli"] 8 8 + }, 9 9 + "clangd": { 10 10 + "command": ["clangd"], 11 11 + "extensions": [".c", ".h", ".cpp", ".hpp", ".cc", ".cxx", ".hh", ".hxx"] 12 12 + } 13 13 + }, 14 14 + "formatter": { 15 15 + "ocamlformat": { 16 16 + "command": ["ocamlformat", "--inplace", "$FILE"], 17 17 + "extensions": [".ml", ".mli"] 18 18 + }, 19 19 + "clang-format": { 20 20 + "command": ["clang-format", "-i", "$FILE"], 21 21 + "extensions": [".c", ".h", ".cpp", ".hpp", ".cc", ".cxx", ".hh", ".hxx"] 22 22 + } 23 23 + }, 24 24 + "mcp": { 25 25 + "beads": { 26 26 + "type": "local", 27 27 + "command": ["uv", "tool", "run", "beads-mcp"], 28 28 + "enabled": true 29 29 + }, 30 30 + "tod": { 31 31 + "type": "local", 32 32 + "command": ["tod", "mcp", "--log-file", "/tmp/tod.log"], 33 33 + "enabled": true 34 34 + }, 35 35 + "jetbrains": { 36 36 + "type": "local", 37 37 + "environment": { 38 38 + "IJ_MCP_SERVER_PORT": "64342" 39 39 + }, 40 40 + "command": [ "/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/jbr/bin/java", "-classpath", "/home/gdiazlo/.local/share/JetBrains/CLion2025.3/mcpserver/lib/mcpserver.jar:/home/gdiazlo/.local/share/JetBrains/CLion2025.3/mcpserver/lib/io.modelcontextprotocol.kotlin.sdk.jar:/home/gdiazlo/.local/share/JetBrains/CLion2025.3/mcpserver/lib/io.github.oshai.kotlin.logging.jvm.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/util-8.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.ktor.client.cio.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.ktor.client.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.ktor.network.tls.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.ktor.io.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.ktor.utils.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.kotlinx.io.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.kotlinx.serialization.core.jar:/home/gdiazlo/.local/share/JetBrains/Toolbox/apps/clion/lib/module-intellij.libraries.kotlinx.serialization.json.jar", "com.intellij.mcpserver.stdio.McpStdioRunnerKt" ] 41 41 + } 42 42 + } 43 43 + }

+19

test/certs/cert.pem

reviewed

··· 1 1 + -----BEGIN CERTIFICATE----- 2 2 + MIIDCTCCAfGgAwIBAgIURfGI0GrBt2X78EYcfpuFIogJg1AwDQYJKoZIhvcNAQEL 3 3 + BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTI1MTIzMDIwNTIyMFoXDTI2MTIz 4 4 + MDIwNTIyMFowFDESMBAGA1UEAwwJbG9jYWxob3N0MIIBIjANBgkqhkiG9w0BAQEF 5 5 + AAOCAQ8AMIIBCgKCAQEA31KLbLy0SawqPU+v3N1fbWDS2/5KVsai65o96pz/ENJA 6 6 + Y2797qomtd9mX3cSUTr8R0lAINqDoz158NIPRBezonWxiyBR3ZFh+uYEvlGjvJ7V 7 7 + RXpzOrW0OhmCHQoOJBf3EmC3GlBKPUK2WwPvF6kA/9kf/rFbPDdUKu3kV3np2Var 8 8 + pyAPQvjWcBvHzAOGMjkFxQHhlSAIY5JJkb5k0BsQsvcIEY1Sj6dqKZKmFhoJY1k2 9 9 + fysDc8nMto87fJm/OHVJtco6vmgEy4uAqpuUOeqdE9VYF9rdzmKUr19HQVFd4AwN 10 10 + UEpCNfjEAIlWg2hQqAXbn9xcjrKq41b/O8MXZBuUkwIDAQABo1MwUTAdBgNVHQ4E 11 11 + FgQUtlOWGEII5hFsFDU9RbLuqZ/1eMgwHwYDVR0jBBgwFoAUtlOWGEII5hFsFDU9 12 12 + RbLuqZ/1eMgwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEAbYHg 13 13 + hbev2BCczOqzoc3AI9rJL8S/m759lG55xcFO2j82ADwi3o8fIQpTBlNQu/HrvOLP 14 14 + BWvcc8kOyKZyTAzcCqZMreBGxP1B9LgOiRaoc8akoyKuqXg/iJ+RKwjqnUZiq0eQ 15 15 + nEhHzcVojRzBqLfKTuhLa/FOx++fUDrbr59zVcrJl62FUuNB9cqdFZZIV8xv0xYH 16 16 + yZ/gN4EceVY/uzC9HL0MCnaSUuJ7ZJ+C5Mv4DC6RoHxc0byjYv9JV0+xArbLMaEC 17 17 + mhe1vqAIbFw9zhgF+4uwQ1WKCvKiIJZGV1h21MhIXBwg8fZckX0OiTsjC4n1spMp 18 18 + JZc3Qt/B18/78/vBdg== 19 19 + -----END CERTIFICATE-----

+28

test/certs/key.pem

reviewed

··· 1 1 + -----BEGIN PRIVATE KEY----- 2 2 + MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQDfUotsvLRJrCo9 3 3 + T6/c3V9tYNLb/kpWxqLrmj3qnP8Q0kBjbv3uqia132ZfdxJROvxHSUAg2oOjPXnw 4 4 + 0g9EF7OidbGLIFHdkWH65gS+UaO8ntVFenM6tbQ6GYIdCg4kF/cSYLcaUEo9QrZb 5 5 + A+8XqQD/2R/+sVs8N1Qq7eRXeenZVqunIA9C+NZwG8fMA4YyOQXFAeGVIAhjkkmR 6 6 + vmTQGxCy9wgRjVKPp2opkqYWGgljWTZ/KwNzycy2jzt8mb84dUm1yjq+aATLi4Cq 7 7 + m5Q56p0T1VgX2t3OYpSvX0dBUV3gDA1QSkI1+MQAiVaDaFCoBduf3FyOsqrjVv87 8 8 + wxdkG5STAgMBAAECggEAb5vARHK2o48geQ3HNVmJZI+cMggPPPj+2UJ3qTYXH2AE 9 9 + f+0riUiOGhzw+8r1Y5VYGYRZQVITsdR6iclhicVSqGGrfn2DjHko/4xPWJJSg2TZ 10 10 + 72Q4DGJdFSBEb6Dj2lQDzbJ6L/Nqdt1NZ4U6y5dSAYuQuugGUbzRGrdThAhQv6Xq 11 11 + slO366T8XaAaYGpp5Bl8RW0C8H46lnVbvhyBZG+v+XCsvsYyuj8XtUc/FLT3NDBF 12 12 + 8KSs62SRlhEr7oVc90oZtOd2/Cy05GqKjxn+e2iEuSGJtqmQwSmoc7kUC3rPpVuQ 13 13 + 8nwVSvztfIO53zmWROJ2Nzq5c5//J5HUgHdDtC+T8QKBgQD9grp8+ZNw2ViHRboT 14 14 + GnvqbETiJFFpdjJHkuZCuDjYTBcOp9Kgtlj8oQP+v4Bxz8BUWuz4RvfloR1qN3AU 15 15 + 79rbJQInOReReAAIrQIz8Hht1ldmwn98xB3CZdD4CQx5+yHRxwyEpIOtdwVlEFpO 16 16 + Y/b7kT0e9V97XABUI+x2voQHGQKBgQDhg+3vxaAkc+g62pW/a6gwJ1qlLziZL1PY 17 17 + KwDP2lzZ840pVnKMZAcLQkyC3mtqV/zxnDjfcY77SIpKI/EusNCC6SgW/nFDCaPw 18 18 + 6HvLpzksS9kaU8KiTnX80cc2Wj0ovKUW0tZN5DpYtGKKwx55NQ2ntqMMruTRCSHo 19 19 + xHlTX6LKiwKBgAKVfokfkh0oWfqm/0qKjpDJIbqcXCgTCFgqayZq8kliHSoNE9yH 20 20 + f0iz63KBSTHfyDoT4y50qrowdjhK8F2GRFjPe8IiltbovjdYbBlTbibQdHubp+kB 21 21 + prwAhazBitsDcEjPGpWPh7gQ6oEpNYJvCmluBY13Os3rFiXFZ/ed4YKhAoGAN4jw 22 22 + sEo/nJp6hvvLQr91RJ58YQ9W5cpU4Hf+lDEXColCqvph7Ra48VnbU6MIWsDeRnWN 23 23 + P+FML692drmRLElYn9RhDgCMzdBy8eGektFUcAchqK0V0jh2L9NNNqJUS1LhaNR0 24 24 + 9+uLPsr1NWzFdV3ORg3g6z+qk5unIRY5NoHnqe8CgYEA0ToCHBg/rM2VGaZbAfFp 25 25 + mTf2TQzbaD9IEQ2J7G3hzuw13FTWCyEbDoXvGtDqZYCnh2Mwj9okusvCLAyOlx29 26 26 + UUIJwEXhaxwoOqseLvUGYyP8wmD4r/D2aYqM6nKbeY4tdqKxZ18x2p27Dc25XKiP 27 27 + zdHQJbsvcTFunZsJiVa4DFQ= 28 28 + -----END PRIVATE KEY-----

+19

test/dune

reviewed

··· 1 1 + (test 2 2 + (name test_hcs) 3 3 + (package hcs) 4 4 + (libraries hcs alcotest qcheck qcheck-alcotest eio_main)) 5 5 + 6 6 + (executable 7 7 + (name test_client_integration) 8 8 + (libraries hcs eio_main mirage-crypto-rng-eio) 9 9 + (modules test_client_integration)) 10 10 + 11 11 + (executable 12 12 + (name test_alpn_server) 13 13 + (libraries hcs eio_main mirage-crypto-rng-eio mirage-crypto-rng.unix) 14 14 + (modules test_alpn_server)) 15 15 + 16 16 + (executable 17 17 + (name test_alpn_client) 18 18 + (libraries hcs eio_main mirage-crypto-rng-eio mirage-crypto-rng.unix) 19 19 + (modules test_alpn_client))

+55

test/h2spec_runner.sh

reviewed

··· 1 1 + #!/bin/bash 2 2 + # h2spec compliance testing for HCS HTTP/2 server 3 3 + # 4 4 + # Prerequisites: 5 5 + # - h2spec installed: go install github.com/summerwind/h2spec/cmd/h2spec@latest 6 6 + # - OR download from: https://github.com/summerwind/h2spec/releases 7 7 + # 8 8 + # Usage: 9 9 + # 1. Start the HCS server: dune exec bin/hcs-demo.exe 10 10 + # 2. Run this script: ./test/h2spec_runner.sh 11 11 + # 12 12 + # Note: The server should be running on localhost:8443 with TLS 13 13 + # or localhost:8080 without TLS 14 14 + 15 15 + set -e 16 16 + 17 17 + H2SPEC=${H2SPEC:-h2spec} 18 18 + HOST=${H2SPEC_HOST:-localhost} 19 19 + PORT=${H2SPEC_PORT:-8080} 20 20 + USE_TLS=${H2SPEC_TLS:-false} 21 21 + 22 22 + echo "H2Spec HTTP/2 Compliance Tests" 23 23 + echo "==============================" 24 24 + echo "Host: $HOST" 25 25 + echo "Port: $PORT" 26 26 + echo "TLS: $USE_TLS" 27 27 + echo "" 28 28 + 29 29 + # Check if h2spec is available 30 30 + if ! command -v "$H2SPEC" &> /dev/null; then 31 31 + echo "Error: h2spec not found in PATH" 32 32 + echo "" 33 33 + echo "Install h2spec:" 34 34 + echo " go install github.com/summerwind/h2spec/cmd/h2spec@latest" 35 35 + echo "" 36 36 + echo "Or download from:" 37 37 + echo " https://github.com/summerwind/h2spec/releases" 38 38 + exit 1 39 39 + fi 40 40 + 41 41 + # Build test options 42 42 + OPTS="-h $HOST -p $PORT" 43 43 + 44 44 + if [ "$USE_TLS" = "true" ]; then 45 45 + OPTS="$OPTS -t -k" # -t for TLS, -k to skip cert verification 46 46 + fi 47 47 + 48 48 + # Run h2spec 49 49 + echo "Running h2spec..." 50 50 + echo "" 51 51 + 52 52 + $H2SPEC $OPTS --strict 53 53 + 54 54 + echo "" 55 55 + echo "H2Spec tests complete."

+67

test/test_alpn_client.ml

reviewed

··· 1 1 + let test_external_servers () = 2 2 + Eio_main.run @@ fun env -> 3 3 + let net = Eio.Stdenv.net env in 4 4 + let clock = Eio.Stdenv.clock env in 5 5 + Eio.Switch.run @@ fun sw -> 6 6 + let urls = 7 7 + [ 8 8 + ("https://www.google.com", "Google"); 9 9 + ("https://httpbin.org/get", "httpbin"); 10 10 + ("https://www.cloudflare.com", "Cloudflare"); 11 11 + ] 12 12 + in 13 13 + List.iter 14 14 + (fun (url, name) -> 15 15 + Eio.traceln "\n=== Testing %s ===" name; 16 16 + Eio.traceln "URL: %s" url; 17 17 + 18 18 + Eio.traceln "\n--- HTTP/1.1 mode ---"; 19 19 + let config = Hcs.Client.default_config |> Hcs.Client.with_http11 in 20 20 + (match Hcs.Client.get ~sw ~net ~clock ~config url with 21 21 + | Ok resp -> 22 22 + let proto = 23 23 + match resp.protocol with 24 24 + | Hcs.Client.HTTP_1_1 -> "HTTP/1.1" 25 25 + | Hcs.Client.HTTP_2 -> "HTTP/2" 26 26 + in 27 27 + Eio.traceln "Status: %d, Protocol: %s, Body size: %d" resp.status 28 28 + proto (String.length resp.body) 29 29 + | Error e -> 30 30 + let msg = 31 31 + match e with 32 32 + | Hcs.Client.Connection_failed s -> "Connection failed: " ^ s 33 33 + | Hcs.Client.Tls_error s -> "TLS error: " ^ s 34 34 + | Hcs.Client.Protocol_error s -> "Protocol error: " ^ s 35 35 + | Hcs.Client.Timeout -> "Timeout" 36 36 + | Hcs.Client.Invalid_response s -> "Invalid response: " ^ s 37 37 + | Hcs.Client.Too_many_redirects -> "Too many redirects" 38 38 + in 39 39 + Eio.traceln "Error: %s" msg); 40 40 + 41 41 + Eio.traceln "\n--- HTTP/2 mode ---"; 42 42 + let config = Hcs.Client.default_config |> Hcs.Client.with_http2 in 43 43 + match Hcs.Client.get ~sw ~net ~clock ~config url with 44 44 + | Ok resp -> 45 45 + let proto = 46 46 + match resp.protocol with 47 47 + | Hcs.Client.HTTP_1_1 -> "HTTP/1.1" 48 48 + | Hcs.Client.HTTP_2 -> "HTTP/2" 49 49 + in 50 50 + Eio.traceln "Status: %d, Protocol: %s, Body size: %d" resp.status 51 51 + proto (String.length resp.body) 52 52 + | Error e -> 53 53 + let msg = 54 54 + match e with 55 55 + | Hcs.Client.Connection_failed s -> "Connection failed: " ^ s 56 56 + | Hcs.Client.Tls_error s -> "TLS error: " ^ s 57 57 + | Hcs.Client.Protocol_error s -> "Protocol error: " ^ s 58 58 + | Hcs.Client.Timeout -> "Timeout" 59 59 + | Hcs.Client.Invalid_response s -> "Invalid response: " ^ s 60 60 + | Hcs.Client.Too_many_redirects -> "Too many redirects" 61 61 + in 62 62 + Eio.traceln "Error: %s" msg) 63 63 + urls 64 64 + 65 65 + let () = 66 66 + Mirage_crypto_rng_unix.use_default (); 67 67 + test_external_servers ()

+28

test/test_alpn_server.ml

reviewed

··· 1 1 + let () = 2 2 + Mirage_crypto_rng_unix.use_default (); 3 3 + Eio_main.run @@ fun env -> 4 4 + let net = Eio.Stdenv.net env in 5 5 + Eio.Switch.run @@ fun sw -> 6 6 + match 7 7 + Hcs.Tls_config.Server.of_pem ~cert_file:"test/certs/cert.pem" 8 8 + ~key_file:"test/certs/key.pem" 9 9 + with 10 10 + | Error msg -> 11 11 + Eio.traceln "TLS config error: %s" msg; 12 12 + exit 1 13 13 + | Ok tls_config -> 14 14 + let handler (req : Hcs.Server.request) = 15 15 + let protocol_str = 16 16 + match req.version with 17 17 + | Hcs.Server.HTTP_1_1 -> "HTTP/1.1" 18 18 + | Hcs.Server.HTTP_2 -> "HTTP/2" 19 19 + in 20 20 + Hcs.Server.respond ~status:`OK 21 21 + (Printf.sprintf "Hello from %s! Target: %s" protocol_str req.target) 22 22 + in 23 23 + let config = 24 24 + Hcs.Server.default_config |> Hcs.Server.with_port 8443 25 25 + |> Hcs.Server.with_protocol Hcs.Server.Auto 26 26 + |> Hcs.Server.with_tls tls_config 27 27 + in 28 28 + Hcs.Server.run ~sw ~net ~config handler

+186

test/test_client_integration.ml

reviewed

··· 1 1 + (** Integration tests using httpbin.org for HTTP client compliance. 2 2 + 3 3 + These tests require network access and use the public httpbin.org service. 4 4 + They validate that the HCS HTTP client correctly implements HTTP semantics. 5 5 + 6 6 + Run with: dune exec test/test_client_integration.exe 7 7 + 8 8 + For local testing, you can run httpbin in Docker: docker run -p 8080:80 9 9 + kennethreitz/httpbin 10 10 + 11 11 + Then set HTTPBIN_URL=http://localhost:8080 *) 12 12 + 13 13 + let httpbin_url = 14 14 + match Sys.getenv_opt "HTTPBIN_URL" with 15 15 + | Some url -> url 16 16 + | None -> "https://httpbin.org" 17 17 + 18 18 + (* Note: These are integration tests that require network access. 19 19 + They are separate from unit tests and should be run manually or in CI 20 20 + with network access enabled. *) 21 21 + 22 22 + let run_tests env () = 23 23 + Eio.Switch.run @@ fun sw -> 24 24 + let net = Eio.Stdenv.net env in 25 25 + let clock = Eio.Stdenv.clock env in 26 26 + 27 27 + (* Test 1: Simple GET request *) 28 28 + Printf.printf "Test 1: GET /get ... "; 29 29 + (try 30 30 + let resp = Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/get") in 31 31 + match resp with 32 32 + | Ok resp -> 33 33 + if resp.status = 200 then begin 34 34 + Printf.printf "OK (status=%d, body=%d bytes)\n" resp.status 35 35 + (String.length resp.body) 36 36 + end 37 37 + else Printf.printf "FAIL (status=%d)\n" resp.status 38 38 + | Error e -> 39 39 + let msg = 40 40 + match e with 41 41 + | Hcs.Client.Connection_failed s -> "Connection_failed: " ^ s 42 42 + | Hcs.Client.Tls_error s -> "Tls_error: " ^ s 43 43 + | Hcs.Client.Protocol_error s -> "Protocol_error: " ^ s 44 44 + | Hcs.Client.Timeout -> "Timeout" 45 45 + | Hcs.Client.Invalid_response s -> "Invalid_response: " ^ s 46 46 + | Hcs.Client.Too_many_redirects -> "Too_many_redirects" 47 47 + in 48 48 + Printf.printf "FAIL (error=%s)\n" msg 49 49 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 50 50 + 51 51 + (* Test 2: GET with query parameters *) 52 52 + Printf.printf "Test 2: GET /get?foo=bar ... "; 53 53 + (try 54 54 + let resp = 55 55 + Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/get?foo=bar&baz=qux") 56 56 + in 57 57 + match resp with 58 58 + | Ok resp -> 59 59 + if resp.status = 200 && String.length resp.body > 0 then 60 60 + Printf.printf "OK\n" 61 61 + else Printf.printf "FAIL\n" 62 62 + | Error _ -> Printf.printf "FAIL\n" 63 63 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 64 64 + 65 65 + (* Test 3: POST with body *) 66 66 + Printf.printf "Test 3: POST /post with body ... "; 67 67 + (try 68 68 + let body = "Hello, httpbin!" in 69 69 + let resp = Hcs.Client.post ~sw ~net ~clock ~body (httpbin_url ^ "/post") in 70 70 + match resp with 71 71 + | Ok resp -> 72 72 + if resp.status = 200 then Printf.printf "OK\n" 73 73 + else Printf.printf "FAIL (status=%d)\n" resp.status 74 74 + | Error _ -> Printf.printf "FAIL\n" 75 75 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 76 76 + 77 77 + (* Test 4: Status code 201 *) 78 78 + Printf.printf "Test 4: GET /status/201 ... "; 79 79 + (try 80 80 + let resp = Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/status/201") in 81 81 + match resp with 82 82 + | Ok resp -> 83 83 + if resp.status = 201 then Printf.printf "OK\n" 84 84 + else Printf.printf "FAIL (status=%d)\n" resp.status 85 85 + | Error _ -> Printf.printf "FAIL\n" 86 86 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 87 87 + 88 88 + (* Test 5: User-Agent header *) 89 89 + Printf.printf "Test 5: GET /user-agent ... "; 90 90 + (try 91 91 + let resp = Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/user-agent") in 92 92 + match resp with 93 93 + | Ok resp -> 94 94 + if resp.status = 200 && String.length resp.body > 0 then 95 95 + Printf.printf "OK\n" 96 96 + else Printf.printf "FAIL\n" 97 97 + | Error _ -> Printf.printf "FAIL\n" 98 98 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 99 99 + 100 100 + (* Test 6: Response headers *) 101 101 + Printf.printf "Test 6: GET /response-headers?X-Test=value ... "; 102 102 + (try 103 103 + let resp = 104 104 + Hcs.Client.get ~sw ~net ~clock 105 105 + (httpbin_url ^ "/response-headers?X-Test=hello") 106 106 + in 107 107 + match resp with 108 108 + | Ok resp -> 109 109 + let has_header = 110 110 + List.exists 111 111 + (fun (k, _) -> String.lowercase_ascii k = "x-test") 112 112 + resp.headers 113 113 + in 114 114 + if resp.status = 200 && has_header then Printf.printf "OK\n" 115 115 + else Printf.printf "FAIL (missing header or bad status)\n" 116 116 + | Error _ -> Printf.printf "FAIL\n" 117 117 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 118 118 + 119 119 + (* Test 7: Redirect (we don't follow redirects by default) *) 120 120 + Printf.printf "Test 7: GET /absolute-redirect/1 ... "; 121 121 + (try 122 122 + (* Use config without redirects *) 123 123 + let config = Hcs.Client.without_redirects Hcs.Client.default_config in 124 124 + let resp = 125 125 + Hcs.Client.get ~sw ~net ~clock ~config 126 126 + (httpbin_url ^ "/absolute-redirect/1") 127 127 + in 128 128 + match resp with 129 129 + | Ok resp -> 130 130 + (* Should get 302 since we don't follow redirects *) 131 131 + Printf.printf "OK (status=%d)\n" resp.status 132 132 + | Error _ -> Printf.printf "FAIL\n" 133 133 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 134 134 + 135 135 + (* Test 8: HTTP/2 if available *) 136 136 + Printf.printf "Test 8: GET /get with HTTP/2 ... "; 137 137 + (try 138 138 + let config = Hcs.Client.with_http2 Hcs.Client.default_config in 139 139 + let resp = Hcs.Client.get ~sw ~net ~clock ~config (httpbin_url ^ "/get") in 140 140 + match resp with 141 141 + | Ok resp -> 142 142 + let proto = 143 143 + match resp.protocol with 144 144 + | Hcs.Client.HTTP_1_1 -> "HTTP/1.1" 145 145 + | Hcs.Client.HTTP_2 -> "HTTP/2" 146 146 + in 147 147 + Printf.printf "OK (status=%d, protocol=%s)\n" resp.status proto 148 148 + | Error _ -> Printf.printf "FAIL\n" 149 149 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 150 150 + 151 151 + (* Test 9: gzip response *) 152 152 + Printf.printf "Test 9: GET /gzip ... "; 153 153 + (try 154 154 + let resp = Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/gzip") in 155 155 + match resp with 156 156 + | Ok resp -> 157 157 + if resp.status = 200 then Printf.printf "OK\n" 158 158 + else Printf.printf "FAIL (status=%d)\n" resp.status 159 159 + | Error _ -> Printf.printf "FAIL\n" 160 160 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 161 161 + 162 162 + (* Test 10: Large response *) 163 163 + Printf.printf "Test 10: GET /bytes/10000 ... "; 164 164 + (try 165 165 + let resp = Hcs.Client.get ~sw ~net ~clock (httpbin_url ^ "/bytes/10000") in 166 166 + match resp with 167 167 + | Ok resp -> 168 168 + if resp.status = 200 && String.length resp.body = 10000 then 169 169 + Printf.printf "OK (%d bytes)\n" (String.length resp.body) 170 170 + else 171 171 + Printf.printf "FAIL (status=%d, body=%d bytes)\n" resp.status 172 172 + (String.length resp.body) 173 173 + | Error _ -> Printf.printf "FAIL\n" 174 174 + with exn -> Printf.printf "FAIL (exception=%s)\n" (Printexc.to_string exn)); 175 175 + 176 176 + Printf.printf "\nIntegration tests complete.\n" 177 177 + 178 178 + let () = 179 179 + Printf.printf "HCS HTTP Client Integration Tests\n"; 180 180 + Printf.printf "Using httpbin at: %s\n\n" httpbin_url; 181 181 + 182 182 + Eio_main.run @@ fun env -> 183 183 + (Mirage_crypto_rng_eio.run [@alert "-deprecated"]) 184 184 + (module Mirage_crypto_rng.Fortuna) 185 185 + env 186 186 + @@ run_tests env

+1030

test/test_hcs.ml

reviewed

··· 1 1 + (** HCS Test Suite 2 2 + 3 3 + This test suite covers: 4 4 + - Codec module (identity, string codecs) 5 5 + - Stream module (sync and async streams) 6 6 + - Http module (request builder DSL) 7 7 + - Router module (path parsing, route matching) 8 8 + - Middleware module (composition, conditional) 9 9 + - Property-based tests using QCheck *) 10 10 + 11 11 + open Alcotest 12 12 + 13 13 + (* ================================================================== *) 14 14 + (* Codec Tests *) 15 15 + (* ================================================================== *) 16 16 + 17 17 + module Test_codec = struct 18 18 + open Hcs.Codec 19 19 + 20 20 + let test_identity_codec_encode () = 21 21 + let encoder : Cstruct.t Identity_codec.encoder = Fun.id in 22 22 + let input = Cstruct.of_string "hello world" in 23 23 + match Identity_codec.encode encoder input with 24 24 + | Ok result -> 25 25 + check string "encode" "hello world" (Cstruct.to_string result) 26 26 + | Error e -> fail e 27 27 + 28 28 + let test_identity_codec_decode () = 29 29 + let decoder : Cstruct.t Identity_codec.decoder = fun cs -> Ok cs in 30 30 + let input = Cstruct.of_string "hello world" in 31 31 + match Identity_codec.decode decoder input with 32 32 + | Ok result -> 33 33 + check string "decode" "hello world" (Cstruct.to_string result) 34 34 + | Error e -> fail e 35 35 + 36 36 + let test_identity_codec_content_type () = 37 37 + check string "content_type" "application/octet-stream" 38 38 + Identity_codec.content_type 39 39 + 40 40 + let test_string_codec_encode () = 41 41 + let encoder : string String_codec.encoder = Fun.id in 42 42 + match String_codec.encode encoder "hello world" with 43 43 + | Ok result -> 44 44 + check string "encode" "hello world" (Cstruct.to_string result) 45 45 + | Error e -> fail e 46 46 + 47 47 + let test_string_codec_decode () = 48 48 + let decoder : string String_codec.decoder = fun s -> Ok s in 49 49 + let input = Cstruct.of_string "hello world" in 50 50 + match String_codec.decode decoder input with 51 51 + | Ok result -> check string "decode" "hello world" result 52 52 + | Error e -> fail e 53 53 + 54 54 + let test_string_codec_content_type () = 55 55 + check string "content_type" "text/plain; charset=utf-8" 56 56 + String_codec.content_type 57 57 + 58 58 + let test_codec_error_to_string () = 59 59 + check string "encode_error" "Encode error: test" 60 60 + (codec_error_to_string (Encode_error "test")); 61 61 + check string "decode_error" "Decode error: test" 62 62 + (codec_error_to_string (Decode_error "test")); 63 63 + check string "unsupported" "Unsupported body type for codec operation" 64 64 + (codec_error_to_string Unsupported_body_type) 65 65 + 66 66 + let test_with_codec_encode_body () = 67 67 + let module W = With_codec (String_codec) in 68 68 + let encoder : string String_codec.encoder = String.uppercase_ascii in 69 69 + match W.encode_body encoder "hello" with 70 70 + | Ok result -> check string "encode_body" "HELLO" result 71 71 + | Error e -> fail (codec_error_to_string e) 72 72 + 73 73 + let test_with_codec_decode_body () = 74 74 + let module W = With_codec (String_codec) in 75 75 + let decoder : string String_codec.decoder = 76 76 + fun s -> Ok (String.uppercase_ascii s) 77 77 + in 78 78 + match W.decode_body decoder "hello" with 79 79 + | Ok result -> check string "decode_body" "HELLO" result 80 80 + | Error e -> fail (codec_error_to_string e) 81 81 + 82 82 + let tests = 83 83 + [ 84 84 + test_case "identity codec encode" `Quick test_identity_codec_encode; 85 85 + test_case "identity codec decode" `Quick test_identity_codec_decode; 86 86 + test_case "identity codec content_type" `Quick 87 87 + test_identity_codec_content_type; 88 88 + test_case "string codec encode" `Quick test_string_codec_encode; 89 89 + test_case "string codec decode" `Quick test_string_codec_decode; 90 90 + test_case "string codec content_type" `Quick 91 91 + test_string_codec_content_type; 92 92 + test_case "codec error to string" `Quick test_codec_error_to_string; 93 93 + test_case "with_codec encode_body" `Quick test_with_codec_encode_body; 94 94 + test_case "with_codec decode_body" `Quick test_with_codec_decode_body; 95 95 + ] 96 96 + end 97 97 + 98 98 + (* ================================================================== *) 99 99 + (* Stream Tests *) 100 100 + (* ================================================================== *) 101 101 + 102 102 + module Test_stream = struct 103 103 + open Hcs.Stream 104 104 + 105 105 + (* Sync stream tests *) 106 106 + let test_sync_empty () = 107 107 + let s = Sync.empty in 108 108 + check (list int) "empty" [] (Sync.to_list s) 109 109 + 110 110 + let test_sync_singleton () = 111 111 + let s = Sync.singleton 42 in 112 112 + check (list int) "singleton" [ 42 ] (Sync.to_list s) 113 113 + 114 114 + let test_sync_of_list () = 115 115 + let s = Sync.of_list [ 1; 2; 3 ] in 116 116 + check (list int) "of_list" [ 1; 2; 3 ] (Sync.to_list s) 117 117 + 118 118 + let test_sync_map () = 119 119 + let s = Sync.of_list [ 1; 2; 3 ] |> Sync.map (fun x -> x * 2) in 120 120 + check (list int) "map" [ 2; 4; 6 ] (Sync.to_list s) 121 121 + 122 122 + let test_sync_filter () = 123 123 + let s = 124 124 + Sync.of_list [ 1; 2; 3; 4; 5 ] |> Sync.filter (fun x -> x mod 2 = 0) 125 125 + in 126 126 + check (list int) "filter" [ 2; 4 ] (Sync.to_list s) 127 127 + 128 128 + let test_sync_take () = 129 129 + let s = Sync.of_list [ 1; 2; 3; 4; 5 ] |> Sync.take 3 in 130 130 + check (list int) "take" [ 1; 2; 3 ] (Sync.to_list s) 131 131 + 132 132 + let test_sync_drop () = 133 133 + let s = Sync.of_list [ 1; 2; 3; 4; 5 ] |> Sync.drop 2 in 134 134 + check (list int) "drop" [ 3; 4; 5 ] (Sync.to_list s) 135 135 + 136 136 + let test_sync_fold () = 137 137 + let result = Sync.of_list [ 1; 2; 3; 4; 5 ] |> Sync.fold ( + ) 0 in 138 138 + check int "fold" 15 result 139 139 + 140 140 + let test_sync_chunks () = 141 141 + let s = Sync.of_list [ 1; 2; 3; 4; 5 ] |> Sync.chunks 2 in 142 142 + check 143 143 + (list (list int)) 144 144 + "chunks" 145 145 + [ [ 1; 2 ]; [ 3; 4 ]; [ 5 ] ] 146 146 + (Sync.to_list s) 147 147 + 148 148 + let test_sync_repeat () = 149 149 + let s = Sync.repeat 3 "x" in 150 150 + check (list string) "repeat" [ "x"; "x"; "x" ] (Sync.to_list s) 151 151 + 152 152 + let test_sync_unfold () = 153 153 + let s = Sync.unfold (fun n -> if n > 0 then Some (n, n - 1) else None) 3 in 154 154 + check (list int) "unfold" [ 3; 2; 1 ] (Sync.to_list s) 155 155 + 156 156 + let test_sync_append () = 157 157 + let s1 = Sync.of_list [ 1; 2 ] in 158 158 + let s2 = Sync.of_list [ 3; 4 ] in 159 159 + let s = Sync.append s1 s2 in 160 160 + check (list int) "append" [ 1; 2; 3; 4 ] (Sync.to_list s) 161 161 + 162 162 + let test_sync_cstructs_to_string () = 163 163 + let s = 164 164 + Sync.of_list 165 165 + [ 166 166 + Cstruct.of_string "hello"; 167 167 + Cstruct.of_string " "; 168 168 + Cstruct.of_string "world"; 169 169 + ] 170 170 + in 171 171 + check string "cstructs_to_string" "hello world" (Sync.cstructs_to_string s) 172 172 + 173 173 + let test_sync_string_to_cstructs () = 174 174 + let s = Sync.string_to_cstructs ~chunk_size:5 "hello world" in 175 175 + let result = 176 176 + s |> Sync.map Cstruct.to_string |> Sync.to_list |> String.concat "" 177 177 + in 178 178 + check string "string_to_cstructs" "hello world" result 179 179 + 180 180 + (* Async stream tests *) 181 181 + let test_async_empty () = 182 182 + let s = Async.empty in 183 183 + check (list int) "async empty" [] (Async.to_list s) 184 184 + 185 185 + let test_async_singleton () = 186 186 + let s = Async.singleton 42 in 187 187 + check (list int) "async singleton" [ 42 ] (Async.to_list s) 188 188 + 189 189 + let test_async_of_list () = 190 190 + let s = Async.of_list [ 1; 2; 3 ] in 191 191 + check (list int) "async of_list" [ 1; 2; 3 ] (Async.to_list s) 192 192 + 193 193 + let test_async_map () = 194 194 + let s = Async.of_list [ 1; 2; 3 ] in 195 195 + let mapped = Async.map (fun x -> x * 2) s in 196 196 + check (list int) "async map" [ 2; 4; 6 ] (Async.to_list mapped) 197 197 + 198 198 + let test_async_filter () = 199 199 + let s = Async.of_list [ 1; 2; 3; 4; 5 ] in 200 200 + let filtered = Async.filter (fun x -> x mod 2 = 0) s in 201 201 + check (list int) "async filter" [ 2; 4 ] (Async.to_list filtered) 202 202 + 203 203 + let test_async_take () = 204 204 + let s = Async.of_list [ 1; 2; 3; 4; 5 ] in 205 205 + let taken = Async.take 3 s in 206 206 + check (list int) "async take" [ 1; 2; 3 ] (Async.to_list taken) 207 207 + 208 208 + let test_async_fold () = 209 209 + let s = Async.of_list [ 1; 2; 3; 4; 5 ] in 210 210 + let result = Async.fold ( + ) 0 s in 211 211 + check int "async fold" 15 result 212 212 + 213 213 + (* Chunked encoding tests *) 214 214 + let test_chunked_encode () = 215 215 + let chunks = Sync.of_list [ Cstruct.of_string "hello" ] in 216 216 + let encoded = Chunked.encode chunks in 217 217 + let result = Sync.cstructs_to_string encoded in 218 218 + (* 5 in hex is "5", chunk format: "5\r\nhello\r\n" followed by terminator "0\r\n\r\n" *) 219 219 + check string "chunked encode" "5\r\nhello\r\n0\r\n\r\n" result 220 220 + 221 221 + let test_chunked_content_length () = 222 222 + let chunks = 223 223 + Sync.of_list [ Cstruct.of_string "hello"; Cstruct.of_string " world" ] 224 224 + in 225 225 + let len = Chunked.content_length chunks in 226 226 + check int "chunked content_length" 11 len 227 227 + 228 228 + let tests = 229 229 + [ 230 230 + (* Sync tests *) 231 231 + test_case "sync empty" `Quick test_sync_empty; 232 232 + test_case "sync singleton" `Quick test_sync_singleton; 233 233 + test_case "sync of_list" `Quick test_sync_of_list; 234 234 + test_case "sync map" `Quick test_sync_map; 235 235 + test_case "sync filter" `Quick test_sync_filter; 236 236 + test_case "sync take" `Quick test_sync_take; 237 237 + test_case "sync drop" `Quick test_sync_drop; 238 238 + test_case "sync fold" `Quick test_sync_fold; 239 239 + test_case "sync chunks" `Quick test_sync_chunks; 240 240 + test_case "sync repeat" `Quick test_sync_repeat; 241 241 + test_case "sync unfold" `Quick test_sync_unfold; 242 242 + test_case "sync append" `Quick test_sync_append; 243 243 + test_case "sync cstructs_to_string" `Quick test_sync_cstructs_to_string; 244 244 + test_case "sync string_to_cstructs" `Quick test_sync_string_to_cstructs; 245 245 + (* Async tests *) 246 246 + test_case "async empty" `Quick test_async_empty; 247 247 + test_case "async singleton" `Quick test_async_singleton; 248 248 + test_case "async of_list" `Quick test_async_of_list; 249 249 + test_case "async map" `Quick test_async_map; 250 250 + test_case "async filter" `Quick test_async_filter; 251 251 + test_case "async take" `Quick test_async_take; 252 252 + test_case "async fold" `Quick test_async_fold; 253 253 + (* Chunked tests *) 254 254 + test_case "chunked encode" `Quick test_chunked_encode; 255 255 + test_case "chunked content_length" `Quick test_chunked_content_length; 256 256 + ] 257 257 + end 258 258 + 259 259 + (* ================================================================== *) 260 260 + (* HTTP Request Builder Tests *) 261 261 + (* ================================================================== *) 262 262 + 263 263 + module Test_http = struct 264 264 + open Hcs.Http 265 265 + 266 266 + let test_get () = 267 267 + let req = get "https://example.com/path" |> build in 268 268 + check string "method" "GET" (meth_to_string req.req_meth); 269 269 + check string "host" "example.com" (host req); 270 270 + check string "path" "/path" (path req); 271 271 + check bool "is_https" true (is_https req) 272 272 + 273 273 + let test_post () = 274 274 + let req = post "http://example.com/api" |> build in 275 275 + check string "method" "POST" (meth_to_string req.req_meth); 276 276 + check bool "is_https" false (is_https req) 277 277 + 278 278 + let test_put () = 279 279 + let req = put "http://example.com/resource" |> build in 280 280 + check string "method" "PUT" (meth_to_string req.req_meth) 281 281 + 282 282 + let test_delete () = 283 283 + let req = delete "http://example.com/resource/1" |> build in 284 284 + check string "method" "DELETE" (meth_to_string req.req_meth) 285 285 + 286 286 + let test_patch () = 287 287 + let req = patch "http://example.com/resource/1" |> build in 288 288 + check string "method" "PATCH" (meth_to_string req.req_meth) 289 289 + 290 290 + let test_head () = 291 291 + let req = head "http://example.com/" |> build in 292 292 + check string "method" "HEAD" (meth_to_string req.req_meth) 293 293 + 294 294 + let test_options () = 295 295 + let req = options "http://example.com/" |> build in 296 296 + check string "method" "OPTIONS" (meth_to_string req.req_meth) 297 297 + 298 298 + let test_header () = 299 299 + let req = 300 300 + get "http://example.com" |> header "X-Custom" "value" 301 301 + |> header "X-Another" "another" 302 302 + |> build 303 303 + in 304 304 + check bool "has X-Custom" 305 305 + (List.mem ("X-Custom", "value") req.req_headers) 306 306 + true; 307 307 + check bool "has X-Another" 308 308 + (List.mem ("X-Another", "another") req.req_headers) 309 309 + true 310 310 + 311 311 + let test_content_type () = 312 312 + let req = 313 313 + post "http://example.com" |> content_type "application/json" |> build 314 314 + in 315 315 + check bool "has Content-Type" 316 316 + (List.mem ("Content-Type", "application/json") req.req_headers) 317 317 + true 318 318 + 319 319 + let test_accept () = 320 320 + let req = get "http://example.com" |> accept "text/html" |> build in 321 321 + check bool "has Accept" 322 322 + (List.mem ("Accept", "text/html") req.req_headers) 323 323 + true 324 324 + 325 325 + let test_user_agent () = 326 326 + let req = get "http://example.com" |> user_agent "HCS/1.0" |> build in 327 327 + check bool "has User-Agent" 328 328 + (List.mem ("User-Agent", "HCS/1.0") req.req_headers) 329 329 + true 330 330 + 331 331 + let test_bearer () = 332 332 + let req = get "http://example.com" |> bearer "token123" |> build in 333 333 + check bool "has Authorization" 334 334 + (List.mem ("Authorization", "Bearer token123") req.req_headers) 335 335 + true 336 336 + 337 337 + let test_query () = 338 338 + let req = 339 339 + get "http://example.com/search" 340 340 + |> query "q" "ocaml" |> query "limit" "10" |> build 341 341 + in 342 342 + let pq = path_and_query req in 343 343 + check bool "has q param" (String.length pq > 0) true 344 344 + 345 345 + let test_body_string () = 346 346 + let req = 347 347 + post "http://example.com" 348 348 + |> body_string ~content_type:"text/plain" "hello" 349 349 + |> build 350 350 + in 351 351 + check string "body" "hello" (body_to_string req.req_body); 352 352 + check bool "has Content-Type" 353 353 + (List.mem ("Content-Type", "text/plain") req.req_headers) 354 354 + true 355 355 + 356 356 + let test_body_json () = 357 357 + let req = 358 358 + post "http://example.com" |> body_json {|{"key": "value"}|} |> build 359 359 + in 360 360 + check string "body" {|{"key": "value"}|} (body_to_string req.req_body); 361 361 + check bool "has Content-Type" 362 362 + (List.mem ("Content-Type", "application/json") req.req_headers) 363 363 + true 364 364 + 365 365 + let test_form () = 366 366 + let req = 367 367 + post "http://example.com" 368 368 + |> form [ ("name", "Alice"); ("age", "30") ] 369 369 + |> build 370 370 + in 371 371 + let body_str = body_to_string req.req_body in 372 372 + check bool "has name" (String.length body_str > 0) true; 373 373 + check bool "has Content-Type" 374 374 + (List.mem 375 375 + ("Content-Type", "application/x-www-form-urlencoded") 376 376 + req.req_headers) 377 377 + true 378 378 + 379 379 + let test_port_default_http () = 380 380 + let req = get "http://example.com/" |> build in 381 381 + check int "port" 80 (port req) 382 382 + 383 383 + let test_port_default_https () = 384 384 + let req = get "https://example.com/" |> build in 385 385 + check int "port" 443 (port req) 386 386 + 387 387 + let test_port_explicit () = 388 388 + let req = get "http://example.com:8080/" |> build in 389 389 + check int "port" 8080 (port req) 390 390 + 391 391 + let test_meth_of_string () = 392 392 + check string "GET" "GET" (meth_to_string (meth_of_string "GET")); 393 393 + check string "POST" "POST" (meth_to_string (meth_of_string "POST")); 394 394 + check string "CUSTOM" "CUSTOM" (meth_to_string (meth_of_string "CUSTOM")) 395 395 + 396 396 + let test_body_length () = 397 397 + check int "empty body" 0 (body_length Empty); 398 398 + check int "string body" 5 (body_length (String "hello")); 399 399 + check int "form body" (String.length "a=1&b=2") 400 400 + (body_length (Form [ ("a", "1"); ("b", "2") ])) 401 401 + 402 402 + let test_cookie () = 403 403 + let req = get "http://example.com" |> cookie "session" "abc123" |> build in 404 404 + check bool "has Cookie" 405 405 + (List.exists 406 406 + (fun (n, v) -> n = "Cookie" && String.length v > 0) 407 407 + req.req_headers) 408 408 + true 409 409 + 410 410 + let test_cookies_multiple () = 411 411 + let req = 412 412 + get "http://example.com" |> cookie "a" "1" |> cookie "b" "2" |> build 413 413 + in 414 414 + let cookie_header = 415 415 + List.find_opt (fun (n, _) -> n = "Cookie") req.req_headers 416 416 + in 417 417 + match cookie_header with 418 418 + | Some (_, v) -> check bool "has a" (String.length v > 0) true 419 419 + | None -> fail "no Cookie header" 420 420 + 421 421 + let tests = 422 422 + [ 423 423 + test_case "get" `Quick test_get; 424 424 + test_case "post" `Quick test_post; 425 425 + test_case "put" `Quick test_put; 426 426 + test_case "delete" `Quick test_delete; 427 427 + test_case "patch" `Quick test_patch; 428 428 + test_case "head" `Quick test_head; 429 429 + test_case "options" `Quick test_options; 430 430 + test_case "header" `Quick test_header; 431 431 + test_case "content_type" `Quick test_content_type; 432 432 + test_case "accept" `Quick test_accept; 433 433 + test_case "user_agent" `Quick test_user_agent; 434 434 + test_case "bearer" `Quick test_bearer; 435 435 + test_case "query" `Quick test_query; 436 436 + test_case "body_string" `Quick test_body_string; 437 437 + test_case "body_json" `Quick test_body_json; 438 438 + test_case "form" `Quick test_form; 439 439 + test_case "port default http" `Quick test_port_default_http; 440 440 + test_case "port default https" `Quick test_port_default_https; 441 441 + test_case "port explicit" `Quick test_port_explicit; 442 442 + test_case "meth_of_string" `Quick test_meth_of_string; 443 443 + test_case "body_length" `Quick test_body_length; 444 444 + test_case "cookie" `Quick test_cookie; 445 445 + test_case "cookies multiple" `Quick test_cookies_multiple; 446 446 + ] 447 447 + end 448 448 + 449 449 + (* ================================================================== *) 450 450 + (* Router Tests *) 451 451 + (* ================================================================== *) 452 452 + 453 453 + module Test_router = struct 454 454 + open Hcs.Router 455 455 + 456 456 + let test_parse_path_empty () = 457 457 + check (list string) "empty" [] 458 458 + (List.map 459 459 + (function Literal s -> s | Param s -> ":" ^ s | Wildcard -> "*") 460 460 + (parse_path "")) 461 461 + 462 462 + let test_parse_path_root () = 463 463 + check (list string) "root" [] 464 464 + (List.map 465 465 + (function Literal s -> s | Param s -> ":" ^ s | Wildcard -> "*") 466 466 + (parse_path "/")) 467 467 + 468 468 + let test_parse_path_simple () = 469 469 + let segments = parse_path "/users/list" in 470 470 + check int "length" 2 (List.length segments); 471 471 + match segments with 472 472 + | [ Literal "users"; Literal "list" ] -> () 473 473 + | _ -> fail "unexpected segments" 474 474 + 475 475 + let test_parse_path_with_params () = 476 476 + let segments = parse_path "/users/:id/posts/:post_id" in 477 477 + check int "length" 4 (List.length segments); 478 478 + match segments with 479 479 + | [ Literal "users"; Param "id"; Literal "posts"; Param "post_id" ] -> () 480 480 + | _ -> fail "unexpected segments" 481 481 + 482 482 + let test_parse_path_with_wildcard () = 483 483 + let segments = parse_path "/files/*" in 484 484 + check int "length" 2 (List.length segments); 485 485 + match segments with 486 486 + | [ Literal "files"; Wildcard ] -> () 487 487 + | _ -> fail "unexpected segments" 488 488 + 489 489 + let test_router_literal_match () = 490 490 + let router = empty () in 491 491 + add_route router ~method_:(Some `GET) ~path:"/users" 492 492 + ~handler:"users_handler"; 493 493 + match lookup router ~method_:`GET ~path:"/users" with 494 494 + | Some (handler, _) -> check string "handler" "users_handler" handler 495 495 + | None -> fail "no match" 496 496 + 497 497 + let test_router_param_match () = 498 498 + let router = empty () in 499 499 + add_route router ~method_:(Some `GET) ~path:"/users/:id" 500 500 + ~handler:"user_handler"; 501 501 + match lookup router ~method_:`GET ~path:"/users/123" with 502 502 + | Some (handler, params) -> 503 503 + check string "handler" "user_handler" handler; 504 504 + check (option string) "id param" (Some "123") (param "id" params) 505 505 + | None -> fail "no match" 506 506 + 507 507 + let test_router_multiple_params () = 508 508 + let router = empty () in 509 509 + add_route router ~method_:(Some `GET) ~path:"/users/:user_id/posts/:post_id" 510 510 + ~handler:"post_handler"; 511 511 + match lookup router ~method_:`GET ~path:"/users/42/posts/100" with 512 512 + | Some (handler, params) -> 513 513 + check string "handler" "post_handler" handler; 514 514 + check (option string) "user_id" (Some "42") (param "user_id" params); 515 515 + check (option string) "post_id" (Some "100") (param "post_id" params) 516 516 + | None -> fail "no match" 517 517 + 518 518 + let test_router_wildcard_match () = 519 519 + let router = empty () in 520 520 + add_route router ~method_:(Some `GET) ~path:"/files/*" 521 521 + ~handler:"files_handler"; 522 522 + match lookup router ~method_:`GET ~path:"/files/path/to/file.txt" with 523 523 + | Some (handler, params) -> 524 524 + check string "handler" "files_handler" handler; 525 525 + check (option string) "wildcard" (Some "path/to/file.txt") 526 526 + (param "*" params) 527 527 + | None -> fail "no match" 528 528 + 529 529 + let test_router_method_match () = 530 530 + let router = empty () in 531 531 + add_route router ~method_:(Some `GET) ~path:"/users" ~handler:"get_handler"; 532 532 + add_route router ~method_:(Some `POST) ~path:"/users" 533 533 + ~handler:"post_handler"; 534 534 + (match lookup router ~method_:`GET ~path:"/users" with 535 535 + | Some (handler, _) -> check string "GET handler" "get_handler" handler 536 536 + | None -> fail "no GET match"); 537 537 + match lookup router ~method_:`POST ~path:"/users" with 538 538 + | Some (handler, _) -> check string "POST handler" "post_handler" handler 539 539 + | None -> fail "no POST match" 540 540 + 541 541 + let test_router_any_method () = 542 542 + let router = empty () in 543 543 + add_route router ~method_:None ~path:"/health" ~handler:"health_handler"; 544 544 + (match lookup router ~method_:`GET ~path:"/health" with 545 545 + | Some (handler, _) -> check string "GET" "health_handler" handler 546 546 + | None -> fail "no GET match"); 547 547 + match lookup router ~method_:`POST ~path:"/health" with 548 548 + | Some (handler, _) -> check string "POST" "health_handler" handler 549 549 + | None -> fail "no POST match" 550 550 + 551 551 + let test_router_no_match () = 552 552 + let router = empty () in 553 553 + add_route router ~method_:(Some `GET) ~path:"/users" ~handler:"handler"; 554 554 + match lookup router ~method_:`GET ~path:"/posts" with 555 555 + | Some _ -> fail "unexpected match" 556 556 + | None -> () 557 557 + 558 558 + let test_router_compile () = 559 559 + let routes = 560 560 + [ 561 561 + Route.get "/users" "list_users"; 562 562 + Route.post "/users" "create_user"; 563 563 + Route.get "/users/:id" "get_user"; 564 564 + Route.delete "/users/:id" "delete_user"; 565 565 + ] 566 566 + in 567 567 + let router = compile routes in 568 568 + (match lookup router ~method_:`GET ~path:"/users" with 569 569 + | Some (h, _) -> check string "list" "list_users" h 570 570 + | None -> fail "no list match"); 571 571 + match lookup router ~method_:`GET ~path:"/users/42" with 572 572 + | Some (h, params) -> 573 573 + check string "get" "get_user" h; 574 574 + check (option string) "id" (Some "42") (param "id" params) 575 575 + | None -> fail "no get match" 576 576 + 577 577 + let test_param_helpers () = 578 578 + let params = [ ("id", "42"); ("name", "alice") ] in 579 579 + check (option string) "param" (Some "42") (param "id" params); 580 580 + check (option string) "param missing" None (param "foo" params); 581 581 + check string "param_or" "default" (param_or "foo" ~default:"default" params); 582 582 + check (option int) "param_int" (Some 42) (param_int "id" params); 583 583 + check int "param_int_or" 0 (param_int_or "foo" ~default:0 params) 584 584 + 585 585 + let tests = 586 586 + [ 587 587 + test_case "parse_path empty" `Quick test_parse_path_empty; 588 588 + test_case "parse_path root" `Quick test_parse_path_root; 589 589 + test_case "parse_path simple" `Quick test_parse_path_simple; 590 590 + test_case "parse_path with params" `Quick test_parse_path_with_params; 591 591 + test_case "parse_path with wildcard" `Quick test_parse_path_with_wildcard; 592 592 + test_case "router literal match" `Quick test_router_literal_match; 593 593 + test_case "router param match" `Quick test_router_param_match; 594 594 + test_case "router multiple params" `Quick test_router_multiple_params; 595 595 + test_case "router wildcard match" `Quick test_router_wildcard_match; 596 596 + test_case "router method match" `Quick test_router_method_match; 597 597 + test_case "router any method" `Quick test_router_any_method; 598 598 + test_case "router no match" `Quick test_router_no_match; 599 599 + test_case "router compile" `Quick test_router_compile; 600 600 + test_case "param helpers" `Quick test_param_helpers; 601 601 + ] 602 602 + end 603 603 + 604 604 + (* ================================================================== *) 605 605 + (* Middleware Tests *) 606 606 + (* ================================================================== *) 607 607 + 608 608 + module Test_middleware = struct 609 609 + open Hcs.Middleware 610 610 + 611 611 + let test_identity () = 612 612 + let handler x = x + 1 in 613 613 + let wrapped = apply identity handler in 614 614 + check int "identity" 2 (wrapped 1) 615 615 + 616 616 + let test_compose () = 617 617 + let m1 : (int, int) t = fun next x -> next (x * 2) in 618 618 + let m2 : (int, int) t = fun next x -> next (x + 1) in 619 619 + let composed = compose m1 m2 in 620 620 + let handler x = x in 621 621 + let result = apply composed handler 5 in 622 622 + (* m1 runs first: 5 * 2 = 10, then m2: 10 + 1 = 11 *) 623 623 + check int "compose" 11 result 624 624 + 625 625 + let test_compose_all () = 626 626 + let m1 : (int, int) t = fun next x -> next (x * 2) in 627 627 + let m2 : (int, int) t = fun next x -> next (x + 1) in 628 628 + let m3 : (int, int) t = fun next x -> next (x - 3) in 629 629 + let composed = compose_all [ m1; m2; m3 ] in 630 630 + let handler x = x in 631 631 + let result = apply composed handler 5 in 632 632 + (* m1: 5 * 2 = 10, m2: 10 + 1 = 11, m3: 11 - 3 = 8 *) 633 633 + check int "compose_all" 8 result 634 634 + 635 635 + let test_infix_compose () = 636 636 + let m1 : (int, int) t = fun next x -> next (x * 2) in 637 637 + let m2 : (int, int) t = fun next x -> next (x + 1) in 638 638 + let composed = m1 @> m2 in 639 639 + let handler x = x in 640 640 + check int "infix" 11 (apply composed handler 5) 641 641 + 642 642 + let test_logging () = 643 643 + let logs = ref [] in 644 644 + let log msg = logs := msg :: !logs in 645 645 + let m = logging ~log in 646 646 + let handler _ = "response" in 647 647 + let _ = apply m handler () in 648 648 + check int "log count" 2 (List.length !logs); 649 649 + check bool "has request log" (List.mem "Request received" !logs) true; 650 650 + check bool "has response log" (List.mem "Response sent" !logs) true 651 651 + 652 652 + let test_timing () = 653 653 + let duration_ref = ref 0.0 in 654 654 + let on_complete d = duration_ref := d in 655 655 + let m = timing ~on_complete in 656 656 + let handler _ = 657 657 + Unix.sleepf 0.01; 658 658 + "response" 659 659 + in 660 660 + let _ = apply m handler () in 661 661 + check bool "duration > 0" (!duration_ref > 0.0) true 662 662 + 663 663 + let test_recover () = 664 664 + let m = recover ~on_error:(fun _ -> "recovered") in 665 665 + let handler _ = failwith "error" in 666 666 + let result = apply m handler () in 667 667 + check string "recover" "recovered" result 668 668 + 669 669 + let test_when_true () = 670 670 + let m : (int, int) t = fun next x -> next (x * 2) in 671 671 + let conditional = when_ (fun x -> x > 0) m in 672 672 + let handler x = x in 673 673 + check int "when true" 10 (apply conditional handler 5); 674 674 + check int "when false" (-5) (apply conditional handler (-5)) 675 675 + 676 676 + let test_unless () = 677 677 + let m : (int, int) t = fun next x -> next (x * 2) in 678 678 + let conditional = unless (fun x -> x < 0) m in 679 679 + let handler x = x in 680 680 + check int "unless true" 10 (apply conditional handler 5); 681 681 + check int "unless false" (-5) (apply conditional handler (-5)) 682 682 + 683 683 + let tests = 684 684 + [ 685 685 + test_case "identity" `Quick test_identity; 686 686 + test_case "compose" `Quick test_compose; 687 687 + test_case "compose_all" `Quick test_compose_all; 688 688 + test_case "infix compose" `Quick test_infix_compose; 689 689 + test_case "logging" `Quick test_logging; 690 690 + test_case "timing" `Quick test_timing; 691 691 + test_case "recover" `Quick test_recover; 692 692 + test_case "when_ true/false" `Quick test_when_true; 693 693 + test_case "unless" `Quick test_unless; 694 694 + ] 695 695 + end 696 696 + 697 697 + (* ================================================================== *) 698 698 + (* Log Tests *) 699 699 + (* ================================================================== *) 700 700 + 701 701 + module Test_log = struct 702 702 + open Hcs.Log 703 703 + 704 704 + let test_level_to_string () = 705 705 + check string "debug" "DEBUG" (level_to_string Debug); 706 706 + check string "info" "INFO" (level_to_string Info); 707 707 + check string "warn" "WARN" (level_to_string Warn); 708 708 + check string "error" "ERROR" (level_to_string Error) 709 709 + 710 710 + let test_level_of_string () = 711 711 + check bool "DEBUG" true (level_of_string "DEBUG" = Some Debug); 712 712 + check bool "debug" true (level_of_string "debug" = Some Debug); 713 713 + check bool "INFO" true (level_of_string "INFO" = Some Info); 714 714 + check bool "WARN" true (level_of_string "WARN" = Some Warn); 715 715 + check bool "unknown" true (level_of_string "unknown" = None) 716 716 + 717 717 + let test_level_gte () = 718 718 + check bool "error >= debug" true (level_gte Error Debug); 719 719 + check bool "error >= error" true (level_gte Error Error); 720 720 + check bool "debug >= error" false (level_gte Debug Error); 721 721 + check bool "warn >= info" true (level_gte Warn Info) 722 722 + 723 723 + let test_method_to_string () = 724 724 + check string "GET" "GET" (method_to_string GET); 725 725 + check string "POST" "POST" (method_to_string POST); 726 726 + check string "Other" "CUSTOM" (method_to_string (Other "CUSTOM")) 727 727 + 728 728 + let test_event_to_string_request_start () = 729 729 + let e = 730 730 + Request_start { id = "req-1"; meth = GET; uri = "/test"; headers = [] } 731 731 + in 732 732 + let s = event_to_string e in 733 733 + check bool "contains id" (String.length s > 0) true; 734 734 + check bool "contains GET" true (String.length s > 0) 735 735 + 736 736 + let test_event_to_string_request_end () = 737 737 + let e = 738 738 + Request_end 739 739 + { 740 740 + id = "req-1"; 741 741 + status = 200; 742 742 + duration_ms = 42.5; 743 743 + body_size = Some 1024; 744 744 + } 745 745 + in 746 746 + let s = event_to_string e in 747 747 + check bool "contains status" (String.length s > 0) true 748 748 + 749 749 + let test_event_to_string_error () = 750 750 + let e = 751 751 + Error 752 752 + { id = Some "req-1"; error = "connection failed"; context = Some "TLS" } 753 753 + in 754 754 + let s = event_to_string e in 755 755 + check bool "contains error" (String.length s > 0) true 756 756 + 757 757 + let test_event_to_json_request_start () = 758 758 + let e = 759 759 + Request_start { id = "req-1"; meth = GET; uri = "/test"; headers = [] } 760 760 + in 761 761 + let j = event_to_json e in 762 762 + check bool "is json" true (String.sub j 0 1 = "{"); 763 763 + check bool "contains event" true (String.length j > 10) 764 764 + 765 765 + let test_event_to_json_custom () = 766 766 + let e = Custom { name = "test_event"; data = [ ("key", "value") ] } in 767 767 + let j = event_to_json e in 768 768 + check bool "is json" true (String.sub j 0 1 = "{"); 769 769 + check bool "contains name" true (String.length j > 10) 770 770 + 771 771 + let test_null_logger () = 772 772 + (* Should not raise *) 773 773 + null Info 774 774 + (Request_start { id = "req-1"; meth = GET; uri = "/"; headers = [] }); 775 775 + null Error (Error { id = None; error = "test"; context = None }) 776 776 + 777 777 + let test_custom_logger () = 778 778 + let logged = ref [] in 779 779 + let logger = custom (fun level msg -> logged := (level, msg) :: !logged) in 780 780 + logger Info 781 781 + (Request_start { id = "req-1"; meth = GET; uri = "/"; headers = [] }); 782 782 + check int "logged count" 1 (List.length !logged) 783 783 + 784 784 + let test_combine_loggers () = 785 785 + let count1 = ref 0 in 786 786 + let count2 = ref 0 in 787 787 + let logger1 = custom (fun _ _ -> incr count1) in 788 788 + let logger2 = custom (fun _ _ -> incr count2) in 789 789 + let combined = combine [ logger1; logger2 ] in 790 790 + combined Info (Custom { name = "test"; data = [] }); 791 791 + check int "logger1 count" 1 !count1; 792 792 + check int "logger2 count" 1 !count2 793 793 + 794 794 + let test_with_min_level () = 795 795 + let logged = ref [] in 796 796 + let base = custom (fun level msg -> logged := (level, msg) :: !logged) in 797 797 + let filtered = with_min_level Warn base in 798 798 + filtered Debug (Custom { name = "debug"; data = [] }); 799 799 + filtered Info (Custom { name = "info"; data = [] }); 800 800 + filtered Warn (Custom { name = "warn"; data = [] }); 801 801 + filtered Error (Custom { name = "error"; data = [] }); 802 802 + check int "logged count" 2 (List.length !logged) 803 803 + 804 804 + let test_generate_request_id () = 805 805 + let id1 = generate_request_id () in 806 806 + let id2 = generate_request_id () in 807 807 + check bool "starts with req-" true (String.sub id1 0 4 = "req-"); 808 808 + check bool "unique" true (id1 <> id2) 809 809 + 810 810 + let tests = 811 811 + [ 812 812 + test_case "level_to_string" `Quick test_level_to_string; 813 813 + test_case "level_of_string" `Quick test_level_of_string; 814 814 + test_case "level_gte" `Quick test_level_gte; 815 815 + test_case "method_to_string" `Quick test_method_to_string; 816 816 + test_case "event_to_string request_start" `Quick 817 817 + test_event_to_string_request_start; 818 818 + test_case "event_to_string request_end" `Quick 819 819 + test_event_to_string_request_end; 820 820 + test_case "event_to_string error" `Quick test_event_to_string_error; 821 821 + test_case "event_to_json request_start" `Quick 822 822 + test_event_to_json_request_start; 823 823 + test_case "event_to_json custom" `Quick test_event_to_json_custom; 824 824 + test_case "null logger" `Quick test_null_logger; 825 825 + test_case "custom logger" `Quick test_custom_logger; 826 826 + test_case "combine loggers" `Quick test_combine_loggers; 827 827 + test_case "with_min_level" `Quick test_with_min_level; 828 828 + test_case "generate_request_id" `Quick test_generate_request_id; 829 829 + ] 830 830 + end 831 831 + 832 832 + module Test_tls_config = struct 833 833 + open Hcs.Tls_config 834 834 + 835 835 + let test_alpn_constants () = 836 836 + check string "h2" "h2" alpn_h2; 837 837 + check string "http/1.1" "http/1.1" alpn_http11; 838 838 + check string "h2c" "h2c" alpn_h2c 839 839 + 840 840 + let test_protocol_of_alpn () = 841 841 + check (option string) "h2 -> HTTP_2" (Some "HTTP_2") 842 842 + (Option.map 843 843 + (function HTTP_2 -> "HTTP_2" | HTTP_1_1 -> "HTTP_1_1") 844 844 + (protocol_of_alpn "h2")); 845 845 + check (option string) "http/1.1 -> HTTP_1_1" (Some "HTTP_1_1") 846 846 + (Option.map 847 847 + (function HTTP_2 -> "HTTP_2" | HTTP_1_1 -> "HTTP_1_1") 848 848 + (protocol_of_alpn "http/1.1")); 849 849 + check (option string) "unknown -> None" None 850 850 + (Option.map 851 851 + (function HTTP_2 -> "HTTP_2" | HTTP_1_1 -> "HTTP_1_1") 852 852 + (protocol_of_alpn "unknown")) 853 853 + 854 854 + let test_alpn_of_protocol () = 855 855 + check string "HTTP_2 -> h2" "h2" (alpn_of_protocol HTTP_2); 856 856 + check string "HTTP_1_1 -> http/1.1" "http/1.1" (alpn_of_protocol HTTP_1_1) 857 857 + 858 858 + let test_client_configs () = 859 859 + check 860 860 + (option (list string)) 861 861 + "default has http/1.1" (Some [ "http/1.1" ]) Client.default.alpn_protocols; 862 862 + check 863 863 + (option (list string)) 864 864 + "h2 has h2" (Some [ "h2" ]) Client.h2.alpn_protocols; 865 865 + check 866 866 + (option (list string)) 867 867 + "h2_or_http11 has both" 868 868 + (Some [ "h2"; "http/1.1" ]) 869 869 + Client.h2_or_http11.alpn_protocols 870 870 + 871 871 + let tests = 872 872 + [ 873 873 + test_case "alpn constants" `Quick test_alpn_constants; 874 874 + test_case "protocol_of_alpn" `Quick test_protocol_of_alpn; 875 875 + test_case "alpn_of_protocol" `Quick test_alpn_of_protocol; 876 876 + test_case "client configs" `Quick test_client_configs; 877 877 + ] 878 878 + end 879 879 + 880 880 + (* ================================================================== *) 881 881 + (* Property-Based Tests (QCheck) *) 882 882 + (* ================================================================== *) 883 883 + 884 884 + module Test_properties = struct 885 885 + (* Stream properties *) 886 886 + let prop_sync_map_identity = 887 887 + QCheck.Test.make ~name:"sync map identity" ~count:100 888 888 + QCheck.(list int) 889 889 + (fun l -> 890 890 + let open Hcs.Stream.Sync in 891 891 + let s = of_list l in 892 892 + to_list (map Fun.id s) = l) 893 893 + 894 894 + let prop_sync_map_composition = 895 895 + QCheck.Test.make ~name:"sync map composition" ~count:100 896 896 + QCheck.(list nat_small) 897 897 + (fun l -> 898 898 + let open Hcs.Stream.Sync in 899 899 + let f x = x + 1 in 900 900 + let g x = x * 2 in 901 901 + let s = of_list l in 902 902 + to_list (map (fun x -> g (f x)) s) = to_list (map g (map f (of_list l)))) 903 903 + 904 904 + let prop_sync_filter_all = 905 905 + QCheck.Test.make ~name:"sync filter true keeps all" ~count:100 906 906 + QCheck.(list int) 907 907 + (fun l -> 908 908 + let open Hcs.Stream.Sync in 909 909 + to_list (filter (fun _ -> true) (of_list l)) = l) 910 910 + 911 911 + let prop_sync_filter_none = 912 912 + QCheck.Test.make ~name:"sync filter false removes all" ~count:100 913 913 + QCheck.(list int) 914 914 + (fun l -> 915 915 + let open Hcs.Stream.Sync in 916 916 + to_list (filter (fun _ -> false) (of_list l)) = []) 917 917 + 918 918 + let prop_sync_take_drop = 919 919 + QCheck.Test.make ~name:"sync take n ++ drop n = original" ~count:100 920 920 + QCheck.(pair (list int) nat_small) 921 921 + (fun (l, n) -> 922 922 + let open Hcs.Stream.Sync in 923 923 + let s1 = of_list l in 924 924 + let s2 = of_list l in 925 925 + let taken = to_list (take n s1) in 926 926 + let dropped = to_list (drop n s2) in 927 927 + taken @ dropped = l) 928 928 + 929 929 + let prop_sync_fold_sum = 930 930 + QCheck.Test.make ~name:"sync fold sum = List.fold_left sum" ~count:100 931 931 + QCheck.(list nat_small) 932 932 + (fun l -> 933 933 + let open Hcs.Stream.Sync in 934 934 + fold ( + ) 0 (of_list l) = List.fold_left ( + ) 0 l) 935 935 + 936 936 + (* Router properties *) 937 937 + let prop_router_param_extraction = 938 938 + QCheck.Test.make ~name:"router extracts all params" ~count:100 939 939 + QCheck.(pair string_small string_small) 940 940 + (fun (id, name) -> 941 941 + (* Skip edge cases: empty strings or strings containing / *) 942 942 + if 943 943 + id = "" || name = "" || String.contains id '/' 944 944 + || String.contains name '/' 945 945 + then true (* vacuously true for invalid inputs *) 946 946 + else 947 947 + let open Hcs.Router in 948 948 + let router = empty () in 949 949 + add_route router ~method_:(Some `GET) ~path:"/users/:id/items/:name" 950 950 + ~handler:"handler"; 951 951 + match 952 952 + lookup router ~method_:`GET 953 953 + ~path:(Printf.sprintf "/users/%s/items/%s" id name) 954 954 + with 955 955 + | Some (_, params) -> 956 956 + param "id" params = Some id && param "name" params = Some name 957 957 + | None -> false) 958 958 + 959 959 + (* HTTP builder properties *) 960 960 + let prop_http_method_roundtrip = 961 961 + QCheck.Test.make ~name:"http method roundtrip" ~count:20 962 962 + QCheck.( 963 963 + make 964 964 + Gen.( 965 965 + oneof 966 966 + [ 967 967 + return "GET"; 968 968 + return "POST"; 969 969 + return "PUT"; 970 970 + return "DELETE"; 971 971 + return "PATCH"; 972 972 + return "HEAD"; 973 973 + return "OPTIONS"; 974 974 + ])) 975 975 + (fun m -> 976 976 + let open Hcs.Http in 977 977 + meth_to_string (meth_of_string m) = m) 978 978 + 979 979 + (* Middleware properties *) 980 980 + let prop_middleware_identity = 981 981 + QCheck.Test.make ~name:"middleware identity is neutral" ~count:100 982 982 + QCheck.int (fun x -> 983 983 + let open Hcs.Middleware in 984 984 + let handler n = n + 1 in 985 985 + apply identity handler x = handler x) 986 986 + 987 987 + let prop_middleware_compose_associative = 988 988 + QCheck.Test.make ~name:"middleware compose is associative" ~count:100 989 989 + QCheck.nat_small (fun x -> 990 990 + let open Hcs.Middleware in 991 991 + let m1 : (int, int) t = fun next n -> next (n + 1) in 992 992 + let m2 : (int, int) t = fun next n -> next (n * 2) in 993 993 + let m3 : (int, int) t = fun next n -> next (n - 3) in 994 994 + let handler n = n in 995 995 + let left = apply (compose (compose m1 m2) m3) handler x in 996 996 + let right = apply (compose m1 (compose m2 m3)) handler x in 997 997 + left = right) 998 998 + 999 999 + let tests = 1000 1000 + List.map QCheck_alcotest.to_alcotest 1001 1001 + [ 1002 1002 + prop_sync_map_identity; 1003 1003 + prop_sync_map_composition; 1004 1004 + prop_sync_filter_all; 1005 1005 + prop_sync_filter_none; 1006 1006 + prop_sync_take_drop; 1007 1007 + prop_sync_fold_sum; 1008 1008 + prop_router_param_extraction; 1009 1009 + prop_http_method_roundtrip; 1010 1010 + prop_middleware_identity; 1011 1011 + prop_middleware_compose_associative; 1012 1012 + ] 1013 1013 + end 1014 1014 + 1015 1015 + (* ================================================================== *) 1016 1016 + (* Main *) 1017 1017 + (* ================================================================== *) 1018 1018 + 1019 1019 + let () = 1020 1020 + run "HCS" 1021 1021 + [ 1022 1022 + ("Codec", Test_codec.tests); 1023 1023 + ("Stream", Test_stream.tests); 1024 1024 + ("Http", Test_http.tests); 1025 1025 + ("Router", Test_router.tests); 1026 1026 + ("Middleware", Test_middleware.tests); 1027 1027 + ("Log", Test_log.tests); 1028 1028 + ("Tls_config", Test_tls_config.tests); 1029 1029 + ("Properties", Test_properties.tests); 1030 1030 + ]