tricu

01fde1b298c8920fe2116d3763ea2e4cc865d0752c25325587289dc72f999d68.tri (26065B)

---

 !import prelude *
 !import io *
 !import patterns *
 !import socket *
 !import parser *
 !export *
 
 -- ---------------------------------------------------------------------------
 --  Constants
 -- ---------------------------------------------------------------------------
 
 maxHeaderBytes = 65536
 maxBodyBytes = 1048576
 maxUriBytes = 8192
 
 crlf = pair 13 (pair 10 t)
 crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t)))
 
 -- ---------------------------------------------------------------------------
 --  Small byte/list helpers
 -- ---------------------------------------------------------------------------
 
 chomp = (xs :
   lazyList
     (_ : t)
     (h r :
       lazyBool
         (_ : reverse r)
         (_ : xs)
         (equal? h 13))
     (reverse xs))
 
 -- ---------------------------------------------------------------------------
 --  Response construction
 -- ---------------------------------------------------------------------------
 
 statusPhrases =
   [(pair 200 "OK")
    (pair 201 "Created")
    (pair 204 "No Content")
    (pair 400 "Bad Request")
    (pair 404 "Not Found")
    (pair 405 "Method Not Allowed")
    (pair 431 "Request Header Fields Too Large")
    (pair 501 "Not Implemented")
    (pair 505 "HTTP Version Not Supported")]
 
 lookupStatusPhrase_ self code phrases =
   lazyList
     (_ : "Internal Server Error")
     (h r :
       lazyBool
         (_ : snd h)
         (_ : self code r)
         (equal? code (fst h)))
     phrases
 
 statusPhrase = (code :
   y lookupStatusPhrase_ code statusPhrases)
 
 statusLine = (code phrase :
   append "HTTP/1.1 " (append (showNumber code) (append " " (append phrase "\r\n"))))
 
 headerLine = (key value :
   append key (append ": " (append value "\r\n")))
 
 buildResponse = (status headers body :
   append
     (statusLine status (statusPhrase status))
     (append
       (foldl (acc h : append acc (headerLine (fst h) (snd h))) "" headers)
       (append "\r\n" body)))
 
 response = (status contentType body :
   buildResponse status
     [(pair "Content-Type" contentType)
      (pair "Content-Length" (showNumber (length body)))
      (pair "Connection" "close")]
     body)
 
 emptyResponse = (status :
   buildResponse status
     [(pair "Content-Length" "0")
      (pair "Connection" "close")]
     "")
 
 okResponse = (body :
   response 200 "text/plain; charset=utf-8" body)
 
 textResponse = (body :
   response 200 "text/plain; charset=utf-8" body)
 
 jsonResponse = (body :
   response 200 "application/json" body)
 
 htmlResponse = (body :
   response 200 "text/html; charset=utf-8" body)
 
 createdResponse = (body :
   response 201 "text/plain; charset=utf-8" body)
 
 notFoundResponse = (
   response 404 "text/plain; charset=utf-8" "Not found\n")
 
 badRequestResponse = (msg :
   response 400 "text/plain; charset=utf-8" msg)
 
 errorResponse = (status msg :
   response status "text/plain; charset=utf-8" msg)
 
 headerEndState state h =
   lazyBool
     (_ :
       lazyBool
         (_ : 3)
         (_ : 1)
         (equal? state 2))
     (_ :
       lazyBool
         (_ :
           lazyBool
             (_ : 4)
             (_ : 2)
             (equal? state 3))
         (_ : 0)
         (boolAnd?
           (equal? h 10)
           (boolOr? (equal? state 1) (equal? state 3))))
     (equal? h 13)
 
 headersOnly_ self bs state acc =
   lazyList
     (_ : reverse acc)
     (h r :
       let nextAcc = pair h acc in
       let nextState = headerEndState state h in
       lazyBool
         (_ : reverse nextAcc)
         (_ : self r nextState nextAcc)
         (equal? nextState 4))
     bs
 
 headersOnly = (response :
   y headersOnly_ response 0 t)
 
 responseForMethod = (method resp :
   lazyBool
     (_ : headersOnly resp)
     (_ : resp)
     (equal? method "HEAD"))
 
 -- ---------------------------------------------------------------------------
 --  Header receive / framing
 -- ---------------------------------------------------------------------------
 
 recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
   onResult_ (recv sock 4096)
     (err :
       pure (err 400 acc))
     (chunk :
       lazyBool
         (_ : pure (err 400 acc))
         (_ :
           let chunkLen = length chunk in
           let nextLen = add accLen chunkLen in
           let next = append acc chunk in
           lazyBool
             (_ :
               lazyBool
                 (_ : pure (ok next t))
                 (_ : self sock pattern maxBytes next nextLen)
                 (contains? pattern next))
             (_ : pure (err 431 next))
             (lte? nextLen maxBytes))
         (emptyList? chunk))))
 
 recvUntilMax = (sock pattern maxBytes :
   recvUntilMax_ sock pattern maxBytes t 0)
 
 recvUntil = (sock pattern :
   recvUntilMax sock pattern maxHeaderBytes)
 
 recvHeaders = (sock :
   recvUntilMax sock crlfcrlf maxHeaderBytes)
 
 -- ---------------------------------------------------------------------------
 --  Request line parsing
 -- ---------------------------------------------------------------------------
 
 -- Retain the original scanner during migration for differential checks.
 readLineBytesLegacy_ = (y (self bs acc :
   lazyList
     (_ : pair (reverse acc) t)
     (h r :
       lazyBool
         (_ : pair (reverse acc) r)
         (_ :
           lazyBool
             (_ : self r acc)
             (_ : self r (pair h acc))
             (equal? h 13))
         (equal? h 10))
     bs))
 
 readLineBytesLegacy = (bs :
   ((result :
     pair (chomp (fst result)) (snd result))
    (readLineBytesLegacy_ bs t)))
 
 -- The finite CRLF/LF line parser consumes LF when present, accepts EOF as
 -- a terminator, and removes CR bytes wherever the historical scanner did.
 httpLineReply =
   parserBind (parserTakeWhile (byte : not? (equal? byte 10)))
     (line : parserMap
       (_ : filter (byte : not? (equal? byte 13)) line)
       (parserOptional (parserExpect 10)))
 
 readLineBytes = (bs :
   parserMatchReply
     (diagnostic rest consumed committed : pair t bs)
     (line rest consumed committed : pair line rest)
     (httpLineReply bs))
 
 -- The finite request line is already framed by readLineBytes. Deliberately
 -- retain the historical three-fields grammar: empty fields are permitted,
 -- but a third separating space is an error. The parser reply exposes byte
 -- consumption to new clients, while parseThreeWords preserves HTTP's public
 -- Result/400 boundary and the original "Bad Request" remainder.
 httpNonSpace? byte = not? (equal? byte 32)
 
 httpThreeWordsReply =
   parserContext "request-line"
     (parserBind (parserTakeWhile httpNonSpace?) (method :
       parserThen (parserExpect 32)
         (parserBind (parserTakeWhile httpNonSpace?) (target :
           parserThen (parserExpect 32)
             (parserBind (parserTakeWhile httpNonSpace?) (version :
               parserMap (_ : pair method (pair target version))
                 parserEof))))))
 
 parseThreeWords = (bs :
   parserMatchReply
     (diagnostic rest consumed committed : err 400 "Bad Request\n")
     (words rest consumed committed : ok words rest)
     (httpThreeWordsReply bs))
 
 parseRequestLine = (bs :
   ((lineRest :
     lazyResult
       (code bad : err 400 "Bad Request\n")
       (req ignored : ok req (snd lineRest))
       (parseThreeWords (fst lineRest)))
    (readLineBytes bs)))
 
 -- ---------------------------------------------------------------------------
 --  Header parsing
 -- ---------------------------------------------------------------------------
 
 
 -- ASCII byte helpers below are structural on the Tree Calculus numeral
 -- spine. Do not replace them with lte?/sub based checks: these names are
 -- normalized at import time under abstract byte inputs.
 boolNot? = (b :
   matchBool false true b)
 
 boolOr? = (a b :
   matchBool true b a)
 
 boolAnd? = (a b :
   matchBool b false a)
 
 low5NonZero? = (b0 b1 b2 b3 b4 :
   boolOr?
     (bit1? b0)
     (boolOr?
       (bit1? b1)
       (boolOr?
         (bit1? b2)
         (boolOr?
           (bit1? b3)
           (bit1? b4)))))
 
 low5TooHighForUpper? = (b0 b1 b2 b3 b4 :
   boolAnd?
     (bit1? b4)
     (boolAnd?
       (bit1? b3)
       (boolOr?
         (bit1? b2)
         (boolAnd?
           (bit1? b1)
           (bit1? b0)))))
 
 upperLow5? = (b0 b1 b2 b3 b4 :
   boolAnd?
     (low5NonZero? b0 b1 b2 b3 b4)
     (boolNot?
       (low5TooHighForUpper? b0 b1 b2 b3 b4)))
 
 lowerAsciiBits = (b0 b1 b2 b3 b4 :
   pair b0
     (pair b1
       (pair b2
         (pair b3
           (pair b4
             (pair true
               (pair true 0)))))))
 
 byte7BitsOr default c k =
   let noStem _ = default in
   let bit6 b0 b1 b2 b3 b4 b5 b6 r6 =
     k b0 b1 b2 b3 b4 b5 b6 r6 in
   let bit5 b0 b1 b2 b3 b4 b5 r5 =
     triage default noStem (bit6 b0 b1 b2 b3 b4 b5) r5 in
   let bit4 b0 b1 b2 b3 b4 r4 =
     triage default noStem (bit5 b0 b1 b2 b3 b4) r4 in
   let bit3 b0 b1 b2 b3 r3 =
     triage default noStem (bit4 b0 b1 b2 b3) r3 in
   let bit2 b0 b1 b2 r2 =
     triage default noStem (bit3 b0 b1 b2) r2 in
   let bit1 b0 b1 r1 =
     triage default noStem (bit2 b0 b1) r1 in
   let bit0 b0 r0 =
     triage default noStem (bit1 b0) r0 in
   triage default noStem bit0 c
 
 toLowerAsciiByte = (c :
   byte7BitsOr c c (b0 b1 b2 b3 b4 b5 b6 rest :
     lazyBool
       (_ : lowerAsciiBits b0 b1 b2 b3 b4)
       (_ : c)
       (boolAnd?
         (isZero? rest)
         (boolAnd?
           (bit1? b6)
           (boolAnd?
             (bit0? b5)
             (upperLow5? b0 b1 b2 b3 b4))))))
 
 finishHeaderLine = (self r headers key value seenColon :
   matchBool
     (matchBool
       (err 400 "Bad Request\n")
       (ok (reverse headers) r)
       seenColon)
     (matchBool
       (self r
         (pair (pair (reverse key) (reverse value)) headers)
         t
         t
         false
         true)
       (err 400 "Bad Request\n")
       seenColon)
     (emptyList? key))
 
 finishHeaderEOF = (headers key value seenColon :
   matchBool
     (ok (reverse headers) t)
     (matchBool
       (ok (reverse (pair (pair (reverse key) (reverse value)) headers)) t)
       (err 400 "Bad Request\n")
       seenColon)
     (emptyList? key))
 
 -- Retained as a behavior oracle while the live header parser migrates.
 parseHeadersLegacy_ = (self bs headers key value seenColon trimValue :
   matchList
     (finishHeaderEOF headers key value seenColon)
     (h r :
       matchBool
         (finishHeaderLine self r headers key value seenColon)
         (matchBool
           (self r headers key value seenColon trimValue)
           (matchBool
             (matchBool
               (self r headers key value true true)
               (self r headers key (pair h value) true false)
               (boolAnd? trimValue (equal? h 32)))
             (matchBool
               (self r headers key value true true)
               (self r headers (pair (toLowerAsciiByte h) key) value false true)
               (equal? h 58))
             seenColon)
           (equal? h 13))
         (equal? h 10))
     bs)
 
 parseHeadersLegacy = (bs :
   y parseHeadersLegacy_ bs t t t false true)
 
 -- readLineBytes has already removed CR and isolated one finite line. The
 -- generic reply keeps failure progress visible: a missing colon after a
 -- nonempty name is a consumed error, while an empty name fails immediately.
 httpHeaderLineReply =
   parserContext "header-line"
     (parserBind
       (parserLabel "header-name"
         (parserSome (parserSatisfy (byte : not? (equal? byte 58)))))
       (name : parserThen (parserLabel "colon" (parserExpect 58))
         (parserMap (value : pair (map toLowerAsciiByte name)
           (dropWhile (byte : equal? byte 32) value))
           (parserTakeWhile (_ : true)))))
 
 httpParseHeaderLines_ self bs reversed =
   lazyList
     (_ : ok (reverse reversed) bs)
     (first rest :
       ((lineRest :
         lazyList
           (_ : ok (reverse reversed) (snd lineRest))
           (head tail :
             parserMatchReply
               (diagnostic suffix consumed committed :
                 err 400 "Bad Request\n")
               (header suffix consumed committed :
                 self (snd lineRest) (pair header reversed))
               (httpHeaderLineReply (fst lineRest)))
           (fst lineRest))
        (readLineBytes bs)))
     bs
 
 parseHeaders = (bs :
   y httpParseHeaderLines_ bs t)
 
 -- ---------------------------------------------------------------------------
 --  Content-Length parsing
 -- ---------------------------------------------------------------------------
 
 bit0? = (x :
   isZero? x)
 
 bit1? = (x :
   triage
     false
     (a : isZero? a)
     (_ _ : false)
     x)
 
 low3 = (b0 b1 b2 :
   matchBool
     (matchBool
       (matchBool 7 6 (bit1? b0))
       (matchBool 5 4 (bit1? b0))
       (bit1? b1))
     (matchBool
       (matchBool 3 2 (bit1? b0))
       (matchBool 1 0 (bit1? b0))
       (bit1? b1))
     (bit1? b2))
 
 decimalDigit = (c :
   triage
     nothing
     (_ : nothing)
     (b0 r0 :
       triage
         nothing
         (_ : nothing)
         (b1 r1 :
           triage
             nothing
             (_ : nothing)
             (b2 r2 :
               triage
                 nothing
                 (_ : nothing)
                 (b3 r3 :
                   triage
                     nothing
                     (_ : nothing)
                     (b4 r4 :
                       triage
                         nothing
                         (_ : nothing)
                         (b5 r5 :
                           matchBool
                             (matchBool
                               (matchBool
                                 (matchBool
                                   (matchBool
                                     (just (low3 b0 b1 b2))
                                     (matchBool
                                       (matchBool
                                         (just (matchBool 9 8 (bit1? b0)))
                                         nothing
                                         (bit0? b2))
                                       nothing
                                       (bit0? b1))
                                     (bit0? b3))
                                   nothing
                                   (bit1? b5))
                                 nothing
                                 (bit1? b4))
                               nothing
                               (isZero? r5))
                             nothing
                             true)
                         r4)
                     r3)
                 r2)
             r1)
         r0)
     c)
 
 readDecimal_ = (self bytes acc :
   matchList
     (just acc)
     (h r :
       matchMaybe
         nothing
         (d : self r (add (mul acc 10) d))
         (decimalDigit h))
     bytes)
 
 readDecimal = (bytes :
   matchBool
     nothing
     (y readDecimal_ bytes 0)
     (emptyList? bytes))
 
 maxBodyBytesDecimal = "1048576"
 
 byte0? b = equal? b 48
 digitLtMax? maxDigit digit = lt? digit maxDigit
 
 stripLeadingZeros_ self raw =
   lazyList
     (_ : t)
     (c r :
       lazyBool
         (_ : self r)
         (_ : raw)
         (byte0? c))
     raw
 
 decimalLengthLte_ self max raw =
   lazyList
     (_ : true)
     (_ rest :
       lazyList
         (_ : false)
         (_ maxRest : self maxRest rest)
         max)
     raw
 
 decimalSameLength_ self max raw =
   lazyList
     (_ :
       lazyList
         (_ : true)
         (_ _ : false)
         max)
     (_ rest :
       lazyList
         (_ : false)
         (_ maxRest : self maxRest rest)
         max)
     raw
 
 sameLengthDecimalLte_ self max raw less =
   lazyList
     (_ : true)
     (digit rest :
       lazyList
         (_ : false)
         (maxDigit maxRest :
           lazyBool
             (_ : self maxRest rest true)
             (_ :
               lazyBool
                 (_ : self maxRest rest true)
                 (_ :
                   lazyBool
                     (_ : self maxRest rest false)
                     (_ : false)
                     (equal? digit maxDigit))
                 (digitLtMax? maxDigit digit))
             less)
         max)
     raw
 
 decimalLengthLte? max raw = y decimalLengthLte_ max raw
 
 decimalSameLength? max raw = y decimalSameLength_ max raw
 
 decimalBytesLte? max raw =
   let trimmed = y stripLeadingZeros_ raw in
   lazyBool
     (_ : y sameLengthDecimalLte_ max trimmed false)
     (_ : decimalLengthLte? max trimmed)
     (decimalSameLength? max trimmed)
 
 -- This digit predicate reuses the existing structural byte decoder: asking
 -- generic numeric comparisons about abstract byte trees would make importing
 -- this module hang before any request has been received.
 httpDecimalDigit? byte =
   lazyMaybe
     (_ : false)
     (digit : true)
     (decimalDigit byte)
 
 httpDecimalReply =
   parserContext "content-length"
     (parserBind
       (parserLabel "decimal-digit"
         (parserSome (parserSatisfy httpDecimalDigit?)))
       (digits : parserThen
         (parserLabel "end-of-decimal" parserEof)
         (lazyMaybe
           (_ : parserFailure
             (parserDiagnostic 2 "decimal-digit" t t t))
           (number : parserPure number)
           (readDecimal digits))))
 
 -- Retain the earlier validator as an oracle until all header consumers have
 -- been exercised with the generic decimal reply.
 parseContentLengthValueLegacy = (raw :
   matchMaybe
     (err 400 "Bad Request\n")
     (n :
       lazyBool
         (_ : ok (just n) t)
         (_ : err 413 "Request body too large\n")
         (decimalBytesLte? maxBodyBytesDecimal raw))
     (readDecimal raw))
 
 parseContentLengthValue = (raw :
   parserMatchReply
     (diagnostic rest consumed committed : err 400 "Bad Request\n")
     (n rest consumed committed :
       lazyBool
         (_ : ok (just n) t)
         (_ : err 413 "Request body too large\n")
         (decimalBytesLte? maxBodyBytesDecimal raw))
     (httpDecimalReply raw))
 
 contentLength_ = (self headers :
   matchList
     (ok nothing t)
     (h r :
       matchBool
         (parseContentLengthValue (snd h))
         (self r)
         (equal? "content-length" (fst h)))
     headers)
 
 contentLength = (headers :
   y contentLength_ headers)
 
 -- ---------------------------------------------------------------------------
 --  Body reading
 -- ---------------------------------------------------------------------------
 
 bodyReadState = (remaining accRev rest :
   pair remaining (pair accRev rest))
 
 bodyReadRemaining = (state :
   fst state)
 
 bodyReadAccRev = (state :
   fst (snd state))
 
 bodyReadRest = (state :
   snd (snd state))
 
 takeBodyBytes_ = (self bytes remaining accRev :
   lazyBool
     (_ : bodyReadState 0 accRev bytes)
     (_ :
       lazyList
         (_ : bodyReadState remaining accRev t)
         (h r :
           self r (pred remaining) (pair h accRev))
         bytes)
     (isZero? remaining))
 
 takeBodyBytes = (bytes remaining accRev :
   y takeBodyBytes_ bytes remaining accRev)
 
 shiftRight1 n = triage 0 (_ : 0) (_ rest : rest) n
 
 shiftRight2 n = shiftRight1 (shiftRight1 n)
 shiftRight4 n = shiftRight2 (shiftRight2 n)
 shiftRight8 n = shiftRight4 (shiftRight4 n)
 shiftRight12 n = shiftRight4 (shiftRight8 n)
 
 shiftRight6 n = shiftRight2 (shiftRight4 n)
 
 atLeast16? n = not? (isZero? (shiftRight4 n))
 atLeast64? n = not? (isZero? (shiftRight6 n))
 atLeast256? n = not? (isZero? (shiftRight8 n))
 atLeast1024? n = not? (isZero? (shiftRight2 (shiftRight8 n)))
 atLeast4096? n = not? (isZero? (shiftRight12 n))
 
 recvChunkMax4096 remaining =
   lazyBool
     (_ : 4096)
     (_ :
       lazyBool
         (_ : 1024)
         (_ :
           lazyBool
             (_ : 256)
             (_ :
               lazyBool
                 (_ : 64)
                 (_ :
                   lazyBool
                     (_ : 16)
                     (_ : 1)
                     (atLeast16? remaining))
                 (atLeast64? remaining))
             (atLeast256? remaining))
         (atLeast1024? remaining))
     (atLeast4096? remaining)
 
 readBodyRecv = (self sock remaining accRev recvBytes :
   onResult_ (recv sock recvBytes)
     (errMsg :
       pure
         (err
           400
           (append "recv failed while reading body: " errMsg)))
     (chunk :
       let state = takeBodyBytes chunk remaining accRev in
       let nextRemaining = bodyReadRemaining state in
       let nextAccRev = bodyReadAccRev state in
       lazyBool
         (_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
         (_ : self sock nextRemaining nextAccRev)
         (isZero? nextRemaining)))
 
 readBodyMore_ = (self sock remaining accRev :
   lazyBool
     (_ : pure (ok (reverse accRev) t))
     (_ : readBodyRecv self sock remaining accRev (recvChunkMax4096 remaining))
     (isZero? remaining))
 
 readBodyMore = (sock remaining accRev :
   y readBodyMore_ sock remaining accRev)
 
 readBodyExact = (sock expected initialBytes :
   let state = takeBodyBytes initialBytes expected t in
   let remaining = bodyReadRemaining state in
   let accRev = bodyReadAccRev state in
   lazyBool
     (_ : pure (ok (reverse accRev) (bodyReadRest state)))
     (_ : readBodyMore sock remaining accRev)
     (isZero? remaining))
 
 validateBodyLength = (expected body rest :
   let actual = length body in
   lazyBool
     (_ : pure (ok body rest))
     (_ :
       pure
         (err
           400
           (append
             "body length mismatch expected="
             (append
               (showNumber expected)
               (append
                 " actual="
                 (showNumber actual))))))
     (equal? actual expected))
 
 readBody = (sock headers initialBytes :
   matchResult
     (status msg :
       pure (err status msg))
     (maybeLen rest :
       lazyMaybe
         (_ : pure (ok t initialBytes))
         (n :
           onOk (readBodyExact sock n initialBytes)
             (body rest :
               validateBodyLength n body rest))
         maybeLen)
     (contentLength headers))
 
 -- ---------------------------------------------------------------------------
 -- Request validation
 -- ---------------------------------------------------------------------------
 
 validMethod? = (method :
   lazyBool
     (_ : true)
     (_ :
       lazyBool
         (_ : true)
         (_ :
           lazyBool
             (_ : true)
             (_ : false)
             (equal? method "HEAD"))
         (equal? method "POST"))
     (equal? method "GET"))
 
 validVersion? = (version :
   lazyBool
     (_ : true)
     (_ : equal? version "HTTP/1.0")
     (equal? version "HTTP/1.1"))
 
 validTarget? = (target :
   startsWith? "/" target)
 
 validateRequest = (method target version headers :
   lazyBool
     (_ :
       lazyBool
         (_ :
           lazyBool
             (_ : ok t t)
             (_ : err 400 "Bad Request\n")
             (validTarget? target))
         (_ : err 505 "HTTP Version Not Supported\n")
         (validVersion? version))
     (_ : err 400 "Bad Request\n")
     (validMethod? method))
 
 -- ---------------------------------------------------------------------------
 -- 11. Handler pipeline
 -- ---------------------------------------------------------------------------
 
 routerMethod = (method :
   lazyBool
     (_ : "GET")
     (_ : method)
     (equal? method "HEAD"))
 
 respondAndClose = (sock resp :
   onOk_ (finally (send sock resp) (closeSocket_ sock)) (_ :
     pure (ok t t)))
 
 handleReadableRequest = (router client method target headers rest3 :
   onResult (readBody client headers rest3)
     (status msg :
       respondAndClose client
         (responseForMethod method
           (errorResponse status msg)))
     (body rest :
       respondAndClose client
         (responseForMethod method
           (router (routerMethod method) target headers body))))
 
 handleParsedHeaders = (router client method target version rest2 :
   matchResult
     (code bad :
       respondAndClose client (badRequestResponse "Bad Request\n"))
     (headers rest3 :
       matchResult
         (status msg :
           respondAndClose client
             (responseForMethod method (errorResponse status msg)))
         (ignored rest :
           handleReadableRequest router client method target headers rest3)
         (validateRequest method target version headers))
     (parseHeaders rest2))
 
 handleParsedRequest = (router client req rest2 :
   ((method :
     ((target :
       ((version :
         handleParsedHeaders router client method target version rest2)
        (snd (snd req))))
      (fst (snd req))))
    (fst req)))
 
 httpHandler = (router client peer :
   onResult_ (recvHeaders client)
     (status :
       respondAndClose client
         (badRequestResponse "Bad Request\n"))
     (raw :
       matchResult
         (code bad :
           respondAndClose client (badRequestResponse "Bad Request\n"))
         (req rest2 :
           handleParsedRequest router client req rest2)
         (parseRequestLine raw)))
 
 -- ---------------------------------------------------------------------------
 -- 12. IO-aware handler pipeline
 -- ---------------------------------------------------------------------------
 
 handleReadableRequestIO = (routerIO client method target headers rest3 :
   onResult (readBody client headers rest3)
     (status msg :
       respondAndClose client
         (responseForMethod method
           (errorResponse status msg)))
     (body rest :
       bind (routerIO (routerMethod method) target headers body) (resp :
         respondAndClose client (responseForMethod method resp))))
 
 handleParsedHeadersIO = (routerIO client method target version rest2 :
   matchResult
     (code bad :
       respondAndClose client (badRequestResponse "Bad Request\n"))
     (headers rest3 :
       matchResult
         (status msg :
           respondAndClose client
             (responseForMethod method (errorResponse status msg)))
         (ignored rest :
           handleReadableRequestIO routerIO client method target headers rest3)
         (validateRequest method target version headers))
     (parseHeaders rest2))
 
 handleParsedRequestIO = (routerIO client req rest2 :
   ((method :
     ((target :
       ((version :
         handleParsedHeadersIO routerIO client method target version rest2)
        (snd (snd req))))
      (fst (snd req))))
    (fst req)))
 
 httpHandlerIO = (routerIO client peer :
   onResult_ (recvHeaders client)
     (status :
       respondAndClose client
         (badRequestResponse "Bad Request\n"))
     (raw :
       matchResult
         (code bad :
           respondAndClose client (badRequestResponse "Bad Request\n"))
         (req rest2 :
           handleParsedRequestIO routerIO client req rest2)
         (parseRequestLine raw)))