334abfb2a873f767808547833ed92ad5544c0e422ecb521ae4289e874b3d72ee.tri (17231B)
1 !import prelude * 2 !import io * 3 !import socket * 4 !import parser * 5 !import native_math as Nat 6 !export * 7 8 -- --------------------------------------------------------------------------- 9 -- Constants 10 -- --------------------------------------------------------------------------- 11 12 maxHeaderBytes = 65536 13 maxBodyBytes = 1048576 14 15 crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t))) 16 17 -- --------------------------------------------------------------------------- 18 -- Response construction 19 -- --------------------------------------------------------------------------- 20 21 statusPhrases = 22 [(pair 200 "OK") 23 (pair 201 "Created") 24 (pair 204 "No Content") 25 (pair 400 "Bad Request") 26 (pair 404 "Not Found") 27 (pair 405 "Method Not Allowed") 28 (pair 413 "Content Too Large") 29 (pair 431 "Request Header Fields Too Large") 30 (pair 501 "Not Implemented") 31 (pair 505 "HTTP Version Not Supported")] 32 33 lookupStatusPhrase code [(key, phrase) | rest] = (let 34 select ^code = phrase 35 select _ = lookupStatusPhrase code rest 36 in select key) 37 lookupStatusPhrase _ _ = "Internal Server Error" 38 39 statusPhrase code = lookupStatusPhrase code statusPhrases 40 41 statusLine code phrase = append "HTTP/1.1 " (append (showNumber code) (append " " (append phrase "\r\n"))) 42 headerLine key value = append key (append ": " (append value "\r\n")) 43 44 httpAppendResponseHeader accumulated (key, value) = append accumulated (headerLine key value) 45 -- Preserve the old pair-projection fallback for malformed response-header items. 46 httpAppendResponseHeader accumulated _ = append accumulated (headerLine "" "") 47 48 buildResponse status headers body = (append 49 (statusLine status (statusPhrase status)) 50 (append (foldl httpAppendResponseHeader "" headers) (append "\r\n" body))) 51 52 response status contentType body = (buildResponse status 53 [(pair "Content-Type" contentType) 54 (pair "Content-Length" (showNumber (length body))) 55 (pair "Connection" "close")] 56 body) 57 58 emptyResponse status = (buildResponse status 59 [(pair "Content-Length" "0") (pair "Connection" "close")] 60 "") 61 62 okResponse body = response 200 "text/plain; charset=utf-8" body 63 textResponse body = response 200 "text/plain; charset=utf-8" body 64 jsonResponse body = response 200 "application/json" body 65 htmlResponse body = response 200 "text/html; charset=utf-8" body 66 createdResponse body = response 201 "text/plain; charset=utf-8" body 67 notFoundResponse = response 404 "text/plain; charset=utf-8" "Not found\n" 68 badRequestResponse message = response 400 "text/plain; charset=utf-8" message 69 errorResponse status message = response status "text/plain; charset=utf-8" message 70 71 headerEndState 2 13 = 3 72 headerEndState _ 13 = 1 73 headerEndState 3 10 = 4 74 headerEndState 1 10 = 2 75 headerEndState _ _ = 0 76 77 httpHeadersOnly [byte | rest] state reversed = (let 78 accumulated = pair byte reversed 79 continue 4 = reverse accumulated 80 continue next = httpHeadersOnly rest next accumulated 81 in continue (headerEndState state byte)) 82 httpHeadersOnly _ _ reversed = reverse reversed 83 84 headersOnly bytes = httpHeadersOnly bytes 0 [] 85 86 responseForMethod "HEAD" response = headersOnly response 87 responseForMethod _ response = response 88 89 -- --------------------------------------------------------------------------- 90 -- Header receive / framing 91 -- --------------------------------------------------------------------------- 92 93 -- maxBytes bounds the entire accumulated receive buffer, including any 94 -- prefetched suffix. Retain that policy; this is not a header-only byte count. 95 httpRecvUntil sock delimiter limit accumulated count = (let 96 received (t, _) = pure (err 400 accumulated) 97 received ((t t), ([], _)) = pure (err 400 accumulated) 98 received ((t t), (chunk, _)) = (let 99 next = append accumulated chunk 100 nextCount = Nat.add count (length chunk) 101 found ^true = pure (ok next t) 102 found _ = httpRecvUntil sock delimiter limit next nextCount 103 bounded ^true = found (contains? delimiter next) 104 bounded _ = pure (err 431 next) 105 in bounded (Nat.lte nextCount limit)) 106 received _ = pure (err 400 accumulated) 107 in do bind 108 reply <- recv sock 4096 109 received reply) 110 111 recvUntilMax sock delimiter limit = httpRecvUntil sock delimiter limit [] 0 112 113 recvUntil sock delimiter = recvUntilMax sock delimiter maxHeaderBytes 114 115 recvHeaders sock = recvUntilMax sock crlfcrlf maxHeaderBytes 116 117 -- --------------------------------------------------------------------------- 118 -- Request line parsing 119 -- --------------------------------------------------------------------------- 120 121 -- HTTP/1.1 lines require CRLF. A bare CR/LF is an error, never a byte to 122 -- discard. Failure retains the offending suffix and prior consumption; EOF 123 -- cannot masquerade as a successfully parsed empty line. 124 httpLineError code found rest consumed = (parserReplyFail 125 (parserDiagnostic code "CRLF" found t ["http-line"]) 126 rest consumed false) 127 128 httpScanLine [13 10 | rest] reversed = parserReplyOk (reverse reversed) rest true false 129 httpScanLine input{[13 | _]} reversed = httpLineError 2 13 input (not? (emptyList? reversed)) 130 httpScanLine input{[10 | _]} reversed = httpLineError 2 10 input (not? (emptyList? reversed)) 131 httpScanLine [byte | rest] reversed = httpScanLine rest (pair byte reversed) 132 httpScanLine [] reversed = httpLineError 1 t [] (not? (emptyList? reversed)) 133 httpScanLine input reversed = httpLineError 2 input input (not? (emptyList? reversed)) 134 135 httpLineReply input = httpScanLine input [] 136 httpBadRequest = err 400 "Bad Request\n" 137 138 -- Unlike the old pair-only helper, this Result distinguishes a blank CRLF 139 -- line from truncated/malformed input. Both callers propagate the failure. 140 readLineBytes input = (parserMatchReply 141 (_ _ _ _ : httpBadRequest) 142 (line rest _ _ : ok line rest) 143 (httpLineReply input)) 144 145 -- The finite request line is already framed by readLineBytes. Deliberately 146 -- retain the historical three-fields grammar: empty fields are permitted, 147 -- but a third separating space is an error. The parser reply exposes byte 148 -- consumption to new clients, while parseThreeWords preserves HTTP's public 149 -- Result/400 boundary and the original "Bad Request" remainder. 150 httpNonSpace? byte = not? (equal? byte 32) 151 152 httpThreeWordsReply = (parserContext "request-line" (do parserBind 153 method <- parserTakeWhile httpNonSpace? 154 parserExpect 32 155 target <- parserTakeWhile httpNonSpace? 156 parserExpect 32 157 version <- parserTakeWhile httpNonSpace? 158 parserEof 159 parserPure (pair method (pair target version)))) 160 161 parseThreeWords = (bs : 162 parserMatchReply 163 (diagnostic rest consumed committed : err 400 "Bad Request\n") 164 (words rest consumed committed : ok words rest) 165 (httpThreeWordsReply bs)) 166 167 parseRequestLine input = (let 168 parseLine ((t t), (line, rest)) = (let 169 parsed ((t t), (request, _)) = ok request rest 170 parsed _ = httpBadRequest 171 in parsed (parseThreeWords line)) 172 parseLine _ = httpBadRequest 173 in parseLine (readLineBytes input)) 174 175 -- --------------------------------------------------------------------------- 176 -- Header parsing 177 -- --------------------------------------------------------------------------- 178 179 -- Canonical byte input (0..255), as supplied by the socket/byte codecs. 180 -- Historical malformed numeral/bit behavior is intentionally not a contract. 181 toLowerAsciiByte byte = (let 182 lower ^true = Nat.add byte 32 183 lower _ = byte 184 in lower (Nat.inRange byte 65 90)) 185 186 -- RFC 9110 token names, OWS, and field-value bytes. obs-text (128..255) 187 -- stays opaque; only the ASCII header name is lowercased. Reject obs-fold. 188 httpTokenByte? byte = (or? (Nat.letter byte) 189 (or? (Nat.digit byte) (any? (equal? byte) "!#$%&'*+-.^_`|~"))) 190 httpOws? byte = or? (equal? byte 32) (equal? byte 9) 191 httpFieldByte? byte = (or? (equal? byte 9) 192 (or? (Nat.printable byte) (Nat.inRange byte 128 255))) 193 httpTrimOws value = reverse (dropWhile httpOws? (reverse (dropWhile httpOws? value))) 194 195 -- Parse exactly one finite line, excluding CRLF. Preserve parser diagnostics 196 -- and consumption, but never accept a valid prefix followed by invalid bytes. 197 httpHeaderLineReply = (parserContext "header-line" (do parserBind 198 name <- parserLabel "header-name" (parserSome (parserSatisfy httpTokenByte?)) 199 parserLabel "colon" (parserExpect 58) 200 value <- parserLabel "header-value" (parserBefore (parserTakeWhile httpFieldByte?) parserEof) 201 parserPure (pair (map toLowerAsciiByte name) (httpTrimOws value)))) 202 203 -- Only an actual empty CRLF line ends the headers. The returned suffix is 204 -- opaque body data, even if it contains CR, LF, NUL or header-looking bytes. 205 httpParseHeaderLines input reversedHeaders = (let 206 parseLine ((t t), ([], rest)) = ok (reverse reversedHeaders) rest 207 parseLine ((t t), (line, rest)) = (let 208 continue ((t t), (header, _)) = httpParseHeaderLines rest (pair header reversedHeaders) 209 continue _ = httpBadRequest 210 in continue (httpHeaderLineReply line)) 211 parseLine _ = httpBadRequest 212 in parseLine (readLineBytes input)) 213 214 parseHeaders input = httpParseHeaderLines input [] 215 216 -- --------------------------------------------------------------------------- 217 -- Content-Length parsing 218 -- --------------------------------------------------------------------------- 219 220 -- The accumulator never exceeds maxBodyBytes. A single checked step can 221 -- reach at most 10 * maxBodyBytes + 9; after that, validate digits without 222 -- constructing a larger number. Trailing junk still means 400, not 413. 223 httpBodyTooLarge = err 413 "Request body too large\n" 224 225 httpLengthOverflow [] = httpBodyTooLarge 226 httpLengthOverflow [byte | rest] = (let 227 continue ^true = httpLengthOverflow rest 228 continue _ = httpBadRequest 229 in continue (Nat.digit byte)) 230 httpLengthOverflow _ = httpBadRequest 231 232 httpLengthDigits [] value = ok (just value) t 233 httpLengthDigits [byte | rest] value = (let 234 digit ^true = (let 235 next = Nat.decimal value (Nat.subtract byte 48) 236 bounded ^true = httpLengthDigits rest next 237 bounded _ = httpLengthOverflow rest 238 in bounded (Nat.lte next maxBodyBytes)) 239 digit _ = httpBadRequest 240 in digit (Nat.digit byte)) 241 httpLengthDigits _ _ = httpBadRequest 242 243 -- Input is a finite canonical byte list, with no OWS: parseHeaders already 244 -- trims field edges. Empty strings, signs, commas and interior whitespace fail. 245 parseContentLengthValue input{[_ | _]} = httpLengthDigits input 0 246 parseContentLengthValue _ = httpBadRequest 247 248 -- Input names are normalized by parseHeaders. Select the sole raw length 249 -- before decoding: duplicate fields and unsupported transfer coding are 400 250 -- regardless of field order or whether a length would otherwise exceed limits. 251 -- This server supports Content-Length framing only, not chunked decoding. 252 httpSelectLength [] t = ok nothing t 253 httpSelectLength [] (t value) = parseContentLengthValue value 254 httpSelectLength [("transfer-encoding", _) | _] _ = httpBadRequest 255 httpSelectLength [("content-length", value) | rest] t = httpSelectLength rest (just value) 256 httpSelectLength [("content-length", _) | _] _ = httpBadRequest 257 httpSelectLength [(_, _) | rest] selected = httpSelectLength rest selected 258 httpSelectLength _ _ = httpBadRequest 259 260 contentLength headers = httpSelectLength headers nothing 261 262 -- --------------------------------------------------------------------------- 263 -- Body reading 264 -- --------------------------------------------------------------------------- 265 266 bodyReadState remaining reversed rest = pair remaining (pair reversed rest) 267 268 -- State is (remaining, (reversed body, unused input)); zero consumes nothing. 269 -- remaining is a canonical natural supplied by the bounded length decoder. 270 takeBodyBytes bytes 0 reversed = bodyReadState 0 reversed bytes 271 takeBodyBytes [byte | rest] remaining reversed = takeBodyBytes rest (Nat.subtract remaining 1) (pair byte reversed) 272 takeBodyBytes _ remaining reversed = bodyReadState remaining reversed [] 273 274 -- Retain the existing receive-size buckets, expressed as native comparisons 275 -- rather than bit shifts. Zero is handled before asking for another chunk. 276 httpRecvBucket remaining [size | rest] = (let 277 choose ^true = size 278 choose _ = httpRecvBucket remaining rest 279 in choose (Nat.gte remaining size)) 280 httpRecvBucket _ _ = 1 281 282 recvChunkMax4096 remaining = httpRecvBucket remaining [4096 1024 256 64 16] 283 284 -- One state machine owns both buffered and subsequent socket input. EOF before 285 -- completion is a 400, not another recv with unchanged remaining length. 286 httpReadBodyState _ (0, (reversed, rest)) = pure (ok (reverse reversed) rest) 287 httpReadBodyState sock (remaining, (reversed, _)) = (let 288 received (t, (message, _)) = pure (err 400 (append "recv failed while reading body: " message)) 289 received ((t t), ([], _)) = pure (err 400 "Unexpected end of request body\n") 290 received ((t t), (chunk, _)) = httpReadBodyState sock (takeBodyBytes chunk remaining reversed) 291 received _ = pure httpBadRequest 292 in do bind 293 reply <- recv sock (recvChunkMax4096 remaining) 294 received reply) 295 httpReadBodyState _ _ = pure httpBadRequest 296 297 readBodyMore sock remaining reversed = httpReadBodyState sock (bodyReadState remaining reversed []) 298 readBodyExact sock expected initial = httpReadBodyState sock (takeBodyBytes initial expected []) 299 300 -- readBodyExact starts with remaining + length(reversed) = expected. 301 -- takeBodyBytes preserves that sum; only remaining=0 succeeds, while early EOF 302 -- or recv failure returns an error. A successful body already has exact length: 303 -- do not traverse it again solely to recount it. 304 readBody sock headers initial = (let 305 selected ((t t), (t, _)) = pure (ok [] initial) 306 selected ((t t), ((t count), _)) = readBodyExact sock count initial 307 selected failure = pure failure 308 in selected (contentLength headers)) 309 310 -- --------------------------------------------------------------------------- 311 -- Request validation 312 -- --------------------------------------------------------------------------- 313 314 validMethod? "GET" = true 315 validMethod? "POST" = true 316 validMethod? "HEAD" = true 317 validMethod? _ = false 318 319 validVersion? "HTTP/1.1" = true 320 validVersion? "HTTP/1.0" = true 321 validVersion? _ = false 322 323 validTarget? [47 | _] = true 324 validTarget? _ = false 325 326 -- Keep error precedence: method, version, then target. Headers are validated 327 -- separately; accepting them here does not select body framing. 328 validateRequest method target version _ = (let 329 targetChecked ^true = ok t t 330 targetChecked _ = httpBadRequest 331 versionChecked ^true = targetChecked (validTarget? target) 332 versionChecked _ = err 505 "HTTP Version Not Supported\n" 333 methodChecked ^true = versionChecked (validVersion? version) 334 methodChecked _ = httpBadRequest 335 in methodChecked (validMethod? method)) 336 337 -- --------------------------------------------------------------------------- 338 -- Handler pipeline 339 -- --------------------------------------------------------------------------- 340 341 routerMethod "HEAD" = "GET" 342 routerMethod method = method 343 344 -- finally preserves a send Result and attempts close even after send failure. 345 -- Like the existing IO helper, it does not catch host exceptions/abortIO. 346 respondAndClose sock response = (do onOk_ 347 finally (send sock response) (closeSocket_ sock) 348 pure (ok t t)) 349 350 httpRespond client method response = respondAndClose client (responseForMethod method response) 351 352 httpHandleBody router client method target headers reply = (let 353 handle ((t t), (body, _)) = (do bind 354 response <- router (routerMethod method) target headers body 355 httpRespond client method response) 356 handle (t, (status, message)) = httpRespond client method (errorResponse status message) 357 handle _ = httpRespond client method (badRequestResponse "Bad Request\n") 358 in handle reply) 359 360 httpHandleHeaders router client method target version input = (let 361 headersParsed ((t t), (headers, initial)) = (let 362 validated ((t t), _) = (do bind 363 reply <- readBody client headers initial 364 httpHandleBody router client method target headers reply) 365 validated (t, (status, message)) = httpRespond client method (errorResponse status message) 366 validated _ = httpRespond client method (badRequestResponse "Bad Request\n") 367 in validated (validateRequest method target version headers)) 368 -- Retain historical behavior: a header syntax failure has no trusted HEAD 369 -- response handling, even though the request line has already been parsed. 370 headersParsed _ = respondAndClose client (badRequestResponse "Bad Request\n") 371 in headersParsed (parseHeaders input)) 372 373 httpHandleRequest router client ((t t), ((method, (target, version)), headers)) = httpHandleHeaders router client method target version headers 374 httpHandleRequest _ client _ = respondAndClose client (badRequestResponse "Bad Request\n") 375 376 httpHandleReceived router client ((t t), (raw, _)) = httpHandleRequest router client (parseRequestLine raw) 377 httpHandleReceived _ client (t, (431, _)) = respondAndClose client (errorResponse 431 "Request Header Fields Too Large\n") 378 httpHandleReceived _ client _ = respondAndClose client (badRequestResponse "Bad Request\n") 379 380 httpHandlerIO router client _ = (do bind 381 reply <- recvHeaders client 382 httpHandleReceived router client reply) 383 384 -- One effectful pipeline; a pure router needs only this value-to-action adapter. 385 httpPureRouter router method target headers body = pure (router method target headers body) 386 httpHandler router client peer = httpHandlerIO (httpPureRouter router) client peer