+2 -1

lib/dune

··· 28 28 decompress.zl 29 29 decompress.gz 30 30 bigstringaf 31 31 - magic-mime)) 31 31 + magic-mime 32 32 + digestif))

+29

lib/error.ml

··· 298 298 299 299 let proxy_error ~host ~reason = 300 300 err (Proxy_error { host; reason }) 301 301 + 302 302 + let tls_handshake_failed ~host ~reason = 303 303 + err (Tls_handshake_failed { host; reason }) 304 304 + 305 305 + let tcp_connect_failed ~host ~port ~reason = 306 306 + err (Tcp_connect_failed { host; port; reason }) 307 307 + 308 308 + (** {1 Format String Constructors} 309 309 + 310 310 + These functions accept printf-style format strings for the reason field, 311 311 + making error construction more concise when messages need interpolation. *) 312 312 + 313 313 + let invalid_requestf fmt = 314 314 + Printf.ksprintf (fun reason -> err (Invalid_request { reason })) fmt 315 315 + 316 316 + let invalid_redirectf ~url fmt = 317 317 + Printf.ksprintf (fun reason -> err (Invalid_redirect { url; reason })) fmt 318 318 + 319 319 + let invalid_urlf ~url fmt = 320 320 + Printf.ksprintf (fun reason -> err (Invalid_url { url; reason })) fmt 321 321 + 322 322 + let proxy_errorf ~host fmt = 323 323 + Printf.ksprintf (fun reason -> err (Proxy_error { host; reason })) fmt 324 324 + 325 325 + let tls_handshake_failedf ~host fmt = 326 326 + Printf.ksprintf (fun reason -> err (Tls_handshake_failed { host; reason })) fmt 327 327 + 328 328 + let tcp_connect_failedf ~host ~port fmt = 329 329 + Printf.ksprintf (fun reason -> err (Tcp_connect_failed { host; port; reason })) fmt

+40

lib/error.mli

