(: Aiche Tee Tee Pee :)
Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell IO runtime... but we're managing all of the actual webserver semantics in tricu! This includes a demo Arboricx application server that is capable of storing and serving bundles.
This commit is contained in:
621
test/Spec.hs
621
test/Spec.hs
@@ -15,7 +15,7 @@ import qualified Network.Socket as NS
|
||||
import Control.Monad (forM_)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import System.IO.Temp (withSystemTempDirectory)
|
||||
import System.Directory (createDirectory)
|
||||
import System.Directory (createDirectory, doesFileExist, doesDirectoryExist)
|
||||
import Data.Bits (xor)
|
||||
import Data.Char (digitToInt)
|
||||
import Data.List (isInfixOf)
|
||||
@@ -57,6 +57,7 @@ tests = testGroup "Tricu Tests"
|
||||
, tricuReaderTests
|
||||
, byteListUtilities
|
||||
, binaryParserTests
|
||||
, httpParsingTests
|
||||
, ioDriverTests
|
||||
]
|
||||
|
||||
@@ -864,15 +865,15 @@ providedLibraries = testGroup "Library Tests"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= ofString "hello world"
|
||||
|
||||
, testCase "strEq? equal strings" $ do
|
||||
, testCase "equal? equal strings" $ do
|
||||
library <- evaluateFile "./lib/list.tri"
|
||||
let input = "strEq? \"abc\" \"abc\""
|
||||
let input = "equal? \"abc\" \"abc\""
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= trueT
|
||||
|
||||
, testCase "strEq? different strings" $ do
|
||||
, testCase "equal? different strings" $ do
|
||||
library <- evaluateFile "./lib/list.tri"
|
||||
let input = "strEq? \"abc\" \"def\""
|
||||
let input = "equal? \"abc\" \"def\""
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= falseT
|
||||
|
||||
@@ -1677,7 +1678,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
|
||||
[ testCase "Tricu reader parses indexed bundle (id fixture)" $ do
|
||||
bundleBytes <- BS.readFile "./test/fixtures/id.arboricx"
|
||||
let bundleT = ofBytes bundleBytes
|
||||
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
||||
readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
|
||||
let env = Map.insert "testBundle" bundleT readerEnv
|
||||
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
||||
tag = result (evalTricu env tagExpr)
|
||||
@@ -1688,7 +1689,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
|
||||
, testCase "Tricu reader parses indexed bundle (append fixture)" $ do
|
||||
bundleBytes <- BS.readFile "./test/fixtures/append.arboricx"
|
||||
let bundleT = ofBytes bundleBytes
|
||||
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
||||
readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
|
||||
let env = Map.insert "testBundle" bundleT readerEnv
|
||||
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
||||
tag = result (evalTricu env tagExpr)
|
||||
@@ -1698,7 +1699,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
|
||||
forM_ ["true", "false"] $ \name -> do
|
||||
bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
|
||||
let bundleT = ofBytes bundleBytes
|
||||
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
||||
readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
|
||||
let env = Map.insert "testBundle" bundleT readerEnv
|
||||
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
||||
tag = result (evalTricu env tagExpr)
|
||||
@@ -1960,13 +1961,13 @@ byteListUtilities = testGroup "Byte List Utility Tests"
|
||||
result env @?= pairT (bytesT [1,2]) (bytesT [])
|
||||
|
||||
, testCase "byteEq: equal bytes are equal" $ do
|
||||
let input = "byteEq? 1 1"
|
||||
let input = "equal? 1 1"
|
||||
library <- evaluateFile "./lib/bytes.tri"
|
||||
let env = evalTricu library (parseTricu input)
|
||||
result env @?= trueT
|
||||
|
||||
, testCase "byteEq: unequal bytes are not equal" $ do
|
||||
let input = "byteEq? 1 2"
|
||||
let input = "equal? 1 2"
|
||||
library <- evaluateFile "./lib/bytes.tri"
|
||||
let env = evalTricu library (parseTricu input)
|
||||
result env @?= falseT
|
||||
@@ -2939,7 +2940,605 @@ ioDriverTests = testGroup "IO driver tests"
|
||||
final @?= ofNumber 99
|
||||
contents <- readFile releasePath
|
||||
contents @?= "released"
|
||||
|
||||
-- Directory and file management primitives
|
||||
, testGroup "listDirectory"
|
||||
[ testCase "listDirectory returns entry names" $
|
||||
withSystemTempDirectory "tricu-listdir" $ \dir -> do
|
||||
writeFile (dir ++ "/a.txt") "a"
|
||||
writeFile (dir ++ "/b.txt") "b"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onListDirectory \"" ++ dir ++ "\""
|
||||
, " (err rest : pure false)"
|
||||
, " (entries rest :"
|
||||
, " pure (pair (lExist? \"a.txt\" entries) (lExist? \"b.txt\" entries))))"
|
||||
]
|
||||
final @?= Fork (Stem Leaf) (Stem Leaf)
|
||||
|
||||
, testCase "listDirectory missing path returns does not exist" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onListDirectory \"/nonexistent/path/12345\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "does not exist"
|
||||
|
||||
, testCase "listDirectory on file returns not a directory" $
|
||||
withSystemTempDirectory "tricu-listdir-file" $ \dir -> do
|
||||
let path = dir ++ "/file.txt"
|
||||
writeFile path "x"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onListDirectory \"" ++ path ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "not a directory"
|
||||
|
||||
, testCase "listDirectory denied path returns permission denied" $
|
||||
withSystemTempDirectory "tricu-listdir-denied" $ \dir -> do
|
||||
let allowedDir = dir ++ "/allowed"
|
||||
deniedDir = dir ++ "/denied"
|
||||
createDirectory allowedDir
|
||||
createDirectory deniedDir
|
||||
let perms = defaultPerms { allowRead = [allowedDir] }
|
||||
final <- runIOSourceWithPerms perms $
|
||||
unlines
|
||||
[ "main = io (listDirectory \"" ++ deniedDir ++ "\")"
|
||||
]
|
||||
final @?= ioErrResult "permission denied"
|
||||
]
|
||||
|
||||
, testCase "listDirectory excludes dot entries" $
|
||||
withSystemTempDirectory "tricu-listdir-dot" $ \dir -> do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onListDirectory \"" ++ dir ++ "\""
|
||||
, " (err rest : pure false)"
|
||||
, " (entries rest :"
|
||||
, " pure (pair (lExist? \".\" entries) (lExist? \"..\" entries))))"
|
||||
]
|
||||
final @?= Fork Leaf Leaf
|
||||
|
||||
, testGroup "renameFile"
|
||||
[ testCase "renameFile moves file atomically" $
|
||||
withSystemTempDirectory "tricu-rename" $ \dir -> do
|
||||
let oldPath = dir ++ "/old.txt"
|
||||
newPath = dir ++ "/new.txt"
|
||||
writeFile oldPath "contents"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
newExists <- doesFileExist newPath
|
||||
oldExists <- doesFileExist oldPath
|
||||
newExists @?= True
|
||||
oldExists @?= False
|
||||
|
||||
, testCase "renameFile missing source returns does not exist" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onRenameFile \"/nonexistent/old.txt\" \"/nonexistent/new.txt\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "does not exist"
|
||||
|
||||
, testCase "renameFile denied destination returns permission denied" $
|
||||
withSystemTempDirectory "tricu-rename-denied" $ \dir -> do
|
||||
let allowedDir = dir ++ "/allowed"
|
||||
deniedDir = dir ++ "/denied"
|
||||
createDirectory allowedDir
|
||||
createDirectory deniedDir
|
||||
let oldPath = allowedDir ++ "/old.txt"
|
||||
newPath = deniedDir ++ "/new.txt"
|
||||
writeFile oldPath "contents"
|
||||
let perms = defaultPerms { allowWrite = [allowedDir] }
|
||||
final <- runIOSourceWithPerms perms $
|
||||
unlines
|
||||
[ "main = io (renameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\")"
|
||||
]
|
||||
final @?= ioErrResult "permission denied"
|
||||
|
||||
, testCase "renameFile replaces existing destination atomically" $
|
||||
withSystemTempDirectory "tricu-rename-replace" $ \dir -> do
|
||||
let oldPath = dir ++ "/old.txt"
|
||||
newPath = dir ++ "/new.txt"
|
||||
writeFile oldPath "new"
|
||||
writeFile newPath "old"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
readFile newPath >>= (@?= "new")
|
||||
oldExists <- doesFileExist oldPath
|
||||
oldExists @?= False
|
||||
]
|
||||
|
||||
, testGroup "createDirectory"
|
||||
[ testCase "createDirectory creates new directory" $
|
||||
withSystemTempDirectory "tricu-mkdir" $ \dir -> do
|
||||
let newDir = dir ++ "/subdir"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCreateDirectory \"" ++ newDir ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
exists <- doesDirectoryExist newDir
|
||||
exists @?= True
|
||||
|
||||
, testCase "createDirectory is idempotent for existing directory" $
|
||||
withSystemTempDirectory "tricu-mkdir-idempotent" $ \dir -> do
|
||||
let existingDir = dir ++ "/exists"
|
||||
createDirectory existingDir
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCreateDirectory \"" ++ existingDir ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
|
||||
, testCase "createDirectory on existing file returns already exists" $
|
||||
withSystemTempDirectory "tricu-mkdir-file" $ \dir -> do
|
||||
let path = dir ++ "/file.txt"
|
||||
writeFile path "x"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCreateDirectory \"" ++ path ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "already exists"
|
||||
|
||||
, testCase "createDirectory missing parent returns does not exist" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCreateDirectory \"/nonexistent/path/12345/sub\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "does not exist"
|
||||
|
||||
, testCase "createDirectory denied path returns permission denied" $
|
||||
withSystemTempDirectory "tricu-mkdir-denied" $ \dir -> do
|
||||
let allowedDir = dir ++ "/allowed"
|
||||
deniedDir = dir ++ "/denied"
|
||||
createDirectory allowedDir
|
||||
createDirectory deniedDir
|
||||
let perms = defaultPerms { allowWrite = [allowedDir] }
|
||||
final <- runIOSourceWithPerms perms $
|
||||
unlines
|
||||
[ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")"
|
||||
]
|
||||
final @?= ioErrResult "permission denied"
|
||||
, testCase "createDirectory with file parent returns not a directory or does not exist" $
|
||||
withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do
|
||||
let parentFile = dir ++ "/file"
|
||||
child = parentFile ++ "/sub"
|
||||
writeFile parentFile "x"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCreateDirectory \"" ++ child ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "not a directory"
|
||||
]
|
||||
|
||||
, testGroup "deleteFile"
|
||||
[ testCase "deleteFile removes file" $
|
||||
withSystemTempDirectory "tricu-delete" $ \dir -> do
|
||||
let path = dir ++ "/del.txt"
|
||||
writeFile path "x"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onDeleteFile \"" ++ path ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
exists <- doesFileExist path
|
||||
exists @?= False
|
||||
|
||||
, testCase "deleteFile is idempotent for missing file" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onDeleteFile \"/nonexistent/path/12345.txt\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "ok"
|
||||
|
||||
, testCase "deleteFile on directory returns is a directory" $
|
||||
withSystemTempDirectory "tricu-delete-dir" $ \dir -> do
|
||||
let subDir = dir ++ "/subdir"
|
||||
createDirectory subDir
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onDeleteFile \"" ++ subDir ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (_ rest : pure \"ok\"))"
|
||||
]
|
||||
final @?= ofString "is a directory"
|
||||
|
||||
, testCase "deleteFile denied path returns permission denied" $
|
||||
withSystemTempDirectory "tricu-delete-denied" $ \dir -> do
|
||||
let allowedDir = dir ++ "/allowed"
|
||||
deniedDir = dir ++ "/denied"
|
||||
createDirectory allowedDir
|
||||
createDirectory deniedDir
|
||||
let path = deniedDir ++ "/file.txt"
|
||||
writeFile path "x"
|
||||
let perms = defaultPerms { allowWrite = [allowedDir] }
|
||||
final <- runIOSourceWithPerms perms $
|
||||
unlines
|
||||
[ "main = io (deleteFile \"" ++ path ++ "\")"
|
||||
]
|
||||
final @?= ioErrResult "permission denied"
|
||||
]
|
||||
|
||||
, testGroup "fileExists"
|
||||
[ testCase "fileExists true for existing file" $
|
||||
withSystemTempDirectory "tricu-exists" $ \dir -> do
|
||||
let path = dir ++ "/file.txt"
|
||||
writeFile path "x"
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onFileExists \"" ++ path ++ "\""
|
||||
, " (err rest : pure err)"
|
||||
, " (exists rest : pure exists))"
|
||||
]
|
||||
final @?= Stem Leaf
|
||||
|
||||
, testCase "fileExists false for missing path" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onFileExists \"/nonexistent/path/12345.txt\""
|
||||
, " (err rest : pure err)"
|
||||
, " (exists rest : pure exists))"
|
||||
]
|
||||
final @?= Leaf
|
||||
|
||||
, testCase "fileExists denied path returns permission denied" $
|
||||
withSystemTempDirectory "tricu-exists-denied" $ \dir -> do
|
||||
let allowedDir = dir ++ "/allowed"
|
||||
deniedDir = dir ++ "/denied"
|
||||
createDirectory allowedDir
|
||||
createDirectory deniedDir
|
||||
let path = deniedDir ++ "/file.txt"
|
||||
writeFile path "x"
|
||||
let perms = defaultPerms { allowRead = [allowedDir] }
|
||||
final <- runIOSourceWithPerms perms $
|
||||
unlines
|
||||
[ "main = io (fileExists \"" ++ path ++ "\")"
|
||||
]
|
||||
final @?= ioErrResult "permission denied"
|
||||
]
|
||||
|
||||
, testGroup "sha256Hex"
|
||||
[ testCase "sha256Hex returns lowercase hex digest" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onSha256Hex [(104) (105)]"
|
||||
, " (err rest : pure err)"
|
||||
, " (hex rest : pure hex))"
|
||||
]
|
||||
final @?= ofString "8f434346648f6b96df89dda901c5176b10a6d83961dd3c1ac88b59b2dc327aa4"
|
||||
|
||||
, testCase "sha256Hex empty bytes returns empty digest" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onSha256Hex []"
|
||||
, " (err rest : pure err)"
|
||||
, " (hex rest : pure hex))"
|
||||
]
|
||||
final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
||||
|
||||
, testCase "sha256Hex hashes raw bytes" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onSha256Hex [(0) (255) (1)]"
|
||||
, " (err rest : pure err)"
|
||||
, " (hex rest : pure hex))"
|
||||
]
|
||||
final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
|
||||
]
|
||||
|
||||
, testGroup "currentTime"
|
||||
[ testCase "currentTime returns a positive integer" $ do
|
||||
final <- runIOSource $
|
||||
unlines
|
||||
[ "main = io (onCurrentTime"
|
||||
, " (err rest : pure 0)"
|
||||
, " (v rest : pure v))"
|
||||
]
|
||||
case toNumber final of
|
||||
Right n | n > 1600000000 -> return () -- after ~Sep 2020
|
||||
Right n -> assertFailure $ "Expected recent timestamp, got: " ++ show n
|
||||
Left err -> assertFailure $ "Expected number, got error: " ++ err
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
httpParsingTests :: TestTree
|
||||
httpParsingTests = testGroup "HTTP Parsing Tests"
|
||||
[
|
||||
-- chomp / request-line reader
|
||||
testCase "chomp strips trailing CR" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "chomp [(104) (105) (13)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= bytesT [104, 105]
|
||||
|
||||
, testCase "chomp leaves line without CR" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "chomp [(104) (105)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= bytesT [104, 105]
|
||||
|
||||
, testCase "chomp empty list" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "chomp []"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= bytesT []
|
||||
|
||||
, testCase "readLineBytes with CRLF" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "readLineBytes [(104) (105) (13) (10) (120)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
|
||||
|
||||
, testCase "readLineBytes with bare LF" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "readLineBytes [(104) (105) (10) (120)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
|
||||
|
||||
, testCase "readLineBytes empty line" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "readLineBytes [(13) (10) (120)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= pairT (bytesT []) (bytesT [120])
|
||||
|
||||
, testCase "readLineBytes EOF mid-line returns line" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "readLineBytes [(104) (105)]"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= pairT (bytesT [104, 105]) (bytesT [])
|
||||
|
||||
-- parseRequestLine
|
||||
, testCase "parseRequestLine GET slash" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserOk
|
||||
(pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
|
||||
(ofString "x")
|
||||
|
||||
, testCase "parseRequestLine POST path" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserOk
|
||||
(pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
|
||||
(ofString "")
|
||||
|
||||
, testCase "parseRequestLine too short" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine \"GET\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
||||
|
||||
, testCase "parseRequestLine no version" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine \"GET /foo\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
||||
|
||||
, testCase "parseRequestLine empty line" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine \"\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
||||
|
||||
, testCase "parseRequestLine rejects extra fields" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
||||
|
||||
-- parseHeaders
|
||||
, testCase "parseHeaders two headers lowercases names" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")"
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserOk
|
||||
(ofList [pairT (ofString "x-custom") (ofString "a: b")])
|
||||
(ofString "x")
|
||||
|
||||
, testCase "parseHeaders accepts empty value" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserOk
|
||||
(ofList [pairT (ofString "x-empty") (ofString "")])
|
||||
(ofString "x")
|
||||
|
||||
, testCase "parseHeaders immediate blank" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseHeaders \"\\r\\nx\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserOk (ofList []) (ofString "x")
|
||||
|
||||
, testCase "parseHeaders rejects missing colon" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "parseHeaders \"Host\\r\\n\\r\\n\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
||||
|
||||
-- statusLine / headerLine
|
||||
, testCase "statusLine 200 OK" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusLine 200 \"OK\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "HTTP/1.1 200 OK\r\n"
|
||||
|
||||
, testCase "headerLine Content-Length" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "headerLine \"Content-Length\" \"42\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Content-Length: 42\r\n"
|
||||
|
||||
-- statusPhrase
|
||||
, testCase "statusPhrase 200" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 200"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "OK"
|
||||
|
||||
, testCase "statusPhrase 201" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 201"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Created"
|
||||
|
||||
, testCase "statusPhrase 204" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 204"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "No Content"
|
||||
|
||||
, testCase "statusPhrase 400" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 400"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Bad Request"
|
||||
|
||||
, testCase "statusPhrase 404" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 404"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Not Found"
|
||||
|
||||
, testCase "statusPhrase 405" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 405"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Method Not Allowed"
|
||||
|
||||
, testCase "statusPhrase 431" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 431"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Request Header Fields Too Large"
|
||||
|
||||
, testCase "statusPhrase 501" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 501"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Not Implemented"
|
||||
|
||||
, testCase "statusPhrase 505" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 505"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "HTTP Version Not Supported"
|
||||
|
||||
, testCase "statusPhrase 500" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 500"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Internal Server Error"
|
||||
|
||||
, testCase "statusPhrase unknown" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "statusPhrase 999"
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "Internal Server Error"
|
||||
|
||||
-- buildResponse
|
||||
, testCase "buildResponse 200 no headers" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "buildResponse 200 [] \"hi\""
|
||||
env = evalTricu lib (parseTricu input)
|
||||
result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
|
||||
|
||||
, testCase "buildResponse 404 with header" $ do
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "okResponse \"hi\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "notFoundResponse"
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "textResponse \"hi\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "jsonResponse \"{}\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "createdResponse \"created\\n\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "emptyResponse 204"
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "badRequestResponse \"Bad Request\\n\""
|
||||
env = evalTricu lib (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
|
||||
lib <- evaluateFile "./lib/http.tri"
|
||||
let input = "errorResponse 405 \"Method Not Allowed\\n\""
|
||||
env = evalTricu lib (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"
|
||||
]
|
||||
|
||||
withFreePort :: (Int -> IO a) -> IO a
|
||||
@@ -2978,4 +3577,4 @@ ioOkResult :: T -> T
|
||||
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
|
||||
|
||||
ioErrResult :: String -> T
|
||||
ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
|
||||
ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
|
||||
Reference in New Issue
Block a user