commit 69b0da8c8068c2d88e97024643d7242494468cdd
parent 38e85b4a5e328be257e4de84a368fa0e643378e6
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 15:49:23 -0500
Invoke byte and HTTP fixture tests without recovery compilation
Diffstat:
5 files changed, 546 insertions(+), 597 deletions(-)
diff --git a/docs/validation.md b/docs/validation.md
@@ -117,6 +117,14 @@ binding and the explicitly scoped recovery foundations. Missing/corrupt snapshot
fail: there is no fallback to working-tree library source. Unmapped test programs
remain live test inputs. Bundle, receipt, namespace, kernel, and ABI checks remain.
+`test/ReferenceFixtures.hs` owns authenticated artifact loading and direct
+published-interface selection. `test/LibraryValueTests.hs` invokes byte-list and
+HTTP exports with host-constructed inputs, without source wrappers or recovery
+compilation. HTTP framing/error expectations and no-socket-access controls remain
+independent of the compiled implementations. Mixed-cohort reuse verification in
+`SupportFixture` still depends on recovery parsing/free-variable analysis; direct
+artifact invocation does not remove that separate provenance dependency.
+
This avoids recompiling libraries on every unit run without silently treating old
executable trees as new source. Ordinary test wrappers may use the Haskell
frontend; production module resolution does not fall back to those wrappers.
diff --git a/test/LibraryValueTests.hs b/test/LibraryValueTests.hs
@@ -0,0 +1,422 @@
+-- Value/protocol tests invoke authenticated exports directly. No source wrappers,
+-- source import resolution, injected kernel names, or recovery compilation.
+module LibraryValueTests (byteListUtilities, httpParsingTests) where
+
+import Runtime
+import Control.Monad (forM_)
+import IODriver (runIO, defaultPerms)
+import qualified Data.Map as Map
+import Test.Tasty
+import Test.Tasty.HUnit
+
+trueT, falseT, nothingT :: T
+trueT = Stem Leaf
+falseT = Leaf
+nothingT = Leaf
+
+justT :: T -> T
+justT = Stem
+
+pairT :: T -> T -> T
+pairT = Fork
+
+byteT :: Integer -> T
+byteT = ofNumber
+
+bytesT :: [Integer] -> T
+bytesT = ofList . map ofNumber
+
+parserOk, parserErr :: T -> T -> T
+parserOk value rest = Fork trueT (Fork value rest)
+parserErr code rest = Fork falseT (Fork code rest)
+
+portableReply :: Bool -> T -> T -> Bool -> Bool -> T
+portableReply success payload rest consumed committed =
+ pairT (if success then trueT else falseT)
+ (pairT payload (pairT rest (pairT
+ (if consumed then trueT else falseT)
+ (if committed then trueT else falseT))))
+
+portableDiagnostic :: T -> T -> T -> T -> T -> T
+portableDiagnostic code expected found location contexts =
+ pairT code (pairT expected (pairT found (pairT location contexts)))
+
+byteListUtilities :: Env -> Env -> TestTree
+byteListUtilities env base = testGroup "Byte List Utility Tests"
+ [ testCase "isNil: empty list is nil" $ do
+ call "bytesNil?" [ofList []] @?= trueT
+
+ , testCase "isNil: non-empty list is not nil" $ do
+ call "bytesNil?" [bytesT [1]] @?= falseT
+
+ , testCase "head: empty list is nothing" $ do
+ call "bytesHead" [ofList []] @?= nothingT
+
+ , testCase "head: non-empty list returns first element" $ do
+ call "bytesHead" [bytesT [1, 2]] @?= justT (byteT 1)
+
+ , testCase "tail: empty list is nothing" $ do
+ call "bytesTail" [ofList []] @?= nothingT
+
+ , testCase "tail: non-empty list returns rest" $ do
+ call "bytesTail" [bytesT [1, 2]] @?= justT (bytesT [2])
+
+ , testCase "length: empty list is zero" $ do
+ call "bytesLength" [ofList []] @?= ofNumber 0
+
+ , testCase "length: single element list is one" $ do
+ call "bytesLength" [bytesT [1]] @?= ofNumber 1
+
+ , testCase "length: three element list is three" $ do
+ call "bytesLength" [bytesT [1, 2, 3]] @?= ofNumber 3
+
+ , testCase "append: empty ++ [1,2] = [1,2]" $ do
+ call "bytesAppend" [ofList [], bytesT [1, 2]] @?= bytesT [1,2]
+
+ , testCase "append: [1,2] ++ [3] = [1,2,3]" $ do
+ call "bytesAppend" [bytesT [1, 2], bytesT [3]] @?= bytesT [1,2,3]
+
+ , testCase "append: [1,2] ++ empty = [1,2]" $ do
+ call "bytesAppend" [bytesT [1, 2], ofList []] @?= bytesT [1,2]
+
+ , testCase "take: take 0 any list = empty" $ do
+ call "bytesTake" [ofNumber 0, bytesT [1, 2, 3]] @?= bytesT []
+
+ , testCase "take: take 2 [1,2,3] = [1,2]" $ do
+ call "bytesTake" [ofNumber 2, bytesT [1, 2, 3]] @?= bytesT [1,2]
+
+ , testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do
+ call "bytesTake" [ofNumber 5, bytesT [1, 2]] @?= bytesT [1,2]
+
+ , testCase "drop: drop 0 any list = list" $ do
+ call "bytesDrop" [ofNumber 0, bytesT [1, 2, 3]] @?= bytesT [1,2,3]
+
+ , testCase "drop: drop 2 [1,2,3] = [3]" $ do
+ call "bytesDrop" [ofNumber 2, bytesT [1, 2, 3]] @?= bytesT [3]
+
+ , testCase "drop: drop 5 [1,2] = empty (overlong)" $ do
+ call "bytesDrop" [ofNumber 5, bytesT [1, 2]] @?= bytesT []
+
+ , testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do
+ call "bytesSplitAt" [ofNumber 0, bytesT [1, 2]] @?= pairT (bytesT []) (bytesT [1,2])
+
+ , testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
+ call "bytesSplitAt" [ofNumber 2, bytesT [1, 2, 3]] @?= pairT (bytesT [1,2]) (bytesT [3])
+
+ , testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do
+ call "bytesSplitAt" [ofNumber 5, bytesT [1, 2]] @?= pairT (bytesT [1,2]) (bytesT [])
+
+ , testCase "byteEq: equal bytes are equal" $ do
+ call "equal?" [ofNumber 1, ofNumber 1] @?= trueT
+
+ , testCase "byteEq: unequal bytes are not equal" $ do
+ call "equal?" [ofNumber 1, ofNumber 2] @?= falseT
+
+ , testCase "bytesEq: empty == empty" $ do
+ call "bytesEq?" [ofList [], ofList []] @?= trueT
+
+ , testCase "bytesEq: empty != [1]" $ do
+ call "bytesEq?" [ofList [], bytesT [1]] @?= falseT
+
+ , testCase "bytesEq: [1] != empty" $ do
+ call "bytesEq?" [bytesT [1], ofList []] @?= falseT
+
+ , testCase "bytesEq: equal lists are equal" $ do
+ call "bytesEq?" [bytesT [1, 2, 3], bytesT [1, 2, 3]] @?= trueT
+
+ , testCase "bytesEq: different last element" $ do
+ call "bytesEq?" [bytesT [1, 2, 3], bytesT [1, 2, 4]] @?= falseT
+
+ , testCase "bytesEq: different lengths" $ do
+ call "bytesEq?" [bytesT [1, 2], bytesT [1, 2, 3]] @?= falseT
+ ]
+ where
+ call "equal?" = foldl apply (base Map.! "equal?")
+ call name = foldl apply (env Map.! name)
+
+httpParsingTests :: Env -> TestTree
+httpParsingTests env = testGroup "HTTP Parsing Tests"
+ [ testCase "HTTP support uses checked native parser exports" $ do
+ Map.member "httpLineReply" env @?= True
+ Map.member "httpHeaderLineReply" env @?= True
+ call "parseHeaders" [ofString "A: b\r\n\r\n"]
+ @?= parserOk (ofList [pairT (ofString "a") (ofString "b")]) Leaf
+ , testCase "finite line parser distinguishes CRLF from truncated EOF" $ do
+ let check source expected =
+ call "httpLineReply" [ofString source] @?= expected
+ check "hi\r\nx" (portableReply True
+ (ofString "hi") (ofString "x") True False)
+ let eof consumed = portableReply False
+ (portableDiagnostic (ofNumber 1) (ofString "CRLF") Leaf Leaf
+ (ofList [ofString "http-line"])) Leaf consumed False
+ check "hi" (eof True)
+ check "" (eof False)
+ , testCase "line parser rejects bare CR/LF with exact failure progress" $ do
+ forM_ [("h\ri\r\nx", 13, "\ri\r\nx", True), ("hi\nx", 10, "\nx", True),
+ ("hi\r", 13, "\r", True), ("\nx", 10, "\nx", False)] $ \(source, found, rest, consumed) ->
+ call "httpLineReply" [ofString source] @?=
+ portableReply False
+ (portableDiagnostic (ofNumber 2) (ofString "CRLF") (ofNumber found) Leaf
+ (ofList [ofString "http-line"])) (ofString rest) consumed False
+ , testCase "request-line fields use the shared finite-byte parser" $ do
+ let check input expected =
+ call "httpThreeWordsReply" [ofString input] @?= expected
+ fields method target version =
+ pairT (ofString method)
+ (pairT (ofString target) (ofString version))
+ check "GET / HTTP/1.1"
+ (portableReply True (fields "GET" "/" "HTTP/1.1") Leaf True False)
+ check "GET /"
+ (portableReply False
+ (portableDiagnostic (ofNumber 1) (ofNumber 32) Leaf Leaf
+ (ofList [ofString "request-line"]))
+ Leaf True False)
+ check "GET / HTTP/1.1 extra"
+ (portableReply False
+ (portableDiagnostic (ofNumber 2) Leaf (ofNumber 32) Leaf
+ (ofList [ofString "request-line"]))
+ (ofString " extra") True False)
+ check " "
+ (portableReply True (fields "" "" "") Leaf True False)
+ , testCase "request-line Result boundary retains legacy response and rest" $ do
+ let check input expected =
+ call "parseThreeWords" [ofString input] @?= expected
+ check "GET / HTTP/1.1"
+ (parserOk (pairT (ofString "GET")
+ (pairT (ofString "/") (ofString "HTTP/1.1"))) Leaf)
+ check "GET / HTTP/1.1 extra"
+ (parserErr (ofNumber 400) (ofString "Bad Request\n"))
+ check "GET /"
+ (parserErr (ofNumber 400) (ofString "Bad Request\n"))
+ -- Result-valued request-line reader
+ , testCase "readLineBytes with CRLF" $ do
+ call "readLineBytes" [bytesT [104, 105, 13, 10, 120]] @?= parserOk (bytesT [104, 105]) (bytesT [120])
+
+ , testCase "readLineBytes rejects bare LF" $ do
+ call "readLineBytes" [bytesT [104, 105, 10, 120]] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "readLineBytes empty line" $ do
+ call "readLineBytes" [bytesT [13, 10, 120]] @?= parserOk (bytesT []) (bytesT [120])
+
+ , testCase "readLineBytes rejects EOF mid-line" $ do
+ call "readLineBytes" [bytesT [104, 105]] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ -- parseRequestLine
+ , testCase "parseRequestLine GET slash" $ do
+ call "parseRequestLine" [ofString ("GET / HTTP/1.1\r\n" ++ "x")] @?= parserOk
+ (pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
+ (ofString "x")
+
+ , testCase "parseRequestLine POST path" $ do
+ call "parseRequestLine" [ofString "POST /foo/bar HTTP/1.1\r\n"] @?= parserOk
+ (pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
+ (ofString "")
+
+ , testCase "parseRequestLine too short" $ do
+ call "parseRequestLine" [ofString "GET\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine no version" $ do
+ call "parseRequestLine" [ofString "GET /foo\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine empty line" $ do
+ call "parseRequestLine" [ofString "\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine rejects extra fields" $ do
+ call "parseRequestLine" [ofString "GET / HTTP/1.1 wat\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ -- parseHeaders
+ , testCase "single header line exposes consumed parser failures" $ do
+ let check input expected =
+ call "httpHeaderLineReply" [ofString input] @?= expected
+ check "Host: a:b"
+ (portableReply True
+ (pairT (ofString "host") (ofString "a:b")) Leaf True False)
+ check "Host"
+ (portableReply False
+ (portableDiagnostic (ofNumber 1) (ofString "colon") Leaf Leaf
+ (ofList [ofString "header-line"]))
+ Leaf True False)
+ check ": bad"
+ (portableReply False
+ (portableDiagnostic (ofNumber 2) (ofString "header-name")
+ (ofNumber 58) Leaf (ofList [ofString "header-line"]))
+ (ofString ": bad") False False)
+ , testCase "headers reject bad syntax and every truncated block prefix" $ do
+ let block = "A: b\r\nB: c\r\n\r\n"
+ inputs = [take n block | n <- [0 .. length block - 1]] ++
+ [ "Bad Name: x\r\n\r\n", "Host : x\r\n\r\n", "\tHost: x\r\n\r\n"
+ , "X\r-Name: x\r\n\r\n", "X: a\rb\r\n\r\n", "X: y\n\n"
+ , "X: y\r\n\tcontinued\r\n\r\n" ]
+ forM_ inputs $ \source ->
+ call "parseHeaders" [ofString source] @?=
+ parserErr (ofNumber 400) (ofString "Bad Request\n")
+ , testCase "header values trim SP/HTAB edges but preserve interior whitespace" $ do
+ call "parseHeaders" [ofString "X:\t a \t b\t \r\nY:\t \r\n\r\nbody"] @?=
+ parserOk (ofList [pairT (ofString "x") (ofString "a \t b"),
+ pairT (ofString "y") Leaf]) (ofString "body")
+ , testCase "request-line scanner rejects missing CRLF and embedded CR" $ do
+ forM_ ["GET / HTTP/1.1", "GET / HTTP/1.1\n", "GET / HTTP/1.1\r",
+ "GE\rT / HTTP/1.1\r\n", "GET /a\rb HTTP/1.1\r\n"] $ \source ->
+ call "parseRequestLine" [ofString source] @?=
+ parserErr (ofNumber 400) (ofString "Bad Request\n")
+ , testCase "parseHeaders two headers lowercases names" $ do
+ call "parseHeaders" [ofString ("Host: localhost\r\nContent-Length: 42\r\n\r\n" ++ "x")] @?= parserOk
+ (ofList
+ [ pairT (ofString "host") (ofString "localhost")
+ , pairT (ofString "content-length") (ofString "42")
+ ])
+ (ofString "x")
+
+ , testCase "parseHeaders preserves colon in value" $ do
+ call "parseHeaders" [ofString ("X-Custom: a: b\r\n\r\n" ++ "x")] @?= parserOk
+ (ofList [pairT (ofString "x-custom") (ofString "a: b")])
+ (ofString "x")
+
+ , testCase "parseHeaders accepts empty value" $ do
+ call "parseHeaders" [ofString ("X-Empty:\r\n\r\n" ++ "x")] @?= parserOk
+ (ofList [pairT (ofString "x-empty") (ofString "")])
+ (ofString "x")
+
+ , testCase "parseHeaders immediate blank" $ do
+ call "parseHeaders" [ofString "\r\nx"] @?= parserOk (ofList []) (ofString "x")
+
+ , testCase "parseHeaders rejects missing colon" $ do
+ call "parseHeaders" [ofString "Host\r\n\r\n"] @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "bounded Content-Length validates syntax even after overflow" $ do
+ forM_ ["", "+1", "-2", "1 2", "12x", "x12", "1, 1", "1048577x",
+ replicate 128 '9' ++ "x"] $ \source ->
+ call "parseContentLengthValue" [ofString source] @?=
+ parserErr (ofNumber 400) (ofString "Bad Request\n")
+ call "parseContentLengthValue" [ofString (replicate 128 '9')] @?=
+ parserErr (ofNumber 413) (ofString "Request body too large\n")
+ , testCase "Content-Length selection rejects ambiguity before decoding" $ do
+ let check headers = call "contentLength" [ofList headers] @?=
+ parserErr (ofNumber 400) (ofString "Bad Request\n")
+ forM_ ["0", "1", "01", "1048577", "x"] $ \first ->
+ forM_ ["0", "1", "01", "1048577", "x"] $ \second ->
+ check [header "content-length" first, header "content-length" second]
+ forM_ ["", "chunked", "identity", "gzip"] $ \coding -> do
+ let transfer = header "transfer-encoding" coding
+ lengthField = header "content-length" "1048577"
+ mapM_ check [[transfer], [transfer, lengthField], [lengthField, transfer]]
+ , testCase "rejected framing produces a pure error before any body IO" $ do
+ forM_ [([header "transfer-encoding" "chunked"], 400, "Bad Request\n"),
+ ([header "content-length" "1", header "content-length" "1"], 400, "Bad Request\n"),
+ ([header "content-length" "1048577"], 413, "Request body too large\n")] $ \(headers, code, message) ->
+ call "readBody" [Leaf, ofList headers, ofString "body"] @?=
+ pairT (ofNumber 0) (parserErr (ofNumber code) (ofString message))
+ , testCase "buffered body selection preserves exact suffix with no socket access" $ do
+ forM_ [([], "body", "", "body"),
+ ([header "content-length" "0"], "body", "", "body"),
+ ([header "content-length" "3"], "abcXYZ", "abc", "XYZ")] $ \(headers, input, body, rest) -> do
+ let action = call "readBody" [Leaf, ofList headers, ofString input]
+ envelope = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
+ runIO defaultPerms envelope >>= (@?= Right (parserOk (ofString body) (ofString rest)))
+ , testCase "parsed Content-Length header validates after framing" $ do
+ -- Test the pipeline directly; the ignored remainder is not source syntax.
+ let parsedLength raw = case call "parseHeaders" [ofString raw] of
+ Fork (Stem Leaf) (Fork headers _) -> call "contentLength" [headers]
+ other -> error ("expected successful header parsing: " ++ show other)
+ parsedLength "Content-Length: 42\r\n\r\nbody" @?=
+ parserOk (justT (ofNumber 42)) Leaf
+ call "contentLength" [ofList [header "content-length" "42", header "content-length" "99"]] @?=
+ parserErr (ofNumber 400) (ofString "Bad Request\n")
+ forM_ ["Content-Length: 1\r\nCONTENT-LENGTH: 1\r\n\r\n",
+ "Transfer-Encoding: chunked\r\n\r\n"] $ \raw ->
+ parsedLength raw @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+ parsedLength "Content-Length:\t 00042 \t\r\n\r\nbody" @?=
+ parserOk (justT (ofNumber 42)) Leaf
+ , testCase "parseContentLengthValue accepts max body bytes" $
+ call "parseContentLengthValue" [ofString "1048576"] @?=
+ parserOk (justT (ofNumber 1048576)) Leaf
+ , testCase "parseContentLengthValue accepts shorter decimal below max" $
+ call "parseContentLengthValue" [ofString "999999"] @?=
+ parserOk (justT (ofNumber 999999)) Leaf
+
+ , testCase "parseContentLengthValue strips leading zeros before limit check" $ do
+ call "parseContentLengthValue" [ofString "0000000000001"] @?= parserOk (justT (ofNumber 1)) Leaf
+
+ , testCase "parseContentLengthValue rejects body above max" $ do
+ call "parseContentLengthValue" [ofString "1048577"] @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
+
+ , testCase "parseContentLengthValue rejects longer body above max" $ do
+ call "parseContentLengthValue" [ofString "2000000"] @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
+
+ -- statusLine / headerLine
+ , testCase "statusLine 200 OK" $ do
+ call "statusLine" [ofNumber 200, ofString "OK"] @?= ofString "HTTP/1.1 200 OK\r\n"
+
+ , testCase "headerLine Content-Length" $ do
+ call "headerLine" [ofString "Content-Length", ofString "42"] @?= ofString "Content-Length: 42\r\n"
+
+ -- statusPhrase
+ , testCase "statusPhrase 200" $ do
+ call "statusPhrase" [ofNumber 200] @?= ofString "OK"
+
+ , testCase "statusPhrase 201" $ do
+ call "statusPhrase" [ofNumber 201] @?= ofString "Created"
+
+ , testCase "statusPhrase 204" $ do
+ call "statusPhrase" [ofNumber 204] @?= ofString "No Content"
+
+ , testCase "statusPhrase 400" $ do
+ call "statusPhrase" [ofNumber 400] @?= ofString "Bad Request"
+
+ , testCase "statusPhrase 404" $ do
+ call "statusPhrase" [ofNumber 404] @?= ofString "Not Found"
+
+ , testCase "statusPhrase 405" $ do
+ call "statusPhrase" [ofNumber 405] @?= ofString "Method Not Allowed"
+
+ , testCase "statusPhrase 431" $ do
+ call "statusPhrase" [ofNumber 431] @?= ofString "Request Header Fields Too Large"
+
+ , testCase "statusPhrase 501" $ do
+ call "statusPhrase" [ofNumber 501] @?= ofString "Not Implemented"
+
+ , testCase "statusPhrase 505" $ do
+ call "statusPhrase" [ofNumber 505] @?= ofString "HTTP Version Not Supported"
+
+ , testCase "statusPhrase 500" $ do
+ call "statusPhrase" [ofNumber 500] @?= ofString "Internal Server Error"
+
+ , testCase "statusPhrase unknown" $ do
+ call "statusPhrase" [ofNumber 999] @?= ofString "Internal Server Error"
+
+ -- buildResponse
+ , testCase "buildResponse 200 no headers" $ do
+ call "buildResponse" [ofNumber 200, ofList [], ofString "hi"] @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
+
+ , testCase "buildResponse 404 with header" $ do
+ 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"
+
+ -- convenience responses
+ , testCase "okResponse" $ do
+ 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"
+
+ , testCase "notFoundResponse" $ do
+ 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"
+
+ , testCase "textResponse" $ do
+ 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"
+
+ , testCase "jsonResponse" $ do
+ 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{}"
+
+ , testCase "createdResponse" $ do
+ 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"
+
+ , testCase "emptyResponse 204" $ do
+ call "emptyResponse" [ofNumber 204] @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
+
+ , testCase "badRequestResponse" $ do
+ 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"
+
+ , testCase "errorResponse 405" $ do
+ 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"
+ ]
+ where
+ call name = foldl apply (env Map.! name)
+ header name value = pairT (ofString name) (ofString value)
+
diff --git a/test/ReferenceFixtures.hs b/test/ReferenceFixtures.hs
@@ -0,0 +1,96 @@
+-- Authenticated retained library artifacts. This module does not compile source
+-- or recreate source import scopes. SupportFixture still uses recovery parsing
+-- for mixed-cohort reuse proofs; that dependency is explicit, not a fallback.
+module ReferenceFixtures
+ ( compilerFixture, supportFixture, compiledLibraries, fixtureExports ) where
+
+import Runtime (Env)
+import Wire
+import ContentStore (hashObject, Domain(..))
+import SupportFixture (verifyMixedSupport, readFixtureSourceBytes)
+import Control.Exception (evaluate)
+import Control.Monad (forM_, unless)
+import Data.List (isPrefixOf)
+import Data.Text (pack, unpack)
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+-- The fast gate executes self-built library trees rather than asking the old
+-- recovery frontend to parse compiler sources. Every mapped reference source is
+-- authenticated independently of working-tree edits. The explicit freshness gate
+-- rejects stale cohorts at batch acceptance; these are reference-artifact tests.
+compilerFixture :: ([(String, String, FilePath)], Env)
+compilerFixture = unsafePerformIO $ do
+ metadata <- lines <$> readFile "./test/fixtures/compiler-library.v1"
+ bytes <- BS.readFile "./test/fixtures/compiler-library.arboricx"
+ unless (take 1 metadata == ["tricu.compiler-library-fixture.v1"]) $
+ error "invalid compiler fixture metadata"
+ let rows = [ (legacy, alias, path, digest)
+ | row <- tail metadata
+ , ["module", legacy, alias, path, digest] <- [words row] ]
+ bundleHash = unpack (hashObject (Domain (pack "tricu.compiler-library-fixture.v1")) bytes)
+ unless (["bundle", bundleHash] `elem` map words metadata) $
+ error "compiler fixture bundle digest mismatch"
+ forM_ rows $ \(_, _, path, digest) -> do
+ source <- readFixtureSourceBytes path
+ unless (unpack (hashObject (Domain (pack "arboricx.source.v1")) source) == digest) $
+ error ("mismatched compiler reference source for " ++ path ++
+ "; authenticate the fixture source snapshot")
+ bundle <- either error pure (decodeBundle bytes)
+ either error pure (verifyBundle bundle)
+ let terms = reconstructBundleTerms (bundleNodes bundle)
+ env = Map.fromList
+ [ (unpack (exportName entry), terms V.! fromIntegral (exportRoot entry))
+ | entry <- manifestExports (bundleManifest bundle) ]
+ pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env)
+{-# NOINLINE compilerFixture #-}
+
+-- Real portable builds own these unmapped general-purpose libraries. Loading
+-- verifies authored inputs and the dependency compiler fixture; no body compiler.
+supportFixture :: ([(String, String, FilePath)], Env)
+supportFixture = unsafePerformIO $ do
+ metadata <- lines <$> readFile "./test/fixtures/support-library.v1"
+ bytes <- BS.readFile "./test/fixtures/support-library.arboricx"
+ compilerBytes <- BS.readFile "./test/fixtures/compiler-library.arboricx"
+ unless (take 1 metadata `elem` [["tricu.support-library-fixture.v1"], ["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]]) $
+ error "invalid support fixture metadata"
+ let rows = [(legacy, alias, path, digest) | row <- tail metadata,
+ ["module", legacy, alias, path, digest] <- [words row]]
+ objectHash domain value = unpack (hashObject (Domain (pack domain)) value)
+ unless (["bundle", objectHash "tricu.support-library-fixture.v1" bytes] `elem` map words metadata) $
+ error "support fixture bundle digest mismatch"
+ unless (["compiler-fixture", objectHash "tricu.compiler-library-fixture.v1" compilerBytes] `elem` map words metadata) $
+ error "support fixture dependency mismatch"
+ if take 1 metadata `elem` [["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]]
+ then verifyMixedSupport metadata bytes compilerBytes
+ else pure ()
+ _ <- evaluate (length (fst compilerFixture))
+ forM_ rows $ \(_, _, path, digest) -> do
+ source <- readFixtureSourceBytes path
+ unless (objectHash "arboricx.source.v1" source == digest) $
+ error ("mismatched support reference source for " ++ path)
+ bundle <- either error pure (decodeBundle bytes)
+ either error pure (verifyBundle bundle)
+ let terms = reconstructBundleTerms (bundleNodes bundle)
+ env = Map.fromList [(unpack (exportName entry), terms V.! fromIntegral (exportRoot entry))
+ | entry <- manifestExports (bundleManifest bundle)]
+ pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env)
+{-# NOINLINE supportFixture #-}
+
+compiledLibraries :: ([(String, String, FilePath)], Env)
+compiledLibraries = (fst compilerFixture ++ fst supportFixture,
+ Map.union (snd compilerFixture) (snd supportFixture))
+
+-- Select only the published interface, not imported names or recovery kernels.
+-- The existing cohort loaders still authenticate sources/receipts/reuse proofs.
+fixtureExports :: String -> Env
+fixtureExports legacy =
+ let (rows, exports) = compiledLibraries
+ in case [alias | (name, alias, _) <- rows, name == legacy] of
+ [alias] -> Map.fromList
+ [(drop (length alias + 1) name, tree) | (name, tree) <- Map.toList exports,
+ (alias ++ ".") `isPrefixOf` name]
+ _ -> error ("missing or ambiguous fixture module: " ++ legacy)
+
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,6 +1,8 @@
module Main where
import Eval
+import qualified LibraryValueTests
+import ReferenceFixtures
import PackageTests (packageTests)
import InteractionInspectionTests (interactionInspectionTests)
import FileEval
@@ -11,7 +13,7 @@ import Research
import TreeObservation (forceTreeShared)
import qualified NodeTable as Nodes
import Wire
-import SupportFixture (verifyMixedSupport, verifyReuseScopes, verifySupportSources, verifyRelocatedSupportSources,
+import SupportFixture (verifyReuseScopes, verifySupportSources, verifyRelocatedSupportSources,
verifySupportExports, verifySupportDependencies, readFixtureSourceBytes, readTestSource, readPinnedSource)
import ContentStore
import ContentStore.Bundle
@@ -101,7 +103,7 @@ tests = testGroup "Tricu Tests"
, verifiedTreePublicationTests
, wireTests
, tricuReaderTests
- , byteListUtilities
+ , LibraryValueTests.byteListUtilities (fixtureExports "bytes") (fixtureExports "base")
, binaryParserTests
, portableParserTests
, locatedLexerTests
@@ -116,7 +118,7 @@ tests = testGroup "Tricu Tests"
, gateUnitTests
, gateResolutionTests
, gateCompilationTests
- , httpParsingTests
+ , LibraryValueTests.httpParsingTests (fixtureExports "http")
, httpPipelineTests
, registryContractTests
, registryPipelineTests
@@ -127,8 +129,6 @@ tests = testGroup "Tricu Tests"
]
--- Demand is tested with exceptions rather than unbounded divergent reductions.
--- Physical sharing below is a Haskell implementation check, not a tree ABI promise.
-- Independent compatibility oracle: production rendering no longer imports ASTs.
runtimePresentationTests :: TestTree
runtimePresentationTests = testGroup "Runtime presentation"
@@ -143,6 +143,8 @@ runtimePresentationTests = testGroup "Runtime presentation"
"TFork (TStem TLeaf) (TFork TLeaf TLeaf)"
]
+-- Demand uses exceptions rather than unbounded divergent reductions.
+-- Physical sharing checks the Haskell implementation, not a tree ABI promise.
evaluationDemandTests :: TestTree
evaluationDemandTests = localOption (mkTimeout 30000000) $ testGroup "Evaluation demand boundaries"
[ testCase "constant application discards its argument" $
@@ -3207,154 +3209,6 @@ sectionRecordExpr sectionType offset lengthBytes =
++ " " ++ bytesExpr (replicate 32 0)
++ ")))))))"
-byteListUtilities :: TestTree
-byteListUtilities = testGroup "Byte List Utility Tests"
- [ testCase "isNil: empty list is nil" $ do
- let input = "bytesNil? []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "isNil: non-empty list is not nil" $ do
- let input = "bytesNil? [(1)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "head: empty list is nothing" $ do
- let input = "bytesHead []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "head: non-empty list returns first element" $ do
- let input = "bytesHead [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (byteT 1)
-
- , testCase "tail: empty list is nothing" $ do
- let input = "bytesTail []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= nothingT
-
- , testCase "tail: non-empty list returns rest" $ do
- let input = "bytesTail [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= justT (bytesT [2])
-
- , testCase "length: empty list is zero" $ do
- let input = "bytesLength []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 0
-
- , testCase "length: single element list is one" $ do
- let input = "bytesLength [(1)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 1
-
- , testCase "length: three element list is three" $ do
- let input = "bytesLength [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofNumber 3
-
- , testCase "append: empty ++ [1,2] = [1,2]" $ do
- let input = "bytesAppend [] [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2]
-
- , testCase "append: [1,2] ++ [3] = [1,2,3]" $ do
- let input = "bytesAppend [(1) (2)] [(3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2,3]
-
- , testCase "append: [1,2] ++ empty = [1,2]" $ do
- let input = "bytesAppend [(1) (2)] []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2]
-
- , testCase "take: take 0 any list = empty" $ do
- let input = "bytesTake 0 [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT []
-
- , testCase "take: take 2 [1,2,3] = [1,2]" $ do
- let input = "bytesTake 2 [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2]
-
- , testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do
- let input = "bytesTake 5 [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2]
-
- , testCase "drop: drop 0 any list = list" $ do
- let input = "bytesDrop 0 [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [1,2,3]
-
- , testCase "drop: drop 2 [1,2,3] = [3]" $ do
- let input = "bytesDrop 2 [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT [3]
-
- , testCase "drop: drop 5 [1,2] = empty (overlong)" $ do
- let input = "bytesDrop 5 [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= bytesT []
-
- , testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do
- let input = "bytesSplitAt 0 [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (bytesT []) (bytesT [1,2])
-
- , testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
- let input = "bytesSplitAt 2 [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (bytesT [1,2]) (bytesT [3])
-
- , testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do
- let input = "bytesSplitAt 5 [(1) (2)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= pairT (bytesT [1,2]) (bytesT [])
-
- , testCase "byteEq: equal bytes are equal" $ do
- let input = "equal? 1 1"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "byteEq: unequal bytes are not equal" $ do
- let input = "equal? 1 2"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "bytesEq: empty == empty" $ do
- let input = "bytesEq? [] []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "bytesEq: empty != [1]" $ do
- let input = "bytesEq? [] [(1)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "bytesEq: [1] != empty" $ do
- let input = "bytesEq? [(1)] []"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "bytesEq: equal lists are equal" $ do
- let input = "bytesEq? [(1) (2) (3)] [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= trueT
-
- , testCase "bytesEq: different last element" $ do
- let input = "bytesEq? [(1) (2) (3)] [(1) (2) (4)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
-
- , testCase "bytesEq: different lengths" $ do
- let input = "bytesEq? [(1) (2)] [(1) (2) (3)]"
- let env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= falseT
- ]
-
-- --------------------------------------------------------------------------
-- Portable finite-stream parser protocol
-- --------------------------------------------------------------------------
@@ -3741,72 +3595,6 @@ gateLexerTests = testGroup "Feasibility-gate source lexer"
-- Single-expression feasibility-gate surface parser
-- --------------------------------------------------------------------------
--- The fast gate executes self-built library trees rather than asking the old
--- recovery frontend to parse compiler sources. Every mapped reference source is
--- authenticated independently of working-tree edits. The explicit freshness gate
--- rejects stale cohorts at batch acceptance; these are reference-artifact tests.
-compilerFixture :: ([(String, String, FilePath)], Env)
-compilerFixture = unsafePerformIO $ do
- metadata <- lines <$> readFile "./test/fixtures/compiler-library.v1"
- bytes <- BS.readFile "./test/fixtures/compiler-library.arboricx"
- unless (take 1 metadata == ["tricu.compiler-library-fixture.v1"]) $
- error "invalid compiler fixture metadata"
- let rows = [ (legacy, alias, path, digest)
- | row <- tail metadata
- , ["module", legacy, alias, path, digest] <- [words row] ]
- bundleHash = unpack (hashObject (Domain (pack "tricu.compiler-library-fixture.v1")) bytes)
- unless (["bundle", bundleHash] `elem` map words metadata) $
- error "compiler fixture bundle digest mismatch"
- forM_ rows $ \(_, _, path, digest) -> do
- source <- readFixtureSourceBytes path
- unless (unpack (hashObject (Domain (pack "arboricx.source.v1")) source) == digest) $
- error ("mismatched compiler reference source for " ++ path ++
- "; authenticate the fixture source snapshot")
- bundle <- either error pure (decodeBundle bytes)
- either error pure (verifyBundle bundle)
- let terms = reconstructBundleTerms (bundleNodes bundle)
- env = Map.fromList
- [ (unpack (exportName entry), terms V.! fromIntegral (exportRoot entry))
- | entry <- manifestExports (bundleManifest bundle) ]
- pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env)
-{-# NOINLINE compilerFixture #-}
-
--- Real portable builds own these unmapped general-purpose libraries. Loading
--- verifies authored inputs and the dependency compiler fixture; no body compiler.
-supportFixture :: ([(String, String, FilePath)], Env)
-supportFixture = unsafePerformIO $ do
- metadata <- lines <$> readFile "./test/fixtures/support-library.v1"
- bytes <- BS.readFile "./test/fixtures/support-library.arboricx"
- compilerBytes <- BS.readFile "./test/fixtures/compiler-library.arboricx"
- unless (take 1 metadata `elem` [["tricu.support-library-fixture.v1"], ["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]]) $
- error "invalid support fixture metadata"
- let rows = [(legacy, alias, path, digest) | row <- tail metadata,
- ["module", legacy, alias, path, digest] <- [words row]]
- objectHash domain value = unpack (hashObject (Domain (pack domain)) value)
- unless (["bundle", objectHash "tricu.support-library-fixture.v1" bytes] `elem` map words metadata) $
- error "support fixture bundle digest mismatch"
- unless (["compiler-fixture", objectHash "tricu.compiler-library-fixture.v1" compilerBytes] `elem` map words metadata) $
- error "support fixture dependency mismatch"
- if take 1 metadata `elem` [["tricu.support-library-fixture.v2"], ["tricu.support-library-fixture.v3"]]
- then verifyMixedSupport metadata bytes compilerBytes
- else pure ()
- _ <- evaluate (length (fst compilerFixture))
- forM_ rows $ \(_, _, path, digest) -> do
- source <- readFixtureSourceBytes path
- unless (objectHash "arboricx.source.v1" source == digest) $
- error ("mismatched support reference source for " ++ path)
- bundle <- either error pure (decodeBundle bytes)
- either error pure (verifyBundle bundle)
- let terms = reconstructBundleTerms (bundleNodes bundle)
- env = Map.fromList [(unpack (exportName entry), terms V.! fromIntegral (exportRoot entry))
- | entry <- manifestExports (bundleManifest bundle)]
- pure ([(legacy, alias, path) | (legacy, alias, path, _) <- rows], env)
-{-# NOINLINE supportFixture #-}
-
-compiledLibraries :: ([(String, String, FilePath)], Env)
-compiledLibraries = (fst compilerFixture ++ fst supportFixture,
- Map.union (snd compilerFixture) (snd supportFixture))
-
compiledModuleEnv :: String -> IO Env
compiledModuleEnv legacy = do
let (rows, exports) = compiledLibraries
@@ -4029,6 +3817,15 @@ compilerFixtureTests = testGroup "self-built reference compiler fixture"
(any (\(_, alias, _) -> alias == "patterns") (fst supportFixture))
assertBool "missing unit compiler export"
(Map.member "source_unit.compileSource" (snd compilerFixture))
+ , testCase "direct fixture interfaces exclude imports and reject unknown modules" $ do
+ let http = fixtureExports "http"
+ assertBool "missing owned HTTP export" (Map.member "parseHeaders" http)
+ forM_ ["append", "kernel", "source_unit.compileSource"] $ \name ->
+ assertBool ("leaked imported/injected name: " ++ name) (Map.notMember name http)
+ rejected <- try (evaluate (Map.size (fixtureExports "missing.fixture"))) :: IO (Either SomeException Int)
+ case rejected of
+ Left _ -> pure ()
+ Right _ -> assertFailure "unknown fixture module silently accepted"
, testCase "every reference compiler module authors native headers" $ do
forM_ (fst compilerFixture) $ \(_, _, path) -> do
source <- readTestSource path
@@ -7140,8 +6937,8 @@ runScriptedEffects initial expected = go (256 :: Int) initial [] expected
httpPipelineTests :: TestTree
httpPipelineTests = testCase "HTTP reference pipeline: buffers, EOF, receive errors and cleanup" $ do
- env <- evaluateTestSupportFile "./lib/http.tri"
- let call name = foldl apply (env Map.! name)
+ let env = fixtureExports "http"
+ call name = foldl apply (env Map.! name)
sock = ofNumber 7
recv size = pairT (ofNumber 76) (pairT sock (ofNumber size))
send bytes = pairT (ofNumber 77) (pairT sock (ofString bytes))
@@ -7188,382 +6985,6 @@ httpPipelineTests = testCase "HTTP reference pipeline: buffers, EOF, receive err
Left _ -> pure ()
Right _ -> assertFailure "HTTP effect interpreter accepted a mismatched script"
-httpParsingTests :: TestTree
-httpParsingTests = testGroup "HTTP Parsing Tests"
- [ testCase "HTTP support uses checked native parser exports" $ do
- env <- evaluateTestSupportFile "./lib/http.tri"
- Map.member "httpLineReply" env @?= True
- Map.member "httpHeaderLineReply" env @?= True
- result (evalTricu env (parseTricu "parseHeaders \"A: b\\r\\n\\r\\n\""))
- @?= parserOk (ofList [pairT (ofString "a") (ofString "b")]) Leaf
- , testCase "finite line parser distinguishes CRLF from truncated EOF" $ do
- let check source expected =
- result (evalTricu allTestLibsEnv (parseTricu
- ("httpLineReply " ++ show source))) @?= expected
- check "hi\r\nx" (portableReply True
- (ofString "hi") (ofString "x") True False)
- let eof consumed = portableReply False
- (portableDiagnostic (ofNumber 1) (ofString "CRLF") Leaf Leaf
- (ofList [ofString "http-line"])) Leaf consumed False
- check "hi" (eof True)
- check "" (eof False)
- , testCase "line parser rejects bare CR/LF with exact failure progress" $ do
- forM_ [("h\ri\r\nx", 13, "\ri\r\nx", True), ("hi\nx", 10, "\nx", True),
- ("hi\r", 13, "\r", True), ("\nx", 10, "\nx", False)] $ \(source, found, rest, consumed) ->
- result (evalTricu allTestLibsEnv (parseTricu ("httpLineReply " ++ show source))) @?=
- portableReply False
- (portableDiagnostic (ofNumber 2) (ofString "CRLF") (ofNumber found) Leaf
- (ofList [ofString "http-line"])) (ofString rest) consumed False
- , testCase "request-line fields use the shared finite-byte parser" $ do
- let check input expected =
- result (evalTricu allTestLibsEnv (parseTricu input)) @?= expected
- fields method target version =
- pairT (ofString method)
- (pairT (ofString target) (ofString version))
- check "httpThreeWordsReply \"GET / HTTP/1.1\""
- (portableReply True (fields "GET" "/" "HTTP/1.1") Leaf True False)
- check "httpThreeWordsReply \"GET /\""
- (portableReply False
- (portableDiagnostic (ofNumber 1) (ofNumber 32) Leaf Leaf
- (ofList [ofString "request-line"]))
- Leaf True False)
- check "httpThreeWordsReply \"GET / HTTP/1.1 extra\""
- (portableReply False
- (portableDiagnostic (ofNumber 2) Leaf (ofNumber 32) Leaf
- (ofList [ofString "request-line"]))
- (ofString " extra") True False)
- check "httpThreeWordsReply \" \""
- (portableReply True (fields "" "" "") Leaf True False)
- , testCase "request-line Result boundary retains legacy response and rest" $ do
- let check input expected =
- result (evalTricu allTestLibsEnv (parseTricu input)) @?= expected
- check "parseThreeWords \"GET / HTTP/1.1\""
- (parserOk (pairT (ofString "GET")
- (pairT (ofString "/") (ofString "HTTP/1.1"))) Leaf)
- check "parseThreeWords \"GET / HTTP/1.1 extra\""
- (parserErr (ofNumber 400) (ofString "Bad Request\n"))
- check "parseThreeWords \"GET /\""
- (parserErr (ofNumber 400) (ofString "Bad Request\n"))
- -- Result-valued request-line reader
- , testCase "readLineBytes with CRLF" $ do
- let input = "readLineBytes [(104) (105) (13) (10) (120)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (bytesT [104, 105]) (bytesT [120])
-
- , testCase "readLineBytes rejects bare LF" $ do
- let input = "readLineBytes [(104) (105) (10) (120)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- , testCase "readLineBytes empty line" $ do
- let input = "readLineBytes [(13) (10) (120)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (bytesT []) (bytesT [120])
-
- , testCase "readLineBytes rejects EOF mid-line" $ do
- let input = "readLineBytes [(104) (105)]"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- -- parseRequestLine
- , testCase "parseRequestLine GET slash" $ do
- let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk
- (pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
- (ofString "x")
-
- , testCase "parseRequestLine POST path" $ do
- let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk
- (pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
- (ofString "")
-
- , testCase "parseRequestLine too short" $ do
- let input = "parseRequestLine \"GET\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- , testCase "parseRequestLine no version" $ do
- let input = "parseRequestLine \"GET /foo\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- , testCase "parseRequestLine empty line" $ do
- let input = "parseRequestLine \"\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- , testCase "parseRequestLine rejects extra fields" $ do
- let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- -- parseHeaders
- , testCase "single header line exposes consumed parser failures" $ do
- let check input expected =
- result (evalTricu allTestLibsEnv (parseTricu input)) @?= expected
- check "httpHeaderLineReply \"Host: a:b\""
- (portableReply True
- (pairT (ofString "host") (ofString "a:b")) Leaf True False)
- check "httpHeaderLineReply \"Host\""
- (portableReply False
- (portableDiagnostic (ofNumber 1) (ofString "colon") Leaf Leaf
- (ofList [ofString "header-line"]))
- Leaf True False)
- check "httpHeaderLineReply \": bad\""
- (portableReply False
- (portableDiagnostic (ofNumber 2) (ofString "header-name")
- (ofNumber 58) Leaf (ofList [ofString "header-line"]))
- (ofString ": bad") False False)
- , testCase "headers reject bad syntax and every truncated block prefix" $ do
- let block = "A: b\r\nB: c\r\n\r\n"
- inputs = [take n block | n <- [0 .. length block - 1]] ++
- [ "Bad Name: x\r\n\r\n", "Host : x\r\n\r\n", "\tHost: x\r\n\r\n"
- , "X\r-Name: x\r\n\r\n", "X: a\rb\r\n\r\n", "X: y\n\n"
- , "X: y\r\n\tcontinued\r\n\r\n" ]
- forM_ inputs $ \source ->
- result (evalTricu allTestLibsEnv (parseTricu ("parseHeaders " ++ show source))) @?=
- parserErr (ofNumber 400) (ofString "Bad Request\n")
- , testCase "header values trim SP/HTAB edges but preserve interior whitespace" $ do
- result (evalTricu allTestLibsEnv
- (parseTricu "parseHeaders \"X:\\t a \\t b\\t \\r\\nY:\\t \\r\\n\\r\\nbody\"")) @?=
- parserOk (ofList [pairT (ofString "x") (ofString "a \t b"),
- pairT (ofString "y") Leaf]) (ofString "body")
- , testCase "request-line scanner rejects missing CRLF and embedded CR" $ do
- forM_ ["GET / HTTP/1.1", "GET / HTTP/1.1\n", "GET / HTTP/1.1\r",
- "GE\rT / HTTP/1.1\r\n", "GET /a\rb HTTP/1.1\r\n"] $ \source ->
- result (evalTricu allTestLibsEnv (parseTricu ("parseRequestLine " ++ show source))) @?=
- parserErr (ofNumber 400) (ofString "Bad Request\n")
- , testCase "parseHeaders two headers lowercases names" $ do
- let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk
- (ofList
- [ pairT (ofString "host") (ofString "localhost")
- , pairT (ofString "content-length") (ofString "42")
- ])
- (ofString "x")
-
- , testCase "parseHeaders preserves colon in value" $ do
- let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk
- (ofList [pairT (ofString "x-custom") (ofString "a: b")])
- (ofString "x")
-
- , testCase "parseHeaders accepts empty value" $ do
- let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk
- (ofList [pairT (ofString "x-empty") (ofString "")])
- (ofString "x")
-
- , testCase "parseHeaders immediate blank" $ do
- let input = "parseHeaders \"\\r\\nx\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (ofList []) (ofString "x")
-
- , testCase "parseHeaders rejects missing colon" $ do
- let input = "parseHeaders \"Host\\r\\n\\r\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
-
- , testCase "bounded Content-Length validates syntax even after overflow" $ do
- forM_ ["", "+1", "-2", "1 2", "12x", "x12", "1, 1", "1048577x",
- replicate 128 '9' ++ "x"] $ \source ->
- result (evalTricu allTestLibsEnv (parseTricu ("parseContentLengthValue " ++ show source))) @?=
- parserErr (ofNumber 400) (ofString "Bad Request\n")
- result (evalTricu allTestLibsEnv
- (parseTricu ("parseContentLengthValue " ++ show (replicate 128 '9')))) @?=
- parserErr (ofNumber 413) (ofString "Request body too large\n")
- , testCase "Content-Length selection rejects ambiguity before decoding" $ do
- let check source = result (evalTricu allTestLibsEnv (parseTricu source)) @?=
- parserErr (ofNumber 400) (ofString "Bad Request\n")
- forM_ ["0", "1", "01", "1048577", "x"] $ \first ->
- forM_ ["0", "1", "01", "1048577", "x"] $ \second ->
- check ("contentLength [(pair \"content-length\" " ++ show first ++
- ") (pair \"content-length\" " ++ show second ++ ")]")
- forM_ ["", "chunked", "identity", "gzip"] $ \coding -> do
- let transfer = "(pair \"transfer-encoding\" " ++ show coding ++ ")"
- lengthField = "(pair \"content-length\" \"1048577\")"
- mapM_ check ["contentLength [" ++ transfer ++ "]",
- "contentLength [" ++ transfer ++ " " ++ lengthField ++ "]",
- "contentLength [" ++ lengthField ++ " " ++ transfer ++ "]"]
- , testCase "rejected framing produces a pure error before any body IO" $ do
- forM_ [("[(pair \"transfer-encoding\" \"chunked\")]", 400, "Bad Request\n"),
- ("[(pair \"content-length\" \"1\") (pair \"content-length\" \"1\")]", 400, "Bad Request\n"),
- ("[(pair \"content-length\" \"1048577\")]", 413, "Request body too large\n")] $ \(headers, code, message) ->
- result (evalTricu allTestLibsEnv (parseTricu ("readBody t " ++ headers ++ " \"body\""))) @?=
- pairT (ofNumber 0) (parserErr (ofNumber code) (ofString message))
- , testCase "buffered body selection preserves exact suffix with no socket access" $ do
- forM_ [("[]", "body", "", "body"),
- ("[(pair \"content-length\" \"0\")]", "body", "", "body"),
- ("[(pair \"content-length\" \"3\")]", "abcXYZ", "abc", "XYZ")] $ \(headers, input, body, rest) -> do
- observed <- runIOSourceWithPerms defaultPerms
- ("main = io (readBody t " ++ headers ++ " " ++ show input ++ ")")
- observed @?= parserOk (ofString body) (ofString rest)
- , testCase "parsed Content-Length header validates after framing" $ do
- let check input expected =
- result (evalTricu allTestLibsEnv (parseTricu input)) @?= expected
- check ("matchResult (code msg : err code msg) "
- ++ "(headers rest : contentLength headers) "
- ++ "(parseHeaders \"Content-Length: 42\\r\\n\\r\\nbody\")")
- (parserOk (justT (ofNumber 42)) Leaf)
- check "contentLength [(pair \"content-length\" \"42\") (pair \"content-length\" \"99\")]"
- (parserErr (ofNumber 400) (ofString "Bad Request\n"))
- forM_ ["Content-Length: 1\r\nCONTENT-LENGTH: 1\r\n\r\n",
- "Transfer-Encoding: chunked\r\n\r\n"] $ \raw ->
- check ("bindResult (parseHeaders " ++ show raw ++ ") (headers rest : contentLength headers)")
- (parserErr (ofNumber 400) (ofString "Bad Request\n"))
- check ("bindResult (parseHeaders \"Content-Length:\\t 00042 \\t\\r\\n\\r\\nbody\") " ++
- "(headers rest : contentLength headers)") (parserOk (justT (ofNumber 42)) Leaf)
- , testCase "parseContentLengthValue accepts max body bytes" $ do
- let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "ok"
-
- , testCase "parseContentLengthValue accepts shorter decimal below max" $ do
- let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "ok"
-
- , testCase "parseContentLengthValue strips leading zeros before limit check" $ do
- let input = "parseContentLengthValue \"0000000000001\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserOk (justT (ofNumber 1)) Leaf
-
- , testCase "parseContentLengthValue rejects body above max" $ do
- let input = "parseContentLengthValue \"1048577\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
-
- , testCase "parseContentLengthValue rejects longer body above max" $ do
- let input = "parseContentLengthValue \"2000000\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
-
- -- statusLine / headerLine
- , testCase "statusLine 200 OK" $ do
- let input = "statusLine 200 \"OK\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP/1.1 200 OK\r\n"
-
- , testCase "headerLine Content-Length" $ do
- let input = "headerLine \"Content-Length\" \"42\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Content-Length: 42\r\n"
-
- -- statusPhrase
- , testCase "statusPhrase 200" $ do
- let input = "statusPhrase 200"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "OK"
-
- , testCase "statusPhrase 201" $ do
- let input = "statusPhrase 201"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Created"
-
- , testCase "statusPhrase 204" $ do
- let input = "statusPhrase 204"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "No Content"
-
- , testCase "statusPhrase 400" $ do
- let input = "statusPhrase 400"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Bad Request"
-
- , testCase "statusPhrase 404" $ do
- let input = "statusPhrase 404"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Not Found"
-
- , testCase "statusPhrase 405" $ do
- let input = "statusPhrase 405"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Method Not Allowed"
-
- , testCase "statusPhrase 431" $ do
- let input = "statusPhrase 431"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Request Header Fields Too Large"
-
- , testCase "statusPhrase 501" $ do
- let input = "statusPhrase 501"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Not Implemented"
-
- , testCase "statusPhrase 505" $ do
- let input = "statusPhrase 505"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP Version Not Supported"
-
- , testCase "statusPhrase 500" $ do
- let input = "statusPhrase 500"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Internal Server Error"
-
- , testCase "statusPhrase unknown" $ do
- let input = "statusPhrase 999"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "Internal Server Error"
-
- -- buildResponse
- , testCase "buildResponse 200 no headers" $ do
- let input = "buildResponse 200 [] \"hi\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
-
- , testCase "buildResponse 404 with header" $ do
- let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found"
-
- -- convenience responses
- , testCase "okResponse" $ do
- let input = "okResponse \"hi\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
-
- , testCase "notFoundResponse" $ do
- let input = "notFoundResponse"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
-
- , testCase "textResponse" $ do
- let input = "textResponse \"hi\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
-
- , testCase "jsonResponse" $ do
- let input = "jsonResponse \"{}\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}"
-
- , testCase "createdResponse" $ do
- let input = "createdResponse \"created\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
-
- , testCase "emptyResponse 204" $ do
- let input = "emptyResponse 204"
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
-
- , testCase "badRequestResponse" $ do
- let input = "badRequestResponse \"Bad Request\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
-
- , testCase "errorResponse 405" $ do
- let input = "errorResponse 405 \"Method Not Allowed\\n\""
- env = evalTricu allTestLibsEnv (parseTricu input)
- result env @?= 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"
- ]
-
containsAll :: String -> [String] -> Assertion
containsAll text needles =
forM_ needles $ \needle ->
diff --git a/tricu.cabal b/tricu.cabal
@@ -235,3 +235,5 @@ test-suite tricu-tests
TreeObservation
Wire
SupportFixture
+ LibraryValueTests
+ ReferenceFixtures