··· 199 199 200 200 val proxy_error : host:string -> reason:string -> exn 201 201 (** Create a [Proxy_error] exception *) 202 202 + 203 203 + val tls_handshake_failed : host:string -> reason:string -> exn 204 204 + (** Create a [Tls_handshake_failed] exception *) 205 205 + 206 206 + val tcp_connect_failed : host:string -> port:int -> reason:string -> exn 207 207 + (** Create a [Tcp_connect_failed] exception *) 208 208 + 209 209 + (** {1 Format String Constructors} 210 210 + 211 211 + These functions accept printf-style format strings for the reason field, 212 212 + making error construction more concise when messages need interpolation. 213 213 + 214 214 + Example: 215 215 + {[ 216 216 + (* Instead of: *) 217 217 + raise (Error.err (Error.Invalid_request { 218 218 + reason = Printf.sprintf "Invalid status code: %s" code_str 219 219 + })) 220 220 + 221 221 + (* Use: *) 222 222 + raise (Error.invalid_requestf "Invalid status code: %s" code_str) 223 223 + ]} *) 224 224 + 225 225 + val invalid_requestf : ('a, unit, string, exn) format4 -> 'a 226 226 + (** Create an [Invalid_request] exception with a format string *) 227 227 + 228 228 + val invalid_redirectf : url:string -> ('a, unit, string, exn) format4 -> 'a 229 229 + (** Create an [Invalid_redirect] exception with a format string *) 230 230 + 231 231 + val invalid_urlf : url:string -> ('a, unit, string, exn) format4 -> 'a 232 232 + (** Create an [Invalid_url] exception with a format string *) 233 233 + 234 234 + val proxy_errorf : host:string -> ('a, unit, string, exn) format4 -> 'a 235 235 + (** Create a [Proxy_error] exception with a format string *) 236 236 + 237 237 + val tls_handshake_failedf : host:string -> ('a, unit, string, exn) format4 -> 'a 238 238 + (** Create a [Tls_handshake_failed] exception with a format string *) 239 239 + 240 240 + val tcp_connect_failedf : host:string -> port:int -> ('a, unit, string, exn) format4 -> 'a 241 241 + (** Create a [Tcp_connect_failed] exception with a format string *)

+590 -64

lib/header_name.ml

··· 7 7 8 8 This module provides type-safe HTTP header names using polymorphic variants. 9 9 All standard headers have dedicated variants, with [`Other] for non-standard 10 10 - or unknown headers. Header names are case-insensitive per RFC 9110 Section 5.1. *) 10 10 + or unknown headers. Header names are case-insensitive per RFC 9110 Section 5.1. 11 11 + 12 12 + Header definitions are based on the IANA HTTP Field Name Registry: 13 13 + {{:https://www.iana.org/assignments/http-fields/http-fields.xhtml} IANA HTTP Field Name Registry} 14 14 + 15 15 + @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics 16 16 + @see <https://www.rfc-editor.org/rfc/rfc9111> RFC 9111: HTTP Caching 17 17 + @see <https://www.rfc-editor.org/rfc/rfc9112> RFC 9112: HTTP/1.1 *) 11 18 12 12 - (** Standard HTTP header names. 19 19 + (** {1 Standard HTTP Headers} 13 20 14 14 - These cover all headers defined in RFC 9110, RFC 9111, RFC 9112, and 15 15 - common authentication headers from RFC 7235, RFC 7617, RFC 6750. *) 21 21 + These cover headers defined in: 22 22 + - RFC 9110 (HTTP Semantics) 23 23 + - RFC 9111 (HTTP Caching) 24 24 + - RFC 9112 (HTTP/1.1) 25 25 + - RFC 6455 (WebSocket Protocol) 26 26 + - RFC 9421 (HTTP Message Signatures) 27 27 + - RFC 9530 (Digest Fields) 28 28 + - Fetch Standard (CORS and Security) 29 29 + - Various other RFCs as noted *) 16 30 type standard = [ 31 31 + (* {2 RFC 9110: HTTP Semantics - Content Headers} *) 32 32 + 17 33 | `Accept 34 34 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.1> RFC 9110 Section 12.5.1 *) 18 35 | `Accept_encoding 36 36 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.3> RFC 9110 Section 12.5.3 *) 19 37 | `Accept_language 20 20 - | `Age 21 21 - | `Authorization 22 22 - | `Cache_control 23 23 - | `Connection 38 38 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.4> RFC 9110 Section 12.5.4 *) 39 39 + | `Accept_ranges 40 40 + (** Indicates whether server supports range requests. 41 41 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.3> RFC 9110 Section 14.3 *) 42 42 + | `Allow 43 43 + (** Lists HTTP methods supported by target resource. 44 44 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.1> RFC 9110 Section 10.2.1 *) 24 45 | `Content_encoding 46 46 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.4> RFC 9110 Section 8.4 *) 47 47 + | `Content_language 48 48 + (** Natural language(s) of the intended audience. 49 49 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.5> RFC 9110 Section 8.5 *) 25 50 | `Content_length 51 51 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.6> RFC 9110 Section 8.6 *) 52 52 + | `Content_location 53 53 + (** URI reference for the representation. 54 54 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.7> RFC 9110 Section 8.7 *) 55 55 + | `Content_range 56 56 + (** Indicates which part of representation is enclosed (206 responses). 57 57 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4> RFC 9110 Section 14.4 *) 26 58 | `Content_type 27 27 - | `Cookie 28 28 - | `Date 29 29 - | `Etag 59 59 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.3> RFC 9110 Section 8.3 *) 60 60 + 61 61 + (* {2 RFC 9110: HTTP Semantics - Request Context} *) 62 62 + 30 63 | `Expect 31 31 - | `Expires 64 64 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.1> RFC 9110 Section 10.1.1 *) 65 65 + | `From 66 66 + (** Email address of the human user controlling the user agent. 67 67 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.2> RFC 9110 Section 10.1.2 *) 32 68 | `Host 69 69 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.2> RFC 9110 Section 7.2 *) 70 70 + | `Max_forwards 71 71 + (** Limits forwarding of TRACE/OPTIONS requests. 72 72 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.2> RFC 9110 Section 7.6.2 *) 73 73 + | `Range 74 74 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.2> RFC 9110 Section 14.2 *) 75 75 + | `Referer 76 76 + (** URI of the resource from which request URI was obtained. 77 77 + Note: Header name is intentionally misspelled (historical). 78 78 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.3> RFC 9110 Section 10.1.3 *) 79 79 + | `Te 80 80 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.4> RFC 9110 Section 10.1.4 *) 81 81 + | `User_agent 82 82 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.1.5> RFC 9110 Section 10.1.5 *) 83 83 + 84 84 + (* {2 RFC 9110: HTTP Semantics - Response Context} *) 85 85 + 86 86 + | `Location 87 87 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.2> RFC 9110 Section 10.2.2 *) 88 88 + | `Retry_after 89 89 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.3> RFC 9110 Section 10.2.3 *) 90 90 + | `Server 91 91 + (** Information about the origin server software. 92 92 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.4> RFC 9110 Section 10.2.4 *) 93 93 + 94 94 + (* {2 RFC 9110: HTTP Semantics - Validators} *) 95 95 + 96 96 + | `Etag 97 97 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.3> RFC 9110 Section 8.8.3 *) 98 98 + | `Last_modified 99 99 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.2> RFC 9110 Section 8.8.2 *) 100 100 + | `Vary 101 101 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-12.5.5> RFC 9110 Section 12.5.5 *) 102 102 + 103 103 + (* {2 RFC 9110: HTTP Semantics - Conditional Requests} *) 104 104 + 33 105 | `If_match 106 106 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.1> RFC 9110 Section 13.1.1 *) 34 107 | `If_modified_since 108 108 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.3> RFC 9110 Section 13.1.3 *) 35 109 | `If_none_match 110 110 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.2> RFC 9110 Section 13.1.2 *) 111 111 + | `If_range 112 112 + (** Makes Range request conditional on representation unchanged. 113 113 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.5> RFC 9110 Section 13.1.5 *) 36 114 | `If_unmodified_since 37 37 - | `Keep_alive 38 38 - | `Last_modified 39 39 - | `Link 40 40 - | `Location 115 115 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.4> RFC 9110 Section 13.1.4 *) 116 116 + 117 117 + (* {2 RFC 9110: HTTP Semantics - Authentication} *) 118 118 + 119 119 + | `Authorization 120 120 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.2> RFC 9110 Section 11.6.2 *) 121 121 + | `Authentication_info 122 122 + (** Server sends after successful auth (e.g., nextnonce for Digest). 123 123 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.3> RFC 9110 Section 11.6.3 *) 41 124 | `Proxy_authenticate 125 125 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.1> RFC 9110 Section 11.7.1 *) 126 126 + | `Proxy_authentication_info 127 127 + (** Proxy sends after successful auth. 128 128 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.3> RFC 9110 Section 11.7.3 *) 42 129 | `Proxy_authorization 43 43 - | `Range 44 44 - | `Retry_after 45 45 - | `Set_cookie 46 46 - | `Te 130 130 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.7.2> RFC 9110 Section 11.7.2 *) 131 131 + | `Www_authenticate 132 132 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.1> RFC 9110 Section 11.6.1 *) 133 133 + 134 134 + (* {2 RFC 9110: HTTP Semantics - Connection Management} *) 135 135 + 136 136 + | `Connection 137 137 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.1> RFC 9110 Section 7.6.1 *) 138 138 + | `Upgrade 139 139 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.8> RFC 9110 Section 7.8 *) 140 140 + | `Via 141 141 + (** Records intermediate protocols and recipients (proxies/gateways). 142 142 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-7.6.3> RFC 9110 Section 7.6.3 *) 143 143 + 144 144 + (* {2 RFC 9110: HTTP Semantics - Date} *) 145 145 + 146 146 + | `Date 147 147 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-6.6.1> RFC 9110 Section 6.6.1 *) 148 148 + 149 149 + (* {2 RFC 9111: HTTP Caching} *) 150 150 + 151 151 + | `Age 152 152 + (** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.1> RFC 9111 Section 5.1 *) 153 153 + | `Cache_control 154 154 + (** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.2> RFC 9111 Section 5.2 *) 155 155 + | `Expires 156 156 + (** @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.3> RFC 9111 Section 5.3 *) 157 157 + | `Pragma 158 158 + (** Deprecated but widely used for HTTP/1.0 compatibility. 159 159 + @see <https://www.rfc-editor.org/rfc/rfc9111#section-5.4> RFC 9111 Section 5.4 160 160 + @deprecated Use Cache-Control instead *) 161 161 + | `Cache_status 162 162 + (** Structured field indicating cache handling (hit/miss/etc). 163 163 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211 *) 164 164 + 165 165 + (* {2 RFC 9112: HTTP/1.1} *) 166 166 + 167 167 + | `Keep_alive 168 168 + (** @see <https://www.rfc-editor.org/rfc/rfc2068#section-19.7.1> RFC 2068 Section 19.7.1 *) 47 169 | `Trailer 170 170 + (** @see <https://www.rfc-editor.org/rfc/rfc9110#section-6.6.2> RFC 9110 Section 6.6.2 *) 48 171 | `Transfer_encoding 49 49 - | `Upgrade 50 50 - | `User_agent 51 51 - | `Vary 52 52 - | `Www_authenticate 172 172 + (** @see <https://www.rfc-editor.org/rfc/rfc9112#section-6.1> RFC 9112 Section 6.1 *) 173 173 + 174 174 + (* {2 Cookies - RFC 6265bis} *) 175 175 + 176 176 + | `Cookie 177 177 + (** @see <https://www.rfc-editor.org/rfc/rfc6265> RFC 6265 *) 178 178 + | `Set_cookie 179 179 + (** @see <https://www.rfc-editor.org/rfc/rfc6265> RFC 6265 *) 180 180 + 181 181 + (* {2 Link Relations - RFC 8288} *) 182 182 + 183 183 + | `Link 184 184 + (** @see <https://www.rfc-editor.org/rfc/rfc8288> RFC 8288 *) 185 185 + 186 186 + (* {2 CORS Headers - Fetch Standard} 187 187 + 188 188 + Cross-Origin Resource Sharing headers for controlling cross-origin requests. 189 189 + @see <https://fetch.spec.whatwg.org/> Fetch Standard *) 190 190 + 191 191 + | `Access_control_allow_credentials 192 192 + (** Whether response can be shared when credentials mode is "include". 193 193 + @see <https://fetch.spec.whatwg.org/#http-access-control-allow-credentials> Fetch *) 194 194 + | `Access_control_allow_headers 195 195 + (** Headers allowed in actual request. 196 196 + @see <https://fetch.spec.whatwg.org/#http-access-control-allow-headers> Fetch *) 197 197 + | `Access_control_allow_methods 198 198 + (** HTTP methods allowed for actual request. 199 199 + @see <https://fetch.spec.whatwg.org/#http-access-control-allow-methods> Fetch *) 200 200 + | `Access_control_allow_origin 201 201 + (** Whether response can be shared, by origin. 202 202 + @see <https://fetch.spec.whatwg.org/#http-access-control-allow-origin> Fetch *) 203 203 + | `Access_control_expose_headers 204 204 + (** Headers that can be exposed to the requesting script. 205 205 + @see <https://fetch.spec.whatwg.org/#http-access-control-expose-headers> Fetch *) 206 206 + | `Access_control_max_age 207 207 + (** How long preflight results can be cached. 208 208 + @see <https://fetch.spec.whatwg.org/#http-access-control-max-age> Fetch *) 209 209 + | `Access_control_request_headers 210 210 + (** Headers to be used in actual request (preflight). 211 211 + @see <https://fetch.spec.whatwg.org/#http-access-control-request-headers> Fetch *) 212 212 + | `Access_control_request_method 213 213 + (** Method to be used in actual request (preflight). 214 214 + @see <https://fetch.spec.whatwg.org/#http-access-control-request-method> Fetch *) 215 215 + | `Origin 216 216 + (** Origin of the request. 217 217 + @see <https://www.rfc-editor.org/rfc/rfc6454> RFC 6454 *) 218 218 + 219 219 + (* {2 Cross-Origin Policy Headers - HTML Standard} *) 220 220 + 221 221 + | `Cross_origin_embedder_policy 222 222 + (** Controls cross-origin embedding. 223 223 + @see <https://html.spec.whatwg.org/multipage/origin.html#coep> HTML *) 224 224 + | `Cross_origin_embedder_policy_report_only 225 225 + (** Report-only mode for COEP. 226 226 + @see <https://html.spec.whatwg.org/multipage/origin.html#coep> HTML *) 227 227 + | `Cross_origin_opener_policy 228 228 + (** Controls browsing context group sharing. 229 229 + @see <https://html.spec.whatwg.org/multipage/origin.html#cross-origin-opener-policies> HTML *) 230 230 + | `Cross_origin_opener_policy_report_only 231 231 + (** Report-only mode for COOP. 232 232 + @see <https://html.spec.whatwg.org/multipage/origin.html#cross-origin-opener-policies> HTML *) 233 233 + | `Cross_origin_resource_policy 234 234 + (** Controls no-cors cross-origin requests. 235 235 + @see <https://fetch.spec.whatwg.org/#cross-origin-resource-policy-header> Fetch *) 236 236 + 237 237 + (* {2 Fetch Metadata Headers - W3C} 238 238 + 239 239 + Request headers providing context about the request initiator. 240 240 + @see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata Request Headers *) 241 241 + 242 242 + | `Sec_fetch_dest 243 243 + (** Request destination (document, image, script, etc.). 244 244 + @see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-dest-header> Fetch Metadata *) 245 245 + | `Sec_fetch_mode 246 246 + (** Request mode (cors, navigate, no-cors, same-origin, websocket). 247 247 + @see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-mode-header> Fetch Metadata *) 248 248 + | `Sec_fetch_site 249 249 + (** Relationship between initiator and target (cross-site, same-origin, etc.). 250 250 + @see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-site-header> Fetch Metadata *) 251 251 + | `Sec_fetch_user 252 252 + (** Whether navigation was user-activated. 253 253 + @see <https://www.w3.org/TR/fetch-metadata/#sec-fetch-user-header> Fetch Metadata *) 254 254 + 255 255 + (* {2 Security Headers} *) 256 256 + 257 257 + | `Content_security_policy 258 258 + (** Controls resources user agent is allowed to load. 259 259 + @see <https://www.w3.org/TR/CSP3/> Content Security Policy Level 3 *) 260 260 + | `Content_security_policy_report_only 261 261 + (** Report-only mode for CSP. 262 262 + @see <https://www.w3.org/TR/CSP3/> Content Security Policy Level 3 *) 263 263 + | `Strict_transport_security 264 264 + (** Instructs browser to only use HTTPS (HSTS). 265 265 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797 *) 266 266 + | `X_content_type_options 267 267 + (** Prevents MIME type sniffing. Value: "nosniff". 268 268 + @see <https://fetch.spec.whatwg.org/#x-content-type-options-header> Fetch *) 269 269 + | `X_frame_options 270 270 + (** Controls whether page can be displayed in frame/iframe. 271 271 + @see <https://html.spec.whatwg.org/multipage/browsing-the-web.html#the-x-frame-options-header> HTML *) 272 272 + | `Referrer_policy 273 273 + (** Controls how much referrer info is included. 274 274 + @see <https://www.w3.org/TR/referrer-policy/> Referrer Policy *) 275 275 + 276 276 + (* {2 RFC 8053: Interactive Authentication} *) 277 277 + 278 278 + | `Optional_www_authenticate 279 279 + (** Offers authentication without requiring it (HTTP 200 with auth option). 280 280 + @see <https://www.rfc-editor.org/rfc/rfc8053#section-3> RFC 8053 Section 3 *) 281 281 + | `Authentication_control 282 282 + (** Controls authentication UI behavior. 283 283 + @see <https://www.rfc-editor.org/rfc/rfc8053#section-4> RFC 8053 Section 4 *) 284 284 + 285 285 + (* {2 RFC 9449: OAuth 2.0 DPoP} *) 286 286 + 287 287 + | `Dpop 288 288 + (** Demonstrating Proof of Possession token. 289 289 + @see <https://www.rfc-editor.org/rfc/rfc9449> RFC 9449 *) 290 290 + | `Dpop_nonce 291 291 + (** Server-provided nonce for DPoP. 292 292 + @see <https://www.rfc-editor.org/rfc/rfc9449> RFC 9449 *) 293 293 + 294 294 + (* {2 RFC 9530: Digest Fields} *) 295 295 + 296 296 + | `Content_digest 297 297 + (** Digest of message content (after content-coding). 298 298 + @see <https://www.rfc-editor.org/rfc/rfc9530#section-2> RFC 9530 Section 2 *) 299 299 + | `Repr_digest 300 300 + (** Digest of representation (before content-coding). 301 301 + @see <https://www.rfc-editor.org/rfc/rfc9530#section-3> RFC 9530 Section 3 *) 302 302 + | `Want_content_digest 303 303 + (** Request for Content-Digest in response. 304 304 + @see <https://www.rfc-editor.org/rfc/rfc9530#section-4> RFC 9530 Section 4 *) 305 305 + | `Want_repr_digest 306 306 + (** Request for Repr-Digest in response. 307 307 + @see <https://www.rfc-editor.org/rfc/rfc9530#section-4> RFC 9530 Section 4 *) 308 308 + 309 309 + (* {2 RFC 9421: HTTP Message Signatures} *) 310 310 + 311 311 + | `Signature 312 312 + (** Cryptographic signature over message components. 313 313 + @see <https://www.rfc-editor.org/rfc/rfc9421#section-4.2> RFC 9421 Section 4.2 *) 314 314 + | `Signature_input 315 315 + (** Metadata for signatures (components, algorithm, key ID, etc.). 316 316 + @see <https://www.rfc-editor.org/rfc/rfc9421#section-4.1> RFC 9421 Section 4.1 *) 317 317 + | `Accept_signature 318 318 + (** Indicates client can process signatures. 319 319 + @see <https://www.rfc-editor.org/rfc/rfc9421#section-5.1> RFC 9421 Section 5.1 *) 320 320 + 321 321 + (* {2 RFC 6455: WebSocket Protocol} 322 322 + 323 323 + Headers used during WebSocket HTTP Upgrade handshake. 324 324 + @see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455 *) 325 325 + 326 326 + | `Sec_websocket_key 327 327 + (** Client's base64-encoded 16-byte random nonce. 328 328 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1> RFC 6455 Section 4.1 *) 329 329 + | `Sec_websocket_accept 330 330 + (** Server's proof of handshake (SHA-1 of key + GUID, base64). 331 331 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.2.2> RFC 6455 Section 4.2.2 *) 332 332 + | `Sec_websocket_protocol 333 333 + (** Subprotocol negotiation. 334 334 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-11.3.4> RFC 6455 Section 11.3.4 *) 335 335 + | `Sec_websocket_version 336 336 + (** WebSocket protocol version (must be "13"). 337 337 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1> RFC 6455 Section 4.1 *) 338 338 + | `Sec_websocket_extensions 339 339 + (** Extension negotiation (e.g., permessage-deflate). 340 340 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-9> RFC 6455 Section 9 *) 53 341 ] 54 342 55 343 (** Complete header name type including non-standard headers. ··· 63 351 Standard headers are converted to their canonical capitalization. 64 352 [`Other] headers are returned as-is. *) 65 353 let to_string : t -> string = function 354 354 + (* RFC 9110: Content *) 66 355 | `Accept -> "Accept" 67 356 | `Accept_encoding -> "Accept-Encoding" 68 357 | `Accept_language -> "Accept-Language" 69 69 - | `Age -> "Age" 70 70 - | `Authorization -> "Authorization" 71 71 - | `Cache_control -> "Cache-Control" 72 72 - | `Connection -> "Connection" 358 358 + | `Accept_ranges -> "Accept-Ranges" 359 359 + | `Allow -> "Allow" 73 360 | `Content_encoding -> "Content-Encoding" 361 361 + | `Content_language -> "Content-Language" 74 362 | `Content_length -> "Content-Length" 363 363 + | `Content_location -> "Content-Location" 364 364 + | `Content_range -> "Content-Range" 75 365 | `Content_type -> "Content-Type" 76 76 - | `Cookie -> "Cookie" 77 77 - | `Date -> "Date" 78 78 - | `Etag -> "ETag" 366 366 + (* RFC 9110: Request Context *) 79 367 | `Expect -> "Expect" 80 80 - | `Expires -> "Expires" 368 368 + | `From -> "From" 81 369 | `Host -> "Host" 370 370 + | `Max_forwards -> "Max-Forwards" 371 371 + | `Range -> "Range" 372 372 + | `Referer -> "Referer" 373 373 + | `Te -> "TE" 374 374 + | `User_agent -> "User-Agent" 375 375 + (* RFC 9110: Response Context *) 376 376 + | `Location -> "Location" 377 377 + | `Retry_after -> "Retry-After" 378 378 + | `Server -> "Server" 379 379 + (* RFC 9110: Validators *) 380 380 + | `Etag -> "ETag" 381 381 + | `Last_modified -> "Last-Modified" 382 382 + | `Vary -> "Vary" 383 383 + (* RFC 9110: Conditional *) 82 384 | `If_match -> "If-Match" 83 385 | `If_modified_since -> "If-Modified-Since" 84 386 | `If_none_match -> "If-None-Match" 387 387 + | `If_range -> "If-Range" 85 388 | `If_unmodified_since -> "If-Unmodified-Since" 86 86 - | `Keep_alive -> "Keep-Alive" 87 87 - | `Last_modified -> "Last-Modified" 88 88 - | `Link -> "Link" 89 89 - | `Location -> "Location" 389 389 + (* RFC 9110: Authentication *) 390 390 + | `Authorization -> "Authorization" 391 391 + | `Authentication_info -> "Authentication-Info" 90 392 | `Proxy_authenticate -> "Proxy-Authenticate" 393 393 + | `Proxy_authentication_info -> "Proxy-Authentication-Info" 91 394 | `Proxy_authorization -> "Proxy-Authorization" 92 92 - | `Range -> "Range" 93 93 - | `Retry_after -> "Retry-After" 94 94 - | `Set_cookie -> "Set-Cookie" 95 95 - | `Te -> "TE" 395 395 + | `Www_authenticate -> "WWW-Authenticate" 396 396 + (* RFC 9110: Connection *) 397 397 + | `Connection -> "Connection" 398 398 + | `Upgrade -> "Upgrade" 399 399 + | `Via -> "Via" 400 400 + (* RFC 9110: Date *) 401 401 + | `Date -> "Date" 402 402 + (* RFC 9111: Caching *) 403 403 + | `Age -> "Age" 404 404 + | `Cache_control -> "Cache-Control" 405 405 + | `Expires -> "Expires" 406 406 + | `Pragma -> "Pragma" 407 407 + | `Cache_status -> "Cache-Status" 408 408 + (* RFC 9112: HTTP/1.1 *) 409 409 + | `Keep_alive -> "Keep-Alive" 96 410 | `Trailer -> "Trailer" 97 411 | `Transfer_encoding -> "Transfer-Encoding" 98 98 - | `Upgrade -> "Upgrade" 99 99 - | `User_agent -> "User-Agent" 100 100 - | `Vary -> "Vary" 101 101 - | `Www_authenticate -> "WWW-Authenticate" 412 412 + (* Cookies *) 413 413 + | `Cookie -> "Cookie" 414 414 + | `Set_cookie -> "Set-Cookie" 415 415 + (* Link *) 416 416 + | `Link -> "Link" 417 417 + (* CORS *) 418 418 + | `Access_control_allow_credentials -> "Access-Control-Allow-Credentials" 419 419 + | `Access_control_allow_headers -> "Access-Control-Allow-Headers" 420 420 + | `Access_control_allow_methods -> "Access-Control-Allow-Methods" 421 421 + | `Access_control_allow_origin -> "Access-Control-Allow-Origin" 422 422 + | `Access_control_expose_headers -> "Access-Control-Expose-Headers" 423 423 + | `Access_control_max_age -> "Access-Control-Max-Age" 424 424 + | `Access_control_request_headers -> "Access-Control-Request-Headers" 425 425 + | `Access_control_request_method -> "Access-Control-Request-Method" 426 426 + | `Origin -> "Origin" 427 427 + (* Cross-Origin Policy *) 428 428 + | `Cross_origin_embedder_policy -> "Cross-Origin-Embedder-Policy" 429 429 + | `Cross_origin_embedder_policy_report_only -> "Cross-Origin-Embedder-Policy-Report-Only" 430 430 + | `Cross_origin_opener_policy -> "Cross-Origin-Opener-Policy" 431 431 + | `Cross_origin_opener_policy_report_only -> "Cross-Origin-Opener-Policy-Report-Only" 432 432 + | `Cross_origin_resource_policy -> "Cross-Origin-Resource-Policy" 433 433 + (* Sec-Fetch *) 434 434 + | `Sec_fetch_dest -> "Sec-Fetch-Dest" 435 435 + | `Sec_fetch_mode -> "Sec-Fetch-Mode" 436 436 + | `Sec_fetch_site -> "Sec-Fetch-Site" 437 437 + | `Sec_fetch_user -> "Sec-Fetch-User" 438 438 + (* Security *) 439 439 + | `Content_security_policy -> "Content-Security-Policy" 440 440 + | `Content_security_policy_report_only -> "Content-Security-Policy-Report-Only" 441 441 + | `Strict_transport_security -> "Strict-Transport-Security" 442 442 + | `X_content_type_options -> "X-Content-Type-Options" 443 443 + | `X_frame_options -> "X-Frame-Options" 444 444 + | `Referrer_policy -> "Referrer-Policy" 445 445 + (* RFC 8053: Interactive Auth *) 446 446 + | `Optional_www_authenticate -> "Optional-WWW-Authenticate" 447 447 + | `Authentication_control -> "Authentication-Control" 448 448 + (* RFC 9449: DPoP *) 449 449 + | `Dpop -> "DPoP" 450 450 + | `Dpop_nonce -> "DPoP-Nonce" 451 451 + (* RFC 9530: Digest Fields *) 452 452 + | `Content_digest -> "Content-Digest" 453 453 + | `Repr_digest -> "Repr-Digest" 454 454 + | `Want_content_digest -> "Want-Content-Digest" 455 455 + | `Want_repr_digest -> "Want-Repr-Digest" 456 456 + (* RFC 9421: Signatures *) 457 457 + | `Signature -> "Signature" 458 458 + | `Signature_input -> "Signature-Input" 459 459 + | `Accept_signature -> "Accept-Signature" 460 460 + (* RFC 6455: WebSocket *) 461 461 + | `Sec_websocket_key -> "Sec-WebSocket-Key" 462 462 + | `Sec_websocket_accept -> "Sec-WebSocket-Accept" 463 463 + | `Sec_websocket_protocol -> "Sec-WebSocket-Protocol" 464 464 + | `Sec_websocket_version -> "Sec-WebSocket-Version" 465 465 + | `Sec_websocket_extensions -> "Sec-WebSocket-Extensions" 466 466 + (* Other *) 102 467 | `Other s -> s 103 468 104 469 (** Convert a string to a header name. ··· 107 472 Unknown headers are wrapped in [`Other]. *) 108 473 let of_string s : t = 109 474 match String.lowercase_ascii s with 475 475 + (* RFC 9110: Content *) 110 476 | "accept" -> `Accept 111 477 | "accept-encoding" -> `Accept_encoding 112 478 | "accept-language" -> `Accept_language 113 113 - | "age" -> `Age 114 114 - | "authorization" -> `Authorization 115 115 - | "cache-control" -> `Cache_control 116 116 - | "connection" -> `Connection 479 479 + | "accept-ranges" -> `Accept_ranges 480 480 + | "allow" -> `Allow 117 481 | "content-encoding" -> `Content_encoding 482 482 + | "content-language" -> `Content_language 118 483 | "content-length" -> `Content_length 484 484 + | "content-location" -> `Content_location 485 485 + | "content-range" -> `Content_range 119 486 | "content-type" -> `Content_type 120 120 - | "cookie" -> `Cookie 121 121 - | "date" -> `Date 122 122 - | "etag" -> `Etag 487 487 + (* RFC 9110: Request Context *) 123 488 | "expect" -> `Expect 124 124 - | "expires" -> `Expires 489 489 + | "from" -> `From 125 490 | "host" -> `Host 491 491 + | "max-forwards" -> `Max_forwards 492 492 + | "range" -> `Range 493 493 + | "referer" -> `Referer 494 494 + | "te" -> `Te 495 495 + | "user-agent" -> `User_agent 496 496 + (* RFC 9110: Response Context *) 497 497 + | "location" -> `Location 498 498 + | "retry-after" -> `Retry_after 499 499 + | "server" -> `Server 500 500 + (* RFC 9110: Validators *) 501 501 + | "etag" -> `Etag 502 502 + | "last-modified" -> `Last_modified 503 503 + | "vary" -> `Vary 504 504 + (* RFC 9110: Conditional *) 126 505 | "if-match" -> `If_match 127 506 | "if-modified-since" -> `If_modified_since 128 507 | "if-none-match" -> `If_none_match 508 508 + | "if-range" -> `If_range 129 509 | "if-unmodified-since" -> `If_unmodified_since 130 130 - | "keep-alive" -> `Keep_alive 131 131 - | "last-modified" -> `Last_modified 132 132 - | "link" -> `Link 133 133 - | "location" -> `Location 510 510 + (* RFC 9110: Authentication *) 511 511 + | "authorization" -> `Authorization 512 512 + | "authentication-info" -> `Authentication_info 134 513 | "proxy-authenticate" -> `Proxy_authenticate 514 514 + | "proxy-authentication-info" -> `Proxy_authentication_info 135 515 | "proxy-authorization" -> `Proxy_authorization 136 136 - | "range" -> `Range 137 137 - | "retry-after" -> `Retry_after 138 138 - | "set-cookie" -> `Set_cookie 139 139 - | "te" -> `Te 516 516 + | "www-authenticate" -> `Www_authenticate 517 517 + (* RFC 9110: Connection *) 518 518 + | "connection" -> `Connection 519 519 + | "upgrade" -> `Upgrade 520 520 + | "via" -> `Via 521 521 + (* RFC 9110: Date *) 522 522 + | "date" -> `Date 523 523 + (* RFC 9111: Caching *) 524 524 + | "age" -> `Age 525 525 + | "cache-control" -> `Cache_control 526 526 + | "expires" -> `Expires 527 527 + | "pragma" -> `Pragma 528 528 + | "cache-status" -> `Cache_status 529 529 + (* RFC 9112: HTTP/1.1 *) 530 530 + | "keep-alive" -> `Keep_alive 140 531 | "trailer" -> `Trailer 141 532 | "transfer-encoding" -> `Transfer_encoding 142 142 - | "upgrade" -> `Upgrade 143 143 - | "user-agent" -> `User_agent 144 144 - | "vary" -> `Vary 145 145 - | "www-authenticate" -> `Www_authenticate 533 533 + (* Cookies *) 534 534 + | "cookie" -> `Cookie 535 535 + | "set-cookie" -> `Set_cookie 536 536 + (* Link *) 537 537 + | "link" -> `Link 538 538 + (* CORS *) 539 539 + | "access-control-allow-credentials" -> `Access_control_allow_credentials 540 540 + | "access-control-allow-headers" -> `Access_control_allow_headers 541 541 + | "access-control-allow-methods" -> `Access_control_allow_methods 542 542 + | "access-control-allow-origin" -> `Access_control_allow_origin 543 543 + | "access-control-expose-headers" -> `Access_control_expose_headers 544 544 + | "access-control-max-age" -> `Access_control_max_age 545 545 + | "access-control-request-headers" -> `Access_control_request_headers 546 546 + | "access-control-request-method" -> `Access_control_request_method 547 547 + | "origin" -> `Origin 548 548 + (* Cross-Origin Policy *) 549 549 + | "cross-origin-embedder-policy" -> `Cross_origin_embedder_policy 550 550 + | "cross-origin-embedder-policy-report-only" -> `Cross_origin_embedder_policy_report_only 551 551 + | "cross-origin-opener-policy" -> `Cross_origin_opener_policy 552 552 + | "cross-origin-opener-policy-report-only" -> `Cross_origin_opener_policy_report_only 553 553 + | "cross-origin-resource-policy" -> `Cross_origin_resource_policy 554 554 + (* Sec-Fetch *) 555 555 + | "sec-fetch-dest" -> `Sec_fetch_dest 556 556 + | "sec-fetch-mode" -> `Sec_fetch_mode 557 557 + | "sec-fetch-site" -> `Sec_fetch_site 558 558 + | "sec-fetch-user" -> `Sec_fetch_user 559 559 + (* Security *) 560 560 + | "content-security-policy" -> `Content_security_policy 561 561 + | "content-security-policy-report-only" -> `Content_security_policy_report_only 562 562 + | "strict-transport-security" -> `Strict_transport_security 563 563 + | "x-content-type-options" -> `X_content_type_options 564 564 + | "x-frame-options" -> `X_frame_options 565 565 + | "referrer-policy" -> `Referrer_policy 566 566 + (* RFC 8053: Interactive Auth *) 567 567 + | "optional-www-authenticate" -> `Optional_www_authenticate 568 568 + | "authentication-control" -> `Authentication_control 569 569 + (* RFC 9449: DPoP *) 570 570 + | "dpop" -> `Dpop 571 571 + | "dpop-nonce" -> `Dpop_nonce 572 572 + (* RFC 9530: Digest Fields *) 573 573 + | "content-digest" -> `Content_digest 574 574 + | "repr-digest" -> `Repr_digest 575 575 + | "want-content-digest" -> `Want_content_digest 576 576 + | "want-repr-digest" -> `Want_repr_digest 577 577 + (* RFC 9421: Signatures *) 578 578 + | "signature" -> `Signature 579 579 + | "signature-input" -> `Signature_input 580 580 + | "accept-signature" -> `Accept_signature 581 581 + (* RFC 6455: WebSocket *) 582 582 + | "sec-websocket-key" -> `Sec_websocket_key 583 583 + | "sec-websocket-accept" -> `Sec_websocket_accept 584 584 + | "sec-websocket-protocol" -> `Sec_websocket_protocol 585 585 + | "sec-websocket-version" -> `Sec_websocket_version 586 586 + | "sec-websocket-extensions" -> `Sec_websocket_extensions 587 587 + (* Other *) 146 588 | _ -> `Other s 147 589 148 590 (** Convert to lowercase string for internal map keys. *) ··· 179 621 `Trailer; 180 622 `Transfer_encoding; 181 623 `Upgrade; 624 624 + `Via; 182 625 ] 183 626 184 627 (** Headers that MUST NOT appear in trailers per RFC 9110 Section 6.5.1. *) ··· 191 634 `Trailer; 192 635 ] 193 636 637 637 + (** CORS response headers. 638 638 + 639 639 + These headers control cross-origin access. 640 640 + @see <https://fetch.spec.whatwg.org/#http-responses> Fetch Standard *) 641 641 + let cors_response_headers : t list = [ 642 642 + `Access_control_allow_credentials; 643 643 + `Access_control_allow_headers; 644 644 + `Access_control_allow_methods; 645 645 + `Access_control_allow_origin; 646 646 + `Access_control_expose_headers; 647 647 + `Access_control_max_age; 648 648 + ] 649 649 + 650 650 + (** CORS request headers. 651 651 + 652 652 + These headers are used in CORS preflight requests. 653 653 + @see <https://fetch.spec.whatwg.org/#http-requests> Fetch Standard *) 654 654 + let cors_request_headers : t list = [ 655 655 + `Access_control_request_headers; 656 656 + `Access_control_request_method; 657 657 + `Origin; 658 658 + ] 659 659 + 660 660 + (** Security headers. 661 661 + 662 662 + Headers related to web security policies. *) 663 663 + let security_headers : t list = [ 664 664 + `Content_security_policy; 665 665 + `Content_security_policy_report_only; 666 666 + `Strict_transport_security; 667 667 + `X_content_type_options; 668 668 + `X_frame_options; 669 669 + `Referrer_policy; 670 670 + `Cross_origin_embedder_policy; 671 671 + `Cross_origin_embedder_policy_report_only; 672 672 + `Cross_origin_opener_policy; 673 673 + `Cross_origin_opener_policy_report_only; 674 674 + `Cross_origin_resource_policy; 675 675 + ] 676 676 + 677 677 + (** Fetch metadata headers. 678 678 + 679 679 + Browser-set headers providing request context. 680 680 + @see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata *) 681 681 + let fetch_metadata_headers : t list = [ 682 682 + `Sec_fetch_dest; 683 683 + `Sec_fetch_mode; 684 684 + `Sec_fetch_site; 685 685 + `Sec_fetch_user; 686 686 + ] 687 687 + 688 688 + (** WebSocket handshake headers. 689 689 + 690 690 + Headers used during WebSocket upgrade. 691 691 + @see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455 *) 692 692 + let websocket_headers : t list = [ 693 693 + `Sec_websocket_key; 694 694 + `Sec_websocket_accept; 695 695 + `Sec_websocket_protocol; 696 696 + `Sec_websocket_version; 697 697 + `Sec_websocket_extensions; 698 698 + ] 699 699 + 194 700 (** Check if a header is a hop-by-hop header. *) 195 701 let is_hop_by_hop (name : t) : bool = 196 702 List.exists (equal name) hop_by_hop_headers ··· 198 704 (** Check if a header is forbidden in trailers. *) 199 705 let is_forbidden_trailer (name : t) : bool = 200 706 List.exists (equal name) forbidden_trailer_headers 707 707 + 708 708 + (** Check if a header is a CORS response header. *) 709 709 + let is_cors_response (name : t) : bool = 710 710 + List.exists (equal name) cors_response_headers 711 711 + 712 712 + (** Check if a header is a CORS request header. *) 713 713 + let is_cors_request (name : t) : bool = 714 714 + List.exists (equal name) cors_request_headers 715 715 + 716 716 + (** Check if a header is a security header. *) 717 717 + let is_security (name : t) : bool = 718 718 + List.exists (equal name) security_headers 719 719 + 720 720 + (** Check if a header is a fetch metadata header. *) 721 721 + let is_fetch_metadata (name : t) : bool = 722 722 + List.exists (equal name) fetch_metadata_headers 723 723 + 724 724 + (** Check if a header is a WebSocket header. *) 725 725 + let is_websocket (name : t) : bool = 726 726 + List.exists (equal name) websocket_headers

+160 -24

lib/header_name.mli

··· 28 28 ]} 29 29 30 30 Header names are case-insensitive per 31 31 - {{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110 Section 5.1}. *) 31 31 + {{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110 Section 5.1}. 32 32 + 33 33 + Header definitions are based on the IANA HTTP Field Name Registry: 34 34 + {{:https://www.iana.org/assignments/http-fields/http-fields.xhtml}IANA HTTP Field Name Registry} *) 32 35 33 36 (** {1 Types} *) 34 37 ··· 38 41 - {{:https://datatracker.ietf.org/doc/html/rfc9110}RFC 9110} (HTTP Semantics) 39 42 - {{:https://datatracker.ietf.org/doc/html/rfc9111}RFC 9111} (HTTP Caching) 40 43 - {{:https://datatracker.ietf.org/doc/html/rfc9112}RFC 9112} (HTTP/1.1) 41 41 - - {{:https://datatracker.ietf.org/doc/html/rfc7235}RFC 7235} (HTTP Authentication) 42 42 - - {{:https://datatracker.ietf.org/doc/html/rfc6265}RFC 6265} (HTTP Cookies) *) 44 44 + - {{:https://datatracker.ietf.org/doc/html/rfc6455}RFC 6455} (WebSocket Protocol) 45 45 + - {{:https://datatracker.ietf.org/doc/html/rfc9421}RFC 9421} (HTTP Message Signatures) 46 46 + - {{:https://datatracker.ietf.org/doc/html/rfc9530}RFC 9530} (Digest Fields) 47 47 + - {{:https://fetch.spec.whatwg.org/}Fetch Standard} (CORS and Security) 48 48 + - Various other RFCs as noted *) 43 49 type standard = [ 50 50 + (* RFC 9110: HTTP Semantics - Content Headers *) 44 51 | `Accept 45 52 | `Accept_encoding 46 53 | `Accept_language 47 47 - | `Age 48 48 - | `Authorization 49 49 - | `Cache_control 50 50 - | `Connection 54 54 + | `Accept_ranges 55 55 + | `Allow 51 56 | `Content_encoding 57 57 + | `Content_language 52 58 | `Content_length 59 59 + | `Content_location 60 60 + | `Content_range 53 61 | `Content_type 54 54 - | `Cookie 55 55 - | `Date 56 56 - | `Etag 62 62 + 63 63 + (* RFC 9110: HTTP Semantics - Request Context *) 57 64 | `Expect 58 58 - | `Expires 65 65 + | `From 59 66 | `Host 67 67 + | `Max_forwards 68 68 + | `Range 69 69 + | `Referer 70 70 + | `Te 71 71 + | `User_agent 72 72 + 73 73 + (* RFC 9110: HTTP Semantics - Response Context *) 74 74 + | `Location 75 75 + | `Retry_after 76 76 + | `Server 77 77 + 78 78 + (* RFC 9110: HTTP Semantics - Validators *) 79 79 + | `Etag 80 80 + | `Last_modified 81 81 + | `Vary 82 82 + 83 83 + (* RFC 9110: HTTP Semantics - Conditional Requests *) 60 84 | `If_match 61 85 | `If_modified_since 62 86 | `If_none_match 87 87 + | `If_range 63 88 | `If_unmodified_since 64 64 - | `Keep_alive 65 65 - | `Last_modified 66 66 - | `Link 67 67 - | `Location 89 89 + 90 90 + (* RFC 9110: HTTP Semantics - Authentication *) 91 91 + | `Authorization 92 92 + | `Authentication_info 68 93 | `Proxy_authenticate 94 94 + | `Proxy_authentication_info 69 95 | `Proxy_authorization 70 70 - | `Range 71 71 - | `Retry_after 72 72 - | `Set_cookie 73 73 - | `Te 96 96 + | `Www_authenticate 97 97 + 98 98 + (* RFC 9110: HTTP Semantics - Connection Management *) 99 99 + | `Connection 100 100 + | `Upgrade 101 101 + | `Via 102 102 + 103 103 + (* RFC 9110: HTTP Semantics - Date *) 104 104 + | `Date 105 105 + 106 106 + (* RFC 9111: HTTP Caching *) 107 107 + | `Age 108 108 + | `Cache_control 109 109 + | `Expires 110 110 + | `Pragma 111 111 + | `Cache_status 112 112 + 113 113 + (* RFC 9112: HTTP/1.1 *) 114 114 + | `Keep_alive 74 115 | `Trailer 75 116 | `Transfer_encoding 76 76 - | `Upgrade 77 77 - | `User_agent 78 78 - | `Vary 79 79 - | `Www_authenticate 117 117 + 118 118 + (* Cookies - RFC 6265bis *) 119 119 + | `Cookie 120 120 + | `Set_cookie 121 121 + 122 122 + (* Link Relations - RFC 8288 *) 123 123 + | `Link 124 124 + 125 125 + (* CORS Headers - Fetch Standard *) 126 126 + | `Access_control_allow_credentials 127 127 + | `Access_control_allow_headers 128 128 + | `Access_control_allow_methods 129 129 + | `Access_control_allow_origin 130 130 + | `Access_control_expose_headers 131 131 + | `Access_control_max_age 132 132 + | `Access_control_request_headers 133 133 + | `Access_control_request_method 134 134 + | `Origin 135 135 + 136 136 + (* Cross-Origin Policy Headers - HTML Standard *) 137 137 + | `Cross_origin_embedder_policy 138 138 + | `Cross_origin_embedder_policy_report_only 139 139 + | `Cross_origin_opener_policy 140 140 + | `Cross_origin_opener_policy_report_only 141 141 + | `Cross_origin_resource_policy 142 142 + 143 143 + (* Fetch Metadata Headers - W3C *) 144 144 + | `Sec_fetch_dest 145 145 + | `Sec_fetch_mode 146 146 + | `Sec_fetch_site 147 147 + | `Sec_fetch_user 148 148 + 149 149 + (* Security Headers *) 150 150 + | `Content_security_policy 151 151 + | `Content_security_policy_report_only 152 152 + | `Strict_transport_security 153 153 + | `X_content_type_options 154 154 + | `X_frame_options 155 155 + | `Referrer_policy 156 156 + 157 157 + (* RFC 8053: Interactive Authentication *) 158 158 + | `Optional_www_authenticate 159 159 + | `Authentication_control 160 160 + 161 161 + (* RFC 9449: OAuth 2.0 DPoP *) 162 162 + | `Dpop 163 163 + | `Dpop_nonce 164 164 + 165 165 + (* RFC 9530: Digest Fields *) 166 166 + | `Content_digest 167 167 + | `Repr_digest 168 168 + | `Want_content_digest 169 169 + | `Want_repr_digest 170 170 + 171 171 + (* RFC 9421: HTTP Message Signatures *) 172 172 + | `Signature 173 173 + | `Signature_input 174 174 + | `Accept_signature 175 175 + 176 176 + (* RFC 6455: WebSocket Protocol *) 177 177 + | `Sec_websocket_key 178 178 + | `Sec_websocket_accept 179 179 + | `Sec_websocket_protocol 180 180 + | `Sec_websocket_version 181 181 + | `Sec_websocket_extensions 80 182 ] 81 183 82 184 (** Complete header name type including non-standard headers. ··· 123 225 124 226 These headers MUST be removed before forwarding a message: 125 227 Connection, Keep-Alive, Proxy-Authenticate, Proxy-Authorization, 126 126 - TE, Trailer, Transfer-Encoding, Upgrade. *) 228 228 + TE, Trailer, Transfer-Encoding, Upgrade, Via. *) 127 229 128 230 val forbidden_trailer_headers : t list 129 231 (** Headers that MUST NOT appear in trailers per ··· 132 234 Includes: Transfer-Encoding, Content-Length, Host, Content-Encoding, 133 235 Content-Type, Trailer. *) 134 236 237 237 + val cors_response_headers : t list 238 238 + (** CORS response headers that control cross-origin access. 239 239 + @see <https://fetch.spec.whatwg.org/#http-responses> Fetch Standard *) 240 240 + 241 241 + val cors_request_headers : t list 242 242 + (** CORS request headers used in preflight requests. 243 243 + @see <https://fetch.spec.whatwg.org/#http-requests> Fetch Standard *) 244 244 + 245 245 + val security_headers : t list 246 246 + (** Headers related to web security policies. *) 247 247 + 248 248 + val fetch_metadata_headers : t list 249 249 + (** Browser-set headers providing request context. 250 250 + @see <https://www.w3.org/TR/fetch-metadata/> Fetch Metadata *) 251 251 + 252 252 + val websocket_headers : t list 253 253 + (** Headers used during WebSocket upgrade. 254 254 + @see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455 *) 255 255 + 135 256 val is_hop_by_hop : t -> bool 136 257 (** [is_hop_by_hop name] returns [true] if [name] is a hop-by-hop header. *) 137 258 138 259 val is_forbidden_trailer : t -> bool 139 260 (** [is_forbidden_trailer name] returns [true] if [name] is forbidden in trailers. *) 261 261 + 262 262 + val is_cors_response : t -> bool 263 263 + (** [is_cors_response name] returns [true] if [name] is a CORS response header. *) 264 264 + 265 265 + val is_cors_request : t -> bool 266 266 + (** [is_cors_request name] returns [true] if [name] is a CORS request header. *) 267 267 + 268 268 + val is_security : t -> bool 269 269 + (** [is_security name] returns [true] if [name] is a security header. *) 270 270 + 271 271 + val is_fetch_metadata : t -> bool 272 272 + (** [is_fetch_metadata name] returns [true] if [name] is a fetch metadata header. *) 273 273 + 274 274 + val is_websocket : t -> bool 275 275 + (** [is_websocket name] returns [true] if [name] is a WebSocket header. *)

+695

lib/header_parsing.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** HTTP Header Value Parsing 7 7 + 8 8 + This module provides parsing and generation functions for complex HTTP header 9 9 + values that go beyond simple strings. 10 10 + 11 11 + @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics *) 12 12 + 13 13 + let src = Logs.Src.create "requests.header_parsing" ~doc:"HTTP Header Parsing" 14 14 + module Log = (val Logs.src_log src : Logs.LOG) 15 15 + 16 16 + (** {1 Content-Range (RFC 9110 Section 14.4)} 17 17 + 18 18 + The Content-Range header indicates which part of a representation is 19 19 + enclosed when a 206 (Partial Content) response is returned. 20 20 + 21 21 + Format: [bytes start-end/complete-length] or [bytes */complete-length] 22 22 + 23 23 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4> RFC 9110 Section 14.4 *) 24 24 + 25 25 + type content_range = { 26 26 + unit : string; 27 27 + (** The range unit, typically "bytes" *) 28 28 + range : (int64 * int64) option; 29 29 + (** The byte range (start, end) inclusive, or None for unsatisfied range *) 30 30 + complete_length : int64 option; 31 31 + (** The complete representation length, or None if unknown *) 32 32 + } 33 33 + 34 34 + let content_range_to_string cr = 35 35 + let range_part = match cr.range with 36 36 + | Some (start, end_) -> Printf.sprintf "%Ld-%Ld" start end_ 37 37 + | None -> "*" 38 38 + in 39 39 + let length_part = match cr.complete_length with 40 40 + | Some len -> Int64.to_string len 41 41 + | None -> "*" 42 42 + in 43 43 + Printf.sprintf "%s %s/%s" cr.unit range_part length_part 44 44 + 45 45 + let parse_content_range s = 46 46 + let s = String.trim s in 47 47 + (* Parse unit (e.g., "bytes") *) 48 48 + match String.index_opt s ' ' with 49 49 + | None -> 50 50 + Log.debug (fun m -> m "Content-Range missing unit separator: %s" s); 51 51 + None 52 52 + | Some space_idx -> 53 53 + let unit = String.sub s 0 space_idx in 54 54 + let rest = String.sub s (space_idx + 1) (String.length s - space_idx - 1) in 55 55 + (* Parse range/length *) 56 56 + match String.index_opt rest '/' with 57 57 + | None -> 58 58 + Log.debug (fun m -> m "Content-Range missing range/length separator: %s" s); 59 59 + None 60 60 + | Some slash_idx -> 61 61 + let range_part = String.sub rest 0 slash_idx in 62 62 + let length_part = String.sub rest (slash_idx + 1) (String.length rest - slash_idx - 1) in 63 63 + (* Parse range *) 64 64 + let range = 65 65 + if range_part = "*" then None 66 66 + else match String.index_opt range_part '-' with 67 67 + | None -> None 68 68 + | Some dash_idx -> 69 69 + let start_s = String.sub range_part 0 dash_idx in 70 70 + let end_s = String.sub range_part (dash_idx + 1) (String.length range_part - dash_idx - 1) in 71 71 + match Int64.of_string_opt start_s, Int64.of_string_opt end_s with 72 72 + | Some start, Some end_ -> Some (start, end_) 73 73 + | _ -> 74 74 + Log.debug (fun m -> m "Content-Range invalid range numbers: %s" range_part); 75 75 + None 76 76 + in 77 77 + (* Parse complete length *) 78 78 + let complete_length = 79 79 + if length_part = "*" then None 80 80 + else Int64.of_string_opt length_part 81 81 + in 82 82 + Some { unit; range; complete_length } 83 83 + 84 84 + (** Create a Content-Range value for a byte range response. 85 85 + 86 86 + @param start The first byte position (0-indexed) 87 87 + @param end_ The last byte position (inclusive) 88 88 + @param complete_length The total size of the representation *) 89 89 + let make_content_range ~start ~end_ ~complete_length = 90 90 + { unit = "bytes"; range = Some (start, end_); complete_length = Some complete_length } 91 91 + 92 92 + (** Create a Content-Range value for an unsatisfied range (416 response). 93 93 + 94 94 + @param complete_length The total size of the representation *) 95 95 + let make_unsatisfied_range ~complete_length = 96 96 + { unit = "bytes"; range = None; complete_length = Some complete_length } 97 97 + 98 98 + (** {1 If-Range (RFC 9110 Section 13.1.5)} 99 99 + 100 100 + The If-Range header makes a Range request conditional. It can contain 101 101 + either an ETag or a Last-Modified date. 102 102 + 103 103 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.5> RFC 9110 Section 13.1.5 *) 104 104 + 105 105 + type if_range = 106 106 + | If_range_etag of string 107 107 + (** An entity tag (strong or weak) *) 108 108 + | If_range_date of string 109 109 + (** A Last-Modified date in HTTP-date format *) 110 110 + 111 111 + let if_range_to_string = function 112 112 + | If_range_etag etag -> etag 113 113 + | If_range_date date -> date 114 114 + 115 115 + (** Parse an If-Range header value. 116 116 + 117 117 + Distinguishes between ETags (contain quotes or start with W/) and 118 118 + HTTP-date values (start with a weekday abbreviation). 119 119 + 120 120 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.3> RFC 9110 Section 8.8.3 (ETag) 121 121 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-5.6.7> RFC 9110 Section 5.6.7 (HTTP-date) *) 122 122 + let parse_if_range s = 123 123 + let s = String.trim s in 124 124 + if String.length s = 0 then None 125 125 + else 126 126 + (* ETags are quoted strings or start with W/ for weak ETags *) 127 127 + let is_etag = 128 128 + (* Strong ETag: starts with quote *) 129 129 + (String.length s >= 2 && s.[0] = '"') || 130 130 + (* Weak ETag: starts with W/ followed by quote *) 131 131 + (String.length s >= 3 && s.[0] = 'W' && s.[1] = '/' && s.[2] = '"') 132 132 + in 133 133 + if is_etag then 134 134 + Some (If_range_etag s) 135 135 + else 136 136 + (* HTTP-date starts with a weekday: Mon, Tue, Wed, Thu, Fri, Sat, Sun 137 137 + or in obsolete formats: Monday, Tuesday, etc. *) 138 138 + let weekdays = ["Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"; "Sun"; 139 139 + "Monday"; "Tuesday"; "Wednesday"; "Thursday"; "Friday"; "Saturday"; "Sunday"] in 140 140 + let starts_with_weekday = 141 141 + List.exists (fun day -> 142 142 + String.length s >= String.length day && 143 143 + String.sub s 0 (String.length day) = day 144 144 + ) weekdays 145 145 + in 146 146 + if starts_with_weekday then 147 147 + Some (If_range_date s) 148 148 + else 149 149 + (* Ambiguous - treat as date if it contains digits typical of dates *) 150 150 + if String.exists (fun c -> c >= '0' && c <= '9') s then 151 151 + Some (If_range_date s) 152 152 + else 153 153 + (* Default to ETag for other values *) 154 154 + Some (If_range_etag s) 155 155 + 156 156 + (** Create an If-Range value from an ETag. *) 157 157 + let if_range_of_etag etag = If_range_etag etag 158 158 + 159 159 + (** Create an If-Range value from a Last-Modified date string. *) 160 160 + let if_range_of_date date = If_range_date date 161 161 + 162 162 + (** Check if an If-Range value is an ETag. *) 163 163 + let if_range_is_etag = function 164 164 + | If_range_etag _ -> true 165 165 + | If_range_date _ -> false 166 166 + 167 167 + (** Check if an If-Range value is a date. *) 168 168 + let if_range_is_date = function 169 169 + | If_range_date _ -> true 170 170 + | If_range_etag _ -> false 171 171 + 172 172 + (** {1 Allow (RFC 9110 Section 10.2.1)} 173 173 + 174 174 + The Allow header lists the set of methods supported by the target resource. 175 175 + 176 176 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.1> RFC 9110 Section 10.2.1 *) 177 177 + 178 178 + (** Parse an Allow header value into a list of methods. 179 179 + 180 180 + The Allow header is a comma-separated list of HTTP method names. 181 181 + Example: "GET, HEAD, PUT" *) 182 182 + let parse_allow s = 183 183 + String.split_on_char ',' s 184 184 + |> List.map String.trim 185 185 + |> List.filter (fun s -> String.length s > 0) 186 186 + |> List.map Method.of_string 187 187 + 188 188 + (** Format a list of methods as an Allow header value. *) 189 189 + let allow_to_string methods = 190 190 + methods 191 191 + |> List.map Method.to_string 192 192 + |> String.concat ", " 193 193 + 194 194 + (** Check if a method is in an Allow header value. *) 195 195 + let allow_contains method_ allow_value = 196 196 + let methods = parse_allow allow_value in 197 197 + List.exists (Method.equal method_) methods 198 198 + 199 199 + (** {1 Authentication-Info (RFC 9110 Section 11.6.3)} 200 200 + 201 201 + The Authentication-Info header is sent by the server after successful 202 202 + authentication. For Digest authentication, it provides a new nonce for 203 203 + subsequent requests (avoiding 401 round-trips) and response authentication. 204 204 + 205 205 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.3> RFC 9110 Section 11.6.3 *) 206 206 + 207 207 + type authentication_info = { 208 208 + nextnonce : string option; 209 209 + (** Next nonce to use for subsequent requests *) 210 210 + qop : string option; 211 211 + (** Quality of protection that was used *) 212 212 + rspauth : string option; 213 213 + (** Response authentication (server proves it knows the password) *) 214 214 + cnonce : string option; 215 215 + (** Client nonce echoed back *) 216 216 + nc : string option; 217 217 + (** Nonce count echoed back *) 218 218 + } 219 219 + 220 220 + (** Parse an Authentication-Info header value. 221 221 + 222 222 + Format is comma-separated key=value or key="value" pairs. 223 223 + Example: [nextnonce="abc123", qop=auth, rspauth="xyz789"] *) 224 224 + let parse_authentication_info s = 225 225 + let pairs = 226 226 + let rec parse_pairs acc str = 227 227 + let str = String.trim str in 228 228 + if str = "" then List.rev acc 229 229 + else 230 230 + match String.index_opt str '=' with 231 231 + | None -> List.rev acc 232 232 + | Some eq_idx -> 233 233 + let key = String.trim (String.sub str 0 eq_idx) in 234 234 + let rest = String.sub str (eq_idx + 1) (String.length str - eq_idx - 1) in 235 235 + let rest = String.trim rest in 236 236 + let value, remaining = 237 237 + if String.length rest > 0 && rest.[0] = '"' then 238 238 + (* Quoted value *) 239 239 + match String.index_from_opt rest 1 '"' with 240 240 + | Some end_quote -> 241 241 + let v = String.sub rest 1 (end_quote - 1) in 242 242 + let rem = String.sub rest (end_quote + 1) (String.length rest - end_quote - 1) in 243 243 + let rem = String.trim rem in 244 244 + let rem = if String.length rem > 0 && rem.[0] = ',' then 245 245 + String.sub rem 1 (String.length rem - 1) 246 246 + else rem in 247 247 + (v, rem) 248 248 + | None -> (rest, "") 249 249 + else 250 250 + (* Unquoted value *) 251 251 + match String.index_opt rest ',' with 252 252 + | Some comma -> 253 253 + let v = String.trim (String.sub rest 0 comma) in 254 254 + let rem = String.sub rest (comma + 1) (String.length rest - comma - 1) in 255 255 + (v, rem) 256 256 + | None -> (String.trim rest, "") 257 257 + in 258 258 + parse_pairs ((String.lowercase_ascii key, value) :: acc) remaining 259 259 + in 260 260 + parse_pairs [] s 261 261 + in 262 262 + { 263 263 + nextnonce = List.assoc_opt "nextnonce" pairs; 264 264 + qop = List.assoc_opt "qop" pairs; 265 265 + rspauth = List.assoc_opt "rspauth" pairs; 266 266 + cnonce = List.assoc_opt "cnonce" pairs; 267 267 + nc = List.assoc_opt "nc" pairs; 268 268 + } 269 269 + 270 270 + (** Check if the Authentication-Info contains a new nonce. 271 271 + 272 272 + If present, the client should use this nonce for subsequent requests 273 273 + instead of waiting for a 401 response with a new challenge. *) 274 274 + let has_nextnonce info = Option.is_some info.nextnonce 275 275 + 276 276 + (** Get the next nonce from Authentication-Info, if present. *) 277 277 + let get_nextnonce info = info.nextnonce 278 278 + 279 279 + (** {1 Retry-After (RFC 9110 Section 10.2.3)} 280 280 + 281 281 + The Retry-After header indicates how long to wait before retrying. 282 282 + It can be either a date or a number of seconds. 283 283 + 284 284 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.3> RFC 9110 Section 10.2.3 *) 285 285 + 286 286 + type retry_after = 287 287 + | Retry_after_date of string 288 288 + (** An HTTP-date when the resource will be available *) 289 289 + | Retry_after_seconds of int 290 290 + (** Number of seconds to wait before retrying *) 291 291 + 292 292 + (** Parse a Retry-After header value. *) 293 293 + let parse_retry_after s = 294 294 + let s = String.trim s in 295 295 + match int_of_string_opt s with 296 296 + | Some seconds -> Some (Retry_after_seconds seconds) 297 297 + | None -> 298 298 + (* Not a number, must be a date *) 299 299 + if String.length s > 0 then 300 300 + Some (Retry_after_date s) 301 301 + else 302 302 + None 303 303 + 304 304 + (** Convert a Retry-After value to a delay in seconds. 305 305 + 306 306 + For date values, this requires the current time to compute the difference. 307 307 + Returns None if the date is in the past or cannot be parsed. 308 308 + 309 309 + @param now The current time as a Unix timestamp *) 310 310 + let retry_after_to_seconds ?now retry_after = 311 311 + match retry_after with 312 312 + | Retry_after_seconds s -> Some s 313 313 + | Retry_after_date _date_str -> 314 314 + (* Date parsing would require http_date module *) 315 315 + match now with 316 316 + | None -> None 317 317 + | Some _now_ts -> 318 318 + (* TODO: Parse HTTP-date and compute difference *) 319 319 + None 320 320 + 321 321 + (** {1 Accept-Ranges (RFC 9110 Section 14.3)} 322 322 + 323 323 + The Accept-Ranges header indicates whether the server supports range requests. 324 324 + 325 325 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.3> RFC 9110 Section 14.3 *) 326 326 + 327 327 + type accept_ranges = 328 328 + | Accept_ranges_bytes 329 329 + (** Server supports byte range requests *) 330 330 + | Accept_ranges_none 331 331 + (** Server does not support range requests *) 332 332 + | Accept_ranges_other of string 333 333 + (** Server supports some other range unit *) 334 334 + 335 335 + (** Parse an Accept-Ranges header value. *) 336 336 + let parse_accept_ranges s = 337 337 + match String.lowercase_ascii (String.trim s) with 338 338 + | "bytes" -> Accept_ranges_bytes 339 339 + | "none" -> Accept_ranges_none 340 340 + | other -> Accept_ranges_other other 341 341 + 342 342 + (** Check if the server supports byte range requests. *) 343 343 + let supports_byte_ranges = function 344 344 + | Accept_ranges_bytes -> true 345 345 + | Accept_ranges_none | Accept_ranges_other _ -> false 346 346 + 347 347 + (** {1 Cache-Status (RFC 9211)} 348 348 + 349 349 + The Cache-Status header field indicates how caches have handled a request. 350 350 + It is a List structured field (RFC 8941) where each member is a cache 351 351 + identifier with optional parameters. 352 352 + 353 353 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: The Cache-Status HTTP Response Header Field *) 354 354 + 355 355 + (** Forward/stored response indicator for Cache-Status *) 356 356 + type cache_status_fwd = 357 357 + | Fwd_uri_miss 358 358 + (** The cache did not contain any matching response *) 359 359 + | Fwd_vary_miss 360 360 + (** The cache contained a response, but Vary header prevented match *) 361 361 + | Fwd_miss 362 362 + (** The cache did not find a usable response (generic) *) 363 363 + | Fwd_request 364 364 + (** The request semantics required forwarding (e.g., no-cache) *) 365 365 + | Fwd_stale 366 366 + (** The cache had a stale response that needed revalidation *) 367 367 + | Fwd_partial 368 368 + (** The cache had a partial response that needed completion *) 369 369 + | Fwd_bypass 370 370 + (** The cache was configured to bypass for this request *) 371 371 + | Fwd_other of string 372 372 + (** Other forward reason *) 373 373 + 374 374 + (** A single cache status entry from the Cache-Status header *) 375 375 + type cache_status_entry = { 376 376 + cache_id : string; 377 377 + (** Identifier for the cache (e.g., "CDN", "proxy", "Cloudflare") *) 378 378 + hit : bool option; 379 379 + (** True if served from cache without forwarding *) 380 380 + fwd : cache_status_fwd option; 381 381 + (** Why the request was forwarded *) 382 382 + fwd_status : int option; 383 383 + (** Status code from the forwarded response *) 384 384 + stored : bool option; 385 385 + (** Whether the response was stored in cache *) 386 386 + collapsed : bool option; 387 387 + (** Whether request was collapsed with others *) 388 388 + ttl : int option; 389 389 + (** Time-to-live remaining in seconds *) 390 390 + key : string option; 391 391 + (** Cache key used *) 392 392 + detail : string option; 393 393 + (** Implementation-specific detail *) 394 394 + } 395 395 + 396 396 + let cache_status_fwd_of_string = function 397 397 + | "uri-miss" -> Fwd_uri_miss 398 398 + | "vary-miss" -> Fwd_vary_miss 399 399 + | "miss" -> Fwd_miss 400 400 + | "request" -> Fwd_request 401 401 + | "stale" -> Fwd_stale 402 402 + | "partial" -> Fwd_partial 403 403 + | "bypass" -> Fwd_bypass 404 404 + | other -> Fwd_other other 405 405 + 406 406 + let cache_status_fwd_to_string = function 407 407 + | Fwd_uri_miss -> "uri-miss" 408 408 + | Fwd_vary_miss -> "vary-miss" 409 409 + | Fwd_miss -> "miss" 410 410 + | Fwd_request -> "request" 411 411 + | Fwd_stale -> "stale" 412 412 + | Fwd_partial -> "partial" 413 413 + | Fwd_bypass -> "bypass" 414 414 + | Fwd_other s -> s 415 415 + 416 416 + (** Parse a single Cache-Status entry. 417 417 + Format: cache-id; param1; param2=value; param3="quoted" *) 418 418 + let parse_cache_status_entry s = 419 419 + let s = String.trim s in 420 420 + let parts = String.split_on_char ';' s in 421 421 + match parts with 422 422 + | [] -> None 423 423 + | cache_id_part :: params -> 424 424 + let cache_id = String.trim cache_id_part in 425 425 + if cache_id = "" then None 426 426 + else 427 427 + let parse_param acc p = 428 428 + let p = String.trim p in 429 429 + match String.index_opt p '=' with 430 430 + | None -> 431 431 + (* Boolean parameter (presence = true) *) 432 432 + (String.lowercase_ascii p, "?1") :: acc 433 433 + | Some eq_idx -> 434 434 + let key = String.trim (String.sub p 0 eq_idx) in 435 435 + let value = String.trim (String.sub p (eq_idx + 1) (String.length p - eq_idx - 1)) in 436 436 + (* Remove quotes if present *) 437 437 + let value = 438 438 + if String.length value >= 2 && value.[0] = '"' && value.[String.length value - 1] = '"' then 439 439 + String.sub value 1 (String.length value - 2) 440 440 + else value 441 441 + in 442 442 + (String.lowercase_ascii key, value) :: acc 443 443 + in 444 444 + let param_list = List.fold_left parse_param [] params in 445 445 + let get_bool key = 446 446 + match List.assoc_opt key param_list with 447 447 + | Some "?1" | Some "true" | Some "1" -> Some true 448 448 + | Some "?0" | Some "false" | Some "0" -> Some false 449 449 + | _ -> None 450 450 + in 451 451 + let get_int key = 452 452 + match List.assoc_opt key param_list with 453 453 + | Some v -> int_of_string_opt v 454 454 + | None -> None 455 455 + in 456 456 + let get_string key = List.assoc_opt key param_list in 457 457 + Some { 458 458 + cache_id; 459 459 + hit = get_bool "hit"; 460 460 + fwd = Option.map cache_status_fwd_of_string (get_string "fwd"); 461 461 + fwd_status = get_int "fwd-status"; 462 462 + stored = get_bool "stored"; 463 463 + collapsed = get_bool "collapsed"; 464 464 + ttl = get_int "ttl"; 465 465 + key = get_string "key"; 466 466 + detail = get_string "detail"; 467 467 + } 468 468 + 469 469 + (** Parse a Cache-Status header value into a list of entries. 470 470 + Multiple caches are separated by commas, with the response generator first. *) 471 471 + let parse_cache_status s = 472 472 + String.split_on_char ',' s 473 473 + |> List.filter_map parse_cache_status_entry 474 474 + 475 475 + (** Format a Cache-Status entry as a string. *) 476 476 + let cache_status_entry_to_string entry = 477 477 + let params = [] in 478 478 + let params = match entry.detail with Some v -> ("detail", Printf.sprintf "\"%s\"" v) :: params | None -> params in 479 479 + let params = match entry.key with Some v -> ("key", Printf.sprintf "\"%s\"" v) :: params | None -> params in 480 480 + let params = match entry.ttl with Some v -> ("ttl", string_of_int v) :: params | None -> params in 481 481 + let params = match entry.collapsed with Some true -> ("collapsed", "") :: params | _ -> params in 482 482 + let params = match entry.stored with Some true -> ("stored", "") :: params | _ -> params in 483 483 + let params = match entry.fwd_status with Some v -> ("fwd-status", string_of_int v) :: params | None -> params in 484 484 + let params = match entry.fwd with Some v -> ("fwd", cache_status_fwd_to_string v) :: params | None -> params in 485 485 + let params = match entry.hit with Some true -> ("hit", "") :: params | _ -> params in 486 486 + let param_strs = List.map (fun (k, v) -> 487 487 + if v = "" then k else k ^ "=" ^ v 488 488 + ) params in 489 489 + match param_strs with 490 490 + | [] -> entry.cache_id 491 491 + | _ -> entry.cache_id ^ "; " ^ String.concat "; " param_strs 492 492 + 493 493 + (** Format a list of Cache-Status entries as a header value. *) 494 494 + let cache_status_to_string entries = 495 495 + String.concat ", " (List.map cache_status_entry_to_string entries) 496 496 + 497 497 + (** Check if any cache reported a hit. *) 498 498 + let cache_status_is_hit entries = 499 499 + List.exists (fun e -> e.hit = Some true) entries 500 500 + 501 501 + (** Check if the response was stored by any cache. *) 502 502 + let cache_status_is_stored entries = 503 503 + List.exists (fun e -> e.stored = Some true) entries 504 504 + 505 505 + (** Get the forward reason from the first cache that forwarded. *) 506 506 + let cache_status_get_fwd entries = 507 507 + List.find_map (fun e -> e.fwd) entries 508 508 + 509 509 + (** {1 Content-Digest / Repr-Digest (RFC 9530)} 510 510 + 511 511 + Content-Digest contains a digest of the content (after content coding). 512 512 + Repr-Digest contains a digest of the representation (before content coding). 513 513 + 514 514 + Format: algorithm=:base64-digest:, algorithm=:base64-digest: 515 515 + 516 516 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields *) 517 517 + 518 518 + (** Supported digest algorithms *) 519 519 + type digest_algorithm = 520 520 + | Sha256 521 521 + (** SHA-256 (recommended) *) 522 522 + | Sha512 523 523 + (** SHA-512 *) 524 524 + | Other of string 525 525 + (** Other algorithm (for forward compatibility) *) 526 526 + 527 527 + let digest_algorithm_of_string s = 528 528 + match String.lowercase_ascii s with 529 529 + | "sha-256" -> Sha256 530 530 + | "sha-512" -> Sha512 531 531 + | other -> Other other 532 532 + 533 533 + let digest_algorithm_to_string = function 534 534 + | Sha256 -> "sha-256" 535 535 + | Sha512 -> "sha-512" 536 536 + | Other s -> s 537 537 + 538 538 + (** A single digest value with its algorithm *) 539 539 + type digest_value = { 540 540 + algorithm : digest_algorithm; 541 541 + (** The hash algorithm used *) 542 542 + digest : string; 543 543 + (** The base64-encoded digest value *) 544 544 + } 545 545 + 546 546 + (** Parse a Content-Digest or Repr-Digest header value. 547 547 + Format: sha-256=:base64data:, sha-512=:base64data: *) 548 548 + let parse_digest_header s = 549 549 + String.split_on_char ',' s 550 550 + |> List.filter_map (fun part -> 551 551 + let part = String.trim part in 552 552 + match String.index_opt part '=' with 553 553 + | None -> None 554 554 + | Some eq_idx -> 555 555 + let algo = String.trim (String.sub part 0 eq_idx) in 556 556 + let value = String.trim (String.sub part (eq_idx + 1) (String.length part - eq_idx - 1)) in 557 557 + (* RFC 9530 uses :base64: format for byte sequences *) 558 558 + let digest = 559 559 + if String.length value >= 2 && value.[0] = ':' && value.[String.length value - 1] = ':' then 560 560 + String.sub value 1 (String.length value - 2) 561 561 + else value 562 562 + in 563 563 + Some { algorithm = digest_algorithm_of_string algo; digest } 564 564 + ) 565 565 + 566 566 + (** Format a digest value as a string. *) 567 567 + let digest_value_to_string dv = 568 568 + Printf.sprintf "%s=:%s:" (digest_algorithm_to_string dv.algorithm) dv.digest 569 569 + 570 570 + (** Format a list of digest values as a header value. *) 571 571 + let digest_header_to_string digests = 572 572 + String.concat ", " (List.map digest_value_to_string digests) 573 573 + 574 574 + (** Compute the SHA-256 digest of content and return base64-encoded result. *) 575 575 + let compute_sha256 content = 576 576 + let hash = Digestif.SHA256.digest_string content in 577 577 + Base64.encode_string (Digestif.SHA256.to_raw_string hash) 578 578 + 579 579 + (** Compute the SHA-512 digest of content and return base64-encoded result. *) 580 580 + let compute_sha512 content = 581 581 + let hash = Digestif.SHA512.digest_string content in 582 582 + Base64.encode_string (Digestif.SHA512.to_raw_string hash) 583 583 + 584 584 + (** Compute a digest for content using the specified algorithm. *) 585 585 + let compute_digest ~algorithm content = 586 586 + let digest = match algorithm with 587 587 + | Sha256 -> compute_sha256 content 588 588 + | Sha512 -> compute_sha512 content 589 589 + | Other _ -> 590 590 + Log.warn (fun m -> m "Unsupported digest algorithm, using SHA-256"); 591 591 + compute_sha256 content 592 592 + in 593 593 + { algorithm; digest } 594 594 + 595 595 + (** Create a Content-Digest header value for content. 596 596 + Defaults to SHA-256 which is recommended by RFC 9530. *) 597 597 + let make_content_digest ?(algorithm = Sha256) content = 598 598 + compute_digest ~algorithm content 599 599 + 600 600 + (** Validate that a digest matches the content. 601 601 + Returns true if any of the provided digests matches. *) 602 602 + let validate_digest ~digests content = 603 603 + List.exists (fun dv -> 604 604 + let computed = compute_digest ~algorithm:dv.algorithm content in 605 605 + computed.digest = dv.digest 606 606 + ) digests 607 607 + 608 608 + (** Get the strongest available digest (prefer SHA-512 over SHA-256). *) 609 609 + let get_strongest_digest digests = 610 610 + let sha512 = List.find_opt (fun d -> d.algorithm = Sha512) digests in 611 611 + let sha256 = List.find_opt (fun d -> d.algorithm = Sha256) digests in 612 612 + match sha512, sha256 with 613 613 + | Some d, _ -> Some d 614 614 + | None, Some d -> Some d 615 615 + | None, None -> List.nth_opt digests 0 616 616 + 617 617 + (** {1 Strict-Transport-Security (RFC 6797)} 618 618 + 619 619 + The Strict-Transport-Security (HSTS) header tells browsers to only 620 620 + access the site over HTTPS. 621 621 + 622 622 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 623 623 + 624 624 + (** HSTS directive values *) 625 625 + type hsts = { 626 626 + max_age : int64; 627 627 + (** Required: Time in seconds the browser should remember HTTPS-only *) 628 628 + include_subdomains : bool; 629 629 + (** If true, policy applies to all subdomains *) 630 630 + preload : bool; 631 631 + (** If true, site requests inclusion in browser preload lists *) 632 632 + } 633 633 + 634 634 + (** Parse a Strict-Transport-Security header value. 635 635 + Format: max-age=31536000; includeSubDomains; preload *) 636 636 + let parse_hsts s = 637 637 + let directives = 638 638 + String.split_on_char ';' s 639 639 + |> List.map String.trim 640 640 + |> List.filter (fun s -> String.length s > 0) 641 641 + in 642 642 + let max_age = ref None in 643 643 + let include_subdomains = ref false in 644 644 + let preload = ref false in 645 645 + List.iter (fun directive -> 646 646 + let directive_lower = String.lowercase_ascii directive in 647 647 + if String.length directive_lower >= 8 && 648 648 + String.sub directive_lower 0 8 = "max-age=" then begin 649 649 + let value_str = String.sub directive 8 (String.length directive - 8) in 650 650 + max_age := Int64.of_string_opt (String.trim value_str) 651 651 + end 652 652 + else if directive_lower = "includesubdomains" then 653 653 + include_subdomains := true 654 654 + else if directive_lower = "preload" then 655 655 + preload := true 656 656 + else 657 657 + Log.debug (fun m -> m "Unknown HSTS directive: %s" directive) 658 658 + ) directives; 659 659 + match !max_age with 660 660 + | Some age -> Some { 661 661 + max_age = age; 662 662 + include_subdomains = !include_subdomains; 663 663 + preload = !preload; 664 664 + } 665 665 + | None -> 666 666 + Log.debug (fun m -> m "HSTS header missing required max-age directive"); 667 667 + None 668 668 + 669 669 + (** Format an HSTS value as a header string. *) 670 670 + let hsts_to_string hsts = 671 671 + let parts = [Printf.sprintf "max-age=%Ld" hsts.max_age] in 672 672 + let parts = if hsts.include_subdomains then parts @ ["includeSubDomains"] else parts in 673 673 + let parts = if hsts.preload then parts @ ["preload"] else parts in 674 674 + String.concat "; " parts 675 675 + 676 676 + (** Create an HSTS header value. 677 677 + @param max_age Time in seconds (default: 1 year = 31536000) 678 678 + @param include_subdomains Apply to subdomains (default: false) 679 679 + @param preload Request preload list inclusion (default: false) *) 680 680 + let make_hsts ?(max_age = 31536000L) ?(include_subdomains = false) ?(preload = false) () = 681 681 + { max_age; include_subdomains; preload } 682 682 + 683 683 + (** Check if HSTS is effectively enabled (max-age > 0). *) 684 684 + let hsts_is_enabled hsts = hsts.max_age > 0L 685 685 + 686 686 + (** Common HSTS configurations *) 687 687 + 688 688 + (** One year with subdomains - recommended for production *) 689 689 + let hsts_one_year_subdomains = { max_age = 31536000L; include_subdomains = true; preload = false } 690 690 + 691 691 + (** Two years with subdomains and preload - for HSTS preload submission *) 692 692 + let hsts_preload = { max_age = 63072000L; include_subdomains = true; preload = true } 693 693 + 694 694 + (** Disable HSTS by setting max-age to 0 *) 695 695 + let hsts_disable = { max_age = 0L; include_subdomains = false; preload = false }

+414

lib/header_parsing.mli

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** HTTP Header Value Parsing 7 7 + 8 8 + This module provides parsing and generation functions for complex HTTP header 9 9 + values that go beyond simple strings. 10 10 + 11 11 + {2 Supported Headers} 12 12 + 13 13 + - {!Content-Range} - Partial content range specification (RFC 9110 Section 14.4) 14 14 + - {!If-Range} - Conditional range request (RFC 9110 Section 13.1.5) 15 15 + - {!Allow} - Supported HTTP methods (RFC 9110 Section 10.2.1) 16 16 + - {!Authentication-Info} - Post-authentication info (RFC 9110 Section 11.6.3) 17 17 + - {!Retry-After} - Retry delay specification (RFC 9110 Section 10.2.3) 18 18 + - {!Accept-Ranges} - Range support indication (RFC 9110 Section 14.3) 19 19 + - {!Cache-Status} - Cache handling indication (RFC 9211) 20 20 + - {!Content-Digest} / {!Repr-Digest} - Body integrity verification (RFC 9530) 21 21 + - {!Strict-Transport-Security} - HSTS policy (RFC 6797) 22 22 + 23 23 + @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics 24 24 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: Cache-Status 25 25 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields 26 26 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 27 27 + 28 28 + (** {1 Content-Range (RFC 9110 Section 14.4)} 29 29 + 30 30 + The Content-Range header indicates which part of a representation is 31 31 + enclosed when a 206 (Partial Content) response is returned. 32 32 + 33 33 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4> RFC 9110 Section 14.4 *) 34 34 + 35 35 + type content_range = { 36 36 + unit : string; 37 37 + (** The range unit, typically "bytes" *) 38 38 + range : (int64 * int64) option; 39 39 + (** The byte range (start, end) inclusive, or None for unsatisfied range *) 40 40 + complete_length : int64 option; 41 41 + (** The complete representation length, or None if unknown *) 42 42 + } 43 43 + 44 44 + val content_range_to_string : content_range -> string 45 45 + (** [content_range_to_string cr] formats a content range as a header value. 46 46 + 47 47 + Example: ["bytes 0-499/1234"] *) 48 48 + 49 49 + val parse_content_range : string -> content_range option 50 50 + (** [parse_content_range s] parses a Content-Range header value. 51 51 + 52 52 + Returns [None] if the value cannot be parsed. 53 53 + 54 54 + Examples: 55 55 + - ["bytes 0-499/1234"] -> Some {unit="bytes"; range=Some(0,499); complete_length=Some 1234} 56 56 + - ["bytes */1234"] -> Some {unit="bytes"; range=None; complete_length=Some 1234} *) 57 57 + 58 58 + val make_content_range : start:int64 -> end_:int64 -> complete_length:int64 -> content_range 59 59 + (** [make_content_range ~start ~end_ ~complete_length] creates a Content-Range 60 60 + value for a byte range response. 61 61 + 62 62 + @param start The first byte position (0-indexed) 63 63 + @param end_ The last byte position (inclusive) 64 64 + @param complete_length The total size of the representation *) 65 65 + 66 66 + val make_unsatisfied_range : complete_length:int64 -> content_range 67 67 + (** [make_unsatisfied_range ~complete_length] creates a Content-Range value for 68 68 + an unsatisfied range (416 response). *) 69 69 + 70 70 + (** {1 If-Range (RFC 9110 Section 13.1.5)} 71 71 + 72 72 + The If-Range header makes a Range request conditional. It can contain 73 73 + either an ETag or a Last-Modified date. 74 74 + 75 75 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.5> RFC 9110 Section 13.1.5 *) 76 76 + 77 77 + type if_range = 78 78 + | If_range_etag of string 79 79 + (** An entity tag (strong or weak) *) 80 80 + | If_range_date of string 81 81 + (** A Last-Modified date in HTTP-date format *) 82 82 + 83 83 + val if_range_to_string : if_range -> string 84 84 + (** [if_range_to_string ir] converts an If-Range value to a string. *) 85 85 + 86 86 + val parse_if_range : string -> if_range option 87 87 + (** [parse_if_range s] parses an If-Range header value. 88 88 + 89 89 + Distinguishes between ETags (contain quotes or start with W/) and 90 90 + HTTP-date values (start with a weekday abbreviation). *) 91 91 + 92 92 + val if_range_of_etag : string -> if_range 93 93 + (** [if_range_of_etag etag] creates an If-Range value from an ETag. *) 94 94 + 95 95 + val if_range_of_date : string -> if_range 96 96 + (** [if_range_of_date date] creates an If-Range value from a date string. *) 97 97 + 98 98 + val if_range_is_etag : if_range -> bool 99 99 + (** [if_range_is_etag ir] returns [true] if [ir] is an ETag. *) 100 100 + 101 101 + val if_range_is_date : if_range -> bool 102 102 + (** [if_range_is_date ir] returns [true] if [ir] is a date. *) 103 103 + 104 104 + (** {1 Allow (RFC 9110 Section 10.2.1)} 105 105 + 106 106 + The Allow header lists the set of methods supported by the target resource. 107 107 + 108 108 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.1> RFC 9110 Section 10.2.1 *) 109 109 + 110 110 + val parse_allow : string -> Method.t list 111 111 + (** [parse_allow s] parses an Allow header value into a list of methods. 112 112 + 113 113 + Example: ["GET, HEAD, PUT"] -> [\`GET; \`HEAD; \`PUT] *) 114 114 + 115 115 + val allow_to_string : Method.t list -> string 116 116 + (** [allow_to_string methods] formats a list of methods as an Allow header value. 117 117 + 118 118 + Example: [\`GET; \`HEAD] -> ["GET, HEAD"] *) 119 119 + 120 120 + val allow_contains : Method.t -> string -> bool 121 121 + (** [allow_contains method_ allow_value] checks if a method is in an Allow header value. *) 122 122 + 123 123 + (** {1 Authentication-Info (RFC 9110 Section 11.6.3)} 124 124 + 125 125 + The Authentication-Info header is sent by the server after successful 126 126 + authentication. For Digest authentication, it provides: 127 127 + 128 128 + - A new nonce for subsequent requests (avoiding 401 round-trips) 129 129 + - Response authentication (server proves it knows the password) 130 130 + - Echo of client nonce and nonce count for verification 131 131 + 132 132 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.3> RFC 9110 Section 11.6.3 *) 133 133 + 134 134 + type authentication_info = { 135 135 + nextnonce : string option; 136 136 + (** Next nonce to use for subsequent requests *) 137 137 + qop : string option; 138 138 + (** Quality of protection that was used *) 139 139 + rspauth : string option; 140 140 + (** Response authentication (server proves it knows the password) *) 141 141 + cnonce : string option; 142 142 + (** Client nonce echoed back *) 143 143 + nc : string option; 144 144 + (** Nonce count echoed back *) 145 145 + } 146 146 + 147 147 + val parse_authentication_info : string -> authentication_info 148 148 + (** [parse_authentication_info s] parses an Authentication-Info header value. 149 149 + 150 150 + Example: ["nextnonce=\"abc123\", qop=auth, rspauth=\"xyz789\""] *) 151 151 + 152 152 + val has_nextnonce : authentication_info -> bool 153 153 + (** [has_nextnonce info] returns [true] if a new nonce is provided. 154 154 + 155 155 + If present, the client should use this nonce for subsequent requests 156 156 + instead of waiting for a 401 response with a new challenge. *) 157 157 + 158 158 + val get_nextnonce : authentication_info -> string option 159 159 + (** [get_nextnonce info] returns the next nonce, if present. *) 160 160 + 161 161 + (** {1 Retry-After (RFC 9110 Section 10.2.3)} 162 162 + 163 163 + The Retry-After header indicates how long to wait before retrying. 164 164 + 165 165 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.3> RFC 9110 Section 10.2.3 *) 166 166 + 167 167 + type retry_after = 168 168 + | Retry_after_date of string 169 169 + (** An HTTP-date when the resource will be available *) 170 170 + | Retry_after_seconds of int 171 171 + (** Number of seconds to wait before retrying *) 172 172 + 173 173 + val parse_retry_after : string -> retry_after option 174 174 + (** [parse_retry_after s] parses a Retry-After header value. 175 175 + 176 176 + Examples: 177 177 + - ["120"] -> Some (Retry_after_seconds 120) 178 178 + - ["Fri, 31 Dec 1999 23:59:59 GMT"] -> Some (Retry_after_date "...") *) 179 179 + 180 180 + val retry_after_to_seconds : ?now:float -> retry_after -> int option 181 181 + (** [retry_after_to_seconds ?now retry_after] converts to seconds. 182 182 + 183 183 + For [Retry_after_seconds], returns the value directly. 184 184 + For [Retry_after_date], returns [None] (date parsing not yet implemented). 185 185 + 186 186 + @param now The current time as a Unix timestamp (for date calculation) *) 187 187 + 188 188 + (** {1 Accept-Ranges (RFC 9110 Section 14.3)} 189 189 + 190 190 + The Accept-Ranges header indicates whether the server supports range requests. 191 191 + 192 192 + @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.3> RFC 9110 Section 14.3 *) 193 193 + 194 194 + type accept_ranges = 195 195 + | Accept_ranges_bytes 196 196 + (** Server supports byte range requests *) 197 197 + | Accept_ranges_none 198 198 + (** Server does not support range requests *) 199 199 + | Accept_ranges_other of string 200 200 + (** Server supports some other range unit *) 201 201 + 202 202 + val parse_accept_ranges : string -> accept_ranges 203 203 + (** [parse_accept_ranges s] parses an Accept-Ranges header value. 204 204 + 205 205 + Examples: 206 206 + - ["bytes"] -> Accept_ranges_bytes 207 207 + - ["none"] -> Accept_ranges_none *) 208 208 + 209 209 + val supports_byte_ranges : accept_ranges -> bool 210 210 + (** [supports_byte_ranges ar] returns [true] if byte range requests are supported. *) 211 211 + 212 212 + (** {1 Cache-Status (RFC 9211)} 213 213 + 214 214 + The Cache-Status header field indicates how caches have handled a request. 215 215 + It is a List structured field (RFC 8941) where each member is a cache 216 216 + identifier with optional parameters. 217 217 + 218 218 + Example: [Cache-Status: "Cloudflare"; hit, ExampleCDN; fwd=uri-miss; stored] 219 219 + 220 220 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: The Cache-Status HTTP Response Header Field *) 221 221 + 222 222 + (** Forward/stored response indicator for Cache-Status *) 223 223 + type cache_status_fwd = 224 224 + | Fwd_uri_miss 225 225 + (** The cache did not contain any matching response *) 226 226 + | Fwd_vary_miss 227 227 + (** The cache contained a response, but Vary header prevented match *) 228 228 + | Fwd_miss 229 229 + (** The cache did not find a usable response (generic) *) 230 230 + | Fwd_request 231 231 + (** The request semantics required forwarding (e.g., no-cache) *) 232 232 + | Fwd_stale 233 233 + (** The cache had a stale response that needed revalidation *) 234 234 + | Fwd_partial 235 235 + (** The cache had a partial response that needed completion *) 236 236 + | Fwd_bypass 237 237 + (** The cache was configured to bypass for this request *) 238 238 + | Fwd_other of string 239 239 + (** Other forward reason *) 240 240 + 241 241 + (** A single cache status entry from the Cache-Status header *) 242 242 + type cache_status_entry = { 243 243 + cache_id : string; 244 244 + (** Identifier for the cache (e.g., "CDN", "proxy", "Cloudflare") *) 245 245 + hit : bool option; 246 246 + (** True if served from cache without forwarding *) 247 247 + fwd : cache_status_fwd option; 248 248 + (** Why the request was forwarded *) 249 249 + fwd_status : int option; 250 250 + (** Status code from the forwarded response *) 251 251 + stored : bool option; 252 252 + (** Whether the response was stored in cache *) 253 253 + collapsed : bool option; 254 254 + (** Whether request was collapsed with others *) 255 255 + ttl : int option; 256 256 + (** Time-to-live remaining in seconds *) 257 257 + key : string option; 258 258 + (** Cache key used *) 259 259 + detail : string option; 260 260 + (** Implementation-specific detail *) 261 261 + } 262 262 + 263 263 + val cache_status_fwd_of_string : string -> cache_status_fwd 264 264 + (** [cache_status_fwd_of_string s] parses a forward reason string. *) 265 265 + 266 266 + val cache_status_fwd_to_string : cache_status_fwd -> string 267 267 + (** [cache_status_fwd_to_string fwd] converts a forward reason to string. *) 268 268 + 269 269 + val parse_cache_status_entry : string -> cache_status_entry option 270 270 + (** [parse_cache_status_entry s] parses a single cache status entry. 271 271 + Format: [cache-id; param1; param2=value] *) 272 272 + 273 273 + val parse_cache_status : string -> cache_status_entry list 274 274 + (** [parse_cache_status s] parses a complete Cache-Status header value. 275 275 + 276 276 + Example: ["Cloudflare; hit, CDN; fwd=uri-miss"] -> list of entries *) 277 277 + 278 278 + val cache_status_entry_to_string : cache_status_entry -> string 279 279 + (** [cache_status_entry_to_string entry] formats a single entry. *) 280 280 + 281 281 + val cache_status_to_string : cache_status_entry list -> string 282 282 + (** [cache_status_to_string entries] formats entries as a header value. *) 283 283 + 284 284 + val cache_status_is_hit : cache_status_entry list -> bool 285 285 + (** [cache_status_is_hit entries] returns [true] if any cache reported a hit. *) 286 286 + 287 287 + val cache_status_is_stored : cache_status_entry list -> bool 288 288 + (** [cache_status_is_stored entries] returns [true] if any cache stored the response. *) 289 289 + 290 290 + val cache_status_get_fwd : cache_status_entry list -> cache_status_fwd option 291 291 + (** [cache_status_get_fwd entries] returns the forward reason from the first 292 292 + cache that forwarded the request, if any. *) 293 293 + 294 294 + (** {1 Content-Digest / Repr-Digest (RFC 9530)} 295 295 + 296 296 + Content-Digest contains a digest of the content (after content coding). 297 297 + Repr-Digest contains a digest of the representation (before content coding). 298 298 + 299 299 + These headers allow integrity verification of HTTP message bodies. 300 300 + 301 301 + Example: [Content-Digest: sha-256=:base64digest:] 302 302 + 303 303 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields *) 304 304 + 305 305 + (** Supported digest algorithms *) 306 306 + type digest_algorithm = 307 307 + | Sha256 308 308 + (** SHA-256 (recommended by RFC 9530) *) 309 309 + | Sha512 310 310 + (** SHA-512 *) 311 311 + | Other of string 312 312 + (** Other algorithm (for forward compatibility) *) 313 313 + 314 314 + val digest_algorithm_of_string : string -> digest_algorithm 315 315 + (** [digest_algorithm_of_string s] parses an algorithm name. 316 316 + Example: ["sha-256"] -> Sha256 *) 317 317 + 318 318 + val digest_algorithm_to_string : digest_algorithm -> string 319 319 + (** [digest_algorithm_to_string algo] converts to standard algorithm name. *) 320 320 + 321 321 + (** A single digest value with its algorithm *) 322 322 + type digest_value = { 323 323 + algorithm : digest_algorithm; 324 324 + (** The hash algorithm used *) 325 325 + digest : string; 326 326 + (** The base64-encoded digest value *) 327 327 + } 328 328 + 329 329 + val parse_digest_header : string -> digest_value list 330 330 + (** [parse_digest_header s] parses a Content-Digest or Repr-Digest header. 331 331 + 332 332 + Example: ["sha-256=:base64data:, sha-512=:base64data:"] -> list of values *) 333 333 + 334 334 + val digest_value_to_string : digest_value -> string 335 335 + (** [digest_value_to_string dv] formats a single digest value. *) 336 336 + 337 337 + val digest_header_to_string : digest_value list -> string 338 338 + (** [digest_header_to_string digests] formats as a header value. *) 339 339 + 340 340 + val compute_sha256 : string -> string 341 341 + (** [compute_sha256 content] computes SHA-256 and returns base64-encoded result. *) 342 342 + 343 343 + val compute_sha512 : string -> string 344 344 + (** [compute_sha512 content] computes SHA-512 and returns base64-encoded result. *) 345 345 + 346 346 + val compute_digest : algorithm:digest_algorithm -> string -> digest_value 347 347 + (** [compute_digest ~algorithm content] computes a digest using the specified algorithm. *) 348 348 + 349 349 + val make_content_digest : ?algorithm:digest_algorithm -> string -> digest_value 350 350 + (** [make_content_digest ?algorithm content] creates a Content-Digest value. 351 351 + Defaults to SHA-256 which is recommended by RFC 9530. *) 352 352 + 353 353 + val validate_digest : digests:digest_value list -> string -> bool 354 354 + (** [validate_digest ~digests content] validates content against provided digests. 355 355 + Returns [true] if any of the digests matches. *) 356 356 + 357 357 + val get_strongest_digest : digest_value list -> digest_value option 358 358 + (** [get_strongest_digest digests] returns the strongest available digest. 359 359 + Prefers SHA-512 over SHA-256 over others. *) 360 360 + 361 361 + (** {1 Strict-Transport-Security (RFC 6797)} 362 362 + 363 363 + The Strict-Transport-Security (HSTS) header tells browsers to only 364 364 + access the site over HTTPS, protecting against protocol downgrade 365 365 + attacks and cookie hijacking. 366 366 + 367 367 + Example: [Strict-Transport-Security: max-age=31536000; includeSubDomains; preload] 368 368 + 369 369 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 370 370 + 371 371 + (** HSTS directive values *) 372 372 + type hsts = { 373 373 + max_age : int64; 374 374 + (** Required: Time in seconds the browser should remember HTTPS-only *) 375 375 + include_subdomains : bool; 376 376 + (** If true, policy applies to all subdomains *) 377 377 + preload : bool; 378 378 + (** If true, site requests inclusion in browser preload lists *) 379 379 + } 380 380 + 381 381 + val parse_hsts : string -> hsts option 382 382 + (** [parse_hsts s] parses a Strict-Transport-Security header value. 383 383 + 384 384 + Returns [None] if the required max-age directive is missing. 385 385 + 386 386 + Example: ["max-age=31536000; includeSubDomains"] -> 387 387 + Some {max_age=31536000; include_subdomains=true; preload=false} *) 388 388 + 389 389 + val hsts_to_string : hsts -> string 390 390 + (** [hsts_to_string hsts] formats an HSTS value as a header string. 391 391 + 392 392 + Example: {max_age=31536000; include_subdomains=true; preload=false} -> 393 393 + ["max-age=31536000; includeSubDomains"] *) 394 394 + 395 395 + val make_hsts : ?max_age:int64 -> ?include_subdomains:bool -> ?preload:bool -> unit -> hsts 396 396 + (** [make_hsts ?max_age ?include_subdomains ?preload ()] creates an HSTS value. 397 397 + 398 398 + @param max_age Time in seconds (default: 1 year = 31536000) 399 399 + @param include_subdomains Apply to subdomains (default: false) 400 400 + @param preload Request preload list inclusion (default: false) *) 401 401 + 402 402 + val hsts_is_enabled : hsts -> bool 403 403 + (** [hsts_is_enabled hsts] returns [true] if HSTS is effectively enabled (max-age > 0). *) 404 404 + 405 405 + (** {2 Common HSTS Configurations} *) 406 406 + 407 407 + val hsts_one_year_subdomains : hsts 408 408 + (** One year with subdomains - recommended for production *) 409 409 + 410 410 + val hsts_preload : hsts 411 411 + (** Two years with subdomains and preload - for HSTS preload submission *) 412 412 + 413 413 + val hsts_disable : hsts 414 414 + (** Disable HSTS by setting max-age to 0 *)

+9 -25

lib/http_read.ml

··· 62 62 for i = 0 to len - 1 do 63 63 if s.[i] = '\r' then begin 64 64 if i + 1 >= len || s.[i + 1] <> '\n' then 65 65 - raise (Error.err (Error.Invalid_request { 66 66 - reason = Printf.sprintf "Bare CR in %s (potential HTTP smuggling attack)" context 67 67 - })) 65 65 + raise (Error.invalid_requestf "Bare CR in %s (potential HTTP smuggling attack)" context) 68 66 end 69 67 done 70 68 ··· 78 76 let status_code r = 79 77 let code_str = Read.take_while is_digit r in 80 78 if String.length code_str <> 3 then 81 81 - raise (Error.err (Error.Invalid_request { 82 82 - reason = "Invalid status code: " ^ code_str 83 83 - })); 79 79 + raise (Error.invalid_requestf "Invalid status code: %s" code_str); 84 80 try int_of_string code_str 85 81 with _ -> 86 86 - raise (Error.err (Error.Invalid_request { 87 87 - reason = "Invalid status code: " ^ code_str 88 88 - })) 82 82 + raise (Error.invalid_requestf "Invalid status code: %s" code_str) 89 83 90 84 let reason_phrase r = 91 85 Read.line r ··· 101 95 let http_version_of_string = function 102 96 | "HTTP/1.0" -> HTTP_1_0 103 97 | "HTTP/1.1" -> HTTP_1_1 104 104 - | v -> raise (Error.err (Error.Invalid_request { 105 105 - reason = "Invalid HTTP version: " ^ v 106 106 - })) 98 98 + | v -> raise (Error.invalid_requestf "Invalid HTTP version: %s" v) 107 99 108 100 let http_version_to_string = function 109 101 | HTTP_1_0 -> "HTTP/1.0" ··· 285 277 (* Protect against overflow: limit hex digits to prevent parsing huge numbers. 286 278 16 hex digits = 64-bit max, which is way more than any reasonable chunk. *) 287 279 if String.length hex_str > max_chunk_size_hex_digits then 288 288 - raise (Error.err (Error.Invalid_request { 289 289 - reason = Printf.sprintf "Chunk size too large (%d hex digits, max %d)" 290 290 - (String.length hex_str) max_chunk_size_hex_digits 291 291 - })); 280 280 + raise (Error.invalid_requestf "Chunk size too large (%d hex digits, max %d)" 281 281 + (String.length hex_str) max_chunk_size_hex_digits); 292 282 (* Skip any chunk extensions (after semicolon) - validate for bare CR *) 293 283 let extensions = Read.take_while (fun c -> c <> '\r' && c <> '\n') r in 294 284 validate_no_bare_cr ~context:"chunk extension" extensions; 295 285 let _ = Read.line r in (* Consume CRLF *) 296 286 try int_of_string ("0x" ^ hex_str) 297 287 with _ -> 298 298 - raise (Error.err (Error.Invalid_request { 299 299 - reason = "Invalid chunk size: " ^ hex_str 300 300 - })) 288 288 + raise (Error.invalid_requestf "Invalid chunk size: %s" hex_str) 301 289 302 290 (** {1 Trailer Header Parsing} 303 291 ··· 694 682 (* Per RFC 9110 Section 8.6: Content-Length MUST be >= 0 *) 695 683 if len < 0L then begin 696 684 Log.warn (fun m -> m "Negative Content-Length rejected: %s" s); 697 697 - raise (Error.err (Error.Invalid_request { 698 698 - reason = Printf.sprintf "Content-Length cannot be negative: %s" s 699 699 - })) 685 685 + raise (Error.invalid_requestf "Content-Length cannot be negative: %s" s) 700 686 end; 701 687 Some len 702 688 with Failure _ -> 703 689 Log.warn (fun m -> m "Invalid Content-Length header value: %s" s); 704 704 - raise (Error.err (Error.Invalid_request { 705 705 - reason = "Invalid Content-Length header: " ^ s 706 706 - })) 690 690 + raise (Error.invalid_requestf "Invalid Content-Length header: %s" s) 707 691 708 692 (** Parse complete response (status + headers + body) to string. 709 693 Per {{:https://datatracker.ietf.org/doc/html/rfc9112#section-6}RFC 9112 Section 6}}. *)

+9 -20

lib/proxy_tunnel.ml

··· 67 67 let status = 68 68 try int_of_string status_str 69 69 with _ -> 70 70 - raise (Error.err (Error.Proxy_error { 71 71 - host = proxy.Proxy.host; 72 72 - reason = Printf.sprintf "Invalid status code in CONNECT response: %s" status_str 73 73 - })) 70 70 + raise (Error.proxy_errorf ~host:proxy.Proxy.host 71 71 + "Invalid status code in CONNECT response: %s" status_str) 74 72 in 75 73 76 74 Log.debug (fun m -> m "CONNECT response: %s %d %s" version_str status reason); ··· 84 82 85 83 (* Check for success (2xx) *) 86 84 if status < 200 || status >= 300 then 87 87 - raise (Error.err (Error.Proxy_error { 88 88 - host = proxy.Proxy.host; 89 89 - reason = Printf.sprintf "CONNECT to %s failed: %d %s" target status reason 90 90 - })); 85 85 + raise (Error.proxy_errorf ~host:proxy.Proxy.host 86 86 + "CONNECT to %s failed: %d %s" target status reason); 91 87 92 88 Log.info (fun m -> m "CONNECT tunnel established to %s via proxy %s:%d" 93 89 target proxy.Proxy.host proxy.Proxy.port) ··· 171 167 (match Domain_name.host domain with 172 168 | Ok host -> host 173 169 | Error (`Msg msg) -> 174 174 - raise (Error.err (Error.Tls_handshake_failed { 175 175 - host = target_host; 176 176 - reason = Printf.sprintf "Invalid hostname for SNI: %s" msg 177 177 - }))) 170 170 + raise (Error.tls_handshake_failedf ~host:target_host 171 171 + "Invalid hostname for SNI: %s" msg)) 178 172 | Error (`Msg msg) -> 179 179 - raise (Error.err (Error.Tls_handshake_failed { 180 180 - host = target_host; 181 181 - reason = Printf.sprintf "Invalid domain name: %s" msg 182 182 - })) 173 173 + raise (Error.tls_handshake_failedf ~host:target_host 174 174 + "Invalid domain name: %s" msg) 183 175 in 184 176 185 177 Log.debug (fun m -> m "Starting TLS handshake with %s through tunnel" target_host); ··· 190 182 target_host proxy.Proxy.host proxy.Proxy.port); 191 183 (tls_flow :> Eio.Flow.two_way_ty Eio.Resource.t) 192 184 with exn -> 193 193 - raise (Error.err (Error.Tls_handshake_failed { 194 194 - host = target_host; 195 195 - reason = Printexc.to_string exn 196 196 - })) 185 185 + raise (Error.tls_handshake_failedf ~host:target_host "%s" (Printexc.to_string exn))

+1 -4

lib/redirect.ml

··· 57 57 | Some scheme when List.mem (String.lowercase_ascii scheme) allowed_schemes -> 58 58 uri 59 59 | Some scheme -> 60 60 - raise (Error.err (Error.Invalid_redirect { 61 61 - url = location; 62 62 - reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme 63 63 - })) 60 60 + raise (Error.invalid_redirectf ~url:location "Disallowed redirect scheme: %s" scheme) 64 61 | None -> 65 62 uri (* Relative URLs are OK - they will be resolved against current URL *)

+3

lib/requests.ml

··· 29 29 module Version = Version 30 30 module Link = Link 31 31 module Timing = Timing 32 32 + module Header_name = Header_name 33 33 + module Header_parsing = Header_parsing 34 34 + module Websocket = Websocket 32 35 33 36 (** Minimum TLS version configuration - re-exported from Tls_config. *) 34 37 type tls_version = Tls_config.tls_version =

+11

lib/requests.mli

··· 917 917 (** HTTP request timing metrics for performance analysis *) 918 918 module Timing = Timing 919 919 920 920 + (** HTTP header name types and utilities *) 921 921 + module Header_name = Header_name 922 922 + 923 923 + (** HTTP header value parsing for complex headers (RFC 9110) 924 924 + @see <https://www.rfc-editor.org/rfc/rfc9110> *) 925 925 + module Header_parsing = Header_parsing 926 926 + 927 927 + (** WebSocket handshake support (RFC 6455) 928 928 + @see <https://www.rfc-editor.org/rfc/rfc6455> *) 929 929 + module Websocket = Websocket 930 930 + 920 931 (** {2 Logging} *) 921 932 922 933 (** Log source for the requests library.

+4 -5

lib/retry.ml

··· 84 84 (* Per RFC 9110 Section 9.2.2: Only idempotent methods should be retried automatically *) 85 85 if status_retryable && not method_allowed then begin 86 86 if config.strict_method_semantics then 87 87 - raise (Error.err (Error.Invalid_request { 88 88 - reason = Printf.sprintf "Cannot retry %s request: method is not idempotent \ 89 89 - (RFC 9110 Section 9.2.2). Disable strict_method_semantics to allow." 90 90 - (Method.to_string method_) 91 91 - })) 87 87 + raise (Error.invalid_requestf 88 88 + "Cannot retry %s request: method is not idempotent \ 89 89 + (RFC 9110 Section 9.2.2). Disable strict_method_semantics to allow." 90 90 + (Method.to_string method_)) 92 91 else 93 92 Log.debug (fun m -> m "Not retrying %s request (status %d): method is not idempotent \ 94 93 (RFC 9110 Section 9.2.2)" (Method.to_string method_) status)

+260

lib/websocket.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** WebSocket Protocol Support (RFC 6455) 7 7 + 8 8 + This module provides functions for the WebSocket HTTP upgrade handshake. 9 9 + WebSocket connections are established by upgrading an HTTP/1.1 connection 10 10 + using the Upgrade mechanism. 11 11 + 12 12 + @see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455: The WebSocket Protocol *) 13 13 + 14 14 + let src = Logs.Src.create "requests.websocket" ~doc:"WebSocket Support" 15 15 + module Log = (val Logs.src_log src : Logs.LOG) 16 16 + 17 17 + (** {1 Constants} *) 18 18 + 19 19 + (** The WebSocket protocol version per RFC 6455. 20 20 + This is the only version defined by the RFC. *) 21 21 + let protocol_version = "13" 22 22 + 23 23 + (** The magic GUID used in Sec-WebSocket-Accept computation. 24 24 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-1.3> RFC 6455 Section 1.3 *) 25 25 + let magic_guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" 26 26 + 27 27 + (** {1 Sec-WebSocket-Key Generation} 28 28 + 29 29 + The client generates a random 16-byte value, base64-encodes it, and sends 30 30 + it in the Sec-WebSocket-Key header. This proves the server understands 31 31 + the WebSocket protocol. 32 32 + 33 33 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1> RFC 6455 Section 4.1 *) 34 34 + 35 35 + (** Generate a random Sec-WebSocket-Key value. 36 36 + 37 37 + Creates a cryptographically random 16-byte nonce and base64-encodes it. 38 38 + The result is suitable for use in the Sec-WebSocket-Key header. *) 39 39 + let generate_key () = 40 40 + let random_bytes = Mirage_crypto_rng.generate 16 in 41 41 + let key = Base64.encode_exn random_bytes in 42 42 + Log.debug (fun m -> m "Generated WebSocket key: %s" key); 43 43 + key 44 44 + 45 45 + (** {1 Sec-WebSocket-Accept Computation} 46 46 + 47 47 + The server computes Sec-WebSocket-Accept as: 48 48 + [base64(SHA-1(Sec-WebSocket-Key + magic_guid))] 49 49 + 50 50 + This proves the server received the client's handshake and understands 51 51 + the WebSocket protocol. 52 52 + 53 53 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.2.2> RFC 6455 Section 4.2.2 *) 54 54 + 55 55 + (** Compute the expected Sec-WebSocket-Accept value for a given key. 56 56 + 57 57 + @param key The Sec-WebSocket-Key sent by the client 58 58 + @return The expected Sec-WebSocket-Accept value *) 59 59 + let compute_accept ~key = 60 60 + let combined = key ^ magic_guid in 61 61 + let hash = Digestif.SHA1.(digest_string combined |> to_raw_string) in 62 62 + let accept = Base64.encode_exn hash in 63 63 + Log.debug (fun m -> m "Computed WebSocket accept for key %s: %s" key accept); 64 64 + accept 65 65 + 66 66 + (** Validate a server's Sec-WebSocket-Accept value. 67 67 + 68 68 + @param key The Sec-WebSocket-Key that was sent 69 69 + @param accept The Sec-WebSocket-Accept received from the server 70 70 + @return [true] if the accept value is correct *) 71 71 + let validate_accept ~key ~accept = 72 72 + let expected = compute_accept ~key in 73 73 + let valid = String.equal expected accept in 74 74 + if not valid then 75 75 + Log.warn (fun m -> m "WebSocket accept validation failed: expected %s, got %s" 76 76 + expected accept); 77 77 + valid 78 78 + 79 79 + (** {1 Sec-WebSocket-Protocol Negotiation} 80 80 + 81 81 + The client sends a list of desired subprotocols; the server selects one. 82 82 + Common subprotocols include "graphql-ws", "graphql-transport-ws", "wamp.2.json". 83 83 + 84 84 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-11.3.4> RFC 6455 Section 11.3.4 *) 85 85 + 86 86 + (** Parse a Sec-WebSocket-Protocol header value into a list of protocols. 87 87 + 88 88 + The header value is a comma-separated list of protocol identifiers. *) 89 89 + let parse_protocols s = 90 90 + String.split_on_char ',' s 91 91 + |> List.map String.trim 92 92 + |> List.filter (fun s -> String.length s > 0) 93 93 + 94 94 + (** Format a list of protocols as a Sec-WebSocket-Protocol header value. *) 95 95 + let protocols_to_string protocols = 96 96 + String.concat ", " protocols 97 97 + 98 98 + (** Select a protocol from the offered list that matches one we support. 99 99 + 100 100 + @param offered The protocols offered by the client 101 101 + @param supported The protocols we support (in preference order) 102 102 + @return The selected protocol, or [None] if no match *) 103 103 + let select_protocol ~offered ~supported = 104 104 + List.find_opt (fun s -> List.mem s offered) supported 105 105 + 106 106 + (** {1 Sec-WebSocket-Extensions Parsing} 107 107 + 108 108 + Extensions provide additional capabilities like compression. 109 109 + The most common extension is "permessage-deflate" (RFC 7692). 110 110 + 111 111 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-9> RFC 6455 Section 9 112 112 + @see <https://www.rfc-editor.org/rfc/rfc7692> RFC 7692: Compression Extensions *) 113 113 + 114 114 + (** An extension with optional parameters. 115 115 + 116 116 + Example: [("permessage-deflate", [("client_max_window_bits", None)])] *) 117 117 + type extension = { 118 118 + name : string; 119 119 + params : (string * string option) list; 120 120 + } 121 121 + 122 122 + (** Parse a single extension (name with optional parameters). 123 123 + 124 124 + Format: [name; param1; param2=value; ...] *) 125 125 + let parse_single_extension s = 126 126 + let parts = String.split_on_char ';' s |> List.map String.trim in 127 127 + match parts with 128 128 + | [] -> None 129 129 + | name :: params -> 130 130 + let parse_param p = 131 131 + match String.index_opt p '=' with 132 132 + | None -> (String.trim p, None) 133 133 + | Some eq_idx -> 134 134 + let key = String.trim (String.sub p 0 eq_idx) in 135 135 + let value = String.trim (String.sub p (eq_idx + 1) (String.length p - eq_idx - 1)) in 136 136 + (* Remove quotes if present *) 137 137 + let value = if String.length value >= 2 && value.[0] = '"' then 138 138 + String.sub value 1 (String.length value - 2) 139 139 + else value 140 140 + in 141 141 + (key, Some value) 142 142 + in 143 143 + Some { 144 144 + name = String.trim name; 145 145 + params = List.map parse_param params; 146 146 + } 147 147 + 148 148 + (** Parse a Sec-WebSocket-Extensions header value. 149 149 + 150 150 + Format is comma-separated extensions, each with semicolon-separated parameters: 151 151 + [permessage-deflate; client_max_window_bits, another-ext] *) 152 152 + let parse_extensions s = 153 153 + (* Split on commas, but be careful of quoted values *) 154 154 + let extensions = String.split_on_char ',' s in 155 155 + List.filter_map parse_single_extension extensions 156 156 + 157 157 + (** Format extensions as a Sec-WebSocket-Extensions header value. *) 158 158 + let extensions_to_string extensions = 159 159 + let ext_to_string ext = 160 160 + let params_str = List.map (fun (k, v) -> 161 161 + match v with 162 162 + | None -> k 163 163 + | Some v -> Printf.sprintf "%s=%s" k v 164 164 + ) ext.params in 165 165 + String.concat "; " (ext.name :: params_str) 166 166 + in 167 167 + String.concat ", " (List.map ext_to_string extensions) 168 168 + 169 169 + (** Check if an extension is present in a list. *) 170 170 + let has_extension ~name extensions = 171 171 + List.exists (fun ext -> String.equal ext.name name) extensions 172 172 + 173 173 + (** Get parameters for a specific extension. *) 174 174 + let get_extension_params ~name extensions = 175 175 + match List.find_opt (fun ext -> String.equal ext.name name) extensions with 176 176 + | Some ext -> Some ext.params 177 177 + | None -> None 178 178 + 179 179 + (** {1 Handshake Header Helpers} *) 180 180 + 181 181 + (** Build the headers for a WebSocket upgrade request. 182 182 + 183 183 + @param key The Sec-WebSocket-Key (use {!generate_key} to create) 184 184 + @param protocols Optional list of subprotocols to request 185 185 + @param extensions Optional list of extensions to request 186 186 + @param origin Optional Origin header value *) 187 187 + let make_upgrade_headers ~key ?protocols ?extensions ?origin () = 188 188 + let headers = Headers.empty 189 189 + |> Headers.set `Upgrade "websocket" 190 190 + |> Headers.set `Connection "Upgrade" 191 191 + |> Headers.set `Sec_websocket_key key 192 192 + |> Headers.set `Sec_websocket_version protocol_version 193 193 + in 194 194 + let headers = match protocols with 195 195 + | Some ps when ps <> [] -> 196 196 + Headers.set `Sec_websocket_protocol (protocols_to_string ps) headers 197 197 + | _ -> headers 198 198 + in 199 199 + let headers = match extensions with 200 200 + | Some exts when exts <> [] -> 201 201 + Headers.set `Sec_websocket_extensions (extensions_to_string exts) headers 202 202 + | _ -> headers 203 203 + in 204 204 + let headers = match origin with 205 205 + | Some o -> Headers.set `Origin o headers 206 206 + | None -> headers 207 207 + in 208 208 + headers 209 209 + 210 210 + (** Helper to check if a string contains a substring. *) 211 211 + let string_contains ~needle haystack = 212 212 + let nlen = String.length needle in 213 213 + let hlen = String.length haystack in 214 214 + if nlen > hlen then false 215 215 + else 216 216 + let rec check i = 217 217 + if i + nlen > hlen then false 218 218 + else if String.sub haystack i nlen = needle then true 219 219 + else check (i + 1) 220 220 + in 221 221 + check 0 222 222 + 223 223 + (** Validate a WebSocket upgrade response. 224 224 + 225 225 + Checks that: 226 226 + - Status code is 101 (Switching Protocols) 227 227 + - Upgrade header is "websocket" 228 228 + - Connection header includes "Upgrade" 229 229 + - Sec-WebSocket-Accept is correct for the given key 230 230 + 231 231 + @param key The Sec-WebSocket-Key that was sent 232 232 + @param status The HTTP status code 233 233 + @param headers The response headers 234 234 + @return [Ok ()] if valid, [Error reason] if invalid *) 235 235 + let validate_upgrade_response ~key ~status ~headers = 236 236 + (* Check status code *) 237 237 + if status <> 101 then 238 238 + Error (Printf.sprintf "Expected status 101, got %d" status) 239 239 + (* Check Upgrade header *) 240 240 + else match Headers.get `Upgrade headers with 241 241 + | None -> Error "Missing Upgrade header" 242 242 + | Some upgrade when String.lowercase_ascii upgrade <> "websocket" -> 243 243 + Error (Printf.sprintf "Upgrade header is '%s', expected 'websocket'" upgrade) 244 244 + | Some _ -> 245 245 + (* Check Connection header *) 246 246 + match Headers.get `Connection headers with 247 247 + | None -> Error "Missing Connection header" 248 248 + | Some conn -> 249 249 + let conn_lower = String.lowercase_ascii conn in 250 250 + if not (string_contains ~needle:"upgrade" conn_lower) then 251 251 + Error (Printf.sprintf "Connection header is '%s', expected 'Upgrade'" conn) 252 252 + else 253 253 + (* Check Sec-WebSocket-Accept *) 254 254 + match Headers.get `Sec_websocket_accept headers with 255 255 + | None -> Error "Missing Sec-WebSocket-Accept header" 256 256 + | Some accept -> 257 257 + if validate_accept ~key ~accept then 258 258 + Ok () 259 259 + else 260 260 + Error "Sec-WebSocket-Accept validation failed"

+156

lib/websocket.mli

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** WebSocket Protocol Support (RFC 6455) 7 7 + 8 8 + This module provides functions for the WebSocket HTTP upgrade handshake. 9 9 + WebSocket connections are established by upgrading an HTTP/1.1 connection 10 10 + using the Upgrade mechanism. 11 11 + 12 12 + {2 Basic Usage} 13 13 + 14 14 + {[ 15 15 + (* Client: initiate WebSocket upgrade *) 16 16 + let key = Websocket.generate_key () in 17 17 + let headers = Websocket.make_upgrade_headers ~key () in 18 18 + (* ... send request with these headers ... *) 19 19 + 20 20 + (* Client: validate server response *) 21 21 + match Websocket.validate_upgrade_response ~key ~status ~headers with 22 22 + | Ok () -> (* Connection upgraded successfully *) 23 23 + | Error reason -> (* Handshake failed *) 24 24 + ]} 25 25 + 26 26 + @see <https://www.rfc-editor.org/rfc/rfc6455> RFC 6455: The WebSocket Protocol *) 27 27 + 28 28 + (** {1 Constants} *) 29 29 + 30 30 + val protocol_version : string 31 31 + (** The WebSocket protocol version per RFC 6455. 32 32 + This is always ["13"]. *) 33 33 + 34 34 + val magic_guid : string 35 35 + (** The magic GUID used in Sec-WebSocket-Accept computation. 36 36 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-1.3> RFC 6455 Section 1.3 *) 37 37 + 38 38 + (** {1 Sec-WebSocket-Key} 39 39 + 40 40 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.1> RFC 6455 Section 4.1 *) 41 41 + 42 42 + val generate_key : unit -> string 43 43 + (** [generate_key ()] creates a random Sec-WebSocket-Key value. 44 44 + 45 45 + Generates a cryptographically random 16-byte nonce and base64-encodes it. 46 46 + The result is suitable for use in the Sec-WebSocket-Key header. *) 47 47 + 48 48 + (** {1 Sec-WebSocket-Accept} 49 49 + 50 50 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-4.2.2> RFC 6455 Section 4.2.2 *) 51 51 + 52 52 + val compute_accept : key:string -> string 53 53 + (** [compute_accept ~key] computes the expected Sec-WebSocket-Accept value. 54 54 + 55 55 + The computation is: [base64(SHA-1(key + magic_guid))] 56 56 + 57 57 + @param key The Sec-WebSocket-Key sent by the client 58 58 + @return The expected Sec-WebSocket-Accept value *) 59 59 + 60 60 + val validate_accept : key:string -> accept:string -> bool 61 61 + (** [validate_accept ~key ~accept] validates a server's Sec-WebSocket-Accept. 62 62 + 63 63 + @param key The Sec-WebSocket-Key that was sent 64 64 + @param accept The Sec-WebSocket-Accept received from the server 65 65 + @return [true] if the accept value is correct *) 66 66 + 67 67 + (** {1 Sec-WebSocket-Protocol} 68 68 + 69 69 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-11.3.4> RFC 6455 Section 11.3.4 *) 70 70 + 71 71 + val parse_protocols : string -> string list 72 72 + (** [parse_protocols s] parses a Sec-WebSocket-Protocol header value. 73 73 + 74 74 + Example: ["graphql-ws, graphql-transport-ws"] -> [["graphql-ws"; "graphql-transport-ws"]] *) 75 75 + 76 76 + val protocols_to_string : string list -> string 77 77 + (** [protocols_to_string protocols] formats protocols as a header value. *) 78 78 + 79 79 + val select_protocol : offered:string list -> supported:string list -> string option 80 80 + (** [select_protocol ~offered ~supported] selects a mutually acceptable protocol. 81 81 + 82 82 + @param offered The protocols offered by the client 83 83 + @param supported The protocols we support (in preference order) 84 84 + @return The selected protocol, or [None] if no match *) 85 85 + 86 86 + (** {1 Sec-WebSocket-Extensions} 87 87 + 88 88 + @see <https://www.rfc-editor.org/rfc/rfc6455#section-9> RFC 6455 Section 9 89 89 + @see <https://www.rfc-editor.org/rfc/rfc7692> RFC 7692: Compression Extensions *) 90 90 + 91 91 + (** An extension with optional parameters. 92 92 + 93 93 + Example: [permessage-deflate; client_max_window_bits] *) 94 94 + type extension = { 95 95 + name : string; 96 96 + params : (string * string option) list; 97 97 + } 98 98 + 99 99 + val parse_extensions : string -> extension list 100 100 + (** [parse_extensions s] parses a Sec-WebSocket-Extensions header value. 101 101 + 102 102 + Example: ["permessage-deflate; client_max_window_bits"] *) 103 103 + 104 104 + val extensions_to_string : extension list -> string 105 105 + (** [extensions_to_string extensions] formats extensions as a header value. *) 106 106 + 107 107 + val has_extension : name:string -> extension list -> bool 108 108 + (** [has_extension ~name extensions] checks if an extension is present. *) 109 109 + 110 110 + val get_extension_params : name:string -> extension list -> (string * string option) list option 111 111 + (** [get_extension_params ~name extensions] gets parameters for an extension. *) 112 112 + 113 113 + (** {1 Handshake Helpers} *) 114 114 + 115 115 + val make_upgrade_headers : 116 116 + key:string -> 117 117 + ?protocols:string list -> 118 118 + ?extensions:extension list -> 119 119 + ?origin:string -> 120 120 + unit -> 121 121 + Headers.t 122 122 + (** [make_upgrade_headers ~key ?protocols ?extensions ?origin ()] builds 123 123 + headers for a WebSocket upgrade request. 124 124 + 125 125 + Sets the following headers: 126 126 + - [Upgrade: websocket] 127 127 + - [Connection: Upgrade] 128 128 + - [Sec-WebSocket-Key: {key}] 129 129 + - [Sec-WebSocket-Version: 13] 130 130 + - [Sec-WebSocket-Protocol: ...] (if protocols provided) 131 131 + - [Sec-WebSocket-Extensions: ...] (if extensions provided) 132 132 + - [Origin: ...] (if origin provided) 133 133 + 134 134 + @param key The Sec-WebSocket-Key (use {!generate_key} to create) 135 135 + @param protocols Optional list of subprotocols to request 136 136 + @param extensions Optional list of extensions to request 137 137 + @param origin Optional Origin header value *) 138 138 + 139 139 + val validate_upgrade_response : 140 140 + key:string -> 141 141 + status:int -> 142 142 + headers:Headers.t -> 143 143 + (unit, string) result 144 144 + (** [validate_upgrade_response ~key ~status ~headers] validates a WebSocket 145 145 + upgrade response. 146 146 + 147 147 + Checks that: 148 148 + - Status code is 101 (Switching Protocols) 149 149 + - Upgrade header is "websocket" 150 150 + - Connection header includes "Upgrade" 151 151 + - Sec-WebSocket-Accept is correct for the given key 152 152 + 153 153 + @param key The Sec-WebSocket-Key that was sent 154 154 + @param status The HTTP status code 155 155 + @param headers The response headers 156 156 + @return [Ok ()] if valid, [Error reason] if invalid *)

+256

specs/http-fields.csv

··· 1 1 + Field Name,Status,Structured Type,Reference,Comments 2 2 + A-IM,permanent,,[RFC 3229: Delta encoding in HTTP], 3 3 + Accept,permanent,,"[RFC 9110, Section 12.5.1: HTTP Semantics]", 4 4 + Accept-Additions,permanent,,[RFC 2324: Hyper Text Coffee Pot Control Protocol (HTCPCP/1.0)], 5 5 + Accept-CH,permanent,List,"[RFC 8942, Section 3.1: HTTP Client Hints]", 6 6 + Accept-Charset,deprecated,,"[RFC 9110, Section 12.5.2: HTTP Semantics]", 7 7 + Accept-Datetime,permanent,,[RFC 7089: HTTP Framework for Time-Based Access to Resource States -- Memento], 8 8 + Accept-Encoding,permanent,,"[RFC 9110, Section 12.5.3: HTTP Semantics]", 9 9 + Accept-Features,permanent,,[RFC 2295: Transparent Content Negotiation in HTTP], 10 10 + Accept-Language,permanent,,"[RFC 9110, Section 12.5.4: HTTP Semantics]", 11 11 + Accept-Patch,permanent,,[RFC 5789: PATCH Method for HTTP], 12 12 + Accept-Post,permanent,,[Linked Data Platform 1.0], 13 13 + Accept-Query,permanent,List,"[RFC-ietf-httpbis-safe-method-w-body-14, Section 3: The HTTP QUERY Method]", 14 14 + Accept-Ranges,permanent,,"[RFC 9110, Section 14.3: HTTP Semantics]", 15 15 + Accept-Signature,permanent,,"[RFC 9421, Section 5.1: HTTP Message Signatures]", 16 16 + Access-Control,obsoleted,,[Access Control for Cross-site Requests], 17 17 + Access-Control-Allow-Credentials,permanent,,[Fetch], 18 18 + Access-Control-Allow-Headers,permanent,,[Fetch], 19 19 + Access-Control-Allow-Methods,permanent,,[Fetch], 20 20 + Access-Control-Allow-Origin,permanent,,[Fetch], 21 21 + Access-Control-Expose-Headers,permanent,,[Fetch], 22 22 + Access-Control-Max-Age,permanent,,[Fetch], 23 23 + Access-Control-Request-Headers,permanent,,[Fetch], 24 24 + Access-Control-Request-Method,permanent,,[Fetch], 25 25 + Activate-Storage-Access,provisional,Item,[https://privacycg.github.io/storage-access-headers], 26 26 + Age,permanent,,"[RFC 9111, Section 5.1: HTTP Caching]", 27 27 + Allow,permanent,,"[RFC 9110, Section 10.2.1: HTTP Semantics]", 28 28 + ALPN,permanent,,"[RFC 7639, Section 2: The ALPN HTTP Header Field]", 29 29 + Alt-Svc,permanent,,[RFC 7838: HTTP Alternative Services], 30 30 + Alt-Used,permanent,,[RFC 7838: HTTP Alternative Services], 31 31 + Alternates,permanent,,[RFC 2295: Transparent Content Negotiation in HTTP], 32 32 + AMP-Cache-Transform,provisional,,[AMP-Cache-Transform HTTP request header], 33 33 + Apply-To-Redirect-Ref,permanent,,[RFC 4437: Web Distributed Authoring and Versioning (WebDAV) Redirect Reference Resources], 34 34 + Authentication-Control,permanent,,"[RFC 8053, Section 4: HTTP Authentication Extensions for Interactive Clients]", 35 35 + Authentication-Info,permanent,,"[RFC 9110, Section 11.6.3: HTTP Semantics]", 36 36 + Authorization,permanent,,"[RFC 9110, Section 11.6.2: HTTP Semantics]", 37 37 + Available-Dictionary,permanent,,"[RFC 9842, Section 2.2: Compression Dictionary Transport]", 38 38 + C-Ext,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 39 39 + C-Man,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 40 40 + C-Opt,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 41 41 + C-PEP,obsoleted,,[PEP - an Extension Mechanism for HTTP],[Status change of HTTP experiments to Historic] 42 42 + C-PEP-Info,deprecated,,[PEP - an Extension Mechanism for HTTP],[Status change of HTTP experiments to Historic] 43 43 + Cache-Control,permanent,,"[RFC 9111, Section 5.2: HTTP Caching]", 44 44 + Cache-Group-Invalidation,permanent,,[RFC9875: HTTP Cache Groups], 45 45 + Cache-Groups,permanent,,[RFC9875: HTTP Cache Groups], 46 46 + Cache-Status,permanent,List,[RFC 9211: The Cache-Status HTTP Response Header Field], 47 47 + Cal-Managed-ID,permanent,,"[RFC 8607, Section 5.1: Calendaring Extensions to WebDAV (CalDAV): Managed Attachments]", 48 48 + CalDAV-Timezones,permanent,,"[RFC 7809, Section 7.1: Calendaring Extensions to WebDAV (CalDAV): Time Zones by Reference]", 49 49 + Capsule-Protocol,permanent,,[RFC 9297: HTTP Datagrams and the Capsule Protocol], 50 50 + CDN-Cache-Control,permanent,Dictionary,[RFC 9213: Targeted HTTP Cache Control],Cache directives targeted at content delivery networks 51 51 + CDN-Loop,permanent,,[RFC 8586: Loop Detection in Content Delivery Networks (CDNs)], 52 52 + Cert-Not-After,permanent,,"[RFC 8739, Section 3.3: Support for Short-Term, Automatically Renewed (STAR) Certificates in the Automated Certificate Management Environment (ACME)]", 53 53 + Cert-Not-Before,permanent,,"[RFC 8739, Section 3.3: Support for Short-Term, Automatically Renewed (STAR) Certificates in the Automated Certificate Management Environment (ACME)]", 54 54 + Clear-Site-Data,permanent,,[Clear Site Data], 55 55 + Client-Cert,permanent,Item,"[RFC 9440, Section 2: Client-Cert HTTP Header Field]", 56 56 + Client-Cert-Chain,permanent,List,"[RFC 9440, Section 2: Client-Cert HTTP Header Field]", 57 57 + Close,permanent,,"[RFC 9112, Section 9.6: HTTP/1.1]",(reserved) 58 58 + CMCD-Object,provisional,,[CTA][CTA-5004 Common Media Client Data], 59 59 + CMCD-Request,provisional,,[CTA][CTA-5004 Common Media Client Data], 60 60 + CMCD-Session,provisional,,[CTA][CTA-5004 Common Media Client Data], 61 61 + CMCD-Status,provisional,,[CTA][CTA-5004 Common Media Client Data], 62 62 + CMSD-Dynamic,provisional,,[CTA][CTA-5006 Common Media Server Data (CMSD)], 63 63 + CMSD-Static,provisional,,[CTA][CTA-5006 Common Media Server Data (CMSD)], 64 64 + Concealed-Auth-Export,permanent,Item,[RFC 9729: The Concealed HTTP Authentication Scheme], 65 65 + Configuration-Context,provisional,,[OSLC Configuration Management Version 1.0. Part 3: Configuration Specification], 66 66 + Connection,permanent,,"[RFC 9110, Section 7.6.1: HTTP Semantics]", 67 67 + Content-Base,obsoleted,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1],Obsoleted by [RFC 2616: Hypertext Transfer Protocol -- HTTP/1.1] 68 68 + Content-Digest,permanent,,"[RFC 9530, Section 2: Digest Fields]", 69 69 + Content-Disposition,permanent,,[RFC 6266: Use of the Content-Disposition Header Field in the Hypertext Transfer Protocol (HTTP)], 70 70 + Content-Encoding,permanent,,"[RFC 9110, Section 8.4: HTTP Semantics]", 71 71 + Content-ID,deprecated,,[The HTTP Distribution and Replication Protocol], 72 72 + Content-Language,permanent,,"[RFC 9110, Section 8.5: HTTP Semantics]", 73 73 + Content-Length,permanent,,"[RFC 9110, Section 8.6: HTTP Semantics]", 74 74 + Content-Location,permanent,,"[RFC 9110, Section 8.7: HTTP Semantics]", 75 75 + Content-MD5,obsoleted,,"[RFC 2616, Section 14.15: Hypertext Transfer Protocol -- HTTP/1.1]","Obsoleted by [RFC 7231, Appendix B: Hypertext Transfer Protocol (HTTP/1.1): Semantics and Content]" 76 76 + Content-Range,permanent,,"[RFC 9110, Section 14.4: HTTP Semantics]", 77 77 + Content-Script-Type,obsoleted,,[HTML 4.01 Specification], 78 78 + Content-Security-Policy,permanent,,[Content Security Policy Level 3], 79 79 + Content-Security-Policy-Report-Only,permanent,,[Content Security Policy Level 3], 80 80 + Content-Style-Type,obsoleted,,[HTML 4.01 Specification], 81 81 + Content-Type,permanent,,"[RFC 9110, Section 8.3: HTTP Semantics]", 82 82 + Content-Version,obsoleted,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1], 83 83 + Cookie,permanent,,"[RFC-ietf-httpbis-rfc6265bis-22, Section 5.8.1: Cookies: HTTP State Management Mechanism]", 84 84 + Cookie2,obsoleted,,[RFC 2965: HTTP State Management Mechanism],Obsoleted by [RFC 6265: HTTP State Management Mechanism] 85 85 + Cross-Origin-Embedder-Policy,permanent,Item,[HTML], 86 86 + Cross-Origin-Embedder-Policy-Report-Only,permanent,Item,[HTML], 87 87 + Cross-Origin-Opener-Policy,permanent,Item,[HTML], 88 88 + Cross-Origin-Opener-Policy-Report-Only,permanent,Item,[HTML], 89 89 + Cross-Origin-Resource-Policy,permanent,,[Fetch], 90 90 + CTA-Common-Access-Token,provisional,,[CTA][Chris_Lemmons], 91 91 + DASL,permanent,,[RFC 5323: Web Distributed Authoring and Versioning (WebDAV) SEARCH], 92 92 + Date,permanent,,"[RFC 9110, Section 6.6.1: HTTP Semantics]", 93 93 + DAV,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 94 94 + Default-Style,obsoleted,,[HTML 4.01 Specification], 95 95 + Delta-Base,permanent,,[RFC 3229: Delta encoding in HTTP], 96 96 + Deprecation,permanent,Item,"[RFC 9745, Section 2: The Deprecation HTTP Response Header Field]", 97 97 + Depth,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 98 98 + Derived-From,obsoleted,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1], 99 99 + Destination,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 100 100 + Detached-JWS,permanent,,[RFC 9635: Grant Negotiation and Authorization Protocol (GNAP)], 101 101 + Differential-ID,deprecated,,[The HTTP Distribution and Replication Protocol], 102 102 + Dictionary-ID,permanent,,"[RFC 9842, Section 2.3: Compression Dictionary Transport]", 103 103 + Digest,obsoleted,,[RFC 3230: Instance Digests in HTTP],"Obsoleted by [RFC 9530, Section 1.3: Digest Fields]" 104 104 + DPoP,permanent,,[RFC 9449: OAuth 2.0 Demonstrating Proof of Possession (DPoP)], 105 105 + DPoP-Nonce,permanent,,[RFC 9449: OAuth 2.0 Demonstrating Proof of Possession (DPoP)], 106 106 + Early-Data,permanent,,[RFC 8470: Using Early Data in HTTP], 107 107 + EDIINT-Features,provisional,,[RFC 6017: Electronic Data Interchange - Internet Integration (EDIINT) Features Header Field], 108 108 + ETag,permanent,,"[RFC 9110, Section 8.8.3: HTTP Semantics]", 109 109 + Expect,permanent,,"[RFC 9110, Section 10.1.1: HTTP Semantics]", 110 110 + Expect-CT,deprecated,,[RFC 9163: Expect-CT Extension for HTTP],"Obsoleted by [IESG] 111 111 + [HTTPBIS]" 112 112 + Expires,permanent,,"[RFC 9111, Section 5.3: HTTP Caching]", 113 113 + Ext,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 114 114 + Forwarded,permanent,,[RFC 7239: Forwarded HTTP Extension], 115 115 + From,permanent,,"[RFC 9110, Section 10.1.2: HTTP Semantics]", 116 116 + GetProfile,obsoleted,,[Implementation of OPS Over HTTP], 117 117 + Hobareg,permanent,,"[RFC 7486, Section 6.1.1: HTTP Origin-Bound Authentication (HOBA)]", 118 118 + Host,permanent,,"[RFC 9110, Section 7.2: HTTP Semantics]", 119 119 + HTTP2-Settings,obsoleted,,"[RFC 7540, Section 3.2.1: Hypertext Transfer Protocol Version 2 (HTTP/2)]",Obsolete; see Section 11.1 of [RFC9113] 120 120 + If,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 121 121 + If-Match,permanent,,"[RFC 9110, Section 13.1.1: HTTP Semantics]", 122 122 + If-Modified-Since,permanent,,"[RFC 9110, Section 13.1.3: HTTP Semantics]", 123 123 + If-None-Match,permanent,,"[RFC 9110, Section 13.1.2: HTTP Semantics]", 124 124 + If-Range,permanent,,"[RFC 9110, Section 13.1.5: HTTP Semantics]", 125 125 + If-Schedule-Tag-Match,permanent,,[ RFC 6338: Scheduling Extensions to CalDAV], 126 126 + If-Unmodified-Since,permanent,,"[RFC 9110, Section 13.1.4: HTTP Semantics]", 127 127 + IM,permanent,,[RFC 3229: Delta encoding in HTTP], 128 128 + Include-Referred-Token-Binding-ID,permanent,,[RFC 8473: Token Binding over HTTP], 129 129 + Isolation,provisional,,[OData Version 4.01 Part 1: Protocol][OASIS][Chet_Ensign], 130 130 + Keep-Alive,permanent,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1], 131 131 + Label,permanent,,[RFC 3253: Versioning Extensions to WebDAV: (Web Distributed Authoring and Versioning)], 132 132 + Last-Event-ID,permanent,,[HTML], 133 133 + Last-Modified,permanent,,"[RFC 9110, Section 8.8.2: HTTP Semantics]", 134 134 + Link,permanent,,[RFC 8288: Web Linking], 135 135 + Link-Template,permanent,,[RFC 9652: The Link-Template HTTP Header Field], 136 136 + Location,permanent,,"[RFC 9110, Section 10.2.2: HTTP Semantics]", 137 137 + Lock-Token,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 138 138 + Man,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 139 139 + Max-Forwards,permanent,,"[RFC 9110, Section 7.6.2: HTTP Semantics]", 140 140 + Memento-Datetime,permanent,,[RFC 7089: HTTP Framework for Time-Based Access to Resource States -- Memento], 141 141 + Meter,permanent,,[RFC 2227: Simple Hit-Metering and Usage-Limiting for HTTP], 142 142 + Method-Check,obsoleted,,[Access Control for Cross-site Requests], 143 143 + Method-Check-Expires,obsoleted,,[Access Control for Cross-site Requests], 144 144 + MIME-Version,permanent,,"[RFC 9112, Appendix B.1: HTTP/1.1]", 145 145 + Negotiate,permanent,,[RFC 2295: Transparent Content Negotiation in HTTP], 146 146 + NEL,permanent,,[Network Error Logging], 147 147 + OData-EntityId,permanent,,[OData Version 4.01 Part 1: Protocol][OASIS][Chet_Ensign], 148 148 + OData-Isolation,permanent,,[OData Version 4.01 Part 1: Protocol][OASIS][Chet_Ensign], 149 149 + OData-MaxVersion,permanent,,[OData Version 4.01 Part 1: Protocol][OASIS][Chet_Ensign], 150 150 + OData-Version,permanent,,[OData Version 4.01 Part 1: Protocol][OASIS][Chet_Ensign], 151 151 + Opt,obsoleted,,[RFC 2774: An HTTP Extension Framework],[Status change of HTTP experiments to Historic] 152 152 + Optional-WWW-Authenticate,permanent,,"[RFC 8053, Section 3: HTTP Authentication Extensions for Interactive Clients]", 153 153 + Ordering-Type,permanent,,[RFC 3648: Web Distributed Authoring and Versioning (WebDAV) Ordered Collections Protocol], 154 154 + Origin,permanent,,[RFC 6454: The Web Origin Concept], 155 155 + Origin-Agent-Cluster,permanent,Item,[HTML], 156 156 + OSCORE,permanent,,"[RFC 8613, Section 11.1: Object Security for Constrained RESTful Environments (OSCORE)]", 157 157 + OSLC-Core-Version,permanent,,[OASIS Project Specification 01][OASIS][Chet_Ensign], 158 158 + Overwrite,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 159 159 + P3P,obsoleted,,[The Platform for Privacy Preferences 1.0 (P3P1.0) Specification], 160 160 + PEP,obsoleted,,[PEP - an Extension Mechanism for HTTP], 161 161 + PEP-Info,obsoleted,,[PEP - an Extension Mechanism for HTTP], 162 162 + Permissions-Policy,provisional,,[Permissions Policy], 163 163 + PICS-Label,obsoleted,,[PICS Label Distribution Label Syntax and Communication Protocols], 164 164 + Ping-From,permanent,,[HTML], 165 165 + Ping-To,permanent,,[HTML], 166 166 + Position,permanent,,[RFC 3648: Web Distributed Authoring and Versioning (WebDAV) Ordered Collections Protocol], 167 167 + Pragma,deprecated,,"[RFC 9111, Section 5.4: HTTP Caching]", 168 168 + Prefer,permanent,,[RFC 7240: Prefer Header for HTTP], 169 169 + Preference-Applied,permanent,,[RFC 7240: Prefer Header for HTTP], 170 170 + Priority,permanent,Dictionary,[RFC 9218: Extensible Prioritization Scheme for HTTP], 171 171 + ProfileObject,obsoleted,,[Implementation of OPS Over HTTP], 172 172 + Protocol,obsoleted,,[PICS Label Distribution Label Syntax and Communication Protocols], 173 173 + Protocol-Info,deprecated,,[White Paper: Joint Electronic Payment Initiative], 174 174 + Protocol-Query,deprecated,,[White Paper: Joint Electronic Payment Initiative], 175 175 + Protocol-Request,obsoleted,,[PICS Label Distribution Label Syntax and Communication Protocols], 176 176 + Proxy-Authenticate,permanent,,"[RFC 9110, Section 11.7.1: HTTP Semantics]", 177 177 + Proxy-Authentication-Info,permanent,,"[RFC 9110, Section 11.7.3: HTTP Semantics]", 178 178 + Proxy-Authorization,permanent,,"[RFC 9110, Section 11.7.2: HTTP Semantics]", 179 179 + Proxy-Features,obsoleted,,[Notification for Proxy Caches], 180 180 + Proxy-Instruction,obsoleted,,[Notification for Proxy Caches], 181 181 + Proxy-Status,permanent,List,[RFC 9209: The Proxy-Status HTTP Response Header Field], 182 182 + Public,obsoleted,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1], 183 183 + Public-Key-Pins,permanent,,[RFC 7469: Public Key Pinning Extension for HTTP], 184 184 + Public-Key-Pins-Report-Only,permanent,,[RFC 7469: Public Key Pinning Extension for HTTP], 185 185 + Range,permanent,,"[RFC 9110, Section 14.2: HTTP Semantics]", 186 186 + Redirect-Ref,permanent,,[RFC 4437: Web Distributed Authoring and Versioning (WebDAV) Redirect Reference Resources], 187 187 + Referer,permanent,,"[RFC 9110, Section 10.1.3: HTTP Semantics]", 188 188 + Referer-Root,obsoleted,,[Access Control for Cross-site Requests], 189 189 + Referrer-Policy,permanent,,[Referrer Policy],The header name does not share the HTTP Referer header's misspelling. 190 190 + Refresh,permanent,,[HTML], 191 191 + Repeatability-Client-ID,provisional,,[Repeatable Requests Version 1.0][OASIS][Chet_Ensign], 192 192 + Repeatability-First-Sent,provisional,,[Repeatable Requests Version 1.0][OASIS][Chet_Ensign], 193 193 + Repeatability-Request-ID,provisional,,[Repeatable Requests Version 1.0][OASIS][Chet_Ensign], 194 194 + Repeatability-Result,provisional,,[Repeatable Requests Version 1.0][OASIS][Chet_Ensign], 195 195 + Replay-Nonce,permanent,,"[RFC 8555, Section 6.5.1: Automatic Certificate Management Environment (ACME)]", 196 196 + Reporting-Endpoints,provisional,,[Reporting API], 197 197 + Repr-Digest,permanent,,"[RFC 9530, Section 3: Digest Fields]", 198 198 + Retry-After,permanent,,"[RFC 9110, Section 10.2.3: HTTP Semantics]", 199 199 + Safe,obsoleted,,[RFC 2310: The Safe Response Header Field],[Status change of HTTP experiments to Historic] 200 200 + Schedule-Reply,permanent,,[RFC 6638: Scheduling Extensions to CalDAV], 201 201 + Schedule-Tag,permanent,,[RFC 6338: Scheduling Extensions to CalDAV], 202 202 + Sec-Fetch-Dest,Permanent,Item,[https://www.w3.org/TR/fetch-metadata/#sec-fetch-dest-header], 203 203 + Sec-Fetch-Mode,Permanent,Item,[https://www.w3.org/TR/fetch-metadata/#sec-fetch-mode-header], 204 204 + Sec-Fetch-Site,Permanent,Item,[https://www.w3.org/TR/fetch-metadata/#sec-fetch-site-header], 205 205 + Sec-Fetch-Storage-Access,provisional,Token,[https://privacycg.github.io/storage-access-headers], 206 206 + Sec-Fetch-User,Permanent,Item,[https://www.w3.org/TR/fetch-metadata/#sec-fetch-user-header], 207 207 + Sec-GPC,provisional,,[Global Privacy Control (GPC)], 208 208 + Sec-Purpose,permanent,,[Fetch],Intended to replace the (not registered) Purpose and x-moz headers. 209 209 + Sec-Token-Binding,permanent,,[RFC 8473: Token Binding over HTTP], 210 210 + Sec-WebSocket-Accept,permanent,,[RFC 6455: The WebSocket Protocol], 211 211 + Sec-WebSocket-Extensions,permanent,,[RFC 6455: The WebSocket Protocol], 212 212 + Sec-WebSocket-Key,permanent,,[RFC 6455: The WebSocket Protocol], 213 213 + Sec-WebSocket-Protocol,permanent,,[RFC 6455: The WebSocket Protocol], 214 214 + Sec-WebSocket-Version,permanent,,[RFC 6455: The WebSocket Protocol], 215 215 + Security-Scheme,obsoleted,,[RFC 2660: The Secure HyperText Transfer Protocol],[Status change of HTTP experiments to Historic] 216 216 + Server,permanent,,"[RFC 9110, Section 10.2.4: HTTP Semantics]", 217 217 + Server-Timing,permanent,,[Server Timing], 218 218 + Set-Cookie,permanent,,"[RFC-ietf-httpbis-rfc6265bis-22, Section 5.8.1: Cookies: HTTP State Management Mechanism]", 219 219 + Set-Cookie2,obsoleted,,[RFC 2965: HTTP State Management Mechanism],Obsoleted by [RFC 6265: HTTP State Management Mechanism] 220 220 + Set-Txn,permanent,,"[RFC-ietf-scim-events-15, Section 3: SCIM Profile for Security Event Tokens]", 221 221 + SetProfile,obsoleted,,[Implementation of OPS Over HTTP], 222 222 + Signature,permanent,,"[RFC 9421, Section 4.2: HTTP Message Signatures]", 223 223 + Signature-Input,permanent,,"[RFC 9421, Section 4.1: HTTP Message Signatures]", 224 224 + SLUG,permanent,,[RFC 5023: The Atom Publishing Protocol], 225 225 + SoapAction,permanent,,[Simple Object Access Protocol (SOAP) 1.1], 226 226 + Status-URI,permanent,,[RFC 2518: HTTP Extensions for Distributed Authoring -- WEBDAV], 227 227 + Strict-Transport-Security,permanent,,[RFC 6797: HTTP Strict Transport Security (HSTS)], 228 228 + Sunset,permanent,,[RFC 8594: The Sunset HTTP Header Field], 229 229 + Surrogate-Capability,provisional,,[Edge Architecture Specification], 230 230 + Surrogate-Control,provisional,,[Edge Architecture Specification], 231 231 + TCN,permanent,,[RFC 2295: Transparent Content Negotiation in HTTP], 232 232 + TE,permanent,,"[RFC 9110, Section 10.1.4: HTTP Semantics]", 233 233 + Timeout,permanent,,[RFC 4918: HTTP Extensions for Web Distributed Authoring and Versioning (WebDAV)], 234 234 + Timing-Allow-Origin,provisional,,[Resource Timing Level 1], 235 235 + Topic,permanent,,"[RFC 8030, Section 5.4: Generic Event Delivery Using HTTP Push]", 236 236 + Traceparent,permanent,,[Trace Context], 237 237 + Tracestate,permanent,,[Trace Context], 238 238 + Trailer,permanent,,"[RFC 9110, Section 6.6.2: HTTP Semantics]", 239 239 + Transfer-Encoding,permanent,,"[RFC 9112, Section 6.1: HTTP Semantics]", 240 240 + TTL,permanent,,"[RFC 8030, Section 5.2: Generic Event Delivery Using HTTP Push]", 241 241 + Upgrade,permanent,,"[RFC 9110, Section 7.8: HTTP Semantics]", 242 242 + Urgency,permanent,,"[RFC 8030, Section 5.3: Generic Event Delivery Using HTTP Push]", 243 243 + URI,obsoleted,,[RFC 2068: Hypertext Transfer Protocol -- HTTP/1.1], 244 244 + Use-As-Dictionary,permanent,,"[RFC 9842, Section 2.1: Compression Dictionary Transport]", 245 245 + User-Agent,permanent,,"[RFC 9110, Section 10.1.5: HTTP Semantics]", 246 246 + Variant-Vary,permanent,,[RFC 2295: Transparent Content Negotiation in HTTP], 247 247 + Vary,permanent,,"[RFC 9110, Section 12.5.5: HTTP Semantics]", 248 248 + Via,permanent,,"[RFC 9110, Section 7.6.3: HTTP Semantics]", 249 249 + Want-Content-Digest,permanent,,"[RFC 9530, Section 4: Digest Fields]", 250 250 + Want-Digest,obsoleted,,[RFC 3230: Instance Digests in HTTP],"Obsoleted by [RFC 9530, Section 1.3: Digest Fields]" 251 251 + Want-Repr-Digest,permanent,,"[RFC 9530, Section 4: Digest Fields]", 252 252 + Warning,obsoleted,,"[RFC 9111, Section 5.5: HTTP Caching]", 253 253 + WWW-Authenticate,permanent,,"[RFC 9110, Section 11.6.1: HTTP Semantics]", 254 254 + X-Content-Type-Options,permanent,,[Fetch], 255 255 + X-Frame-Options,permanent,,[HTML], 256 256 + *,permanent,,"[RFC 9110, Section 12.5.5: HTTP Semantics]",(reserved)

+8

test/dune

··· 18 18 (name test_http_date) 19 19 (libraries requests eio eio_main alcotest fmt fmt.tty logs logs.fmt ptime)) 20 20 21 21 + (executable 22 22 + (name test_header_parsing) 23 23 + (libraries requests alcotest fmt fmt.tty logs logs.fmt)) 24 24 + 25 25 + (executable 26 26 + (name test_websocket) 27 27 + (libraries requests alcotest base64 fmt fmt.tty logs logs.fmt mirage-crypto-rng.unix)) 28 28 + 21 29 (cram 22 30 (deps %{bin:ocurl}))

+416

test/test_header_parsing.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Tests for Header_parsing module *) 7 7 + 8 8 + module Header_parsing = Requests.Header_parsing 9 9 + module Headers = Requests.Headers 10 10 + module Method = Requests.Method 11 11 + 12 12 + (** {1 Content-Range Tests (RFC 9110 Section 14.4)} *) 13 13 + 14 14 + let test_content_range_basic () = 15 15 + let result = Header_parsing.parse_content_range "bytes 0-499/1234" in 16 16 + match result with 17 17 + | Some cr -> 18 18 + Alcotest.(check string) "unit" "bytes" cr.unit; 19 19 + Alcotest.(check (option (pair int64 int64))) "range" 20 20 + (Some (0L, 499L)) cr.range; 21 21 + Alcotest.(check (option int64)) "complete_length" 22 22 + (Some 1234L) cr.complete_length 23 23 + | None -> 24 24 + Alcotest.fail "Expected Some content_range" 25 25 + 26 26 + let test_content_range_unsatisfied () = 27 27 + let result = Header_parsing.parse_content_range "bytes */1234" in 28 28 + match result with 29 29 + | Some cr -> 30 30 + Alcotest.(check string) "unit" "bytes" cr.unit; 31 31 + Alcotest.(check (option (pair int64 int64))) "range" None cr.range; 32 32 + Alcotest.(check (option int64)) "complete_length" 33 33 + (Some 1234L) cr.complete_length 34 34 + | None -> 35 35 + Alcotest.fail "Expected Some content_range for unsatisfied" 36 36 + 37 37 + let test_content_range_unknown_length () = 38 38 + let result = Header_parsing.parse_content_range "bytes 0-499/*" in 39 39 + match result with 40 40 + | Some cr -> 41 41 + Alcotest.(check string) "unit" "bytes" cr.unit; 42 42 + Alcotest.(check (option (pair int64 int64))) "range" 43 43 + (Some (0L, 499L)) cr.range; 44 44 + Alcotest.(check (option int64)) "complete_length" None cr.complete_length 45 45 + | None -> 46 46 + Alcotest.fail "Expected Some content_range for unknown length" 47 47 + 48 48 + let test_content_range_to_string () = 49 49 + let cr = Header_parsing.make_content_range ~start:0L ~end_:499L ~complete_length:1234L in 50 50 + let s = Header_parsing.content_range_to_string cr in 51 51 + Alcotest.(check string) "to_string" "bytes 0-499/1234" s 52 52 + 53 53 + let test_content_range_unsatisfied_to_string () = 54 54 + let cr = Header_parsing.make_unsatisfied_range ~complete_length:1234L in 55 55 + let s = Header_parsing.content_range_to_string cr in 56 56 + Alcotest.(check string) "unsatisfied to_string" "bytes */1234" s 57 57 + 58 58 + let test_content_range_invalid () = 59 59 + let invalid_inputs = [ 60 60 + ""; 61 61 + "invalid"; 62 62 + "0-499/1234"; (* missing unit *) 63 63 + "bytes 0-499"; (* missing length *) 64 64 + ] in 65 65 + List.iter (fun input -> 66 66 + let result = Header_parsing.parse_content_range input in 67 67 + Alcotest.(check bool) (Printf.sprintf "Invalid: %S" input) 68 68 + true (Option.is_none result) 69 69 + ) invalid_inputs 70 70 + 71 71 + (** {1 If-Range Tests (RFC 9110 Section 13.1.5)} *) 72 72 + 73 73 + let test_if_range_etag_strong () = 74 74 + let result = Header_parsing.parse_if_range "\"abc123\"" in 75 75 + match result with 76 76 + | Some (If_range_etag etag) -> 77 77 + Alcotest.(check string) "strong etag" "\"abc123\"" etag 78 78 + | _ -> 79 79 + Alcotest.fail "Expected If_range_etag for strong etag" 80 80 + 81 81 + let test_if_range_etag_weak () = 82 82 + let result = Header_parsing.parse_if_range "W/\"abc123\"" in 83 83 + match result with 84 84 + | Some (If_range_etag etag) -> 85 85 + Alcotest.(check string) "weak etag" "W/\"abc123\"" etag 86 86 + | _ -> 87 87 + Alcotest.fail "Expected If_range_etag for weak etag" 88 88 + 89 89 + let test_if_range_date () = 90 90 + let result = Header_parsing.parse_if_range "Sun, 06 Nov 1994 08:49:37 GMT" in 91 91 + match result with 92 92 + | Some (If_range_date date) -> 93 93 + Alcotest.(check string) "date" "Sun, 06 Nov 1994 08:49:37 GMT" date 94 94 + | _ -> 95 95 + Alcotest.fail "Expected If_range_date" 96 96 + 97 97 + let test_if_range_is_etag () = 98 98 + let etag = Header_parsing.if_range_of_etag "\"test\"" in 99 99 + let date = Header_parsing.if_range_of_date "Sun, 06 Nov 1994 08:49:37 GMT" in 100 100 + Alcotest.(check bool) "etag is_etag" true (Header_parsing.if_range_is_etag etag); 101 101 + Alcotest.(check bool) "date is_etag" false (Header_parsing.if_range_is_etag date); 102 102 + Alcotest.(check bool) "etag is_date" false (Header_parsing.if_range_is_date etag); 103 103 + Alcotest.(check bool) "date is_date" true (Header_parsing.if_range_is_date date) 104 104 + 105 105 + (** {1 Allow Tests (RFC 9110 Section 10.2.1)} *) 106 106 + 107 107 + let test_allow_parse_basic () = 108 108 + let methods = Header_parsing.parse_allow "GET, HEAD, PUT" in 109 109 + Alcotest.(check int) "count" 3 (List.length methods); 110 110 + Alcotest.(check bool) "has GET" true (List.mem `GET methods); 111 111 + Alcotest.(check bool) "has HEAD" true (List.mem `HEAD methods); 112 112 + Alcotest.(check bool) "has PUT" true (List.mem `PUT methods) 113 113 + 114 114 + let test_allow_parse_single () = 115 115 + let methods = Header_parsing.parse_allow "OPTIONS" in 116 116 + Alcotest.(check int) "count" 1 (List.length methods); 117 117 + Alcotest.(check bool) "has OPTIONS" true (List.mem `OPTIONS methods) 118 118 + 119 119 + let test_allow_parse_with_spaces () = 120 120 + let methods = Header_parsing.parse_allow "GET, HEAD, POST" in 121 121 + Alcotest.(check int) "count" 3 (List.length methods); 122 122 + Alcotest.(check bool) "has GET" true (List.mem `GET methods); 123 123 + Alcotest.(check bool) "has HEAD" true (List.mem `HEAD methods); 124 124 + Alcotest.(check bool) "has POST" true (List.mem `POST methods) 125 125 + 126 126 + let test_allow_to_string () = 127 127 + let methods = [`GET; `HEAD; `PUT] in 128 128 + let s = Header_parsing.allow_to_string methods in 129 129 + Alcotest.(check string) "to_string" "GET, HEAD, PUT" s 130 130 + 131 131 + let test_allow_contains () = 132 132 + let allow = "GET, HEAD, PUT" in 133 133 + Alcotest.(check bool) "contains GET" true 134 134 + (Header_parsing.allow_contains `GET allow); 135 135 + Alcotest.(check bool) "contains POST" false 136 136 + (Header_parsing.allow_contains `POST allow) 137 137 + 138 138 + (** {1 Authentication-Info Tests (RFC 9110 Section 11.6.3)} *) 139 139 + 140 140 + let test_auth_info_full () = 141 141 + let info = Header_parsing.parse_authentication_info 142 142 + "nextnonce=\"abc123\", qop=auth, rspauth=\"xyz789\", cnonce=\"client\", nc=00000001" in 143 143 + Alcotest.(check (option string)) "nextnonce" (Some "abc123") info.nextnonce; 144 144 + Alcotest.(check (option string)) "qop" (Some "auth") info.qop; 145 145 + Alcotest.(check (option string)) "rspauth" (Some "xyz789") info.rspauth; 146 146 + Alcotest.(check (option string)) "cnonce" (Some "client") info.cnonce; 147 147 + Alcotest.(check (option string)) "nc" (Some "00000001") info.nc 148 148 + 149 149 + let test_auth_info_nextnonce_only () = 150 150 + let info = Header_parsing.parse_authentication_info "nextnonce=\"newone\"" in 151 151 + Alcotest.(check (option string)) "nextnonce" (Some "newone") info.nextnonce; 152 152 + Alcotest.(check bool) "has_nextnonce" true (Header_parsing.has_nextnonce info); 153 153 + Alcotest.(check (option string)) "qop" None info.qop 154 154 + 155 155 + let test_auth_info_empty () = 156 156 + let info = Header_parsing.parse_authentication_info "" in 157 157 + Alcotest.(check (option string)) "nextnonce" None info.nextnonce; 158 158 + Alcotest.(check bool) "has_nextnonce" false (Header_parsing.has_nextnonce info) 159 159 + 160 160 + (** {1 Retry-After Tests (RFC 9110 Section 10.2.3)} *) 161 161 + 162 162 + let test_retry_after_seconds () = 163 163 + let result = Header_parsing.parse_retry_after "120" in 164 164 + match result with 165 165 + | Some (Retry_after_seconds s) -> 166 166 + Alcotest.(check int) "seconds" 120 s 167 167 + | _ -> 168 168 + Alcotest.fail "Expected Retry_after_seconds" 169 169 + 170 170 + let test_retry_after_date () = 171 171 + let result = Header_parsing.parse_retry_after "Fri, 31 Dec 1999 23:59:59 GMT" in 172 172 + match result with 173 173 + | Some (Retry_after_date d) -> 174 174 + Alcotest.(check string) "date" "Fri, 31 Dec 1999 23:59:59 GMT" d 175 175 + | _ -> 176 176 + Alcotest.fail "Expected Retry_after_date" 177 177 + 178 178 + let test_retry_after_to_seconds () = 179 179 + let ra = Header_parsing.Retry_after_seconds 60 in 180 180 + Alcotest.(check (option int)) "to_seconds" (Some 60) 181 181 + (Header_parsing.retry_after_to_seconds ra) 182 182 + 183 183 + (** {1 Accept-Ranges Tests (RFC 9110 Section 14.3)} *) 184 184 + 185 185 + let test_accept_ranges_bytes () = 186 186 + let ar = Header_parsing.parse_accept_ranges "bytes" in 187 187 + Alcotest.(check bool) "supports bytes" true 188 188 + (Header_parsing.supports_byte_ranges ar) 189 189 + 190 190 + let test_accept_ranges_none () = 191 191 + let ar = Header_parsing.parse_accept_ranges "none" in 192 192 + Alcotest.(check bool) "supports none" false 193 193 + (Header_parsing.supports_byte_ranges ar) 194 194 + 195 195 + let test_accept_ranges_case_insensitive () = 196 196 + let ar1 = Header_parsing.parse_accept_ranges "BYTES" in 197 197 + let ar2 = Header_parsing.parse_accept_ranges "Bytes" in 198 198 + Alcotest.(check bool) "BYTES supports" true 199 199 + (Header_parsing.supports_byte_ranges ar1); 200 200 + Alcotest.(check bool) "Bytes supports" true 201 201 + (Header_parsing.supports_byte_ranges ar2) 202 202 + 203 203 + (** {1 Cache-Status Tests (RFC 9211)} *) 204 204 + 205 205 + let test_cache_status_basic () = 206 206 + let entries = Header_parsing.parse_cache_status "Cloudflare; hit" in 207 207 + Alcotest.(check int) "count" 1 (List.length entries); 208 208 + let entry = List.hd entries in 209 209 + Alcotest.(check string) "cache_id" "Cloudflare" entry.cache_id; 210 210 + Alcotest.(check (option bool)) "hit" (Some true) entry.hit 211 211 + 212 212 + let test_cache_status_fwd () = 213 213 + let entries = Header_parsing.parse_cache_status "CDN; fwd=uri-miss; stored" in 214 214 + Alcotest.(check int) "count" 1 (List.length entries); 215 215 + let entry = List.hd entries in 216 216 + Alcotest.(check string) "cache_id" "CDN" entry.cache_id; 217 217 + Alcotest.(check (option bool)) "stored" (Some true) entry.stored; 218 218 + match entry.fwd with 219 219 + | Some Header_parsing.Fwd_uri_miss -> Alcotest.(check pass) "fwd" () () 220 220 + | _ -> Alcotest.fail "Expected Fwd_uri_miss" 221 221 + 222 222 + let test_cache_status_multiple () = 223 223 + let entries = Header_parsing.parse_cache_status "Origin, CDN; hit, Edge; fwd=stale" in 224 224 + Alcotest.(check int) "count" 3 (List.length entries); 225 225 + Alcotest.(check bool) "is_hit" true (Header_parsing.cache_status_is_hit entries) 226 226 + 227 227 + let test_cache_status_with_params () = 228 228 + let entries = Header_parsing.parse_cache_status "CDN; ttl=3600; fwd-status=200" in 229 229 + Alcotest.(check int) "count" 1 (List.length entries); 230 230 + let entry = List.hd entries in 231 231 + Alcotest.(check (option int)) "ttl" (Some 3600) entry.ttl; 232 232 + Alcotest.(check (option int)) "fwd_status" (Some 200) entry.fwd_status 233 233 + 234 234 + let test_cache_status_to_string () = 235 235 + let entry = { 236 236 + Header_parsing.cache_id = "CDN"; 237 237 + hit = Some true; 238 238 + fwd = None; 239 239 + fwd_status = None; 240 240 + stored = None; 241 241 + collapsed = None; 242 242 + ttl = Some 3600; 243 243 + key = None; 244 244 + detail = None; 245 245 + } in 246 246 + let s = Header_parsing.cache_status_entry_to_string entry in 247 247 + Alcotest.(check bool) "contains hit" true (String.length s > 0) 248 248 + 249 249 + (** {1 Content-Digest Tests (RFC 9530)} *) 250 250 + 251 251 + let test_digest_parse_sha256 () = 252 252 + let digests = Header_parsing.parse_digest_header "sha-256=:YWJjZGVm:" in 253 253 + Alcotest.(check int) "count" 1 (List.length digests); 254 254 + let dv = List.hd digests in 255 255 + Alcotest.(check bool) "is sha256" true (dv.algorithm = Header_parsing.Sha256); 256 256 + Alcotest.(check string) "digest" "YWJjZGVm" dv.digest 257 257 + 258 258 + let test_digest_parse_multiple () = 259 259 + let digests = Header_parsing.parse_digest_header "sha-256=:abc:, sha-512=:xyz:" in 260 260 + Alcotest.(check int) "count" 2 (List.length digests) 261 261 + 262 262 + let test_digest_compute_sha256 () = 263 263 + let content = "hello world" in 264 264 + let digest = Header_parsing.compute_sha256 content in 265 265 + (* SHA-256 of "hello world" is known *) 266 266 + Alcotest.(check bool) "not empty" true (String.length digest > 0) 267 267 + 268 268 + let test_digest_compute_sha512 () = 269 269 + let content = "hello world" in 270 270 + let digest = Header_parsing.compute_sha512 content in 271 271 + Alcotest.(check bool) "not empty" true (String.length digest > 0) 272 272 + 273 273 + let test_digest_validate () = 274 274 + let content = "test content" in 275 275 + let dv = Header_parsing.make_content_digest content in 276 276 + let valid = Header_parsing.validate_digest ~digests:[dv] content in 277 277 + Alcotest.(check bool) "validates" true valid 278 278 + 279 279 + let test_digest_validate_mismatch () = 280 280 + let dv = Header_parsing.make_content_digest "original" in 281 281 + let valid = Header_parsing.validate_digest ~digests:[dv] "modified" in 282 282 + Alcotest.(check bool) "does not validate" false valid 283 283 + 284 284 + let test_digest_to_string () = 285 285 + let dv = { Header_parsing.algorithm = Header_parsing.Sha256; digest = "abc123" } in 286 286 + let s = Header_parsing.digest_value_to_string dv in 287 287 + Alcotest.(check string) "format" "sha-256=:abc123:" s 288 288 + 289 289 + let test_digest_strongest () = 290 290 + let digests = [ 291 291 + { Header_parsing.algorithm = Header_parsing.Sha256; digest = "a" }; 292 292 + { Header_parsing.algorithm = Header_parsing.Sha512; digest = "b" }; 293 293 + ] in 294 294 + match Header_parsing.get_strongest_digest digests with 295 295 + | Some d -> Alcotest.(check bool) "is sha512" true (d.algorithm = Header_parsing.Sha512) 296 296 + | None -> Alcotest.fail "Expected Some digest" 297 297 + 298 298 + (** {1 HSTS Tests (RFC 6797)} *) 299 299 + 300 300 + let test_hsts_basic () = 301 301 + match Header_parsing.parse_hsts "max-age=31536000" with 302 302 + | Some hsts -> 303 303 + Alcotest.(check int64) "max_age" 31536000L hsts.max_age; 304 304 + Alcotest.(check bool) "include_subdomains" false hsts.include_subdomains; 305 305 + Alcotest.(check bool) "preload" false hsts.preload 306 306 + | None -> 307 307 + Alcotest.fail "Expected Some hsts" 308 308 + 309 309 + let test_hsts_full () = 310 310 + match Header_parsing.parse_hsts "max-age=63072000; includeSubDomains; preload" with 311 311 + | Some hsts -> 312 312 + Alcotest.(check int64) "max_age" 63072000L hsts.max_age; 313 313 + Alcotest.(check bool) "include_subdomains" true hsts.include_subdomains; 314 314 + Alcotest.(check bool) "preload" true hsts.preload 315 315 + | None -> 316 316 + Alcotest.fail "Expected Some hsts" 317 317 + 318 318 + let test_hsts_case_insensitive () = 319 319 + match Header_parsing.parse_hsts "Max-Age=31536000; INCLUDESUBDOMAINS" with 320 320 + | Some hsts -> 321 321 + Alcotest.(check int64) "max_age" 31536000L hsts.max_age; 322 322 + Alcotest.(check bool) "include_subdomains" true hsts.include_subdomains 323 323 + | None -> 324 324 + Alcotest.fail "Expected Some hsts" 325 325 + 326 326 + let test_hsts_missing_max_age () = 327 327 + let result = Header_parsing.parse_hsts "includeSubDomains; preload" in 328 328 + Alcotest.(check bool) "is None" true (Option.is_none result) 329 329 + 330 330 + let test_hsts_to_string () = 331 331 + let hsts = Header_parsing.make_hsts ~max_age:31536000L ~include_subdomains:true () in 332 332 + let s = Header_parsing.hsts_to_string hsts in 333 333 + Alcotest.(check bool) "contains max-age" true 334 334 + (String.length s > 0 && String.sub s 0 8 = "max-age=") 335 335 + 336 336 + let test_hsts_is_enabled () = 337 337 + Alcotest.(check bool) "enabled" true 338 338 + (Header_parsing.hsts_is_enabled Header_parsing.hsts_one_year_subdomains); 339 339 + Alcotest.(check bool) "disabled" false 340 340 + (Header_parsing.hsts_is_enabled Header_parsing.hsts_disable) 341 341 + 342 342 + let test_hsts_presets () = 343 343 + Alcotest.(check int64) "one_year max_age" 31536000L 344 344 + Header_parsing.hsts_one_year_subdomains.max_age; 345 345 + Alcotest.(check bool) "preload has preload" true 346 346 + Header_parsing.hsts_preload.preload; 347 347 + Alcotest.(check int64) "disable max_age" 0L 348 348 + Header_parsing.hsts_disable.max_age 349 349 + 350 350 + (** {1 Test Suite} *) 351 351 + 352 352 + let () = 353 353 + Alcotest.run "Header Parsing" [ 354 354 + ("Content-Range", [ 355 355 + Alcotest.test_case "Basic parsing" `Quick test_content_range_basic; 356 356 + Alcotest.test_case "Unsatisfied range" `Quick test_content_range_unsatisfied; 357 357 + Alcotest.test_case "Unknown length" `Quick test_content_range_unknown_length; 358 358 + Alcotest.test_case "To string" `Quick test_content_range_to_string; 359 359 + Alcotest.test_case "Unsatisfied to string" `Quick test_content_range_unsatisfied_to_string; 360 360 + Alcotest.test_case "Invalid inputs" `Quick test_content_range_invalid; 361 361 + ]); 362 362 + ("If-Range", [ 363 363 + Alcotest.test_case "Strong ETag" `Quick test_if_range_etag_strong; 364 364 + Alcotest.test_case "Weak ETag" `Quick test_if_range_etag_weak; 365 365 + Alcotest.test_case "Date" `Quick test_if_range_date; 366 366 + Alcotest.test_case "Type predicates" `Quick test_if_range_is_etag; 367 367 + ]); 368 368 + ("Allow", [ 369 369 + Alcotest.test_case "Basic parsing" `Quick test_allow_parse_basic; 370 370 + Alcotest.test_case "Single method" `Quick test_allow_parse_single; 371 371 + Alcotest.test_case "With extra spaces" `Quick test_allow_parse_with_spaces; 372 372 + Alcotest.test_case "To string" `Quick test_allow_to_string; 373 373 + Alcotest.test_case "Contains" `Quick test_allow_contains; 374 374 + ]); 375 375 + ("Authentication-Info", [ 376 376 + Alcotest.test_case "Full parsing" `Quick test_auth_info_full; 377 377 + Alcotest.test_case "Nextnonce only" `Quick test_auth_info_nextnonce_only; 378 378 + Alcotest.test_case "Empty" `Quick test_auth_info_empty; 379 379 + ]); 380 380 + ("Retry-After", [ 381 381 + Alcotest.test_case "Seconds" `Quick test_retry_after_seconds; 382 382 + Alcotest.test_case "Date" `Quick test_retry_after_date; 383 383 + Alcotest.test_case "To seconds" `Quick test_retry_after_to_seconds; 384 384 + ]); 385 385 + ("Accept-Ranges", [ 386 386 + Alcotest.test_case "Bytes" `Quick test_accept_ranges_bytes; 387 387 + Alcotest.test_case "None" `Quick test_accept_ranges_none; 388 388 + Alcotest.test_case "Case insensitive" `Quick test_accept_ranges_case_insensitive; 389 389 + ]); 390 390 + ("Cache-Status", [ 391 391 + Alcotest.test_case "Basic parsing" `Quick test_cache_status_basic; 392 392 + Alcotest.test_case "Forward reason" `Quick test_cache_status_fwd; 393 393 + Alcotest.test_case "Multiple entries" `Quick test_cache_status_multiple; 394 394 + Alcotest.test_case "With params" `Quick test_cache_status_with_params; 395 395 + Alcotest.test_case "To string" `Quick test_cache_status_to_string; 396 396 + ]); 397 397 + ("Content-Digest", [ 398 398 + Alcotest.test_case "Parse SHA-256" `Quick test_digest_parse_sha256; 399 399 + Alcotest.test_case "Parse multiple" `Quick test_digest_parse_multiple; 400 400 + Alcotest.test_case "Compute SHA-256" `Quick test_digest_compute_sha256; 401 401 + Alcotest.test_case "Compute SHA-512" `Quick test_digest_compute_sha512; 402 402 + Alcotest.test_case "Validate match" `Quick test_digest_validate; 403 403 + Alcotest.test_case "Validate mismatch" `Quick test_digest_validate_mismatch; 404 404 + Alcotest.test_case "To string" `Quick test_digest_to_string; 405 405 + Alcotest.test_case "Get strongest" `Quick test_digest_strongest; 406 406 + ]); 407 407 + ("HSTS", [ 408 408 + Alcotest.test_case "Basic parsing" `Quick test_hsts_basic; 409 409 + Alcotest.test_case "Full parsing" `Quick test_hsts_full; 410 410 + Alcotest.test_case "Case insensitive" `Quick test_hsts_case_insensitive; 411 411 + Alcotest.test_case "Missing max-age" `Quick test_hsts_missing_max_age; 412 412 + Alcotest.test_case "To string" `Quick test_hsts_to_string; 413 413 + Alcotest.test_case "Is enabled" `Quick test_hsts_is_enabled; 414 414 + Alcotest.test_case "Presets" `Quick test_hsts_presets; 415 415 + ]); 416 416 + ]

+291

test/test_websocket.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Tests for WebSocket module (RFC 6455) *) 7 7 + 8 8 + module Websocket = Requests.Websocket 9 9 + module Headers = Requests.Headers 10 10 + 11 11 + (** Helper for string contains *) 12 12 + let string_contains ~affix s = 13 13 + let alen = String.length affix in 14 14 + let slen = String.length s in 15 15 + if alen > slen then false 16 16 + else 17 17 + let rec check i = 18 18 + if i + alen > slen then false 19 19 + else if String.sub s i alen = affix then true 20 20 + else check (i + 1) 21 21 + in 22 22 + check 0 23 23 + 24 24 + (** {1 Key Generation Tests} *) 25 25 + 26 26 + let test_generate_key_length () = 27 27 + let key = Websocket.generate_key () in 28 28 + (* Base64 of 16 bytes = 24 characters (with padding) *) 29 29 + (* Actually 16 bytes -> ceil(16/3)*4 = 24 chars with padding, 30 30 + but base64 library might not pad. Let's check it decodes to 16 bytes *) 31 31 + let decoded = Base64.decode_exn key in 32 32 + Alcotest.(check int) "decoded length" 16 (String.length decoded) 33 33 + 34 34 + let test_generate_key_unique () = 35 35 + let key1 = Websocket.generate_key () in 36 36 + let key2 = Websocket.generate_key () in 37 37 + Alcotest.(check bool) "keys are different" true (key1 <> key2) 38 38 + 39 39 + let test_generate_key_valid_base64 () = 40 40 + let key = Websocket.generate_key () in 41 41 + (* Should not raise *) 42 42 + let _ = Base64.decode_exn key in 43 43 + Alcotest.(check pass) "valid base64" () () 44 44 + 45 45 + (** {1 Accept Computation Tests (RFC 6455 Section 4.2.2)} *) 46 46 + 47 47 + let test_compute_accept_rfc_example () = 48 48 + (* RFC 6455 Section 1.3 example: 49 49 + Key: "dGhlIHNhbXBsZSBub25jZQ==" 50 50 + Accept: "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" *) 51 51 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 52 52 + let expected = "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" in 53 53 + let accept = Websocket.compute_accept ~key in 54 54 + Alcotest.(check string) "RFC example accept" expected accept 55 55 + 56 56 + let test_validate_accept_correct () = 57 57 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 58 58 + let accept = "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" in 59 59 + Alcotest.(check bool) "valid accept" true 60 60 + (Websocket.validate_accept ~key ~accept) 61 61 + 62 62 + let test_validate_accept_incorrect () = 63 63 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 64 64 + let accept = "wrongvalue" in 65 65 + Alcotest.(check bool) "invalid accept" false 66 66 + (Websocket.validate_accept ~key ~accept) 67 67 + 68 68 + let test_compute_validate_roundtrip () = 69 69 + let key = Websocket.generate_key () in 70 70 + let accept = Websocket.compute_accept ~key in 71 71 + Alcotest.(check bool) "roundtrip validation" true 72 72 + (Websocket.validate_accept ~key ~accept) 73 73 + 74 74 + (** {1 Protocol Negotiation Tests} *) 75 75 + 76 76 + let test_parse_protocols_basic () = 77 77 + let protos = Websocket.parse_protocols "graphql-ws, graphql-transport-ws" in 78 78 + Alcotest.(check int) "count" 2 (List.length protos); 79 79 + Alcotest.(check bool) "has graphql-ws" true (List.mem "graphql-ws" protos); 80 80 + Alcotest.(check bool) "has graphql-transport-ws" true 81 81 + (List.mem "graphql-transport-ws" protos) 82 82 + 83 83 + let test_parse_protocols_single () = 84 84 + let protos = Websocket.parse_protocols "chat" in 85 85 + Alcotest.(check (list string)) "single" ["chat"] protos 86 86 + 87 87 + let test_parse_protocols_empty () = 88 88 + let protos = Websocket.parse_protocols "" in 89 89 + Alcotest.(check (list string)) "empty" [] protos 90 90 + 91 91 + let test_protocols_to_string () = 92 92 + let protos = ["graphql-ws"; "graphql-transport-ws"] in 93 93 + let s = Websocket.protocols_to_string protos in 94 94 + Alcotest.(check string) "to_string" "graphql-ws, graphql-transport-ws" s 95 95 + 96 96 + let test_select_protocol_match () = 97 97 + let offered = ["chat"; "superchat"] in 98 98 + let supported = ["superchat"; "chat"] in 99 99 + let selected = Websocket.select_protocol ~offered ~supported in 100 100 + (* Should select first from supported that is in offered *) 101 101 + Alcotest.(check (option string)) "selected" (Some "superchat") selected 102 102 + 103 103 + let test_select_protocol_no_match () = 104 104 + let offered = ["chat"] in 105 105 + let supported = ["other"] in 106 106 + let selected = Websocket.select_protocol ~offered ~supported in 107 107 + Alcotest.(check (option string)) "no match" None selected 108 108 + 109 109 + (** {1 Extension Parsing Tests} *) 110 110 + 111 111 + let test_parse_extensions_basic () = 112 112 + let exts = Websocket.parse_extensions "permessage-deflate" in 113 113 + Alcotest.(check int) "count" 1 (List.length exts); 114 114 + Alcotest.(check string) "name" "permessage-deflate" (List.hd exts).name; 115 115 + Alcotest.(check int) "params count" 0 (List.length (List.hd exts).params) 116 116 + 117 117 + let test_parse_extensions_with_params () = 118 118 + let exts = Websocket.parse_extensions 119 119 + "permessage-deflate; client_max_window_bits; server_no_context_takeover" in 120 120 + Alcotest.(check int) "count" 1 (List.length exts); 121 121 + let ext = List.hd exts in 122 122 + Alcotest.(check string) "name" "permessage-deflate" ext.name; 123 123 + Alcotest.(check int) "params count" 2 (List.length ext.params) 124 124 + 125 125 + let test_parse_extensions_with_values () = 126 126 + let exts = Websocket.parse_extensions 127 127 + "permessage-deflate; client_max_window_bits=15" in 128 128 + let ext = List.hd exts in 129 129 + Alcotest.(check string) "name" "permessage-deflate" ext.name; 130 130 + match ext.params with 131 131 + | [(key, Some value)] -> 132 132 + Alcotest.(check string) "param key" "client_max_window_bits" key; 133 133 + Alcotest.(check string) "param value" "15" value 134 134 + | _ -> 135 135 + Alcotest.fail "Expected one param with value" 136 136 + 137 137 + let test_parse_extensions_multiple () = 138 138 + let exts = Websocket.parse_extensions "permessage-deflate, x-custom" in 139 139 + Alcotest.(check int) "count" 2 (List.length exts); 140 140 + Alcotest.(check bool) "has permessage-deflate" true 141 141 + (Websocket.has_extension ~name:"permessage-deflate" exts); 142 142 + Alcotest.(check bool) "has x-custom" true 143 143 + (Websocket.has_extension ~name:"x-custom" exts) 144 144 + 145 145 + let test_extensions_to_string () = 146 146 + let exts = [ 147 147 + { Websocket.name = "permessage-deflate"; 148 148 + params = [("client_max_window_bits", None)] } 149 149 + ] in 150 150 + let s = Websocket.extensions_to_string exts in 151 151 + Alcotest.(check string) "to_string" 152 152 + "permessage-deflate; client_max_window_bits" s 153 153 + 154 154 + let test_get_extension_params () = 155 155 + let exts = Websocket.parse_extensions 156 156 + "permessage-deflate; client_max_window_bits=15" in 157 157 + match Websocket.get_extension_params ~name:"permessage-deflate" exts with 158 158 + | Some params -> 159 159 + Alcotest.(check int) "params count" 1 (List.length params) 160 160 + | None -> 161 161 + Alcotest.fail "Expected Some params" 162 162 + 163 163 + (** {1 Upgrade Headers Tests} *) 164 164 + 165 165 + let test_make_upgrade_headers_basic () = 166 166 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 167 167 + let headers = Websocket.make_upgrade_headers ~key () in 168 168 + Alcotest.(check (option string)) "Upgrade" (Some "websocket") 169 169 + (Headers.get `Upgrade headers); 170 170 + Alcotest.(check (option string)) "Connection" (Some "Upgrade") 171 171 + (Headers.get `Connection headers); 172 172 + Alcotest.(check (option string)) "Sec-WebSocket-Key" (Some key) 173 173 + (Headers.get `Sec_websocket_key headers); 174 174 + Alcotest.(check (option string)) "Sec-WebSocket-Version" (Some "13") 175 175 + (Headers.get `Sec_websocket_version headers) 176 176 + 177 177 + let test_make_upgrade_headers_with_protocols () = 178 178 + let key = Websocket.generate_key () in 179 179 + let headers = Websocket.make_upgrade_headers ~key 180 180 + ~protocols:["graphql-ws"; "graphql-transport-ws"] () in 181 181 + match Headers.get `Sec_websocket_protocol headers with 182 182 + | Some proto -> 183 183 + Alcotest.(check bool) "contains graphql-ws" true 184 184 + (string_contains ~affix:"graphql-ws" proto) 185 185 + | None -> 186 186 + Alcotest.fail "Expected Sec-WebSocket-Protocol header" 187 187 + 188 188 + let test_make_upgrade_headers_with_origin () = 189 189 + let key = Websocket.generate_key () in 190 190 + let headers = Websocket.make_upgrade_headers ~key 191 191 + ~origin:"https://example.com" () in 192 192 + Alcotest.(check (option string)) "Origin" (Some "https://example.com") 193 193 + (Headers.get `Origin headers) 194 194 + 195 195 + (** {1 Upgrade Response Validation Tests} *) 196 196 + 197 197 + let test_validate_response_success () = 198 198 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 199 199 + let accept = "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" in 200 200 + let headers = Headers.empty 201 201 + |> Headers.set `Upgrade "websocket" 202 202 + |> Headers.set `Connection "Upgrade" 203 203 + |> Headers.set `Sec_websocket_accept accept in 204 204 + let result = Websocket.validate_upgrade_response ~key ~status:101 ~headers in 205 205 + match result with 206 206 + | Ok () -> Alcotest.(check pass) "valid response" () () 207 207 + | Error msg -> Alcotest.fail msg 208 208 + 209 209 + let test_validate_response_wrong_status () = 210 210 + let key = Websocket.generate_key () in 211 211 + let headers = Headers.empty in 212 212 + let result = Websocket.validate_upgrade_response ~key ~status:200 ~headers in 213 213 + match result with 214 214 + | Error msg -> 215 215 + Alcotest.(check bool) "mentions 101" true 216 216 + (string_contains ~affix:"101" msg) 217 217 + | Ok () -> 218 218 + Alcotest.fail "Expected error for wrong status" 219 219 + 220 220 + let test_validate_response_missing_upgrade () = 221 221 + let key = Websocket.generate_key () in 222 222 + let headers = Headers.empty 223 223 + |> Headers.set `Connection "Upgrade" in 224 224 + let result = Websocket.validate_upgrade_response ~key ~status:101 ~headers in 225 225 + match result with 226 226 + | Error msg -> 227 227 + Alcotest.(check bool) "mentions Upgrade" true 228 228 + (string_contains ~affix:"Upgrade" msg) 229 229 + | Ok () -> 230 230 + Alcotest.fail "Expected error for missing Upgrade" 231 231 + 232 232 + let test_validate_response_wrong_accept () = 233 233 + let key = "dGhlIHNhbXBsZSBub25jZQ==" in 234 234 + let headers = Headers.empty 235 235 + |> Headers.set `Upgrade "websocket" 236 236 + |> Headers.set `Connection "Upgrade" 237 237 + |> Headers.set `Sec_websocket_accept "wrongvalue" in 238 238 + let result = Websocket.validate_upgrade_response ~key ~status:101 ~headers in 239 239 + match result with 240 240 + | Error msg -> 241 241 + Alcotest.(check bool) "mentions accept" true 242 242 + (string_contains ~affix:"Accept" msg || 243 243 + string_contains ~affix:"accept" msg) 244 244 + | Ok () -> 245 245 + Alcotest.fail "Expected error for wrong accept" 246 246 + 247 247 + (** {1 Test Suite} *) 248 248 + 249 249 + let () = 250 250 + (* Initialize RNG for key generation *) 251 251 + Mirage_crypto_rng_unix.use_default (); 252 252 + Alcotest.run "WebSocket (RFC 6455)" [ 253 253 + ("Key Generation", [ 254 254 + Alcotest.test_case "Key length" `Quick test_generate_key_length; 255 255 + Alcotest.test_case "Keys unique" `Quick test_generate_key_unique; 256 256 + Alcotest.test_case "Valid base64" `Quick test_generate_key_valid_base64; 257 257 + ]); 258 258 + ("Accept Computation", [ 259 259 + Alcotest.test_case "RFC example" `Quick test_compute_accept_rfc_example; 260 260 + Alcotest.test_case "Validate correct" `Quick test_validate_accept_correct; 261 261 + Alcotest.test_case "Validate incorrect" `Quick test_validate_accept_incorrect; 262 262 + Alcotest.test_case "Roundtrip" `Quick test_compute_validate_roundtrip; 263 263 + ]); 264 264 + ("Protocol Negotiation", [ 265 265 + Alcotest.test_case "Parse basic" `Quick test_parse_protocols_basic; 266 266 + Alcotest.test_case "Parse single" `Quick test_parse_protocols_single; 267 267 + Alcotest.test_case "Parse empty" `Quick test_parse_protocols_empty; 268 268 + Alcotest.test_case "To string" `Quick test_protocols_to_string; 269 269 + Alcotest.test_case "Select match" `Quick test_select_protocol_match; 270 270 + Alcotest.test_case "Select no match" `Quick test_select_protocol_no_match; 271 271 + ]); 272 272 + ("Extension Parsing", [ 273 273 + Alcotest.test_case "Basic" `Quick test_parse_extensions_basic; 274 274 + Alcotest.test_case "With params" `Quick test_parse_extensions_with_params; 275 275 + Alcotest.test_case "With values" `Quick test_parse_extensions_with_values; 276 276 + Alcotest.test_case "Multiple" `Quick test_parse_extensions_multiple; 277 277 + Alcotest.test_case "To string" `Quick test_extensions_to_string; 278 278 + Alcotest.test_case "Get params" `Quick test_get_extension_params; 279 279 + ]); 280 280 + ("Upgrade Headers", [ 281 281 + Alcotest.test_case "Basic headers" `Quick test_make_upgrade_headers_basic; 282 282 + Alcotest.test_case "With protocols" `Quick test_make_upgrade_headers_with_protocols; 283 283 + Alcotest.test_case "With origin" `Quick test_make_upgrade_headers_with_origin; 284 284 + ]); 285 285 + ("Response Validation", [ 286 286 + Alcotest.test_case "Success" `Quick test_validate_response_success; 287 287 + Alcotest.test_case "Wrong status" `Quick test_validate_response_wrong_status; 288 288 + Alcotest.test_case "Missing Upgrade" `Quick test_validate_response_missing_upgrade; 289 289 + Alcotest.test_case "Wrong accept" `Quick test_validate_response_wrong_accept; 290 290 + ]); 291 291 + ]