LibraryValueTests.hs (20375B)
1 -- Value/protocol tests invoke authenticated exports directly. No source wrappers, 2 -- source import resolution, injected kernel names, or recovery compilation. 3 module LibraryValueTests (byteListUtilities, httpParsingTests) where 4 5 import Runtime 6 import Control.Monad (forM_) 7 import IODriver (runIO, defaultPerms) 8 import qualified Data.Map as Map 9 import Test.Tasty 10 import Test.Tasty.HUnit 11 12 trueT, falseT, nothingT :: T 13 trueT = Stem Leaf 14 falseT = Leaf 15 nothingT = Leaf 16 17 justT :: T -> T 18 justT = Stem 19 20 pairT :: T -> T -> T 21 pairT = Fork 22 23 byteT :: Integer -> T 24 byteT = ofNumber 25 26 bytesT :: [Integer] -> T 27 bytesT = ofList . map ofNumber 28 29 parserOk, parserErr :: T -> T -> T 30 parserOk value rest = Fork trueT (Fork value rest) 31 parserErr code rest = Fork falseT (Fork code rest) 32 33 portableReply :: Bool -> T -> T -> Bool -> Bool -> T 34 portableReply success payload rest consumed committed = 35 pairT (if success then trueT else falseT) 36 (pairT payload (pairT rest (pairT 37 (if consumed then trueT else falseT) 38 (if committed then trueT else falseT)))) 39 40 portableDiagnostic :: T -> T -> T -> T -> T -> T 41 portableDiagnostic code expected found location contexts = 42 pairT code (pairT expected (pairT found (pairT location contexts))) 43 44 byteListUtilities :: Env -> Env -> TestTree 45 byteListUtilities env base = testGroup "Byte List Utility Tests" 46 [ testCase "isNil: empty list is nil" $ do 47 call "bytesNil?" [ofList []] @?= trueT 48 49 , testCase "isNil: non-empty list is not nil" $ do 50 call "bytesNil?" [bytesT [1]] @?= falseT 51 52 , testCase "head: empty list is nothing" $ do 53 call "bytesHead" [ofList []] @?= nothingT 54 55 , testCase "head: non-empty list returns first element" $ do 56 call "bytesHead" [bytesT [1, 2]] @?= justT (byteT 1) 57 58 , testCase "tail: empty list is nothing" $ do 59 call "bytesTail" [ofList []] @?= nothingT 60 61 , testCase "tail: non-empty list returns rest" $ do 62 call "bytesTail" [bytesT [1, 2]] @?= justT (bytesT [2]) 63 64 , testCase "length: empty list is zero" $ do 65 call "bytesLength" [ofList []] @?= ofNumber 0 66 67 , testCase "length: single element list is one" $ do 68 call "bytesLength" [bytesT [1]] @?= ofNumber 1 69 70 , testCase "length: three element list is three" $ do 71 call "bytesLength" [bytesT [1, 2, 3]] @?= ofNumber 3 72 73 , testCase "append: empty ++ [1,2] = [1,2]" $ do 74 call "bytesAppend" [ofList [], bytesT [1, 2]] @?= bytesT [1,2] 75 76 , testCase "append: [1,2] ++ [3] = [1,2,3]" $ do 77 call "bytesAppend" [bytesT [1, 2], bytesT [3]] @?= bytesT [1,2,3] 78 79 , testCase "append: [1,2] ++ empty = [1,2]" $ do 80 call "bytesAppend" [bytesT [1, 2], ofList []] @?= bytesT [1,2] 81 82 , testCase "take: take 0 any list = empty" $ do 83 call "bytesTake" [ofNumber 0, bytesT [1, 2, 3]] @?= bytesT [] 84 85 , testCase "take: take 2 [1,2,3] = [1,2]" $ do 86 call "bytesTake" [ofNumber 2, bytesT [1, 2, 3]] @?= bytesT [1,2] 87 88 , testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do 89 call "bytesTake" [ofNumber 5, bytesT [1, 2]] @?= bytesT [1,2] 90 91 , testCase "drop: drop 0 any list = list" $ do 92 call "bytesDrop" [ofNumber 0, bytesT [1, 2, 3]] @?= bytesT [1,2,3] 93 94 , testCase "drop: drop 2 [1,2,3] = [3]" $ do 95 call "bytesDrop" [ofNumber 2, bytesT [1, 2, 3]] @?= bytesT [3] 96 97 , testCase "drop: drop 5 [1,2] = empty (overlong)" $ do 98 call "bytesDrop" [ofNumber 5, bytesT [1, 2]] @?= bytesT [] 99 100 , testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do 101 call "bytesSplitAt" [ofNumber 0, bytesT [1, 2]] @?= pairT (bytesT []) (bytesT [1,2]) 102 103 , testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do 104 call "bytesSplitAt" [ofNumber 2, bytesT [1, 2, 3]] @?= pairT (bytesT [1,2]) (bytesT [3]) 105 106 , testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do 107 call "bytesSplitAt" [ofNumber 5, bytesT [1, 2]] @?= pairT (bytesT [1,2]) (bytesT []) 108 109 , testCase "byteEq: equal bytes are equal" $ do 110 call "equal?" [ofNumber 1, ofNumber 1] @?= trueT 111 112 , testCase "byteEq: unequal bytes are not equal" $ do 113 call "equal?" [ofNumber 1, ofNumber 2] @?= falseT 114 115 , testCase "bytesEq: empty == empty" $ do 116 call "bytesEq?" [ofList [], ofList []] @?= trueT 117 118 , testCase "bytesEq: empty != [1]" $ do 119 call "bytesEq?" [ofList [], bytesT [1]] @?= falseT 120 121 , testCase "bytesEq: [1] != empty" $ do 122 call "bytesEq?" [bytesT [1], ofList []] @?= falseT 123 124 , testCase "bytesEq: equal lists are equal" $ do 125 call "bytesEq?" [bytesT [1, 2, 3], bytesT [1, 2, 3]] @?= trueT 126 127 , testCase "bytesEq: different last element" $ do 128 call "bytesEq?" [bytesT [1, 2, 3], bytesT [1, 2, 4]] @?= falseT 129 130 , testCase "bytesEq: different lengths" $ do 131 call "bytesEq?" [bytesT [1, 2], bytesT [1, 2, 3]] @?= falseT 132 ] 133 where 134 call "equal?" = foldl apply (base Map.! "equal?") 135 call name = foldl apply (env Map.! name) 136 137 httpParsingTests :: Env -> TestTree 138 httpParsingTests env = testGroup "HTTP Parsing Tests" 139 [ testCase "HTTP support uses checked native parser exports" $ do 140 Map.member "httpLineReply" env @?= True 141 Map.member "httpHeaderLineReply" env @?= True 142 call "parseHeaders" [ofString "A: b\r\n\r\n"] 143 @?= parserOk (ofList [pairT (ofString "a") (ofString "b")]) Leaf 144 , testCase "finite line parser distinguishes CRLF from truncated EOF" $ do 145 let check source expected = 146 call "httpLineReply" [ofString source] @?= expected 147 check "hi\r\nx" (portableReply True 148 (ofString "hi") (ofString "x") True False) 149 let eof consumed = portableReply False 150 (portableDiagnostic (ofNumber 1) (ofString "CRLF") Leaf Leaf 151 (ofList [ofString "http-line"])) Leaf consumed False 152 check "hi" (eof True) 153 check "" (eof False) 154 , testCase "line parser rejects bare CR/LF with exact failure progress" $ do 155 forM_ [("h\ri\r\nx", 13, "\ri\r\nx", True), ("hi\nx", 10, "\nx", True), 156 ("hi\r", 13, "\r", True), ("\nx", 10, "\nx", False)] $ \(source, found, rest, consumed) -> 157 call "httpLineReply" [ofString source] @?= 158 portableReply False 159 (portableDiagnostic (ofNumber 2) (ofString "CRLF") (ofNumber found) Leaf 160 (ofList [ofString "http-line"])) (ofString rest) consumed False 161 , testCase "request-line fields use the shared finite-byte parser" $ do 162 let check input expected = 163 call "httpThreeWordsReply" [ofString input] @?= expected 164 fields method target version = 165 pairT (ofString method) 166 (pairT (ofString target) (ofString version)) 167 check "GET / HTTP/1.1" 168 (portableReply True (fields "GET" "/" "HTTP/1.1") Leaf True False) 169 check "GET /" 170 (portableReply False 171 (portableDiagnostic (ofNumber 1) (ofNumber 32) Leaf Leaf 172 (ofList [ofString "request-line"])) 173 Leaf True False) 174 check "GET / HTTP/1.1 extra" 175 (portableReply False 176 (portableDiagnostic (ofNumber 2) Leaf (ofNumber 32) Leaf 177 (ofList [ofString "request-line"])) 178 (ofString " extra") True False) 179 check " " 180 (portableReply True (fields "" "" "") Leaf True False) 181 , testCase "request-line Result boundary retains legacy response and rest" $ do 182 let check input expected = 183 call "parseThreeWords" [ofString input] @?= expected 184 check "GET / HTTP/1.1" 185 (parserOk (pairT (ofString "GET") 186 (pairT (ofString "/") (ofString "HTTP/1.1"))) Leaf) 187 check "GET / HTTP/1.1 extra" 188 (parserErr (ofNumber 400) (ofString "Bad Request\n")) 189 check "GET /" 190 (parserErr (ofNumber 400) (ofString "Bad Request\n")) 191 -- Result-valued request-line reader 192 , testCase "readLineBytes with CRLF" $ do 193 call "readLineBytes" [bytesT [104, 105, 13, 10, 120]] @?= parserOk (bytesT [104, 105]) (bytesT [120]) 194 195 , testCase "readLineBytes rejects bare LF" $ do 196 call "readLineBytes" [bytesT [104, 105, 10, 120]] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 197 198 , testCase "readLineBytes empty line" $ do 199 call "readLineBytes" [bytesT [13, 10, 120]] @?= parserOk (bytesT []) (bytesT [120]) 200 201 , testCase "readLineBytes rejects EOF mid-line" $ do 202 call "readLineBytes" [bytesT [104, 105]] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 203 204 -- parseRequestLine 205 , testCase "parseRequestLine GET slash" $ do 206 call "parseRequestLine" [ofString ("GET / HTTP/1.1\r\n" ++ "x")] @?= parserOk 207 (pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1"))) 208 (ofString "x") 209 210 , testCase "parseRequestLine POST path" $ do 211 call "parseRequestLine" [ofString "POST /foo/bar HTTP/1.1\r\n"] @?= parserOk 212 (pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1"))) 213 (ofString "") 214 215 , testCase "parseRequestLine too short" $ do 216 call "parseRequestLine" [ofString "GET\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 217 218 , testCase "parseRequestLine no version" $ do 219 call "parseRequestLine" [ofString "GET /foo\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 220 221 , testCase "parseRequestLine empty line" $ do 222 call "parseRequestLine" [ofString "\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 223 224 , testCase "parseRequestLine rejects extra fields" $ do 225 call "parseRequestLine" [ofString "GET / HTTP/1.1 wat\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 226 227 -- parseHeaders 228 , testCase "single header line exposes consumed parser failures" $ do 229 let check input expected = 230 call "httpHeaderLineReply" [ofString input] @?= expected 231 check "Host: a:b" 232 (portableReply True 233 (pairT (ofString "host") (ofString "a:b")) Leaf True False) 234 check "Host" 235 (portableReply False 236 (portableDiagnostic (ofNumber 1) (ofString "colon") Leaf Leaf 237 (ofList [ofString "header-line"])) 238 Leaf True False) 239 check ": bad" 240 (portableReply False 241 (portableDiagnostic (ofNumber 2) (ofString "header-name") 242 (ofNumber 58) Leaf (ofList [ofString "header-line"])) 243 (ofString ": bad") False False) 244 , testCase "headers reject bad syntax and every truncated block prefix" $ do 245 let block = "A: b\r\nB: c\r\n\r\n" 246 inputs = [take n block | n <- [0 .. length block - 1]] ++ 247 [ "Bad Name: x\r\n\r\n", "Host : x\r\n\r\n", "\tHost: x\r\n\r\n" 248 , "X\r-Name: x\r\n\r\n", "X: a\rb\r\n\r\n", "X: y\n\n" 249 , "X: y\r\n\tcontinued\r\n\r\n" ] 250 forM_ inputs $ \source -> 251 call "parseHeaders" [ofString source] @?= 252 parserErr (ofNumber 400) (ofString "Bad Request\n") 253 , testCase "header values trim SP/HTAB edges but preserve interior whitespace" $ do 254 call "parseHeaders" [ofString "X:\t a \t b\t \r\nY:\t \r\n\r\nbody"] @?= 255 parserOk (ofList [pairT (ofString "x") (ofString "a \t b"), 256 pairT (ofString "y") Leaf]) (ofString "body") 257 , testCase "request-line scanner rejects missing CRLF and embedded CR" $ do 258 forM_ ["GET / HTTP/1.1", "GET / HTTP/1.1\n", "GET / HTTP/1.1\r", 259 "GE\rT / HTTP/1.1\r\n", "GET /a\rb HTTP/1.1\r\n"] $ \source -> 260 call "parseRequestLine" [ofString source] @?= 261 parserErr (ofNumber 400) (ofString "Bad Request\n") 262 , testCase "parseHeaders two headers lowercases names" $ do 263 call "parseHeaders" [ofString ("Host: localhost\r\nContent-Length: 42\r\n\r\n" ++ "x")] @?= parserOk 264 (ofList 265 [ pairT (ofString "host") (ofString "localhost") 266 , pairT (ofString "content-length") (ofString "42") 267 ]) 268 (ofString "x") 269 270 , testCase "parseHeaders preserves colon in value" $ do 271 call "parseHeaders" [ofString ("X-Custom: a: b\r\n\r\n" ++ "x")] @?= parserOk 272 (ofList [pairT (ofString "x-custom") (ofString "a: b")]) 273 (ofString "x") 274 275 , testCase "parseHeaders accepts empty value" $ do 276 call "parseHeaders" [ofString ("X-Empty:\r\n\r\n" ++ "x")] @?= parserOk 277 (ofList [pairT (ofString "x-empty") (ofString "")]) 278 (ofString "x") 279 280 , testCase "parseHeaders immediate blank" $ do 281 call "parseHeaders" [ofString "\r\nx"] @?= parserOk (ofList []) (ofString "x") 282 283 , testCase "parseHeaders rejects missing colon" $ do 284 call "parseHeaders" [ofString "Host\r\n\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 285 286 , testCase "bounded Content-Length validates syntax even after overflow" $ do 287 forM_ ["", "+1", "-2", "1 2", "12x", "x12", "1, 1", "1048577x", 288 replicate 128 '9' ++ "x"] $ \source -> 289 call "parseContentLengthValue" [ofString source] @?= 290 parserErr (ofNumber 400) (ofString "Bad Request\n") 291 call "parseContentLengthValue" [ofString (replicate 128 '9')] @?= 292 parserErr (ofNumber 413) (ofString "Request body too large\n") 293 , testCase "Content-Length selection rejects ambiguity before decoding" $ do 294 let check headers = call "contentLength" [ofList headers] @?= 295 parserErr (ofNumber 400) (ofString "Bad Request\n") 296 forM_ ["0", "1", "01", "1048577", "x"] $ \first -> 297 forM_ ["0", "1", "01", "1048577", "x"] $ \second -> 298 check [header "content-length" first, header "content-length" second] 299 forM_ ["", "chunked", "identity", "gzip"] $ \coding -> do 300 let transfer = header "transfer-encoding" coding 301 lengthField = header "content-length" "1048577" 302 mapM_ check [[transfer], [transfer, lengthField], [lengthField, transfer]] 303 , testCase "rejected framing produces a pure error before any body IO" $ do 304 forM_ [([header "transfer-encoding" "chunked"], 400, "Bad Request\n"), 305 ([header "content-length" "1", header "content-length" "1"], 400, "Bad Request\n"), 306 ([header "content-length" "1048577"], 413, "Request body too large\n")] $ \(headers, code, message) -> 307 call "readBody" [Leaf, ofList headers, ofString "body"] @?= 308 pairT (ofNumber 0) (parserErr (ofNumber code) (ofString message)) 309 , testCase "buffered body selection preserves exact suffix with no socket access" $ do 310 forM_ [([], "body", "", "body"), 311 ([header "content-length" "0"], "body", "", "body"), 312 ([header "content-length" "3"], "abcXYZ", "abc", "XYZ")] $ \(headers, input, body, rest) -> do 313 let action = call "readBody" [Leaf, ofList headers, ofString input] 314 envelope = Fork (ofString "tricuIO") (Fork (ofNumber 1) action) 315 runIO defaultPerms envelope >>= (@?= Right (parserOk (ofString body) (ofString rest))) 316 , testCase "parsed Content-Length header validates after framing" $ do 317 -- Test the pipeline directly; the ignored remainder is not source syntax. 318 let parsedLength raw = case call "parseHeaders" [ofString raw] of 319 Fork (Stem Leaf) (Fork headers _) -> call "contentLength" [headers] 320 other -> error ("expected successful header parsing: " ++ show other) 321 parsedLength "Content-Length: 42\r\n\r\nbody" @?= 322 parserOk (justT (ofNumber 42)) Leaf 323 call "contentLength" [ofList [header "content-length" "42", header "content-length" "99"]] @?= 324 parserErr (ofNumber 400) (ofString "Bad Request\n") 325 forM_ ["Content-Length: 1\r\nCONTENT-LENGTH: 1\r\n\r\n", 326 "Transfer-Encoding: chunked\r\n\r\n"] $ \raw -> 327 parsedLength raw @?= parserErr (ofNumber 400) (ofString "Bad Request\n") 328 parsedLength "Content-Length:\t 00042 \t\r\n\r\nbody" @?= 329 parserOk (justT (ofNumber 42)) Leaf 330 , testCase "parseContentLengthValue accepts max body bytes" $ 331 call "parseContentLengthValue" [ofString "1048576"] @?= 332 parserOk (justT (ofNumber 1048576)) Leaf 333 , testCase "parseContentLengthValue accepts shorter decimal below max" $ 334 call "parseContentLengthValue" [ofString "999999"] @?= 335 parserOk (justT (ofNumber 999999)) Leaf 336 337 , testCase "parseContentLengthValue strips leading zeros before limit check" $ do 338 call "parseContentLengthValue" [ofString "0000000000001"] @?= parserOk (justT (ofNumber 1)) Leaf 339 340 , testCase "parseContentLengthValue rejects body above max" $ do 341 call "parseContentLengthValue" [ofString "1048577"] @?= parserErr (ofNumber 413) (ofString "Request body too large\n") 342 343 , testCase "parseContentLengthValue rejects longer body above max" $ do 344 call "parseContentLengthValue" [ofString "2000000"] @?= parserErr (ofNumber 413) (ofString "Request body too large\n") 345 346 -- statusLine / headerLine 347 , testCase "statusLine 200 OK" $ do 348 call "statusLine" [ofNumber 200, ofString "OK"] @?= ofString "HTTP/1.1 200 OK\r\n" 349 350 , testCase "headerLine Content-Length" $ do 351 call "headerLine" [ofString "Content-Length", ofString "42"] @?= ofString "Content-Length: 42\r\n" 352 353 -- statusPhrase 354 , testCase "statusPhrase 200" $ do 355 call "statusPhrase" [ofNumber 200] @?= ofString "OK" 356 357 , testCase "statusPhrase 201" $ do 358 call "statusPhrase" [ofNumber 201] @?= ofString "Created" 359 360 , testCase "statusPhrase 204" $ do 361 call "statusPhrase" [ofNumber 204] @?= ofString "No Content" 362 363 , testCase "statusPhrase 400" $ do 364 call "statusPhrase" [ofNumber 400] @?= ofString "Bad Request" 365 366 , testCase "statusPhrase 404" $ do 367 call "statusPhrase" [ofNumber 404] @?= ofString "Not Found" 368 369 , testCase "statusPhrase 405" $ do 370 call "statusPhrase" [ofNumber 405] @?= ofString "Method Not Allowed" 371 372 , testCase "statusPhrase 431" $ do 373 call "statusPhrase" [ofNumber 431] @?= ofString "Request Header Fields Too Large" 374 375 , testCase "statusPhrase 501" $ do 376 call "statusPhrase" [ofNumber 501] @?= ofString "Not Implemented" 377 378 , testCase "statusPhrase 505" $ do 379 call "statusPhrase" [ofNumber 505] @?= ofString "HTTP Version Not Supported" 380 381 , testCase "statusPhrase 500" $ do 382 call "statusPhrase" [ofNumber 500] @?= ofString "Internal Server Error" 383 384 , testCase "statusPhrase unknown" $ do 385 call "statusPhrase" [ofNumber 999] @?= ofString "Internal Server Error" 386 387 -- buildResponse 388 , testCase "buildResponse 200 no headers" $ do 389 call "buildResponse" [ofNumber 200, ofList [], ofString "hi"] @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi" 390 391 , testCase "buildResponse 404 with header" $ do 392 call "buildResponse" [ofNumber 404, ofList [header "Content-Length" "9"], ofString "Not found"] @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found" 393 394 -- convenience responses 395 , testCase "okResponse" $ do 396 call "okResponse" [ofString "hi"] @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi" 397 398 , testCase "notFoundResponse" $ do 399 call "notFoundResponse" [] @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 10\r\nConnection: close\r\n\r\nNot found\n" 400 401 , testCase "textResponse" $ do 402 call "textResponse" [ofString "hi"] @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi" 403 404 , testCase "jsonResponse" $ do 405 call "jsonResponse" [ofString "{}"] @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}" 406 407 , testCase "createdResponse" $ do 408 call "createdResponse" [ofString "created\n"] @?= ofString "HTTP/1.1 201 Created\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 8\r\nConnection: close\r\n\r\ncreated\n" 409 410 , testCase "emptyResponse 204" $ do 411 call "emptyResponse" [ofNumber 204] @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n" 412 413 , testCase "badRequestResponse" $ do 414 call "badRequestResponse" [ofString "Bad Request\n"] @?= ofString "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 12\r\nConnection: close\r\n\r\nBad Request\n" 415 416 , testCase "errorResponse 405" $ do 417 call "errorResponse" [ofNumber 405, ofString "Method Not Allowed\n"] @?= ofString "HTTP/1.1 405 Method Not Allowed\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 19\r\nConnection: close\r\n\r\nMethod Not Allowed\n" 418 ] 419 where 420 call name = foldl apply (env Map.! name) 421 header name value = pairT (ofString name) (ofString value) 422