From 8623c1f081abe8b6db19ce07cfae91e8b19b67bd Mon Sep 17 00:00:00 2001 From: Jack Ek Date: Wed, 13 Nov 2024 04:55:05 +0100 Subject: [PATCH] http,dat: significant cleanup of http driver --- sire/driver_http.sire | 4 +- sire/driver_http_tests.sire | 406 +++++++++++++++++++++++++++--------- sire/lib_http.sire | 305 +++++++++++---------------- sire/sire_07_dat.sire | 7 +- 4 files changed, 433 insertions(+), 289 deletions(-) diff --git a/sire/driver_http.sire b/sire/driver_http.sire index dd5fa55f..45068157 100644 --- a/sire/driver_http.sire +++ b/sire/driver_http.sire @@ -76,7 +76,9 @@ TRUE | if (barIsEmpty data) | trk [connectionClosed=io] | return () -@ updatedBuffer | processHttpChunk buffer data +: updatedBuffer < maybeCase | processHttpChunk buffer data + | launch (TCP_SHUT io) return +| trk [=io tookBytes=(barLen data) received=(getReceivedLength buffer) expected=(mayExplainContentLength buffer)] | ifNot (validRequest updatedBuffer) | processConnection io getResponse updatedBuffer return | trk [validRequestOn=io] diff --git a/sire/driver_http_tests.sire b/sire/driver_http_tests.sire index 8a4cc5e0..bc5b343f 100644 --- a/sire/driver_http_tests.sire +++ b/sire/driver_http_tests.sire @@ -10,12 +10,32 @@ ; lib tests -= testBar | x#474554202F7468696E6720485454502F312E310d0A486F73743A206578616D706C652E636F6D0d0d0A436F6E74656E742D547970653A20746578742F68746D6C0d0A436F6E74656E742D4C656E6774683A2031350d0d0A0d0a48656C6C6F2C20576F726C6421 -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{} NONE FALSE 0 b#{} FALSE - -= testHeaderBar | x#486f73743a206578616d706c652e636f6d0d0a436f6e74656e742d547970653a20746578742f68746d6c0d0a436f6e74656e742d4c656e6774683a2031350d0a -= expectedHeaders | tabFromPairs [[b#Host b#{example.com}] [b#{Content-Type} b#{text/html}] [b#{Content-Length} b#15]] - += testBar +| x#474554202F7468696E6720485454502F312E310d0A486F73743A206578616D706C652E636F6D0d0d0A436F6E74656E742D547970653A20746578742F68746D6C0d0A436F6E74656E742D4C656E6774683A2031350d0d0A0d0a48656C6C6F2C20576F726C6421 + += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + += testHeaderBar +| x#486f73743a206578616d706c652e636f6d0d0a436f6e74656e742d547970653a20746578742f68746d6c0d0a436f6e74656e742d4c656e6774683a2031350d0a + += expectedHeaders +| tabFromPairs +++ [b#Host b#{example.com}] +++ [b#{Content-Type} b#{text/html}] +++ [b#{Content-Length} b#15] =?= (listFromRow [x#de x#ad x#20be x#ef]) | barSubstringLinesList x#0d x#{de0dad0d20be0def0d0d} @@ -33,33 +53,110 @@ | barSubstringLinesList x#0d0a0d x#{de0d0a0dad0d0a0d200dbe0d0a0def0d0a0d} -=?= expectedHeaders | (extractHeaders testHeaderBar) - -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{GET /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE - -=?= (0 b#{GET}) | mayExplainMethod testBuffer - -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{POST /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE - -=?= (0 b#{POST}) | mayExplainMethod testBuffer - -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{} NONE FALSE 0 b#{} FALSE +=?= expectedHeaders | extractHeaders testHeaderBar + += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{GET /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + +=?= (SOME b#{GET}) | mayExplainMethod testBuffer + += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{POST /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + +=?= (SOME b#{POST}) | mayExplainMethod testBuffer + += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{} +* NONE +* FALSE +* 0 +* b#{} +* FALSE =?= NONE | mayExplainMethod testBuffer - -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{GET /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE - -=?= (0 b#{/foo}) | mayExplainUri testBuffer - -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{asdfsadfsdf} NONE FALSE 0 b#{} FALSE += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{GET /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + +=?= (SOME b#{/foo}) | mayExplainUri testBuffer + += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{asdfsadfsdf} +* NONE +* FALSE +* 0 +* b#{} +* FALSE =?= NONE | mayExplainUri testBuffer -= testBuffer | HTTP_BUF 9 8888 testBar FALSE emptyTab FALSE b#{GET /foo HTTP/1.0} NONE FALSE 0 b#{} FALSE += testBuffer +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* emptyTab +* FALSE +* b#{GET /foo HTTP/1.0} +* NONE +* FALSE +* 0 +* b#{} +* FALSE -=?= (0 b#{HTTP/1.0}) | mayExplainHttpVersion testBuffer +=?= (SOME b#{HTTP/1.0}) | mayExplainHttpVersion testBuffer = headersSansContentLength | tabFromPairs [[b#a b#b] [b#c b#d]] @@ -67,23 +164,60 @@ = headersContentLengthNonZero | tabFromPairs [[b#a b#b] [b#{Content-Length} b#15]] =?= FALSE | (haveBodyContent headersSansContentLength) - =?= FALSE | (haveBodyContent headersContentLengthZero) - =?= TRUE | (haveBodyContent headersContentLengthNonZero) = headersSansContentLength | tabFromPairs [[b#a b#b] [b#c b#d]] = headersContentLengthZero | tabFromPairs [[b#a b#b] [b#{Content-Length} b#0]] = headersContentLengthNonZero | tabFromPairs [[b#a b#b] [b#{Content-Length} b#15]] -= clSans | HTTP_BUF 9 8888 testBar FALSE headersSansContentLength FALSE b#{GET /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE -= clZero | HTTP_BUF 9 8888 testBar FALSE headersContentLengthZero FALSE b#{GET /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE -= clSome | HTTP_BUF 9 8888 testBar FALSE headersContentLengthNonZero FALSE b#{GET /foo HTTP/1.1} NONE FALSE 0 b#{} FALSE += clSans +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* headersSansContentLength +* FALSE +* b#{GET /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + += clZero +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* headersContentLengthZero +* FALSE +* b#{GET /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + += clSome +| HTTP_BUF +* 9 +* 8888 +* testBar +* FALSE +* headersContentLengthNonZero +* FALSE +* b#{GET /foo HTTP/1.1} +* NONE +* FALSE +* 0 +* b#{} +* FALSE =?= NONE | mayExplainContentLength clSans - =?= NONE | mayExplainContentLength clZero - =?= SOME-15 | mayExplainContentLength clSome ; TODO: write a test that has a request where the body is longer than the content @@ -93,15 +227,31 @@ ; This assembled data is a full POST request with a body content that is longer than the "Content-Length" = testAssembledData | x#504F5354202F776861742D69732D6C69666520485454502F312E300d0A486F73743A20676F6F676C652E636F6D0d0A557365722D4167656E743A206375726C2F372E37312E310d0A436F6E74656E742D4C656E6774683A20320d0A0d0A48656C6C6F -= buffer | HTTP_BUF 9999 8888 testAssembledData TRUE headersWithContentLength TRUE b#{POST /what-is-life HTTP/1.0} 1 FALSE (barLen testAssembledData) b#{Hello} TRUE += buffer +| HTTP_BUF +* 9999 +* 8888 +* testAssembledData +* TRUE +* headersWithContentLength +* TRUE +* b#{POST /what-is-life HTTP/1.0} +* 1 +* FALSE +* barLen testAssembledData +* b#{Hello} +* TRUE + = badStream | x#48454144202F776861742D69732D6C69666520485454502F312E300d0A486F73743A20676F6F676C652E636F6D0d0A557365722D4167656E743A206375726C2F372E37312E310d0A436F6E74656E742D4C656E6774683A20320d0a0d0a48656C6C6F ; todo try running the other parsers first as a setup +=?= (SOME 1) + | mayExplainContentLength buffer + =?= NONE | parseAndSetBody badStream buffer - =?= [b#hel b#{lo } b#wor b#{ld.}] | splitBarIntoSegments 3 b#{hello world.} @@ -112,20 +262,47 @@ | splitBarIntoSegments 1000 b#{hello world.} ; TODO: maybe kill altogher: -= testEmptyBuffer | HTTP_BUF 9999 8888 b#{} FALSE emptyTab FALSE b#{} NONE FALSE 0 b#{} FALSE += testEmptyBuffer +| HTTP_BUF +* 9999 +* 8888 +* b#{} +* FALSE +* emptyTab +* FALSE +* b#{} +* NONE +* FALSE +* 0 +* b#{} +* FALSE + = headersTab | tabFromPairs -, [b#{Host} b#{google.com}] - [b#{Accept} b#{*/*}] - [b#{User-Agent} b#{curl/7.71.1}] - [b#{Content-Type} b#{text/plain}] - [b#{Content-Length} b#{11}] +++ [b#{Host} b#{google.com}] +++ [b#{Accept} b#{*/*}] +++ [b#{User-Agent} b#{curl/7.71.1}] +++ [b#{Content-Type} b#{text/plain}] +++ [b#{Content-Length} b#{11}] = httpPostWithBody | x#504f5354202f776861742d69732d6c69666520485454502f312e300d0a486f73743a20676f6f676c652e636f6d0d0a557365722d4167656e743a206375726c2f372e37312e310d0a4163636570743a202a2f2a0d0a436f6e74656e742d547970653a20746578742f706c61696e0d0a436f6e74656e742d4c656e6774683a2031310d0a0d0a68656c6c6f20776f726c64 = splitHTTPRow | splitBarIntoSegments 5 httpPostWithBody -= expectedBuffer | HTTP_BUF 9999 8888 httpPostWithBody TRUE headersTab TRUE b#{POST /what-is-life HTTP/1.0} NONE FALSE 600 b#{hello world} FALSE += expectedBuffer +| HTTP_BUF +* 9999 +* 8888 +* httpPostWithBody +* TRUE +* headersTab +* TRUE +* b#{POST /what-is-life HTTP/1.0} +* NONE +* FALSE +* 600 +* b#{hello world} +* FALSE = assembledBuffer | fakeProcessConnection splitHTTPRow testEmptyBuffer @@ -149,17 +326,29 @@ | getBody assembledBuffer -= httpGetNoBody | x#474554202f776861742d69732d6c69666520485454502f312e300d0a486f73743a20676f6f676c652e636f6d0d0a557365722d4167656e743a206375726c2f372e37312e310d0a4163636570743a202a2f2a0d0a0d0a += httpGetNoBody +| x#474554202f776861742d69732d6c69666520485454502f312e300d0a486f73743a20676f6f676c652e636f6d0d0a557365722d4167656e743a206375726c2f372e37312e310d0a4163636570743a202a2f2a0d0a0d0a = splitHTTPRow | splitBarIntoSegments 5 httpGetNoBody = headersTab | tabFromPairs -, [b#{Host} b#{google.com}] - [b#{Accept} b#{*/*}] - [b#{User-Agent} b#{curl/7.71.1}] - -= expectedBuffer | HTTP_BUF 9999 8888 httpGetNoBody TRUE headersTab TRUE b#{GET /what-is-life HTTP/1.0} NONE FALSE 600 b#{} FALSE +[[b#{Host} b#{google.com}] [b#{Accept} b#{*/*}] [b#{User-Agent} b#{curl/7.71.1}]] + += expectedBuffer +| HTTP_BUF +* 9999 +* 8888 +* httpGetNoBody +* TRUE +* headersTab +* TRUE +* b#{GET /what-is-life HTTP/1.0} +* NONE +* FALSE +* 600 +* b#{} +* FALSE = assembledBuffer | fakeProcessConnection splitHTTPRow testEmptyBuffer @@ -169,17 +358,29 @@ =?= (getBody expectedBuffer) | getBody assembledBuffer -= httpHead | x#48454144202f776861742d69732d6c69666520485454502f312e300d0a486f73743a20676f6f676c652e636f6d0d0a557365722d4167656e743a206375726c2f372e37312e310d0a4163636570743a202a2f2a0d0a0d0a += httpHead +| x#48454144202f776861742d69732d6c69666520485454502f312e300d0a486f73743a20676f6f676c652e636f6d0d0a557365722d4167656e743a206375726c2f372e37312e310d0a4163636570743a202a2f2a0d0a0d0a = splitHTTPRow | splitBarIntoSegments 5 httpHead = headersTab | tabFromPairs -, [b#{Host} b#{google.com}] - [b#{Accept} b#{*/*}] - [b#{User-Agent} b#{curl/7.71.1}] - -= expectedBuffer | HTTP_BUF 9999 8888 httpHead TRUE headersTab TRUE b#{HEAD /what-is-life HTTP/1.0} NONE FALSE 600 b#{} FALSE +[[b#{Host} b#{google.com}] [b#{Accept} b#{*/*}] [b#{User-Agent} b#{curl/7.71.1}]] + += expectedBuffer +| HTTP_BUF +* 9999 +* 8888 +* httpHead +* TRUE +* headersTab +* TRUE +* b#{HEAD /what-is-life HTTP/1.0} +* NONE +* FALSE +* 600 +* b#{} +* FALSE = assembledBuffer | fakeProcessConnection splitHTTPRow testEmptyBuffer @@ -193,7 +394,10 @@ ;;;;;;;; proc tests = appHeaders | tabFromPairs [[b#hello b#world] [b#cookie b#thing]] -= expectedHeaderList | listFromRow [b#{hello: world} b#{cookie: thing} b#{Server: Pallas/0.1} b#{Content-Length: 3}] + += expectedHeaderList +| listFromRow +[b#{hello: world} b#{cookie: thing} b#{Server: Pallas/0.1} b#{Content-Length: 3}] = expectedRes | HTTP_RES @@ -212,66 +416,73 @@ ; =?= (error500 b#{are you mad?}) ; | appResponseToHTTP [emptyTab b#{hell} 9999 b#{wtf}] -= appHeaders | tabFromPairs [[b#Server b#{Pallas/0.1}] [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}] [b#{Content-Type} b#{text/plain; charset=UTF-8}] [b#{Content-Length} b#{9}]] += appHeaders +| tabFromPairs +++ [b#Server b#{Pallas/0.1}] +++ [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}] +++ [b#{Content-Type} b#{text/plain; charset=UTF-8}] +++ [b#{Content-Length} b#{9}] + = preparedResponse | appResponseToHTTP [appHeaders b#{Nice body} 200 b#{OK}] = hexResponse - | barCat - , b#{HTTP/1.0 200 OK} - CRLF - b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} - CRLF - b#{Server: Pallas/0.1} - CRLF - b#{Content-Type: text/plain; charset=UTF-8} - CRLF - b#{Content-Length: 9} - DOUBLE_CRLF - b#{Nice body} +| barCat +++ b#{HTTP/1.0 200 OK} +++ CRLF +++ b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} +++ CRLF +++ b#{Server: Pallas/0.1} +++ CRLF +++ b#{Content-Type: text/plain; charset=UTF-8} +++ CRLF +++ b#{Content-Length: 9} +++ DOUBLE_CRLF +++ b#{Nice body} = inHex - | x#485454502F312E3020323030204F4B0d0A446174653A205475652C2032342053657020323032342031323A30303A303020474D540d0A5365727665723A2050616C6C61732F302E310d0A436F6E74656E742D547970653A20746578742F706C61696E3B20636861727365743D5554462D380d0A436F6E74656E742D4C656E6774683A20390d0A0d0a4E69636520626F6479 +| x#485454502F312E3020323030204F4B0d0A446174653A205475652C2032342053657020323032342031323A30303A303020474D540d0A5365727665723A2050616C6C61732F302E310d0A436F6E74656E742D547970653A20746578742F706C61696E3B20636861727365743D5554462D380d0A436F6E74656E742D4C656E6774683A20390d0A0d0a4E69636520626F6479 ; Sanity check that our barCat-constructed, human-readable response is equivalent ; to its proper hex representation: =?= inHex | hexResponse -=?= inHex - | (httpResToBar preparedResponse) +=?= inHex | (httpResToBar preparedResponse) = hex2 - | barCat - , b#{HTTP/1.0 204 OK} - CRLF - b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} - CRLF - b#{Server: Pallas/0.1} - CRLF - b#{Content-Length: 0} - -= appHeaders | tabFromPairs [[b#Server b#{Pallas/0.1}] [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}]] +| barCat +++ b#{HTTP/1.0 204 OK} +++ CRLF +++ b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} +++ CRLF +++ b#{Server: Pallas/0.1} +++ CRLF +++ b#{Content-Length: 0} + += appHeaders +| tabFromPairs +[[b#Server b#{Pallas/0.1}] [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}]] + = prep2 | appResponseToHTTP [appHeaders b#{} 204 b#{OK}] -=?= hex2 - | (httpResToBar prep2) +=?= hex2 | (httpResToBar prep2) = hexNoBod - | barCat - , b#{HTTP/1.0 204 GotHead} - CRLF - b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} - CRLF - b#{Server: Pallas/0.1} - CRLF - b#{Content-Length: 0} - -= appHeaders | tabFromPairs [[b#Server b#{Pallas/0.1}] [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}]] -= prepBodless | appResponseToHTTP [appHeaders NIL 204 b#{GotHead}] - -=?= hexNoBod - | (httpResToBar prepBodless) +| barCat +++ b#{HTTP/1.0 204 GotHead} +++ CRLF +++ b#{Date: Tue, 24 Sep 2024 12:00:00 GMT} +++ CRLF +++ b#{Server: Pallas/0.1} +++ CRLF +++ b#{Content-Length: 0} + += appHeaders +| tabFromPairs +[[b#Server b#{Pallas/0.1}] [b#Date b#{Tue, 24 Sep 2024 12:00:00 GMT}]] += prepBodless | appResponseToHTTP [appHeaders NIL 204 b#{GotHead}] +=?= hexNoBod | (httpResToBar prepBodless) ; Entire TCP packet from WireShark: ; = testPacket | x#0000000000000000000000000800450002886f6440004006bb097f0000017f000001800ace6f124ebb61a8099d2780180200007d00000101080a75b32e7e75b32db1474554202f6e6f746520485454502f312e310d0a486f73743a206c6f63616c686f73743a35323834370d0a557365722d4167656e743a204d6f7a696c6c612f352e3020285831313b205562756e74753b204c696e7578207838365f36343b2072763a3132392e3029204765636b6f2f32303130303130312046697265666f782f3132392e300d0a4163636570743a202a2f2a0d0a4163636570742d4c616e67756167653a20656e2d55532c656e3b713d302e350d0a4163636570742d456e636f64696e673a20677a69702c206465666c6174652c2062722c207a7374640d0a526566657265723a20687474703a2f2f6c6f63616c686f73743a35323834372f0d0a436f6e6e656374696f6e3a206b6565702d616c6976650d0a436f6f6b69653a205f706b5f69642e322e316666663d353966343331626532303136396566332e313731373630313536392e3b205f706b5f69642e312e316666663d306261313033373862393362356238332e313731373631323234312e3b20706c756e64617574682d3d353439356562653035616264613961636633366130363733323138383866383133613366353366396461643739623330303032626435623764393036653533623b20435352462d546f6b656e2d35325241353d36507172555464506a5171416854515268725167434b754b6b35794172626b550d0a5365632d46657463682d446573743a20656d7074790d0a5365632d46657463682d4d6f64653a20636f72730d0a5365632d46657463682d536974653a2073616d652d6f726967696e0d0a5072696f726974793a20753d340d0a0d0a @@ -284,9 +495,6 @@ = testPacketHTTPOnly | x#474554202f6e6f746520485454502f312e310d0a486f73743a206c6f63616c686f73743a35323834370d0a557365722d4167656e743a204d6f7a696c6c612f352e3020285831313b205562756e74753b204c696e7578207838365f36343b2072763a3132392e3029204765636b6f2f32303130303130312046697265666f782f3132392e300d0a4163636570743a202a2f2a0d0a4163636570742d4c616e67756167653a20656e2d55532c656e3b713d302e350d0a4163636570742d456e636f64696e673a20677a69702c206465666c6174652c2062722c207a7374640d0a526566657265723a20687474703a2f2f6c6f63616c686f73743a35323834372f0d0a436f6e6e656374696f6e3a206b6565702d616c6976650d0a436f6f6b69653a205f706b5f69642e322e316666663d353966343331626532303136396566332e313731373630313536392e3b205f706b5f69642e312e316666663d306261313033373862393362356238332e313731373631323234312e3b20706c756e64617574682d3d353439356562653035616264613961636633366130363733323138383866383133613366353366396461643739623330303032626435623764393036653533623b20435352462d546f6b656e2d35325241353d36507172555464506a5171416854515268725167434b754b6b35794172626b550d0a5365632d46657463682d446573743a20656d7074790d0a5365632d46657463682d4d6f64653a20636f72730d0a5365632d46657463682d536974653a2073616d652d6f726967696e0d0a5072696f726974793a20753d340d0a0d0a68656c6c6f20776f726c64 - - - ;;;; = (hydrate return) diff --git a/sire/lib_http.sire b/sire/lib_http.sire index 31d1fe2b..e8c7c92e 100644 --- a/sire/lib_http.sire +++ b/sire/lib_http.sire @@ -65,17 +65,13 @@ = (error400 msg) -@ headers | emptyTab -; TODO: move these thigns to "constants" -@ headers | tabIns b#{Content-Length} 0 headers -@ headers | tabIns b#{Server} b#{Pallas/0.1} headers -@ headersList - | tabValsList - | tabMapWithKey - (k v & (barCat [k b#{: } v])) - headers +@ headers | tabIns b#{Content-Length} 0 + | tabSing b#{Server} b#{Pallas/0.1} +@ headersList | tabValsList + | tabMapWithKey (k v & (barCat [k b#{: } v])) + | headers | HTTP_RES -; TODO: move these thigns to "constants" +;; TODO: move these things to "constants" * b#{HTTP/1.0} * 400 * msg @@ -83,17 +79,13 @@ * NIL = (error500 msg) -@ headers | emptyTab -; TODO: move these thigns to "constants" -@ headers | tabIns b#{Content-Length} 0 headers -@ headers | tabIns b#{Server} b#{Pallas/0.1} headers -@ headersList - | tabValsList - | tabMapWithKey - (k v & (barCat [k b#{: } v])) - headers +@ headers | tabIns b#{Content-Length} 0 + | tabSing b#{Server} b#{Pallas/0.1} +@ headersList | tabValsList + | tabMapWithKey (k v & (barCat [k b#{: } v])) + | headers | HTTP_RES -; TODO: move these thigns to "constants" +;; TODO: move these things to "constants" * b#{HTTP/1.0} * 500 * msg @@ -110,12 +102,11 @@ @ indices (barSubstringSearch seek bar) @ seekLen (barLen seek) @ wid (barLen bar) -^ listFilter (compose not barIsEmpty) _ +| listFilter (compose not barIsEmpty) ^ _ 0 indices ? (go start idxList) -| listCase idxList - | CONS (barSlice start (sub wid start) bar) NIL -& (idx rest) +: idx rest < listCase idxList + | listSing (barSlice start (sub wid start) bar) | CONS (barSlice start (sub idx start) bar) | go (add idx seekLen) rest @@ -135,221 +126,161 @@ ; Helper for determining if the Request Line looks right > Bar > Bit = (validReqLine reqLine) -| if (eql reqLine 0) - FALSE @ split | listToRow | barSplit { } reqLine -| if (neq 3 (len split)) - ; we don't have three items - FALSE -| if (any (x & (or (eql x 0) (eql 0 (barLen x)))) split) - ; we have three, but some of them are empty? - | die [split] - FALSE -TRUE - -; Helper for getting the Method +| and | not (barIsEmpty reqLine) +| and (len-split == 3) +| not (any x&(x==0 || (barLen x)==0) split) ;; TODO x==0 seems ill-typed? + > HTTPBuffer > Maybe Bar = (mayExplainMethod buffer) @ reqLine | getReqLine buffer -| if | not (validReqLine reqLine) - NONE -@ [method uri protocol] | listToRow | barSplit { } reqLine +| maybeGuard | validReqLine reqLine +@ [method _ _] | listToRow | barSplit { } reqLine | SOME method -; Helper for getting the URI > HTTPBuffer > Maybe Bar = (mayExplainUri buffer) @ reqLine | getReqLine buffer -| if | not (validReqLine reqLine) - NONE -@ [method uri protocol] | listToRow | barSplit { } reqLine +| maybeGuard | validReqLine reqLine +@ [_ uri _] | listToRow | barSplit { } reqLine | SOME uri -; Helper for getting the HTTP version > HTTPBuffer > Maybe Bar = (mayExplainHttpVersion buffer) @ reqLine | getReqLine buffer -| if | not (validReqLine reqLine) - NONE -@ [method uri protocol] | listToRow | barSplit { } reqLine +| maybeGuard | validReqLine reqLine +@ [_ _ protocol] | listToRow | barSplit { } reqLine | SOME protocol > (Tab Bar Bar) > Bit = (haveBodyContent headerMap) -@ haveContentLength | tabGet headerMap b#{Content-Length} -| ifz haveContentLength - ; No Content-Length header at all - FALSE -| ifz unpackSome-(parseNat haveContentLength) - ; Content-Length header, but received a 0 for value - FALSE -; Non-zero Content-Length header -TRUE +| bindMaybe | tabLookup b#{Content-Length} headerMap +| neq b#{0} ; Helper for getting the Content-Length > HTTPBuffer > Maybe Nat = (mayExplainContentLength buffer) -| if | not (haveBodyContent (getHeaders buffer)) - NONE -@ cl | tabGet (getHeaders buffer) b#{Content-Length} -parseNat-cl +| maybeGuard | haveBodyContent (getHeaders buffer) +| parseNat | tabGet (getHeaders buffer) b#{Content-Length} -; TODO: deprecated; remove (soon) > HTTPBuffer > Bit = (isMessageComplete buffer) | maybeCase (mayExplainContentLength buffer) | getHeadersParsed buffer - ; headers are parsed and we didn't expect a body. -& expectedLength -| eql expectedLength (getReceivedLength buffer) - - -; TODO: write tests for isMessageComplete +| eql (getReceivedLength buffer) ;;;; parsers ;;;; -; Given an HTTP stream from the beginning, see if its appropriate -; to parse the request line yet, and if so, do it and update the buffer +;; Given an HTTP stream from the beginning, see if its appropriate +;; to parse the request line yet, and if so, do it and update the buffer > Bar > Bar > HTTPBuffer = (parseAndSetReqline stream buffer) -| if (getReqLineParsed buffer) - ; already done, nothing to do. - buffer -; do we have a first 0d0a? -; if not, just return buffer -| listCase (barSubstringSearch CRLF stream) buffer -& (idx _) -; if so, we have a reqline -; slice from here to the 0d0a +| if (getReqLineParsed buffer) | buffer +;; do we have a first 0d0a? +;; if not, just return buffer +: idx _ < listCase (barSubstringSearch CRLF stream) | buffer +;; if so, we have a reqline +;; slice from here to the 0d0a @ rl | barTake idx stream -; put that in reqline +;; put that in reqline @ buffer | setReqLine rl buffer -; mark it parsed +;; mark it parsed @ buffer | setReqLineParsed TRUE buffer -buffer +| buffer -; Given an HTTP stream from the beginning, see if its appropriate -; to parse the headers yet, and if so, do it and update the buffer +;; Given an HTTP stream from the beginning, see if its appropriate +;; to parse the headers yet, and if so, do it and update the buffer > Bar > Bar > HTTPBuffer = (parseAndSetHeaders stream buffer) -| if | not (getReqLineParsed buffer) - ; haven't even done request line yet, stop! - buffer -; now request line is parsed, so we AT LEAST got the first x#0d0a... -; so we should wait until we have _all_ the headers, which is denoted by -; an empty line. -| listCase (barSubstringSearch CRLF stream) buffer -; if so, we have a reqline -& (requestLineIdx _) -; split at the request line and ignore it +| ifNot (getReqLineParsed buffer) | buffer ; haven't even done request line yet, stop! +;; now request line is parsed, so we AT LEAST got the first x#0d0a... +;; so we should wait until we have _all_ the headers, which is denoted by +;; an empty line. +: requestLineIdx _ < listCase (barSubstringSearch CRLF stream) buffer +;; if so, we have a reqline +;; split at the request line and ignore it @ [rl remain] | barSplitAt requestLineIdx stream @ remainTrimmed | barDrop 2 remain -; Again, check to see if we have CRLF yet... -| listCase (barSubstringSearch DOUBLE_CRLF remainTrimmed) buffer -; if so, we have all the headers -& (headersEndIdx _) -@ h | barTake headersEndIdx remainTrimmed -@ headers | (extractHeaders h) -@ buffer | setHeaders headers buffer -; mark it parsed -@ buffer | setHeadersParsed TRUE buffer -buffer - - -; TODO: > Bar > Bar > Maybe HTTPBuffer -; Depending on how the stream-parsing goes, if this function sticks around, it -; should be updated to return a Maybe HTTPBuffer - with the NONE case indicating -; some kind of poorly-constructed request error. -> Bar > Bar > HTTPBuffer +: headersEndIdx _ < listCase (barSubstringSearch DOUBLE_CRLF remainTrimmed) + | buffer +@ h | barTake headersEndIdx remainTrimmed +@ headers | extractHeaders h +@ buffer | setHeaders headers buffer +@ buffer | setHeadersParsed TRUE buffer +| buffer + + +> Bar > Bar > Maybe HTTPBuffer = (parseAndSetBody stream buffer) -| if | not (getHeadersParsed buffer) - ; haven't parsed headers yet, stop! - buffer -; Do we have a content length? (we should already be guarded against this -; by the fact that this function will not be called in processHttpChunk unless -; there is a content length but its worth being careful) -| maybeCase (mayExplainContentLength buffer) buffer -& contentLength -; Find the first double CRLF - this should be the end of the headers -| listCase (barSubstringSearch DOUBLE_CRLF stream) buffer -; if so, we have a reqline -& (headersEndIdx _) +| ifNot (getHeadersParsed buffer) | SOME buffer ; haven't parsed headers yet, stop! +;; Do we have a content length? (we should already be guarded against this +;; by the fact that this function will not be called in processHttpChunk unless +;; there is a content length but its worth being careful) +: contentLength < maybeCase (mayExplainContentLength buffer) | SOME buffer +;; Find the first double CRLF - this should be the end of the headers +: headersEndIdx _ < listCase (barSubstringSearch DOUBLE_CRLF stream) | SOME buffer +;; if so, we have a reqline @ body | barDrop (barLen DOUBLE_CRLF) | barDrop headersEndIdx stream -@ newReceivedLength | (add (getReceivedLength buffer) | barLen body) +@ newReceivedLength | add (getReceivedLength buffer) | barLen body @ buffer | setReceivedLength newReceivedLength buffer -| if (gth (barLen body) contentLength) - ; TODO: - ; body is longer than headers indicated. bad request! - NONE +| maybeGuardNot (gth (barLen body) contentLength) ;; body too long | if (lth (barLen body) contentLength) - ; we don't have all the content yet. allow the processing to continue - ; TODO: - ; | SOME buffer - buffer + | SOME buffer ; we don't have all content yet. allow processing to continue @ buffer | setBody body buffer @ buffer | setBodyParsed TRUE buffer -; TODO: -; | SOME buffer -buffer +| SOME buffer -; TODO: ; take a valid HTTP Response and create an HTTP-1.0-compliant hex array > HTTPResponse > Bar = (httpResToBar httpRes) -@ v | (getVersion httpRes) -@ c | (getStatusCode httpRes) -@ s | (getReasonPhrase httpRes) -@ h | (getResHeaderL httpRes) -@ b | (getResBody httpRes) -@ noBod | (or (barIsEmpty b) (eql 0 b)) -@ mBody | if noBod NONE | else SOME b -@ mBSep | if noBod NONE | else SOME DOUBLE_CRLF +@ v | getVersion httpRes +@ c | getStatusCode httpRes +@ s | getReasonPhrase httpRes +@ h | getResHeaderL httpRes +@ b | getResBody httpRes +@ noBod | or (barIsEmpty b) (b == 0) @ statusLine | barCat [v x#20 (natBar | showNat c) x#20 s] @ headersSeparated | barIntercalateList CRLF h -@ printBodySeparator | fromSome NIL mBSep -@ printBody | fromSome NIL mBody +@ printBodySeparator | if noBod b#{} DOUBLE_CRLF +@ printBody | if noBod b#{} b | barCat - , statusLine - CRLF - headersSeparated - printBodySeparator - printBody - - - - -; Take an HTTP chunk of any size and help build a buffer. -; - append into the assembledData -; - if we have the Request Line completed yet, set it in the buffer -; - if we have all the headers completed yet, set them in the buffer -; - if we have a body, set it in the buffer -; -; TODO: this is a sort of crummy pattern. Each of the parseAndSet* things below -; runs every time, and each of those (see their bodies) have some repeated -; logic for dealing with the _entire_ assembledData bar. -; We should do this more efficiently and in such a way that: -; - this can return a Maybe (so that a consumer knows that NONE == malformed) -; - the individual parsers aren't running unnecessarily -; - the individual parsers don't have logic from othe responsibilities mixed in +++ statusLine +++ CRLF +++ headersSeparated +++ printBodySeparator +++ printBody + + +;; Take an HTTP chunk of any size and help build a buffer. +;; - append into the assembledData +;; - if we have the Request Line completed yet, set it in the buffer +;; - if we have all the headers completed yet, set them in the buffer +;; - if we have a body, set it in the buffer +;; +;; TODO: this is a sort of crummy pattern. Each of the parseAndSet* things below +;; runs every time, and each of those (see their bodies) have some repeated +;; logic for dealing with the _entire_ assembledData bar. +;; We should do this more efficiently and in such a way that: +;; - this can return a Maybe (so that a consumer knows that NONE == malformed) +;; - the individual parsers aren't running unnecessarily +;; - the individual parsers don't have logic from othe responsibilities mixed in = (processHttpChunk buffer chunk) -@ newAssembledData | (barWeld (getAssembledData buffer) chunk) +@ newAssembledData | barWeld (getAssembledData buffer) chunk @ buffer | setAssembledData newAssembledData buffer @ buffer | parseAndSetReqline newAssembledData buffer @ buffer | parseAndSetHeaders newAssembledData buffer | if (haveBodyContent (getHeaders buffer)) - @ buffer | parseAndSetBody newAssembledData buffer - buffer -buffer + | parseAndSetBody newAssembledData buffer +| SOME buffer > HTTPBuffer > Maybe HTTPRequest = (makeRequest buffer) -| ifNot (isMessageComplete buffer) - NONE -: method < maybeCase (mayExplainMethod buffer) NONE -: path < maybeCase (mayExplainUri buffer) NONE -: version < maybeCase (mayExplainHttpVersion buffer) NONE +| maybeGuard | isMessageComplete buffer +: method < bindMaybe | mayExplainMethod buffer +: path < bindMaybe | mayExplainUri buffer +: version < bindMaybe | mayExplainHttpVersion buffer @ headers | getHeaders buffer @ body | getBody buffer | SOME @@ -361,30 +292,28 @@ buffer * PIN-body -; TODO: maybe kill altogher: +;; TODO: maybe kill altogher: > Row Bar > HTTPBuffer = (fakeProcessConnection fakeIn buffer) -| if (eql 0 (len fakeIn)) - | trk [%ranOuttaIns] - ; what does this case actually mean? - buffer +| ifz (len fakeIn) | buffer ; what does this case actually mean? @ [data remainder] | splitAt 1 fakeIn ; consider first item -@ updatedBuffer | processHttpChunk buffer (idx 0 data) -: request < maybeCase (makeRequest updatedBuffer) ; message incomplete - | trk [%processConnectionRecurring] - | fakeProcessConnection remainder updatedBuffer -updatedBuffer +: updatedBuffer < maybeCase | processHttpChunk buffer (idx 0 data) + | die {bad buffer} +: request < maybeCase | makeRequest updatedBuffer ; message incomplete + | fakeProcessConnection remainder updatedBuffer +| updatedBuffer = (splitBarIntoSegmentsList segSize bar) @ wid (barLen bar) -^ (_ 0) +^ _ 0 ? (go off) | if (gte off wid) NIL @ end (add off segSize) | CONS (barSlice off (sub end off) bar) | go end -(splitBarIntoSegments segSize bar)=(listToRow | splitBarIntoSegmentsList segSize bar) += (splitBarIntoSegments segSize bar) +| listToRow | splitBarIntoSegmentsList segSize bar ;;;;;;;;;;;; Unused now, may be useful later diff --git a/sire/sire_07_dat.sire b/sire/sire_07_dat.sire index 7be114c3..7c96f36d 100644 --- a/sire/sire_07_dat.sire +++ b/sire/sire_07_dat.sire @@ -180,6 +180,11 @@ =?= SOME-1 | fmapMaybe SOME-0 inc =?= NONE | fmapMaybe NONE inc += (bindMaybe myb k) | maybeCase myb NONE k + +=?= (SOME 1) | bindMaybe (SOME 0) (compose SOME inc) +=?= NONE | bindMaybe NONE (compose SOME inc) + =?= 1 | isSome (SOME 0) =?= 0 | isSome NONE =?= 0 | isNone (SOME 0) @@ -960,7 +965,7 @@ F=found ^-^ ^-^ NONE SOME maybeCase maybe ^-^ fromSome unpackSome -^-^ isSome isNone fmapMaybe +^-^ isSome isNone fmapMaybe bindMaybe ^-^ maybeGuard maybeGuardNot ^-^ ^-^ mapMaybe catMaybes