commit 256bfc928b59d4acf9cb6731e7c2d7f23c9906ea
parent 52c81f51df59e3897e6a8c65478438d376a1f633
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 17:59:57 -0500
Move IO integration tests off the recovery frontend
Diffstat:
5 files changed, 1343 insertions(+), 1297 deletions(-)
diff --git a/docs/validation.md b/docs/validation.md
@@ -161,6 +161,13 @@ 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.
+`test/IODriverTests.hs` uses explicit ABI trees for primitive/scheduler controls
+and portable-compiled programs for library sequencing, state, concurrency and
+socket integration. Its source scope contains only published `io`, `prelude` and
+`socket` interfaces. The shared `ScriptedEffects` interpreter checks exact effect
+order and complete replies without real filesystem/network access; live IO tests
+retain their permission and failure checks.
+
This avoids recompiling libraries on every unit run without silently treating old
executable trees as new source. Compiler conformance wrappers use
`test/PortableTestCompiler.hs`: the retained stable unit compiler receives explicit
diff --git a/test/IODriverTests.hs b/test/IODriverTests.hs
@@ -0,0 +1,1299 @@
+module IODriverTests (ioDriverTests) where
+
+import ScriptedEffects (runScriptedEffects)
+import Data.Text (pack)
+import Data.Text.Encoding (encodeUtf8)
+import Runtime
+import ReferenceFixtures (fixtureExports)
+import PortableTestCompiler (compileFixtureDefinitions)
+import IODriver
+import Control.Exception (bracket)
+import Control.Monad (forM_)
+import Data.IORef
+import Data.List (isInfixOf)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import qualified Network.Socket as NS
+import qualified System.Timeout as Timeout
+import System.Directory (createDirectory, doesFileExist, doesDirectoryExist)
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+ioDriverTests :: TestTree
+ioDriverTests = testGroup "IO driver tests"
+ [ testCase "abortIO terminates before the pending Bind action" $
+ withSystemTempDirectory "tricu-io-abort" $ \dir -> do
+ let output = dir ++ "/after"
+ action = envelope (thenAction (actionT 2 (ofString "stop"))
+ (actionT 21 (Fork (ofString output) (ofString "unexpected"))))
+ outcome <- runIO unsafePerms action
+ outcome @?= Left "execution aborted: stop"
+ exists <- doesFileExist output
+ exists @?= False
+
+ , testCase "child abort terminates an awaiting execution" $ do
+ let source = "main = io (bind (fork (bind yield (_ : abortIO \"child\"))) (h : bind (await h) (_ : pure \"unexpected\")))"
+ action <- compileIO source
+ outcome <- Timeout.timeout 2000000 (runIO unsafePerms action)
+ outcome @?= Just (Left "execution aborted: child")
+
+ , testCase "yield observation preserves result and explicit state" $ do
+ count <- newIORef (0 :: Int)
+ let action = envelope (thenAction (actionT 41 (ofNumber 7))
+ (thenAction (actionT 62 Leaf) (thenAction (actionT 62 Leaf) (actionT 0 (ofNumber 9)))))
+ observed <- runIOWithYieldHook (modifyIORef' count (+ 1)) unsafePerms Leaf Leaf action
+ ordinary <- runIOWith unsafePerms Leaf Leaf action
+ observed @?= ordinary
+ observed @?= Right (ofNumber 9, ofNumber 7)
+ readIORef count >>= (@?= 2)
+ samples <- newIORef []
+ profiled <- runIOWithYieldStatsHook (\sample -> modifyIORef' samples (sample :))
+ unsafePerms Leaf Leaf action
+ profiled @?= ordinary
+ readIORef samples >>= (@?= [YieldStats 1 0 1, YieldStats 1 0 1])
+
+ , testCase "application Result keeps structured errors as data" $ do
+ let value = Fork Leaf (Fork (ofString "application-error") Leaf)
+ action = envelope (actionT 0 value)
+ runIO unsafePerms action >>= (@?= Right value)
+
+ , testCase "readFile through onReadFile returns file contents" $
+ withSystemTempDirectory "tricu-io-read" $ \dir -> do
+ let sourcePath = dir ++ "/input.txt"
+ writeFile sourcePath "abc123"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
+ , " (err rest : pure \"read failed\")"
+ , " (contents rest : pure contents))"
+ ]
+ final @?= ofString "abc123"
+
+ , testCase "readFile error path returns explicit error branch" $
+ withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do
+ let sourcePath = dir ++ "/missing.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
+ , " (err rest : pure \"read failed\")"
+ , " (contents rest : pure contents))"
+ ]
+ final @?= ofString "read failed"
+
+ , testCase "chains multiple readFile actions through Result-aware helper" $
+ withSystemTempDirectory "tricu-io-chain" $ \dir -> do
+ let firstPath = dir ++ "/first.txt"
+ secondPath = dir ++ "/second.txt"
+ writeFile firstPath "abc"
+ writeFile secondPath "def"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ firstPath ++ "\""
+ , " (err rest : pure \"first read failed\")"
+ , " (first rest : onReadFile \"" ++ secondPath ++ "\""
+ , " (err rest : pure \"second read failed\")"
+ , " (second rest : pure (append first second))))"
+ ]
+ final @?= ofString "abcdef"
+
+ -- Monad law tests
+ , testCase "left identity: bind (pure x) f == f x" $ do
+ left <- runIOSource $
+ unlines
+ [ "f = x : pure (append x \"!\")"
+ , "main = io (bind (pure \"abc\") f)"
+ ]
+ right <- runIOSource $
+ unlines
+ [ "f = x : pure (append x \"!\")"
+ , "main = io (f \"abc\")"
+ ]
+ left @?= right
+ left @?= ofString "abc!"
+
+ , testCase "right identity: bind m pure == m" $
+ withSystemTempDirectory "tricu-io-right-id" $ \dir -> do
+ let path = dir ++ "/input.txt"
+ writeFile path "abc"
+ left <- runIOSource $
+ unlines
+ [ "main = io (bind (readFile \"" ++ path ++ "\")"
+ , " (result : pure result))"
+ ]
+ right <- runAction (actionT 20 (ofString path))
+ left @?= right
+ left @?= ioOkResult (ofString "abc")
+
+ , testCase "associativity: bind (bind m f) g == bind m (x : bind (f x) g)" $
+ withSystemTempDirectory "tricu-io-assoc" $ \dir -> do
+ let path = dir ++ "/input.txt"
+ writeFile path "abc"
+ left <- runIOSource $
+ unlines
+ [ "m = readFile \"" ++ path ++ "\""
+ , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
+ , "g = value : pure (append value \"-g\")"
+ , "main = io (bind (bind m f) g)"
+ ]
+ right <- runIOSource $
+ unlines
+ [ "m = readFile \"" ++ path ++ "\""
+ , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
+ , "g = value : pure (append value \"-g\")"
+ , "main = io (bind m (x : bind (f x) g))"
+ ]
+ left @?= right
+ left @?= ofString "abc-f-g"
+
+ , testCase "associativity preserves error flow" $
+ withSystemTempDirectory "tricu-io-assoc-err" $ \dir -> do
+ let missingPath = dir ++ "/missing.txt"
+ left <- runIOSource $
+ unlines
+ [ "m = readFile \"" ++ missingPath ++ "\""
+ , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
+ , "g = value : pure (append value \"-g\")"
+ , "main = io (bind (bind m f) g)"
+ ]
+ right <- runIOSource $
+ unlines
+ [ "m = readFile \"" ++ missingPath ++ "\""
+ , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
+ , "g = value : pure (append value \"-g\")"
+ , "main = io (bind m (x : bind (f x) g))"
+ ]
+ left @?= right
+ left @?= ofString "handled-g"
+
+ , testCase "bind defers continuation until left action completes" $
+ withSystemTempDirectory "tricu-io-lazy-k" $ \dir -> do
+ let path = dir ++ "/created.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bind (writeFile \"" ++ path ++ "\" \"created\")"
+ , " (_ : readFile \"" ++ path ++ "\"))"
+ ]
+ final @?= ioOkResult (ofString "created")
+
+ -- Primitive effect shape tests
+ , testCase "readFile without continuation returns Result" $
+ withSystemTempDirectory "tricu-io-raw-read" $ \dir -> do
+ let path = dir ++ "/input.txt"
+ writeFile path "abc"
+ final <- runAction (actionT 20 (ofString path))
+ final @?= ioOkResult (ofString "abc")
+
+ , testCase "writeFile then readFile executes exactly once" $
+ withSystemTempDirectory "tricu-io-once" $ \dir -> do
+ let path = dir ++ "/test.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bind (writeFile \"" ++ path ++ "\" \"abc\")"
+ , " (_ : readFile \"" ++ path ++ "\"))"
+ ]
+ final @?= ioOkResult (ofString "abc")
+
+ , testCase "sequencing order is left-to-right" $
+ withSystemTempDirectory "tricu-io-order" $ \dir -> do
+ let path = dir ++ "/test.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bind (writeFile \"" ++ path ++ "\" \"a\")"
+ , " (_ : bind (writeFile \"" ++ path ++ "\" \"ab\")"
+ , " (_ : readFile \"" ++ path ++ "\")))"
+ ]
+ final @?= ioOkResult (ofString "ab")
+
+ , testCase "thenIO sequences two actions and discards first result" $
+ withSystemTempDirectory "tricu-io-then" $ \dir -> do
+ let path = dir ++ "/test.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (thenIO (writeFile \"" ++ path ++ "\" \"x\")"
+ , " (readFile \"" ++ path ++ "\"))"
+ ]
+ final @?= ioOkResult (ofString "x")
+
+ , testCase "bind does not short-circuit on readFile error" $
+ withSystemTempDirectory "tricu-io-no-short" $ \dir -> do
+ let path = dir ++ "/missing.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bind (readFile \"" ++ path ++ "\")"
+ , " (result : pure \"continued\"))"
+ ]
+ final @?= ofString "continued"
+
+ , testCase "mapIO transforms pure value" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (mapIO (pure \"abc\") (x : append x \"!\"))"
+ ]
+ final @?= ofString "abc!"
+
+ -- Malformed action tests
+ , testCase "unknown IO action tag returns err result" $ do
+ final <- runAction (actionT 99 Leaf)
+ final @?= ioErrResult "invalid action"
+
+ , testCase "malformed Bind returns err result" $ do
+ final <- runAction (actionT 1 Leaf)
+ final @?= ioErrResult "invalid action"
+
+ , testCase "malformed ReadFile payload returns err result" $ do
+ final <- runAction (actionT 20 (Stem Leaf))
+ final @?= ioErrResult "invalid string"
+
+ -- Permission tests
+ , testCase "allowed read path succeeds" $
+ withSystemTempDirectory "tricu-io-allowed" $ \dir -> do
+ let path = dir ++ "/allowed.txt"
+ writeFile path "allowed"
+ let perms = defaultPerms { allowRead = [path] }
+ result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString path))
+ result @?= ioOkResult (ofString "allowed")
+
+ , testCase "readFile denied path returns err result" $
+ withSystemTempDirectory "tricu-io-read-denied" $ \dir -> do
+ let allowedPath = dir ++ "/allowed.txt"
+ deniedPath = dir ++ "/denied.txt"
+ writeFile allowedPath "allowed"
+ writeFile deniedPath "denied"
+ let perms = defaultPerms { allowRead = [allowedPath] }
+ result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString deniedPath))
+ result @?= ioErrResult "permission denied"
+
+ , testCase "writeFile denied path returns err result" $
+ withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do
+ let allowedPath = dir ++ "/allowed.txt"
+ deniedPath = dir ++ "/denied.txt"
+ let perms = defaultPerms { allowWrite = [allowedPath] }
+ result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 21 (Fork (ofString deniedPath) (ofString "x")))
+ result @?= ioErrResult "permission denied"
+
+ , testCase "path prefix does not allow prefix bypass" $
+ withSystemTempDirectory "tricu-io-prefix" $ \dir -> do
+ let allowedDir = dir ++ "/foo"
+ bypassPath = dir ++ "/foobar/secret.txt"
+ createDirectory allowedDir
+ createDirectory (dir ++ "/foobar")
+ writeFile bypassPath "secret"
+ let perms = defaultPerms { allowRead = [allowedDir] }
+ result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString bypassPath))
+ result @?= ioErrResult "permission denied"
+
+ -- Pure test
+ , testCase "pure performs no effects" $ do
+ final <- runAction (actionT 0 (ofString "abc"))
+ final @?= ofString "abc"
+
+ -- Reader tests
+ , testCase "ask returns initial environment" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "dev") $
+ unlines
+ [ "main = io (bind ask (env : pure env))"
+ ]
+ final @?= ofString "dev"
+
+ , testCase "local transforms environment" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (local (env : append env \"-local\") (bind ask (env : pure env)))"
+ ]
+ final @?= ofString "root-local"
+
+ , testCase "local restores environment afterward" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (bind ask (before :"
+ , " bind (local (env : append env \"-local\") (bind ask (env : pure env))) (inside :"
+ , " bind ask (after :"
+ , " pure (pair before (pair inside after))))))"
+ ]
+ final @?= Fork (ofString "root") (Fork (ofString "root-local") (ofString "root"))
+
+ , testCase "nested local composes correctly" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "f = x : append x \"-f\""
+ , "g = x : append x \"-g\""
+ , "main = io (bind"
+ , " (local f (local g (bind ask (env : pure env))))"
+ , " (inner :"
+ , " bind ask (after :"
+ , " pure (pair inner after))))"
+ ]
+ final @?= Fork (ofString "root-f-g") (ofString "root")
+
+ , testCase "local result passes through bind correctly" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (bind"
+ , " (local (env : append env \"-local\") (pure \"value\"))"
+ , " (x : pure x))"
+ ]
+ final @?= ofString "value"
+
+ , testCase "IO inside local uses transformed environment and restores after" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (bind"
+ , " (local (env : append env \"-local\")"
+ , " (bind ask (env : pure env)))"
+ , " (result :"
+ , " bind ask (after :"
+ , " pure (pair result after))))"
+ ]
+ final @?= Fork (ofString "root-local") (ofString "root")
+
+ , testCase "local does not affect outer bind continuation" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (bind"
+ , " (local (env : append env \"-local\") (pure \"x\"))"
+ , " (_ : bind ask (env : pure env)))"
+ ]
+ final @?= ofString "root"
+
+ , testCase "local environment persists across inner binds" $ do
+ final <- runIOSourceWithEnv unsafePerms (ofString "root") $
+ unlines
+ [ "main = io (local (env : append env \"-local\")"
+ , " (bind (pure t) (_ :"
+ , " bind ask (env : pure env))))"
+ ]
+ final @?= ofString "root-local"
+
+ , testCase "local restores environment when scoped action returns error value" $ do
+ final <- runIOSourceWithEnv defaultPerms (ofString "root") $
+ unlines
+ [ "main = io (bind"
+ , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))"
+ , " (_ : bind ask (env : pure env)))"
+ ]
+ final @?= ofString "root"
+
+ -- State tests
+ , testCase "get returns initial state" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 42) $
+ unlines
+ [ "main = io (bind get (s : pure s))"
+ ]
+ final @?= ofNumber 42
+ st @?= ofNumber 42
+
+ , testCase "put updates state" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
+ unlines
+ [ "main = io (bind (put 100) (_ : bind get (s : pure s)))"
+ ]
+ final @?= ofNumber 100
+ st @?= ofNumber 100
+
+ , testCase "state persists through bind" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 5) $
+ unlines
+ [ "main = io (bind get (s1 :"
+ , " bind (put (succ s1)) (_ :"
+ , " bind get (s2 :"
+ , " pure (pair s1 s2)))))"
+ ]
+ final @?= Fork (ofNumber 5) (ofNumber 6)
+ st @?= ofNumber 6
+
+ , testCase "local does not restore state" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
+ unlines
+ [ "main = io (bind (put 10) (_ :"
+ , " bind (local (env : env) (put 20)) (_ :"
+ , " bind get (s :"
+ , " pure s))))"
+ ]
+ final @?= ofNumber 20
+ st @?= ofNumber 20
+
+ , testCase "state and reader are independent" $ do
+ (final, st) <- runIOSourceWith unsafePerms (ofString "hello") (ofNumber 42) $
+ unlines
+ [ "main = io (bind ask (env :"
+ , " bind get (s :"
+ , " pure (pair env s))))"
+ ]
+ final @?= Fork (ofString "hello") (ofNumber 42)
+ st @?= ofNumber 42
+
+ -- Async tests
+ , testCase "fork returns handle and await returns child value" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (pure \"child\")) (h :"
+ , " await h))"
+ ]
+ final @?= ofString "child"
+ st @?= Leaf
+
+ , testCase "main completion abandons unawaited child" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (pure \"child\")) (_ :"
+ , " pure \"main\"))"
+ ]
+ final @?= ofString "main"
+
+ , testCase "fork captures reader environment at fork point" $ do
+ (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
+ unlines
+ [ "main = io (local (env : append env \"-local\")"
+ , " (bind (fork (bind ask (env : pure env))) (h :"
+ , " await h)))"
+ ]
+ final @?= ofString "root-local"
+
+ , testCase "fork inside local captures child env and parent restores env" $ do
+ (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
+ unlines
+ [ "main = io (bind"
+ , " (local (env : append env \"-local\")"
+ , " (fork (bind ask (env : pure env))))"
+ , " (h : bind ask (after :"
+ , " bind (await h) (child :"
+ , " pure (pair after child)))))"
+ ]
+ final @?= Fork (ofString "root") (ofString "root-local")
+
+ , testCase "fork copies state and child state does not merge" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
+ unlines
+ [ "main = io (bind (put 1) (_ :"
+ , " bind (fork (bind (put 99) (_ : bind get (s : pure s)))) (h :"
+ , " bind (put 2) (_ :"
+ , " bind (await h) (childState :"
+ , " bind get (parentState :"
+ , " pure (pair childState parentState)))))))"
+ ]
+ final @?= Fork (ofNumber 99) (ofNumber 2)
+ st @?= ofNumber 2
+
+ , testCase "multiple awaiters receive same completed value" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (pure \"done\")) (h :"
+ , " bind (await h) (a :"
+ , " bind (await h) (b :"
+ , " pure (pair a b)))))"
+ ]
+ final @?= Fork (ofString "done") (ofString "done")
+
+ , testCase "self await returns async error" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (await (pair \"task\" 0))"
+ ]
+ final @?= ioErrResult "self await"
+
+ , testCase "await invalid handle returns async error" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (await 123)"
+ ]
+ final @?= ioErrResult "invalid task handle"
+
+ , testCase "yield returns unit and resumes continuation" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind yield (_ : pure \"after\"))"
+ ]
+ final @?= ofString "after"
+
+ , testCase "sleep resumes continuation" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
+ ]
+ final @?= ofString "awake"
+
+ , testCase "await waits for sleeping child" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"awake\"))) (h :"
+ , " await h))"
+ ]
+ final @?= ofString "awake"
+
+ , testCase "await waits for sleeping child and returns child value" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :"
+ , " await h))"
+ ]
+ final @?= ofString "child done"
+ st @?= Leaf
+
+ , testCase "sleep inside bind resumes as unit" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
+ ]
+ final @?= ofString "awake"
+ st @?= Leaf
+
+ , testCase "fork await returns child value" $ do
+ (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (pure \"child done\")) (h :"
+ , " await h))"
+ ]
+ final @?= ofString "child done"
+ st @?= Leaf
+
+ -- Scheduler hardening tests
+ , testCase "runIO rejects non-IO tree with sentinel error" $ do
+ result <- runIO unsafePerms (ofString "not an io program")
+ case result of
+ Left _ -> return ()
+ Right _ -> assertFailure "Expected Left for invalid sentinel"
+
+ , testCase "cyclic await returns error instead of hanging" $ do
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "main = io (bind (fork (await (pair \"task\" 0))) (h :"
+ , " await h))"
+ ]
+ final @?= ioErrResult "cyclic await"
+
+ , testCase "source file UTF-8 returns exact bytes and scalar characters" $
+ withSystemTempDirectory "tricu-source-utf8" $ \dir -> do
+ let path = dir ++ "/source.tri"
+ samples = ["main = 42\n", "-- \233\8364\128512\nmain = \"\233\8364\128512\"\n",
+ "-- embedded \xfeff and decomposed e\x301\r\n",
+ "\0\x80\x7ff\x800\xd7ff\xe000\xffff\x10000\x10ffff"]
+ forM_ samples $ \text -> do
+ let bytes = encodeUtf8 (pack text)
+ BS.writeFile path bytes
+ let action = Fork (ofNumber 37) (ofString path)
+ program = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
+ actual <- runIO unsafePerms program
+ actual @?= Right (ioOkResult (Fork (ofBytes bytes) (ofString text)))
+ binary <- runIO unsafePerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 20) (ofString path))))
+ binary @?= Right (ioOkResult (ofBytes bytes))
+ encoded <- runIO unsafePerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) (ofString text))))
+ encoded @?= Right (ioOkResult (ofBytes bytes))
+
+ , testCase "source UTF-8 rejects malformed sequences and initial BOM" $
+ withSystemTempDirectory "tricu-source-invalid" $ \dir -> do
+ let path = dir ++ "/bad.tri"
+ malformed = [[0x80], [0xc0,0xaf], [0xc1,0xbf], [0xc2], [0xe2,0x82],
+ [0xf0,0x9f,0x98], [0xe0,0x80,0xaf], [0xed,0xa0,0x80],
+ [0xf0,0x80,0x80,0xaf], [0xf4,0x90,0x80,0x80],
+ [0xf5,0x80,0x80,0x80], [0xff], [0xc2,0x41], [0xef,0xbb,0xbf]]
+ forM_ malformed $ \bytes -> do
+ BS.writeFile path (BS.pack bytes)
+ actual <- runIO unsafePerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString path))))
+ case actual of
+ Right (Fork Leaf (Fork diagnostic Leaf)) -> case toString diagnostic of
+ Right message -> do
+ assertBool "source path in diagnostic" (path `isInfixOf` message)
+ assertBool "UTF-8 diagnostic" ("UTF-8" `isInfixOf` message)
+ _ -> assertFailure "non-string diagnostic"
+ _ -> assertFailure ("accepted malformed source: " ++ show bytes)
+
+ , testCase "source read permission and scalar encoding controls" $ do
+ denied <- runIO defaultPerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString "denied.tri"))))
+ case denied of
+ Right (Fork Leaf _) -> pure ()
+ _ -> assertFailure "source read bypassed permission"
+ forM_ [0xd800, 0xdfff, 0x110000] $ \scalar -> do
+ actual <- runIO unsafePerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1)
+ (Fork (ofNumber 38) (ofList [ofNumber scalar]))))
+ actual @?= Right (ioErrResult "invalid source scalar list")
+
+ , testCase "source encoder rejects improper lists and noncanonical scalar naturals" $ do
+ forM_ [Stem Leaf, Fork (ofNumber 65) (Stem Leaf),
+ ofList [Fork Leaf Leaf], ofList [Fork (Stem Leaf) (Fork Leaf Leaf)]] $ \value -> do
+ actual <- runIO unsafePerms
+ (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) value)))
+ actual @?= Right (ioErrResult "invalid source scalar list")
+
+ , testCase "writeBytes and readFile roundtrip binary data" $
+ withSystemTempDirectory "tricu-io-bytes" $ \dir -> do
+ let path = dir ++ "/binary.bin"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bind (writeBytes \"" ++ path ++ "\" [(0) (255) (128) (1)])"
+ , " (_ : readFile \"" ++ path ++ "\"))"
+ ]
+ final @?= ioOkResult (ofBytes (BS.pack [0, 255, 128, 1]))
+
+ , testCase "stress test: many concurrent sleepers complete promptly" $ do
+ let n = 5000
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "spawner = y (self n acc : if (equal? n 0) (pure acc) (bind (fork (sleep 1)) (h : self (pred n) (pair h acc))))"
+ , "awaitAll = y (self hs : matchList (pure \"done\") (h r : bind (await h) (_ : self r)) hs)"
+ , "main = io (bind (spawner " ++ show n ++ " t) (hs : awaitAll hs))"
+ ]
+ final @?= ofString "done"
+
+ , testCase "long fork await loop does not leak" $ do
+ let awaited = actionT 1 (Fork (actionT 60 (actionT 0 (ofString "x")))
+ (fixtureExports "io" Map.! "await"))
+ action = foldr (\_ next -> thenAction awaited next) (actionT 0 (ofString "done")) [1..200 :: Int]
+ (final, _) <- runActionWith unsafePerms Leaf Leaf action
+ final @?= ofString "done"
+
+ , testGroup "Socket primitives"
+ [ testCase "socket returns ok result with valid handle" $ do
+ final <- runIOSource "main = io socket"
+ final @?= ioOkResult (Fork (ofString "sock") (ofNumber 0))
+
+ , testCase "closeSocket on invalid handle returns error" $ do
+ final <- runIOSource "main = io (closeSocket (pair \"sock\" 99999))"
+ final @?= ioErrResult "invalid socket handle"
+
+ , testCase "bindSocket and listen succeed on loopback port 0" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
+ , " bind (listen server 1) (listenResult :"
+ , " pure listenResult))))"
+ ]
+ final @?= ioOkResult Leaf
+
+ , testCase "connect to non-listening port returns error" $ do
+ final <- runIOSource "main = io (onOk socket (sock rest : connect sock \"127.0.0.1\" 1))"
+ case final of
+ Fork Leaf (Fork _ Leaf) -> return ()
+ other -> assertFailure $ "Expected error result, got: " ++ show other
+
+ , testCase "accept and recv receive bytes from forked client" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "client = port :"
+ , " onOk socket (sock rest :"
+ , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
+ , " send sock [104 105]))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (client " ++ show port ++ ")) (_ :"
+ , " onOk (accept server) (accepted rest :"
+ , " recv (fst accepted) 2))))))"
+ ]
+ final @?= ioOkResult (ofBytes (BS.pack [104, 105]))
+
+ , testCase "client recv receives server response via accepted socket" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "serverTask = (server :"
+ , " onOk (accept server) (accepted rest :"
+ , " onOk (recv (fst accepted) 4) (msg rest :"
+ , " send (fst accepted) [112 111 110 103])))"
+ , ""
+ , "clientTask = (port :"
+ , " onOk socket (sock rest :"
+ , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
+ , " bind (send sock [112 105 110 103]) (_ :"
+ , " recv sock 4))))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (serverTask server)) (_ :"
+ , " clientTask " ++ show port ++ ")))))"
+ ]
+ final @?= ioOkResult (ofBytes (BS.pack [112, 111, 110, 103]))
+
+ , testCase "recv on closed peer returns connection closed" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "clientTask = port :"
+ , " onOk socket (sock rest :"
+ , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
+ , " closeSocket sock))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
+ , " onOk (accept server) (accepted rest :"
+ , " bind (yield) (_ :"
+ , " recv (fst accepted) 1)))))))"
+ ]
+ final @?= ioErrResult "connection closed"
+
+ , testCase "accept invalid socket handle returns error" $ do
+ final <- runIOSource "main = io (accept (pair \"sock\" 99999))"
+ final @?= ioErrResult "invalid socket handle"
+
+ , testCase "recv invalid socket handle returns error" $ do
+ final <- runIOSource "main = io (recv (pair \"sock\" 99999) 1)"
+ final @?= ioErrResult "invalid socket handle"
+
+ , testCase "send invalid socket handle returns error" $ do
+ final <- runIOSource "main = io (send (pair \"sock\" 99999) [(1)])"
+ final @?= ioErrResult "invalid socket handle"
+
+ , testCase "socket conveniences close acquired handles on failures and preserve replies" $ do
+ let env = fixtureExports "socket"
+ let call name = foldl apply (env Map.! name)
+ sock = ofNumber 7
+ primitive tag payload = Fork (ofNumber tag) payload
+ create = primitive 70 Leaf
+ close = primitive 71 sock
+ address = ofString "127.0.0.1"
+ port = ofNumber 9050
+ bound = primitive 72 (Fork sock (Fork address port))
+ listening = primitive 73 (Fork sock (ofNumber 128))
+ connected = primitive 75 (Fork sock (Fork address port))
+ acquired = parserOk sock (ofNumber 23)
+ ready = parserOk (ofNumber 19) (ofNumber 29)
+ failed = parserErr (ofString "denied") (ofString "opaque remainder")
+ closeFailed = parserErr (ofString "close failed") (ofNumber 41)
+ listener = call "listenSocket" [address, port, ofNumber 128]
+ client = call "connectTo" [address, port]
+ forM_ [listener, client] $ \action ->
+ runScriptedEffects action [(create, failed)] >>= (@?= failed)
+ runScriptedEffects listener [(create, acquired), (bound, ready), (listening, ready)]
+ >>= (@?= parserOk sock Leaf)
+ runScriptedEffects client [(create, acquired), (connected, ready)]
+ >>= (@?= parserOk sock (ofNumber 29))
+ forM_ [ready, closeFailed] $ \closed -> do
+ runScriptedEffects listener [(create, acquired), (bound, failed), (close, closed)]
+ >>= (@?= failed)
+ runScriptedEffects listener [(create, acquired), (bound, ready), (listening, failed), (close, closed)]
+ >>= (@?= failed)
+ runScriptedEffects client [(create, acquired), (connected, failed), (close, closed)]
+ >>= (@?= failed)
+
+ , testCase "listenSocket creates a live listener whose ownership transfers to the caller" $ do
+ final <- runIOSource "main = io (onOk_ (listenSocket \"127.0.0.1\" 0 1) (server : finally (getSocketName server) (closeSocket_ server)))"
+ case final of
+ Fork (Stem Leaf) (Fork value Leaf) -> case toNumber value of
+ Right port -> assertBool "positive bound port" (port > 0)
+ Left problem -> assertFailure problem
+ other -> assertFailure $ "expected bound port: " ++ show other
+
+ , testCase "getSocketName returns positive port after bind 0" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
+ , " bind (getSocketName server) (nameResult :"
+ , " pure nameResult))))"
+ ]
+ case final of
+ Fork (Stem Leaf) (Fork val Leaf) ->
+ case toNumber val of
+ Right port | port > 0 -> return ()
+ Right 0 -> assertFailure "Expected positive port, got 0"
+ Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val
+ other -> assertFailure $ "Expected ok result, got: " ++ show other
+
+ , testCase "connectTo creates connected socket" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "clientTask = port :"
+ , " onOk (connectTo \"127.0.0.1\" port) (client rest :"
+ , " onOk (send client [104 105]) (_ rest :"
+ , " pure t))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
+ , " onOk (accept server) (accepted rest :"
+ , " onOk (recv (fst accepted) 2) (msg rest :"
+ , " pure msg)))))))"
+ ]
+ final @?= ofBytes (BS.pack [104, 105])
+
+ , testCase "serveOnce handles a single client connection" $
+ withFreePort $ \port -> do
+ final <- runIOSource $
+ unlines
+ [ "echoHandler = (client peer :"
+ , " onOk (recv client 2) (msg rest :"
+ , " onOk (send client msg) (_ rest :"
+ , " pure t)))"
+ , ""
+ , "clientTask = (port :"
+ , " onOk socket (sock rest :"
+ , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
+ , " onOk (send sock [104 105]) (_ rest :"
+ , " onOk (recv sock 2) (msg rest :"
+ , " pure msg)))))"
+ , ""
+ , "main = io ("
+ , " onOk socket (server rest :"
+ , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
+ , " onOk (listen server 1) (_ rest :"
+ , " bind (fork (serveOnce server echoHandler)) (_ :"
+ , " clientTask " ++ show port ++ ")))))"
+ ]
+ final @?= ofBytes (BS.pack [104, 105])
+
+ , testCase "finally preserves successful action result" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (finally (pure 42) (pure 99))"
+ ]
+ final @?= ofNumber 42
+
+ , testCase "finally runs cleanup after successful action" $
+ withSystemTempDirectory "tricu-finally" $ \dir -> do
+ let cleanupPath = dir ++ "/cleanup.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (finally"
+ , " (pure 42)"
+ , " (writeFile \"" ++ cleanupPath ++ "\" \"cleaned\"))"
+ ]
+ final @?= ofNumber 42
+ contents <- readFile cleanupPath
+ contents @?= "cleaned"
+
+ , testCase "bracket passes acquired resource to use" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (bracket (pure (ok 41 7)) (_ : pure t) (r : pure (succ r)))"
+ ]
+ final @?= ofNumber 42
+
+ , testCase "bracket preserves successful use result over release result" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (bracket (pure (ok \"res\" 7)) (_ : pure 123) (_ : pure 99))"
+ ]
+ final @?= ofNumber 99
+
+ , testCase "bracket runs release on successful use" $
+ withSystemTempDirectory "tricu-bracket" $ \dir -> do
+ let releasePath = dir ++ "/release.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bracket"
+ , " (pure (ok \"" ++ releasePath ++ "\" 7))"
+ , " (path : writeFile path \"released\")"
+ , " (path : pure 99))"
+ ]
+ final @?= ofNumber 99
+ contents <- readFile releasePath
+ contents @?= "released"
+
+ , testCase "bracket passes acquired resource to release" $
+ withSystemTempDirectory "tricu-bracket-release-resource" $ \dir -> do
+ let releasePath = dir ++ "/release.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (bracket"
+ , " (pure (ok \"" ++ releasePath ++ "\" 7))"
+ , " (path : writeFile path \"released\")"
+ , " (_ : pure 99))"
+ ]
+ 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 <- fmap fst $ runActionWith perms Leaf Leaf (actionT 26 (ofString 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 <- fmap fst $ runActionWith perms Leaf Leaf (actionT 27 (ofString 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
+ ]
+ ]
+ ]
+
+withFreePort :: (Int -> IO a) -> IO a
+withFreePort action =
+ bracket
+ (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol)
+ NS.close
+ (\s -> do
+ NS.setSocketOption s NS.ReuseAddr 1
+ NS.bind s (NS.SockAddrInet 0 (NS.tupleToHostAddress (127, 0, 0, 1)))
+ port <- NS.socketPort s
+ action (fromIntegral port))
+
+-- Explicit IO/prelude/socket interfaces only; the retained portable compiler
+-- owns source sequencing. No ambient imports, recovery kernel or source loader.
+compileIO :: String -> IO T
+compileIO source = do
+ env <- compileFixtureDefinitions (Map.unions (map fixtureExports ["io", "prelude", "socket"])) source
+ maybe (assertFailure "IO program has no main" >> pure Leaf) pure (Map.lookup "main" env)
+
+runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T)
+runIOSourceWith perms readerEnv initialState source = do
+ fullTree <- compileIO source
+ runEnvelopeWith perms readerEnv initialState fullTree
+
+-- Direct ABI construction is independent of the library/compiler under test.
+actionT :: Integer -> T -> T
+actionT tag = Fork (ofNumber tag)
+envelope :: T -> T
+envelope action = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
+thenAction :: T -> T -> T
+thenAction left right = actionT 1 (Fork left (Fork Leaf right))
+
+runEnvelopeWith :: IOPermissions -> T -> T -> T -> IO (T, T)
+runEnvelopeWith perms readerEnv initialState fullTree = do
+ result <- runIOWith perms readerEnv initialState fullTree
+ case result of
+ Left err -> assertFailure ("IO runtime error: " ++ err)
+ Right pair -> pure pair
+
+runActionWith :: IOPermissions -> T -> T -> T -> IO (T, T)
+runActionWith perms readerEnv initialState = runEnvelopeWith perms readerEnv initialState . envelope
+runAction :: T -> IO T
+runAction = fmap fst . runActionWith unsafePerms Leaf Leaf
+
+runIOSource :: String -> IO T
+runIOSource source = fmap fst $ runIOSourceWith unsafePerms Leaf Leaf source
+
+runIOSourceWithPerms :: IOPermissions -> String -> IO T
+runIOSourceWithPerms perms source = fmap fst $ runIOSourceWith perms Leaf Leaf source
+
+runIOSourceWithEnv :: IOPermissions -> T -> String -> IO T
+runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms readerEnv Leaf source
+
+ioOkResult :: T -> T
+ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
+
+ioErrResult :: String -> T
+ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
+
+parserOk, parserErr :: T -> T -> T
+parserOk value rest = Fork (Stem Leaf) (Fork value rest)
+parserErr diagnostic rest = Fork Leaf (Fork diagnostic rest)
diff --git a/test/ScriptedEffects.hs b/test/ScriptedEffects.hs
@@ -0,0 +1,28 @@
+module ScriptedEffects (runScriptedEffects) where
+
+import Runtime
+import Test.Tasty.HUnit
+
+-- Small independent host interpreter for authenticated HTTP/registry actions.
+-- Never opens a socket. Every primitive must match its complete expected action;
+-- no unused script entries, implicit cleanup or unbounded EOF loops are allowed.
+runScriptedEffects :: T -> [(T, T)] -> IO T
+runScriptedEffects initial expected = go (256 :: Int) initial [] expected
+ where
+ go 0 _ _ _ = assertFailure "scripted effect trace exceeded fuel"
+ go fuel (Fork tag payload) stack script = case toNumber tag of
+ Right 0 -> case stack of
+ next : rest -> go (fuel - 1) (apply next payload) rest script
+ [] -> do
+ assertBool "effect script left unused entries" (null script)
+ pure payload
+ Right 1 -> case payload of
+ Fork action continuation -> go (fuel - 1) action (continuation : stack) script
+ _ -> assertFailure "malformed scripted Bind"
+ _ -> case script of
+ (wanted, reply) : rest -> do
+ Fork tag payload @?= wanted
+ go (fuel - 1) (Fork (ofNumber 0) reply) stack rest
+ [] -> assertFailure ("unscripted effect: " ++ show (toNumber tag))
+ go _ _ _ _ = assertFailure "malformed scripted action"
+
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,5 +1,7 @@
module Main where
+import ScriptedEffects (runScriptedEffects)
+import IODriverTests (ioDriverTests)
import Eval
import qualified ParserValueTests
import qualified LibraryValueTests
@@ -21,14 +23,13 @@ import ContentStore
import ContentStore.Bundle
import Module.Manifest
import Module.Resolver
-import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms, runIOWithYieldHook, YieldStats(..), runIOWithYieldStatsHook)
+import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
import Control.Exception (bracket, evaluate, try, SomeException)
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.StableName (makeStableName)
import Data.IORef (IORef, newIORef, modifyIORef', readIORef, atomicModifyIORef')
-import qualified Network.Socket as NS
import Control.Monad (foldM, forM, forM_, unless)
import Control.Monad.IO.Class (liftIO)
import System.IO.Temp (withSystemTempDirectory)
@@ -577,9 +578,10 @@ verifiedTreeLoadingTests = testGroup "verified tree loading"
payload = encodeTreeTerm value
path = dir </> "object"
BS.writeFile path payload
- final <- runIOSourceWithPerms (defaultPerms { allowRead = [dir] }) $
- "main = io (readTreeTerm " ++ show path ++ " " ++ show (unpack (hashObject treeTermDomain payload)) ++ ")\n"
- final @?= ioOkResult value
+ let io = fixtureExports "io"
+ action = apply (io Map.! "io") (foldl apply (io Map.! "readTreeTerm")
+ [ofString path, ofString (unpack (hashObject treeTermDomain payload))])
+ runIO (defaultPerms { allowRead = [dir] }) action >>= (@?= Right (ioOkResult value))
]
where
readTerm perms path digest = runAction perms (ofString path) (ofString digest)
@@ -5173,1246 +5175,6 @@ parserErr code rest = Fork falseT (Fork code rest)
-- IO driver tests
-- --------------------------------------------------------------------------
-ioDriverTests :: TestTree
-ioDriverTests = testGroup "IO driver tests"
- [ testCase "abortIO terminates before the pending Bind action" $
- withSystemTempDirectory "tricu-io-abort" $ \dir -> do
- let output = dir ++ "/after"
- source = "main = io (bind (abortIO \"stop\") (_ : writeFile \"" ++ output ++ "\" \"unexpected\"))"
- action = mainResult (evalTricu allTestLibsEnv (parseTricu source))
- outcome <- runIO unsafePerms action
- outcome @?= Left "execution aborted: stop"
- exists <- doesFileExist output
- exists @?= False
-
- , testCase "child abort terminates an awaiting execution" $ do
- let source = "main = io (bind (fork (bind yield (_ : abortIO \"child\"))) (h : bind (await h) (_ : pure \"unexpected\")))"
- action = mainResult (evalTricu allTestLibsEnv (parseTricu source))
- outcome <- Timeout.timeout 2000000 (runIO unsafePerms action)
- outcome @?= Just (Left "execution aborted: child")
-
- , testCase "yield observation preserves result and explicit state" $ do
- count <- newIORef (0 :: Int)
- let source = "main = io (bind (put 7) (_ : bind yield (_ : bind yield (_ : pure 9))))"
- action = mainResult (evalTricu allTestLibsEnv (parseTricu source))
- observed <- runIOWithYieldHook (modifyIORef' count (+ 1)) unsafePerms Leaf Leaf action
- ordinary <- runIOWith unsafePerms Leaf Leaf action
- observed @?= ordinary
- observed @?= Right (ofNumber 9, ofNumber 7)
- readIORef count >>= (@?= 2)
- samples <- newIORef []
- profiled <- runIOWithYieldStatsHook (\sample -> modifyIORef' samples (sample :))
- unsafePerms Leaf Leaf action
- profiled @?= ordinary
- readIORef samples >>= (@?= [YieldStats 1 0 1, YieldStats 1 0 1])
-
- , testCase "application Result keeps structured errors as data" $ do
- let value = Fork Leaf (Fork (ofString "application-error") Leaf)
- action = apply (allTestLibsEnv Map.! "io") (apply (allTestLibsEnv Map.! "pure") value)
- runIO unsafePerms action >>= (@?= Right value)
-
- , testCase "readFile through onReadFile returns file contents" $
- withSystemTempDirectory "tricu-io-read" $ \dir -> do
- let sourcePath = dir ++ "/input.txt"
- writeFile sourcePath "abc123"
- final <- runIOSource $
- unlines
- [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
- , " (err rest : pure \"read failed\")"
- , " (contents rest : pure contents))"
- ]
- final @?= ofString "abc123"
-
- , testCase "readFile error path returns explicit error branch" $
- withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do
- let sourcePath = dir ++ "/missing.txt"
- final <- runIOSource $
- unlines
- [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
- , " (err rest : pure \"read failed\")"
- , " (contents rest : pure contents))"
- ]
- final @?= ofString "read failed"
-
- , testCase "chains multiple readFile actions through Result-aware helper" $
- withSystemTempDirectory "tricu-io-chain" $ \dir -> do
- let firstPath = dir ++ "/first.txt"
- secondPath = dir ++ "/second.txt"
- writeFile firstPath "abc"
- writeFile secondPath "def"
- final <- runIOSource $
- unlines
- [ "main = io (onReadFile \"" ++ firstPath ++ "\""
- , " (err rest : pure \"first read failed\")"
- , " (first rest : onReadFile \"" ++ secondPath ++ "\""
- , " (err rest : pure \"second read failed\")"
- , " (second rest : pure (append first second))))"
- ]
- final @?= ofString "abcdef"
-
- -- Monad law tests
- , testCase "left identity: bind (pure x) f == f x" $ do
- left <- runIOSource $
- unlines
- [ "f = x : pure (append x \"!\")"
- , "main = io (bind (pure \"abc\") f)"
- ]
- right <- runIOSource $
- unlines
- [ "f = x : pure (append x \"!\")"
- , "main = io (f \"abc\")"
- ]
- left @?= right
- left @?= ofString "abc!"
-
- , testCase "right identity: bind m pure == m" $
- withSystemTempDirectory "tricu-io-right-id" $ \dir -> do
- let path = dir ++ "/input.txt"
- writeFile path "abc"
- left <- runIOSource $
- unlines
- [ "main = io (bind (readFile \"" ++ path ++ "\")"
- , " (result : pure result))"
- ]
- right <- runIOSource $
- unlines
- [ "main = io (readFile \"" ++ path ++ "\")"
- ]
- left @?= right
- left @?= ioOkResult (ofString "abc")
-
- , testCase "associativity: bind (bind m f) g == bind m (x : bind (f x) g)" $
- withSystemTempDirectory "tricu-io-assoc" $ \dir -> do
- let path = dir ++ "/input.txt"
- writeFile path "abc"
- left <- runIOSource $
- unlines
- [ "m = readFile \"" ++ path ++ "\""
- , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
- , "g = value : pure (append value \"-g\")"
- , "main = io (bind (bind m f) g)"
- ]
- right <- runIOSource $
- unlines
- [ "m = readFile \"" ++ path ++ "\""
- , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
- , "g = value : pure (append value \"-g\")"
- , "main = io (bind m (x : bind (f x) g))"
- ]
- left @?= right
- left @?= ofString "abc-f-g"
-
- , testCase "associativity preserves error flow" $
- withSystemTempDirectory "tricu-io-assoc-err" $ \dir -> do
- let missingPath = dir ++ "/missing.txt"
- left <- runIOSource $
- unlines
- [ "m = readFile \"" ++ missingPath ++ "\""
- , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
- , "g = value : pure (append value \"-g\")"
- , "main = io (bind (bind m f) g)"
- ]
- right <- runIOSource $
- unlines
- [ "m = readFile \"" ++ missingPath ++ "\""
- , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
- , "g = value : pure (append value \"-g\")"
- , "main = io (bind m (x : bind (f x) g))"
- ]
- left @?= right
- left @?= ofString "handled-g"
-
- , testCase "bind defers continuation until left action completes" $
- withSystemTempDirectory "tricu-io-lazy-k" $ \dir -> do
- let path = dir ++ "/created.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bind (writeFile \"" ++ path ++ "\" \"created\")"
- , " (_ : readFile \"" ++ path ++ "\"))"
- ]
- final @?= ioOkResult (ofString "created")
-
- -- Primitive effect shape tests
- , testCase "readFile without continuation returns Result" $
- withSystemTempDirectory "tricu-io-raw-read" $ \dir -> do
- let path = dir ++ "/input.txt"
- writeFile path "abc"
- final <- runIOSource $
- unlines
- [ "main = io (readFile \"" ++ path ++ "\")"
- ]
- final @?= ioOkResult (ofString "abc")
-
- , testCase "writeFile then readFile executes exactly once" $
- withSystemTempDirectory "tricu-io-once" $ \dir -> do
- let path = dir ++ "/test.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bind (writeFile \"" ++ path ++ "\" \"abc\")"
- , " (_ : readFile \"" ++ path ++ "\"))"
- ]
- final @?= ioOkResult (ofString "abc")
-
- , testCase "sequencing order is left-to-right" $
- withSystemTempDirectory "tricu-io-order" $ \dir -> do
- let path = dir ++ "/test.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bind (writeFile \"" ++ path ++ "\" \"a\")"
- , " (_ : bind (writeFile \"" ++ path ++ "\" \"ab\")"
- , " (_ : readFile \"" ++ path ++ "\")))"
- ]
- final @?= ioOkResult (ofString "ab")
-
- , testCase "thenIO sequences two actions and discards first result" $
- withSystemTempDirectory "tricu-io-then" $ \dir -> do
- let path = dir ++ "/test.txt"
- final <- runIOSource $
- unlines
- [ "main = io (thenIO (writeFile \"" ++ path ++ "\" \"x\")"
- , " (readFile \"" ++ path ++ "\"))"
- ]
- final @?= ioOkResult (ofString "x")
-
- , testCase "bind does not short-circuit on readFile error" $
- withSystemTempDirectory "tricu-io-no-short" $ \dir -> do
- let path = dir ++ "/missing.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bind (readFile \"" ++ path ++ "\")"
- , " (result : pure \"continued\"))"
- ]
- final @?= ofString "continued"
-
- , testCase "mapIO transforms pure value" $ do
- final <- runIOSource $
- unlines
- [ "main = io (mapIO (pure \"abc\") (x : append x \"!\"))"
- ]
- final @?= ofString "abc!"
-
- -- Malformed action tests
- , testCase "unknown IO action tag returns err result" $ do
- final <- runIOSource "main = io (pair 99 t)"
- final @?= ioErrResult "invalid action"
-
- , testCase "malformed Bind returns err result" $ do
- final <- runIOSource "main = io (pair 1 t)"
- final @?= ioErrResult "invalid action"
-
- , testCase "malformed ReadFile payload returns err result" $ do
- final <- runIOSource "main = io (readFile (t t))"
- final @?= ioErrResult "invalid string"
-
- -- Permission tests
- , testCase "allowed read path succeeds" $
- withSystemTempDirectory "tricu-io-allowed" $ \dir -> do
- let path = dir ++ "/allowed.txt"
- writeFile path "allowed"
- let perms = defaultPerms { allowRead = [path] }
- result <- runIOSourceWithPerms perms $
- unlines
- [ "main = io (readFile \"" ++ path ++ "\")"
- ]
- result @?= ioOkResult (ofString "allowed")
-
- , testCase "readFile denied path returns err result" $
- withSystemTempDirectory "tricu-io-read-denied" $ \dir -> do
- let allowedPath = dir ++ "/allowed.txt"
- deniedPath = dir ++ "/denied.txt"
- writeFile allowedPath "allowed"
- writeFile deniedPath "denied"
- let perms = defaultPerms { allowRead = [allowedPath] }
- result <- runIOSourceWithPerms perms $
- unlines
- [ "main = io (readFile \"" ++ deniedPath ++ "\")"
- ]
- result @?= ioErrResult "permission denied"
-
- , testCase "writeFile denied path returns err result" $
- withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do
- let allowedPath = dir ++ "/allowed.txt"
- deniedPath = dir ++ "/denied.txt"
- let perms = defaultPerms { allowWrite = [allowedPath] }
- result <- runIOSourceWithPerms perms $
- unlines
- [ "main = io (writeFile \"" ++ deniedPath ++ "\" \"x\")"
- ]
- result @?= ioErrResult "permission denied"
-
- , testCase "path prefix does not allow prefix bypass" $
- withSystemTempDirectory "tricu-io-prefix" $ \dir -> do
- let allowedDir = dir ++ "/foo"
- bypassPath = dir ++ "/foobar/secret.txt"
- createDirectory allowedDir
- createDirectory (dir ++ "/foobar")
- writeFile bypassPath "secret"
- let perms = defaultPerms { allowRead = [allowedDir] }
- result <- runIOSourceWithPerms perms $
- unlines
- [ "main = io (readFile \"" ++ bypassPath ++ "\")"
- ]
- result @?= ioErrResult "permission denied"
-
- -- Pure test
- , testCase "pure performs no effects" $ do
- final <- runIOSource "main = io (pure \"abc\")"
- final @?= ofString "abc"
-
- -- Reader tests
- , testCase "ask returns initial environment" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "dev") $
- unlines
- [ "main = io (bind ask (env : pure env))"
- ]
- final @?= ofString "dev"
-
- , testCase "local transforms environment" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (local (env : append env \"-local\") (bind ask (env : pure env)))"
- ]
- final @?= ofString "root-local"
-
- , testCase "local restores environment afterward" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (bind ask (before :"
- , " bind (local (env : append env \"-local\") (bind ask (env : pure env))) (inside :"
- , " bind ask (after :"
- , " pure (pair before (pair inside after))))))"
- ]
- final @?= Fork (ofString "root") (Fork (ofString "root-local") (ofString "root"))
-
- , testCase "nested local composes correctly" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "f = x : append x \"-f\""
- , "g = x : append x \"-g\""
- , "main = io (bind"
- , " (local f (local g (bind ask (env : pure env))))"
- , " (inner :"
- , " bind ask (after :"
- , " pure (pair inner after))))"
- ]
- final @?= Fork (ofString "root-f-g") (ofString "root")
-
- , testCase "local result passes through bind correctly" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (bind"
- , " (local (env : append env \"-local\") (pure \"value\"))"
- , " (x : pure x))"
- ]
- final @?= ofString "value"
-
- , testCase "IO inside local uses transformed environment and restores after" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (bind"
- , " (local (env : append env \"-local\")"
- , " (bind ask (env : pure env)))"
- , " (result :"
- , " bind ask (after :"
- , " pure (pair result after))))"
- ]
- final @?= Fork (ofString "root-local") (ofString "root")
-
- , testCase "local does not affect outer bind continuation" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (bind"
- , " (local (env : append env \"-local\") (pure \"x\"))"
- , " (_ : bind ask (env : pure env)))"
- ]
- final @?= ofString "root"
-
- , testCase "local environment persists across inner binds" $ do
- final <- runIOSourceWithEnv unsafePerms (ofString "root") $
- unlines
- [ "main = io (local (env : append env \"-local\")"
- , " (bind (pure t) (_ :"
- , " bind ask (env : pure env))))"
- ]
- final @?= ofString "root-local"
-
- , testCase "local restores environment when scoped action returns error value" $ do
- final <- runIOSourceWithEnv defaultPerms (ofString "root") $
- unlines
- [ "main = io (bind"
- , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))"
- , " (_ : bind ask (env : pure env)))"
- ]
- final @?= ofString "root"
-
- -- State tests
- , testCase "get returns initial state" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 42) $
- unlines
- [ "main = io (bind get (s : pure s))"
- ]
- final @?= ofNumber 42
- st @?= ofNumber 42
-
- , testCase "put updates state" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
- unlines
- [ "main = io (bind (put 100) (_ : bind get (s : pure s)))"
- ]
- final @?= ofNumber 100
- st @?= ofNumber 100
-
- , testCase "state persists through bind" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 5) $
- unlines
- [ "main = io (bind get (s1 :"
- , " bind (put (succ s1)) (_ :"
- , " bind get (s2 :"
- , " pure (pair s1 s2)))))"
- ]
- final @?= Fork (ofNumber 5) (ofNumber 6)
- st @?= ofNumber 6
-
- , testCase "local does not restore state" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
- unlines
- [ "main = io (bind (put 10) (_ :"
- , " bind (local (env : env) (put 20)) (_ :"
- , " bind get (s :"
- , " pure s))))"
- ]
- final @?= ofNumber 20
- st @?= ofNumber 20
-
- , testCase "state and reader are independent" $ do
- (final, st) <- runIOSourceWith unsafePerms (ofString "hello") (ofNumber 42) $
- unlines
- [ "main = io (bind ask (env :"
- , " bind get (s :"
- , " pure (pair env s))))"
- ]
- final @?= Fork (ofString "hello") (ofNumber 42)
- st @?= ofNumber 42
-
- -- Async tests
- , testCase "fork returns handle and await returns child value" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (pure \"child\")) (h :"
- , " await h))"
- ]
- final @?= ofString "child"
- st @?= Leaf
-
- , testCase "main completion abandons unawaited child" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (pure \"child\")) (_ :"
- , " pure \"main\"))"
- ]
- final @?= ofString "main"
-
- , testCase "fork captures reader environment at fork point" $ do
- (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
- unlines
- [ "main = io (local (env : append env \"-local\")"
- , " (bind (fork (bind ask (env : pure env))) (h :"
- , " await h)))"
- ]
- final @?= ofString "root-local"
-
- , testCase "fork inside local captures child env and parent restores env" $ do
- (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
- unlines
- [ "main = io (bind"
- , " (local (env : append env \"-local\")"
- , " (fork (bind ask (env : pure env))))"
- , " (h : bind ask (after :"
- , " bind (await h) (child :"
- , " pure (pair after child)))))"
- ]
- final @?= Fork (ofString "root") (ofString "root-local")
-
- , testCase "fork copies state and child state does not merge" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
- unlines
- [ "main = io (bind (put 1) (_ :"
- , " bind (fork (bind (put 99) (_ : bind get (s : pure s)))) (h :"
- , " bind (put 2) (_ :"
- , " bind (await h) (childState :"
- , " bind get (parentState :"
- , " pure (pair childState parentState)))))))"
- ]
- final @?= Fork (ofNumber 99) (ofNumber 2)
- st @?= ofNumber 2
-
- , testCase "multiple awaiters receive same completed value" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (pure \"done\")) (h :"
- , " bind (await h) (a :"
- , " bind (await h) (b :"
- , " pure (pair a b)))))"
- ]
- final @?= Fork (ofString "done") (ofString "done")
-
- , testCase "self await returns async error" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (await (pair \"task\" 0))"
- ]
- final @?= ioErrResult "self await"
-
- , testCase "await invalid handle returns async error" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (await 123)"
- ]
- final @?= ioErrResult "invalid task handle"
-
- , testCase "yield returns unit and resumes continuation" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind yield (_ : pure \"after\"))"
- ]
- final @?= ofString "after"
-
- , testCase "sleep resumes continuation" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
- ]
- final @?= ofString "awake"
-
- , testCase "await waits for sleeping child" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"awake\"))) (h :"
- , " await h))"
- ]
- final @?= ofString "awake"
-
- , testCase "await waits for sleeping child and returns child value" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :"
- , " await h))"
- ]
- final @?= ofString "child done"
- st @?= Leaf
-
- , testCase "sleep inside bind resumes as unit" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
- ]
- final @?= ofString "awake"
- st @?= Leaf
-
- , testCase "fork await returns child value" $ do
- (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (pure \"child done\")) (h :"
- , " await h))"
- ]
- final @?= ofString "child done"
- st @?= Leaf
-
- -- Scheduler hardening tests
- , testCase "runIO rejects non-IO tree with sentinel error" $ do
- result <- runIO unsafePerms (ofString "not an io program")
- case result of
- Left _ -> return ()
- Right _ -> assertFailure "Expected Left for invalid sentinel"
-
- , testCase "cyclic await returns error instead of hanging" $ do
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "main = io (bind (fork (await (pair \"task\" 0))) (h :"
- , " await h))"
- ]
- final @?= ioErrResult "cyclic await"
-
- , testCase "source file UTF-8 returns exact bytes and scalar characters" $
- withSystemTempDirectory "tricu-source-utf8" $ \dir -> do
- let path = dir ++ "/source.tri"
- samples = ["main = 42\n", "-- \233\8364\128512\nmain = \"\233\8364\128512\"\n",
- "-- embedded \xfeff and decomposed e\x301\r\n",
- "\0\x80\x7ff\x800\xd7ff\xe000\xffff\x10000\x10ffff"]
- forM_ samples $ \text -> do
- let bytes = encodeUtf8 (pack text)
- BS.writeFile path bytes
- let action = Fork (ofNumber 37) (ofString path)
- program = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
- actual <- runIO unsafePerms program
- actual @?= Right (ioOkResult (Fork (ofBytes bytes) (ofString text)))
- binary <- runIO unsafePerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 20) (ofString path))))
- binary @?= Right (ioOkResult (ofBytes bytes))
- encoded <- runIO unsafePerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) (ofString text))))
- encoded @?= Right (ioOkResult (ofBytes bytes))
-
- , testCase "source UTF-8 rejects malformed sequences and initial BOM" $
- withSystemTempDirectory "tricu-source-invalid" $ \dir -> do
- let path = dir ++ "/bad.tri"
- malformed = [[0x80], [0xc0,0xaf], [0xc1,0xbf], [0xc2], [0xe2,0x82],
- [0xf0,0x9f,0x98], [0xe0,0x80,0xaf], [0xed,0xa0,0x80],
- [0xf0,0x80,0x80,0xaf], [0xf4,0x90,0x80,0x80],
- [0xf5,0x80,0x80,0x80], [0xff], [0xc2,0x41], [0xef,0xbb,0xbf]]
- forM_ malformed $ \bytes -> do
- BS.writeFile path (BS.pack bytes)
- actual <- runIO unsafePerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString path))))
- case actual of
- Right (Fork Leaf (Fork diagnostic Leaf)) -> case toString diagnostic of
- Right message -> do
- assertBool "source path in diagnostic" (path `isInfixOf` message)
- assertBool "UTF-8 diagnostic" ("UTF-8" `isInfixOf` message)
- _ -> assertFailure "non-string diagnostic"
- _ -> assertFailure ("accepted malformed source: " ++ show bytes)
-
- , testCase "source read permission and scalar encoding controls" $ do
- denied <- runIO defaultPerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString "denied.tri"))))
- case denied of
- Right (Fork Leaf _) -> pure ()
- _ -> assertFailure "source read bypassed permission"
- forM_ [0xd800, 0xdfff, 0x110000] $ \scalar -> do
- actual <- runIO unsafePerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1)
- (Fork (ofNumber 38) (ofList [ofNumber scalar]))))
- actual @?= Right (ioErrResult "invalid source scalar list")
-
- , testCase "source encoder rejects improper lists and noncanonical scalar naturals" $ do
- forM_ [Stem Leaf, Fork (ofNumber 65) (Stem Leaf),
- ofList [Fork Leaf Leaf], ofList [Fork (Stem Leaf) (Fork Leaf Leaf)]] $ \value -> do
- actual <- runIO unsafePerms
- (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) value)))
- actual @?= Right (ioErrResult "invalid source scalar list")
-
- , testCase "writeBytes and readFile roundtrip binary data" $
- withSystemTempDirectory "tricu-io-bytes" $ \dir -> do
- let path = dir ++ "/binary.bin"
- final <- runIOSource $
- unlines
- [ "main = io (bind (writeBytes \"" ++ path ++ "\" [(0) (255) (128) (1)])"
- , " (_ : readFile \"" ++ path ++ "\"))"
- ]
- final @?= ioOkResult (ofBytes (BS.pack [0, 255, 128, 1]))
-
- , testCase "stress test: many concurrent sleepers complete promptly" $ do
- let n = 5000
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
- unlines
- [ "spawner = y (self n acc : if (equal? n 0) (pure acc) (bind (fork (sleep 1)) (h : self (pred n) (pair h acc))))"
- , "awaitAll = y (self hs : matchList (pure \"done\") (h r : bind (await h) (_ : self r)) hs)"
- , "main = io (bind (spawner " ++ show n ++ " t) (hs : awaitAll hs))"
- ]
- final @?= ofString "done"
-
- , testCase "long fork await loop does not leak" $ do
- let n = 200
- build 0 = "pure \"done\""
- build k = "bind (fork (pure \"x\")) (h : bind (await h) (_ : " ++ build (k - 1) ++ "))"
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf ("main = io (" ++ build n ++ ")")
- final @?= ofString "done"
-
- , testGroup "Socket primitives"
- [ testCase "socket returns ok result with valid handle" $ do
- final <- runIOSource "main = io socket"
- final @?= ioOkResult (Fork (ofString "sock") (ofNumber 0))
-
- , testCase "closeSocket on invalid handle returns error" $ do
- final <- runIOSource "main = io (closeSocket (pair \"sock\" 99999))"
- final @?= ioErrResult "invalid socket handle"
-
- , testCase "bindSocket and listen succeed on loopback port 0" $ do
- final <- runIOSource $
- unlines
- [ "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
- , " bind (listen server 1) (listenResult :"
- , " pure listenResult))))"
- ]
- final @?= ioOkResult Leaf
-
- , testCase "connect to non-listening port returns error" $ do
- final <- runIOSource "main = io (onOk socket (sock rest : connect sock \"127.0.0.1\" 1))"
- case final of
- Fork Leaf (Fork _ Leaf) -> return ()
- other -> assertFailure $ "Expected error result, got: " ++ show other
-
- , testCase "accept and recv receive bytes from forked client" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "client = port :"
- , " onOk socket (sock rest :"
- , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
- , " send sock [104 105]))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (client " ++ show port ++ ")) (_ :"
- , " onOk (accept server) (accepted rest :"
- , " recv (fst accepted) 2))))))"
- ]
- final @?= ioOkResult (ofBytes (BS.pack [104, 105]))
-
- , testCase "client recv receives server response via accepted socket" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "serverTask = (server :"
- , " onOk (accept server) (accepted rest :"
- , " onOk (recv (fst accepted) 4) (msg rest :"
- , " send (fst accepted) [112 111 110 103])))"
- , ""
- , "clientTask = (port :"
- , " onOk socket (sock rest :"
- , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
- , " bind (send sock [112 105 110 103]) (_ :"
- , " recv sock 4))))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (serverTask server)) (_ :"
- , " clientTask " ++ show port ++ ")))))"
- ]
- final @?= ioOkResult (ofBytes (BS.pack [112, 111, 110, 103]))
-
- , testCase "recv on closed peer returns connection closed" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "clientTask = port :"
- , " onOk socket (sock rest :"
- , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
- , " closeSocket sock))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
- , " onOk (accept server) (accepted rest :"
- , " bind (yield) (_ :"
- , " recv (fst accepted) 1)))))))"
- ]
- final @?= ioErrResult "connection closed"
-
- , testCase "accept invalid socket handle returns error" $ do
- final <- runIOSource "main = io (accept (pair \"sock\" 99999))"
- final @?= ioErrResult "invalid socket handle"
-
- , testCase "recv invalid socket handle returns error" $ do
- final <- runIOSource "main = io (recv (pair \"sock\" 99999) 1)"
- final @?= ioErrResult "invalid socket handle"
-
- , testCase "send invalid socket handle returns error" $ do
- final <- runIOSource "main = io (send (pair \"sock\" 99999) [(1)])"
- final @?= ioErrResult "invalid socket handle"
-
- , testCase "socket conveniences close acquired handles on failures and preserve replies" $ do
- env <- evaluateTestSupportFile "./lib/socket.tri"
- let call name = foldl apply (env Map.! name)
- sock = ofNumber 7
- primitive tag payload = Fork (ofNumber tag) payload
- create = primitive 70 Leaf
- close = primitive 71 sock
- address = ofString "127.0.0.1"
- port = ofNumber 9050
- bound = primitive 72 (Fork sock (Fork address port))
- listening = primitive 73 (Fork sock (ofNumber 128))
- connected = primitive 75 (Fork sock (Fork address port))
- acquired = parserOk sock (ofNumber 23)
- ready = parserOk (ofNumber 19) (ofNumber 29)
- failed = parserErr (ofString "denied") (ofString "opaque remainder")
- closeFailed = parserErr (ofString "close failed") (ofNumber 41)
- listener = call "listenSocket" [address, port, ofNumber 128]
- client = call "connectTo" [address, port]
- forM_ [listener, client] $ \action ->
- runScriptedEffects action [(create, failed)] >>= (@?= failed)
- runScriptedEffects listener [(create, acquired), (bound, ready), (listening, ready)]
- >>= (@?= parserOk sock Leaf)
- runScriptedEffects client [(create, acquired), (connected, ready)]
- >>= (@?= parserOk sock (ofNumber 29))
- forM_ [ready, closeFailed] $ \closed -> do
- runScriptedEffects listener [(create, acquired), (bound, failed), (close, closed)]
- >>= (@?= failed)
- runScriptedEffects listener [(create, acquired), (bound, ready), (listening, failed), (close, closed)]
- >>= (@?= failed)
- runScriptedEffects client [(create, acquired), (connected, failed), (close, closed)]
- >>= (@?= failed)
-
- , testCase "listenSocket creates a live listener whose ownership transfers to the caller" $ do
- final <- runIOSource "main = io (onOk_ (listenSocket \"127.0.0.1\" 0 1) (server : finally (getSocketName server) (closeSocket_ server)))"
- case final of
- Fork (Stem Leaf) (Fork value Leaf) -> case toNumber value of
- Right port -> assertBool "positive bound port" (port > 0)
- Left problem -> assertFailure problem
- other -> assertFailure $ "expected bound port: " ++ show other
-
- , testCase "getSocketName returns positive port after bind 0" $ do
- final <- runIOSource $
- unlines
- [ "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
- , " bind (getSocketName server) (nameResult :"
- , " pure nameResult))))"
- ]
- case final of
- Fork (Stem Leaf) (Fork val Leaf) ->
- case toNumber val of
- Right port | port > 0 -> return ()
- Right 0 -> assertFailure "Expected positive port, got 0"
- Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val
- other -> assertFailure $ "Expected ok result, got: " ++ show other
-
- , testCase "connectTo creates connected socket" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "clientTask = port :"
- , " onOk (connectTo \"127.0.0.1\" port) (client rest :"
- , " onOk (send client [104 105]) (_ rest :"
- , " pure t))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (clientTask " ++ show port ++ ")) (_ :"
- , " onOk (accept server) (accepted rest :"
- , " onOk (recv (fst accepted) 2) (msg rest :"
- , " pure msg)))))))"
- ]
- final @?= ofBytes (BS.pack [104, 105])
-
- , testCase "serveOnce handles a single client connection" $
- withFreePort $ \port -> do
- final <- runIOSource $
- unlines
- [ "echoHandler = (client peer :"
- , " onOk (recv client 2) (msg rest :"
- , " onOk (send client msg) (_ rest :"
- , " pure t)))"
- , ""
- , "clientTask = (port :"
- , " onOk socket (sock rest :"
- , " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
- , " onOk (send sock [104 105]) (_ rest :"
- , " onOk (recv sock 2) (msg rest :"
- , " pure msg)))))"
- , ""
- , "main = io ("
- , " onOk socket (server rest :"
- , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
- , " onOk (listen server 1) (_ rest :"
- , " bind (fork (serveOnce server echoHandler)) (_ :"
- , " clientTask " ++ show port ++ ")))))"
- ]
- final @?= ofBytes (BS.pack [104, 105])
-
- , testCase "finally preserves successful action result" $ do
- final <- runIOSource $
- unlines
- [ "main = io (finally (pure 42) (pure 99))"
- ]
- final @?= ofNumber 42
-
- , testCase "finally runs cleanup after successful action" $
- withSystemTempDirectory "tricu-finally" $ \dir -> do
- let cleanupPath = dir ++ "/cleanup.txt"
- final <- runIOSource $
- unlines
- [ "main = io (finally"
- , " (pure 42)"
- , " (writeFile \"" ++ cleanupPath ++ "\" \"cleaned\"))"
- ]
- final @?= ofNumber 42
- contents <- readFile cleanupPath
- contents @?= "cleaned"
-
- , testCase "bracket passes acquired resource to use" $ do
- final <- runIOSource $
- unlines
- [ "main = io (bracket (pure (ok 41 7)) (_ : pure t) (r : pure (succ r)))"
- ]
- final @?= ofNumber 42
-
- , testCase "bracket preserves successful use result over release result" $ do
- final <- runIOSource $
- unlines
- [ "main = io (bracket (pure (ok \"res\" 7)) (_ : pure 123) (_ : pure 99))"
- ]
- final @?= ofNumber 99
-
- , testCase "bracket runs release on successful use" $
- withSystemTempDirectory "tricu-bracket" $ \dir -> do
- let releasePath = dir ++ "/release.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bracket"
- , " (pure (ok \"" ++ releasePath ++ "\" 7))"
- , " (path : writeFile path \"released\")"
- , " (path : pure 99))"
- ]
- final @?= ofNumber 99
- contents <- readFile releasePath
- contents @?= "released"
-
- , testCase "bracket passes acquired resource to release" $
- withSystemTempDirectory "tricu-bracket-release-resource" $ \dir -> do
- let releasePath = dir ++ "/release.txt"
- final <- runIOSource $
- unlines
- [ "main = io (bracket"
- , " (pure (ok \"" ++ releasePath ++ "\" 7))"
- , " (path : writeFile path \"released\")"
- , " (_ : pure 99))"
- ]
- 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
- ]
- ]
- ]
-
-- A deliberately small interpreter: it records every read request, even if
-- the supplied host reply is a failure. Unknown effects fail the test rather
-- than being silently ignored. No filesystem or socket effects are executed.
@@ -6642,29 +5404,6 @@ compileLocalControl bindings source = do
pure function
other -> assertFailure ("local control compilation failed: " ++ show other) >> pure Leaf
--- Small independent host interpreter for authenticated HTTP/registry actions.
--- Never opens a socket. Every primitive must match its complete expected action;
--- no unused script entries, implicit cleanup or unbounded EOF loops are allowed.
-runScriptedEffects :: T -> [(T, T)] -> IO T
-runScriptedEffects initial expected = go (256 :: Int) initial [] expected
- where
- go 0 _ _ _ = assertFailure "scripted effect trace exceeded fuel"
- go fuel (Fork tag payload) stack script = case toNumber tag of
- Right 0 -> case stack of
- next : rest -> go (fuel - 1) (apply next payload) rest script
- [] -> do
- assertBool "effect script left unused entries" (null script)
- pure payload
- Right 1 -> case payload of
- Fork action continuation -> go (fuel - 1) action (continuation : stack) script
- _ -> assertFailure "malformed scripted Bind"
- _ -> case script of
- (wanted, reply) : rest -> do
- Fork tag payload @?= wanted
- go (fuel - 1) (Fork (ofNumber 0) reply) stack rest
- [] -> assertFailure ("unscripted effect: " ++ show (toNumber tag))
- go _ _ _ _ = assertFailure "malformed scripted action"
-
httpPipelineTests :: TestTree
httpPipelineTests = testCase "HTTP reference pipeline: buffers, EOF, receive errors and cleanup" $ do
let env = fixtureExports "http"
@@ -6720,35 +5459,6 @@ containsAll text needles =
forM_ needles $ \needle ->
assertBool ("expected " ++ show needle ++ " in: " ++ text) (needle `isInfixOf` text)
-withFreePort :: (Int -> IO a) -> IO a
-withFreePort action =
- bracket
- (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol)
- NS.close
- (\s -> do
- NS.setSocketOption s NS.ReuseAddr 1
- NS.bind s (NS.SockAddrInet 0 (NS.tupleToHostAddress (127, 0, 0, 1)))
- port <- NS.socketPort s
- action (fromIntegral port))
-
-runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T)
-runIOSourceWith perms readerEnv initialState source = do
- let asts = parseTricu source
- evalEnv = evalTricu allTestLibsEnv asts
- fullTree = mainResult evalEnv
- result <- runIOWith perms readerEnv initialState fullTree
- case result of
- Left err -> assertFailure ("IO runtime error: " ++ err)
- Right pair -> pure pair
-
-runIOSource :: String -> IO T
-runIOSource source = fmap fst $ runIOSourceWith unsafePerms Leaf Leaf source
-
-runIOSourceWithPerms :: IOPermissions -> String -> IO T
-runIOSourceWithPerms perms source = fmap fst $ runIOSourceWith perms Leaf Leaf source
-
-runIOSourceWithEnv :: IOPermissions -> T -> String -> IO T
-runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms readerEnv Leaf source
ioOkResult :: T -> T
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
diff --git a/tricu.cabal b/tricu.cabal
@@ -209,4 +209,6 @@ test-suite tricu-tests
LibraryValueTests
ParserValueTests
PortableTestCompiler
+ IODriverTests
+ ScriptedEffects
ReferenceFixtures
