(: Aiche Tee Tee Pee :)
Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell IO runtime... but we're managing all of the actual webserver semantics in tricu! This includes a demo Arboricx application server that is capable of storing and serving bundles.
This commit is contained in:
755
lib/http.tri
Normal file
755
lib/http.tri
Normal file
@@ -0,0 +1,755 @@
|
||||
!import "prelude.tri" !Local
|
||||
!import "io.tri" !Local
|
||||
!import "socket.tri" !Local
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 1. Constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
maxHeaderBytes = 65536
|
||||
maxBodyBytes = 1048576
|
||||
maxUriBytes = 8192
|
||||
|
||||
crlf = pair 13 (pair 10 t)
|
||||
crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 2. Lazy eliminators
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
lazyBool = (thenK elseK cond :
|
||||
((chosen : chosen t)
|
||||
(matchBool
|
||||
thenK
|
||||
elseK
|
||||
cond)))
|
||||
|
||||
lazyList = (nilK consK xs :
|
||||
((chosen : chosen t)
|
||||
(matchList
|
||||
nilK
|
||||
(h r : (_ : consK h r))
|
||||
xs)))
|
||||
|
||||
lazyMaybe = (noneK someK m :
|
||||
((chosen : chosen t)
|
||||
(matchMaybe
|
||||
noneK
|
||||
(x : (_ : someK x))
|
||||
m)))
|
||||
|
||||
lazyResult = (errK okK result :
|
||||
((chosen : chosen t)
|
||||
(matchResult
|
||||
(code rest : (_ : errK code rest))
|
||||
(value rest : (_ : okK value rest))
|
||||
result)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 3. Small byte/list helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
chomp = (xs :
|
||||
lazyList
|
||||
(_ : t)
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ : reverse r)
|
||||
(_ : xs)
|
||||
(equal? h 13))
|
||||
(reverse xs))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 4. Response construction
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
statusPhrase = (code :
|
||||
lazyBool
|
||||
(_ : "OK")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Created")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "No Content")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Bad Request")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Not Found")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Method Not Allowed")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Request Header Fields Too Large")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "Not Implemented")
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : "HTTP Version Not Supported")
|
||||
(_ : "Internal Server Error")
|
||||
(equal? code 505))
|
||||
(equal? code 501))
|
||||
(equal? code 431))
|
||||
(equal? code 405))
|
||||
(equal? code 404))
|
||||
(equal? code 400))
|
||||
(equal? code 204))
|
||||
(equal? code 201))
|
||||
(equal? code 200))
|
||||
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
headersOnly_ = (y (self bs s1 s2 s3 acc :
|
||||
lazyList
|
||||
(_ : reverse acc)
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : reverse (pair 10 (pair 13 (pair 10 (pair 13 acc)))))
|
||||
(_ : self r true false false (pair h acc))
|
||||
(equal? h 10))
|
||||
(_ : self r false false false (pair h acc))
|
||||
s3)
|
||||
(_ : self r false true false (pair h acc))
|
||||
(and? s2 (equal? h 13)))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r false false true (pair h acc))
|
||||
(_ : self r false false false (pair h acc))
|
||||
(and? s1 (equal? h 10)))
|
||||
(equal? h 13))
|
||||
bs))
|
||||
|
||||
headersOnly = (response :
|
||||
headersOnly_ response false false false t)
|
||||
|
||||
responseForMethod = (method resp :
|
||||
lazyBool
|
||||
(_ : headersOnly resp)
|
||||
(_ : resp)
|
||||
(equal? method "HEAD"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 5. 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))
|
||||
(_ :
|
||||
((chunkLen :
|
||||
((nextLen :
|
||||
((next :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : pure (ok next t))
|
||||
(_ : self sock pattern maxBytes next nextLen)
|
||||
(contains? pattern next))
|
||||
(_ : pure (err 431 next))
|
||||
(lte? nextLen maxBytes))
|
||||
(append acc chunk)))
|
||||
(add accLen chunkLen)))
|
||||
(length chunk)))
|
||||
(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)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 6. Request line parsing
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
readLineBytes_ = (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))
|
||||
|
||||
readLineBytes = (bs :
|
||||
((result :
|
||||
pair (chomp (fst result)) (snd result))
|
||||
(readLineBytes_ bs t)))
|
||||
|
||||
parseThreeWords_ = (y (self bs phase acc w1 w2 :
|
||||
lazyList
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : ok (pair w1 (pair w2 (reverse acc))) t)
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(equal? phase 2))
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r 1 t (reverse acc) w2)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : self r 2 t w1 (reverse acc))
|
||||
(_ : err 400 "Bad Request\n")
|
||||
(equal? phase 1))
|
||||
(equal? phase 0))
|
||||
(_ : self r phase (pair h acc) w1 w2)
|
||||
(equal? h 32))
|
||||
bs))
|
||||
|
||||
parseThreeWords = (bs :
|
||||
parseThreeWords_ bs 0 t t t)
|
||||
|
||||
parseRequestLine = (bs :
|
||||
((lineRest :
|
||||
lazyResult
|
||||
(code bad : err 400 "Bad Request\n")
|
||||
(req ignored : ok req (snd lineRest))
|
||||
(parseThreeWords (fst lineRest)))
|
||||
(readLineBytes bs)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 7. 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)))))))
|
||||
|
||||
toLowerAsciiByte = (c :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b0 r0 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b1 r1 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b2 r2 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b3 r3 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b4 r4 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b5 r5 :
|
||||
triage
|
||||
c
|
||||
(_ : c)
|
||||
(b6 r6 :
|
||||
matchBool
|
||||
(lowerAsciiBits b0 b1 b2 b3 b4)
|
||||
c
|
||||
(boolAnd?
|
||||
(isZero? r6)
|
||||
(boolAnd?
|
||||
(bit1? b6)
|
||||
(boolAnd?
|
||||
(bit0? b5)
|
||||
(upperLow5? b0 b1 b2 b3 b4)))))
|
||||
r5)
|
||||
r4)
|
||||
r3)
|
||||
r2)
|
||||
r1)
|
||||
r0)
|
||||
c)
|
||||
|
||||
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))
|
||||
|
||||
parseHeaders_ = (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)
|
||||
|
||||
parseHeaders = (bs :
|
||||
y parseHeaders_ bs t t t false true)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 8. 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))
|
||||
|
||||
parseContentLengthValue = (raw :
|
||||
matchMaybe
|
||||
(err 400 "Bad Request\n")
|
||||
(n : ok (just n) t)
|
||||
(readDecimal 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)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 9. Body reading
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
consumeAvailable_ = (y (self bytes remaining acc :
|
||||
lazyList
|
||||
(_ : pair (reverse acc) (pair remaining t))
|
||||
(h r :
|
||||
lazyBool
|
||||
(_ : pair (reverse acc) (pair 0 r))
|
||||
(_ : self r (pred remaining) (pair h acc))
|
||||
(isZero? remaining))
|
||||
bytes))
|
||||
|
||||
consumeAvailable = (bytes n :
|
||||
consumeAvailable_ bytes n t)
|
||||
|
||||
readBodyN_ = (y (self sock remaining acc :
|
||||
lazyBool
|
||||
(_ : pure (ok acc t))
|
||||
(_ :
|
||||
onResult_ (recv sock remaining)
|
||||
(err :
|
||||
pure (err 400 acc))
|
||||
(chunk :
|
||||
((got :
|
||||
lazyBool
|
||||
(_ : pure (err 400 acc))
|
||||
(_ : self sock (sub remaining got) (append acc chunk))
|
||||
(equal? got 0))
|
||||
(length chunk))))
|
||||
(isZero? remaining)))
|
||||
|
||||
readBodyN = (sock n acc :
|
||||
readBodyN_ sock n acc)
|
||||
|
||||
readBody = (sock headers initialBytes :
|
||||
matchResult
|
||||
(status msg :
|
||||
pure (err status "Bad Request\n"))
|
||||
(maybeLen rest :
|
||||
lazyMaybe
|
||||
(_ : pure (ok t initialBytes))
|
||||
(n :
|
||||
((consumed :
|
||||
((body0 :
|
||||
((remaining :
|
||||
lazyBool
|
||||
(_ : pure (ok body0 t))
|
||||
(_ :
|
||||
onOk (readBodyN sock remaining body0)
|
||||
(body rest : pure (ok body t)))
|
||||
(isZero? remaining))
|
||||
(fst (snd consumed))))
|
||||
(fst consumed)))
|
||||
(consumeAvailable initialBytes n)))
|
||||
maybeLen)
|
||||
(contentLength headers))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- 10. 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 :
|
||||
respondAndClose client
|
||||
(responseForMethod method
|
||||
(badRequestResponse "Bad Request\n")))
|
||||
(body :
|
||||
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 :
|
||||
respondAndClose client
|
||||
(responseForMethod method
|
||||
(badRequestResponse "Bad Request\n")))
|
||||
(body :
|
||||
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)))
|
||||
Reference in New Issue
Block a user