IODriverTests.hs (54051B)
1 module IODriverTests (ioDriverTests) where 2 3 import ScriptedEffects (runScriptedEffects) 4 import Data.Text (pack) 5 import Data.Text.Encoding (encodeUtf8) 6 import Runtime 7 import ReferenceFixtures (fixtureExports) 8 import PortableTestCompiler (compileFixtureDefinitions) 9 import IODriver 10 import Control.Exception (bracket) 11 import Control.Monad (forM_) 12 import Data.IORef 13 import Data.List (isInfixOf) 14 import qualified Data.ByteString as BS 15 import qualified Data.Map as Map 16 import qualified Network.Socket as NS 17 import qualified System.Timeout as Timeout 18 import System.Directory (createDirectory, doesFileExist, doesDirectoryExist) 19 import System.IO.Temp (withSystemTempDirectory) 20 import Test.Tasty 21 import Test.Tasty.HUnit 22 23 ioDriverTests :: TestTree 24 ioDriverTests = testGroup "IO driver tests" 25 [ testCase "abortIO terminates before the pending Bind action" $ 26 withSystemTempDirectory "tricu-io-abort" $ \dir -> do 27 let output = dir ++ "/after" 28 action = envelope (thenAction (actionT 2 (ofString "stop")) 29 (actionT 21 (Fork (ofString output) (ofString "unexpected")))) 30 outcome <- runIO unsafePerms action 31 outcome @?= Left "execution aborted: stop" 32 exists <- doesFileExist output 33 exists @?= False 34 35 , testCase "child abort terminates an awaiting execution" $ do 36 let source = "main = io (bind (fork (bind yield (_ : abortIO \"child\"))) (h : bind (await h) (_ : pure \"unexpected\")))" 37 action <- compileIO source 38 outcome <- Timeout.timeout 2000000 (runIO unsafePerms action) 39 outcome @?= Just (Left "execution aborted: child") 40 41 , testCase "yield observation preserves result and explicit state" $ do 42 count <- newIORef (0 :: Int) 43 let action = envelope (thenAction (actionT 41 (ofNumber 7)) 44 (thenAction (actionT 62 Leaf) (thenAction (actionT 62 Leaf) (actionT 0 (ofNumber 9))))) 45 observed <- runIOWithYieldHook (modifyIORef' count (+ 1)) unsafePerms Leaf Leaf action 46 ordinary <- runIOWith unsafePerms Leaf Leaf action 47 observed @?= ordinary 48 observed @?= Right (ofNumber 9, ofNumber 7) 49 readIORef count >>= (@?= 2) 50 samples <- newIORef [] 51 profiled <- runIOWithYieldStatsHook (\sample -> modifyIORef' samples (sample :)) 52 unsafePerms Leaf Leaf action 53 profiled @?= ordinary 54 readIORef samples >>= (@?= [YieldStats 1 0 1, YieldStats 1 0 1]) 55 56 , testCase "application Result keeps structured errors as data" $ do 57 let value = Fork Leaf (Fork (ofString "application-error") Leaf) 58 action = envelope (actionT 0 value) 59 runIO unsafePerms action >>= (@?= Right value) 60 61 , testCase "readFile through onReadFile returns file contents" $ 62 withSystemTempDirectory "tricu-io-read" $ \dir -> do 63 let sourcePath = dir ++ "/input.txt" 64 writeFile sourcePath "abc123" 65 final <- runIOSource $ 66 unlines 67 [ "main = io (onReadFile \"" ++ sourcePath ++ "\"" 68 , " (err rest : pure \"read failed\")" 69 , " (contents rest : pure contents))" 70 ] 71 final @?= ofString "abc123" 72 73 , testCase "readFile error path returns explicit error branch" $ 74 withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do 75 let sourcePath = dir ++ "/missing.txt" 76 final <- runIOSource $ 77 unlines 78 [ "main = io (onReadFile \"" ++ sourcePath ++ "\"" 79 , " (err rest : pure \"read failed\")" 80 , " (contents rest : pure contents))" 81 ] 82 final @?= ofString "read failed" 83 84 , testCase "chains multiple readFile actions through Result-aware helper" $ 85 withSystemTempDirectory "tricu-io-chain" $ \dir -> do 86 let firstPath = dir ++ "/first.txt" 87 secondPath = dir ++ "/second.txt" 88 writeFile firstPath "abc" 89 writeFile secondPath "def" 90 final <- runIOSource $ 91 unlines 92 [ "main = io (onReadFile \"" ++ firstPath ++ "\"" 93 , " (err rest : pure \"first read failed\")" 94 , " (first rest : onReadFile \"" ++ secondPath ++ "\"" 95 , " (err rest : pure \"second read failed\")" 96 , " (second rest : pure (append first second))))" 97 ] 98 final @?= ofString "abcdef" 99 100 -- Monad law tests 101 , testCase "left identity: bind (pure x) f == f x" $ do 102 left <- runIOSource $ 103 unlines 104 [ "f = x : pure (append x \"!\")" 105 , "main = io (bind (pure \"abc\") f)" 106 ] 107 right <- runIOSource $ 108 unlines 109 [ "f = x : pure (append x \"!\")" 110 , "main = io (f \"abc\")" 111 ] 112 left @?= right 113 left @?= ofString "abc!" 114 115 , testCase "right identity: bind m pure == m" $ 116 withSystemTempDirectory "tricu-io-right-id" $ \dir -> do 117 let path = dir ++ "/input.txt" 118 writeFile path "abc" 119 left <- runIOSource $ 120 unlines 121 [ "main = io (bind (readFile \"" ++ path ++ "\")" 122 , " (result : pure result))" 123 ] 124 right <- runAction (actionT 20 (ofString path)) 125 left @?= right 126 left @?= ioOkResult (ofString "abc") 127 128 , testCase "associativity: bind (bind m f) g == bind m (x : bind (f x) g)" $ 129 withSystemTempDirectory "tricu-io-assoc" $ \dir -> do 130 let path = dir ++ "/input.txt" 131 writeFile path "abc" 132 left <- runIOSource $ 133 unlines 134 [ "m = readFile \"" ++ path ++ "\"" 135 , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result" 136 , "g = value : pure (append value \"-g\")" 137 , "main = io (bind (bind m f) g)" 138 ] 139 right <- runIOSource $ 140 unlines 141 [ "m = readFile \"" ++ path ++ "\"" 142 , "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result" 143 , "g = value : pure (append value \"-g\")" 144 , "main = io (bind m (x : bind (f x) g))" 145 ] 146 left @?= right 147 left @?= ofString "abc-f-g" 148 149 , testCase "associativity preserves error flow" $ 150 withSystemTempDirectory "tricu-io-assoc-err" $ \dir -> do 151 let missingPath = dir ++ "/missing.txt" 152 left <- runIOSource $ 153 unlines 154 [ "m = readFile \"" ++ missingPath ++ "\"" 155 , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result" 156 , "g = value : pure (append value \"-g\")" 157 , "main = io (bind (bind m f) g)" 158 ] 159 right <- runIOSource $ 160 unlines 161 [ "m = readFile \"" ++ missingPath ++ "\"" 162 , "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result" 163 , "g = value : pure (append value \"-g\")" 164 , "main = io (bind m (x : bind (f x) g))" 165 ] 166 left @?= right 167 left @?= ofString "handled-g" 168 169 , testCase "bind defers continuation until left action completes" $ 170 withSystemTempDirectory "tricu-io-lazy-k" $ \dir -> do 171 let path = dir ++ "/created.txt" 172 final <- runIOSource $ 173 unlines 174 [ "main = io (bind (writeFile \"" ++ path ++ "\" \"created\")" 175 , " (_ : readFile \"" ++ path ++ "\"))" 176 ] 177 final @?= ioOkResult (ofString "created") 178 179 -- Primitive effect shape tests 180 , testCase "readFile without continuation returns Result" $ 181 withSystemTempDirectory "tricu-io-raw-read" $ \dir -> do 182 let path = dir ++ "/input.txt" 183 writeFile path "abc" 184 final <- runAction (actionT 20 (ofString path)) 185 final @?= ioOkResult (ofString "abc") 186 187 , testCase "writeFile then readFile executes exactly once" $ 188 withSystemTempDirectory "tricu-io-once" $ \dir -> do 189 let path = dir ++ "/test.txt" 190 final <- runIOSource $ 191 unlines 192 [ "main = io (bind (writeFile \"" ++ path ++ "\" \"abc\")" 193 , " (_ : readFile \"" ++ path ++ "\"))" 194 ] 195 final @?= ioOkResult (ofString "abc") 196 197 , testCase "sequencing order is left-to-right" $ 198 withSystemTempDirectory "tricu-io-order" $ \dir -> do 199 let path = dir ++ "/test.txt" 200 final <- runIOSource $ 201 unlines 202 [ "main = io (bind (writeFile \"" ++ path ++ "\" \"a\")" 203 , " (_ : bind (writeFile \"" ++ path ++ "\" \"ab\")" 204 , " (_ : readFile \"" ++ path ++ "\")))" 205 ] 206 final @?= ioOkResult (ofString "ab") 207 208 , testCase "thenIO sequences two actions and discards first result" $ 209 withSystemTempDirectory "tricu-io-then" $ \dir -> do 210 let path = dir ++ "/test.txt" 211 final <- runIOSource $ 212 unlines 213 [ "main = io (thenIO (writeFile \"" ++ path ++ "\" \"x\")" 214 , " (readFile \"" ++ path ++ "\"))" 215 ] 216 final @?= ioOkResult (ofString "x") 217 218 , testCase "bind does not short-circuit on readFile error" $ 219 withSystemTempDirectory "tricu-io-no-short" $ \dir -> do 220 let path = dir ++ "/missing.txt" 221 final <- runIOSource $ 222 unlines 223 [ "main = io (bind (readFile \"" ++ path ++ "\")" 224 , " (result : pure \"continued\"))" 225 ] 226 final @?= ofString "continued" 227 228 , testCase "mapIO transforms pure value" $ do 229 final <- runIOSource $ 230 unlines 231 [ "main = io (mapIO (pure \"abc\") (x : append x \"!\"))" 232 ] 233 final @?= ofString "abc!" 234 235 -- Malformed action tests 236 , testCase "unknown IO action tag returns err result" $ do 237 final <- runAction (actionT 99 Leaf) 238 final @?= ioErrResult "invalid action" 239 240 , testCase "malformed Bind returns err result" $ do 241 final <- runAction (actionT 1 Leaf) 242 final @?= ioErrResult "invalid action" 243 244 , testCase "malformed ReadFile payload returns err result" $ do 245 final <- runAction (actionT 20 (Stem Leaf)) 246 final @?= ioErrResult "invalid string" 247 248 -- Permission tests 249 , testCase "allowed read path succeeds" $ 250 withSystemTempDirectory "tricu-io-allowed" $ \dir -> do 251 let path = dir ++ "/allowed.txt" 252 writeFile path "allowed" 253 let perms = defaultPerms { allowRead = [path] } 254 result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString path)) 255 result @?= ioOkResult (ofString "allowed") 256 257 , testCase "readFile denied path returns err result" $ 258 withSystemTempDirectory "tricu-io-read-denied" $ \dir -> do 259 let allowedPath = dir ++ "/allowed.txt" 260 deniedPath = dir ++ "/denied.txt" 261 writeFile allowedPath "allowed" 262 writeFile deniedPath "denied" 263 let perms = defaultPerms { allowRead = [allowedPath] } 264 result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString deniedPath)) 265 result @?= ioErrResult "permission denied" 266 267 , testCase "writeFile denied path returns err result" $ 268 withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do 269 let allowedPath = dir ++ "/allowed.txt" 270 deniedPath = dir ++ "/denied.txt" 271 let perms = defaultPerms { allowWrite = [allowedPath] } 272 result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 21 (Fork (ofString deniedPath) (ofString "x"))) 273 result @?= ioErrResult "permission denied" 274 275 , testCase "path prefix does not allow prefix bypass" $ 276 withSystemTempDirectory "tricu-io-prefix" $ \dir -> do 277 let allowedDir = dir ++ "/foo" 278 bypassPath = dir ++ "/foobar/secret.txt" 279 createDirectory allowedDir 280 createDirectory (dir ++ "/foobar") 281 writeFile bypassPath "secret" 282 let perms = defaultPerms { allowRead = [allowedDir] } 283 result <- fmap fst $ runActionWith perms Leaf Leaf (actionT 20 (ofString bypassPath)) 284 result @?= ioErrResult "permission denied" 285 286 -- Pure test 287 , testCase "pure performs no effects" $ do 288 final <- runAction (actionT 0 (ofString "abc")) 289 final @?= ofString "abc" 290 291 -- Reader tests 292 , testCase "ask returns initial environment" $ do 293 final <- runIOSourceWithEnv unsafePerms (ofString "dev") $ 294 unlines 295 [ "main = io (bind ask (env : pure env))" 296 ] 297 final @?= ofString "dev" 298 299 , testCase "local transforms environment" $ do 300 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 301 unlines 302 [ "main = io (local (env : append env \"-local\") (bind ask (env : pure env)))" 303 ] 304 final @?= ofString "root-local" 305 306 , testCase "local restores environment afterward" $ do 307 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 308 unlines 309 [ "main = io (bind ask (before :" 310 , " bind (local (env : append env \"-local\") (bind ask (env : pure env))) (inside :" 311 , " bind ask (after :" 312 , " pure (pair before (pair inside after))))))" 313 ] 314 final @?= Fork (ofString "root") (Fork (ofString "root-local") (ofString "root")) 315 316 , testCase "nested local composes correctly" $ do 317 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 318 unlines 319 [ "f = x : append x \"-f\"" 320 , "g = x : append x \"-g\"" 321 , "main = io (bind" 322 , " (local f (local g (bind ask (env : pure env))))" 323 , " (inner :" 324 , " bind ask (after :" 325 , " pure (pair inner after))))" 326 ] 327 final @?= Fork (ofString "root-f-g") (ofString "root") 328 329 , testCase "local result passes through bind correctly" $ do 330 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 331 unlines 332 [ "main = io (bind" 333 , " (local (env : append env \"-local\") (pure \"value\"))" 334 , " (x : pure x))" 335 ] 336 final @?= ofString "value" 337 338 , testCase "IO inside local uses transformed environment and restores after" $ do 339 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 340 unlines 341 [ "main = io (bind" 342 , " (local (env : append env \"-local\")" 343 , " (bind ask (env : pure env)))" 344 , " (result :" 345 , " bind ask (after :" 346 , " pure (pair result after))))" 347 ] 348 final @?= Fork (ofString "root-local") (ofString "root") 349 350 , testCase "local does not affect outer bind continuation" $ do 351 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 352 unlines 353 [ "main = io (bind" 354 , " (local (env : append env \"-local\") (pure \"x\"))" 355 , " (_ : bind ask (env : pure env)))" 356 ] 357 final @?= ofString "root" 358 359 , testCase "local environment persists across inner binds" $ do 360 final <- runIOSourceWithEnv unsafePerms (ofString "root") $ 361 unlines 362 [ "main = io (local (env : append env \"-local\")" 363 , " (bind (pure t) (_ :" 364 , " bind ask (env : pure env))))" 365 ] 366 final @?= ofString "root-local" 367 368 , testCase "local restores environment when scoped action returns error value" $ do 369 final <- runIOSourceWithEnv defaultPerms (ofString "root") $ 370 unlines 371 [ "main = io (bind" 372 , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))" 373 , " (_ : bind ask (env : pure env)))" 374 ] 375 final @?= ofString "root" 376 377 -- State tests 378 , testCase "get returns initial state" $ do 379 (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 42) $ 380 unlines 381 [ "main = io (bind get (s : pure s))" 382 ] 383 final @?= ofNumber 42 384 st @?= ofNumber 42 385 386 , testCase "put updates state" $ do 387 (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $ 388 unlines 389 [ "main = io (bind (put 100) (_ : bind get (s : pure s)))" 390 ] 391 final @?= ofNumber 100 392 st @?= ofNumber 100 393 394 , testCase "state persists through bind" $ do 395 (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 5) $ 396 unlines 397 [ "main = io (bind get (s1 :" 398 , " bind (put (succ s1)) (_ :" 399 , " bind get (s2 :" 400 , " pure (pair s1 s2)))))" 401 ] 402 final @?= Fork (ofNumber 5) (ofNumber 6) 403 st @?= ofNumber 6 404 405 , testCase "local does not restore state" $ do 406 (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $ 407 unlines 408 [ "main = io (bind (put 10) (_ :" 409 , " bind (local (env : env) (put 20)) (_ :" 410 , " bind get (s :" 411 , " pure s))))" 412 ] 413 final @?= ofNumber 20 414 st @?= ofNumber 20 415 416 , testCase "state and reader are independent" $ do 417 (final, st) <- runIOSourceWith unsafePerms (ofString "hello") (ofNumber 42) $ 418 unlines 419 [ "main = io (bind ask (env :" 420 , " bind get (s :" 421 , " pure (pair env s))))" 422 ] 423 final @?= Fork (ofString "hello") (ofNumber 42) 424 st @?= ofNumber 42 425 426 -- Async tests 427 , testCase "fork returns handle and await returns child value" $ do 428 (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ 429 unlines 430 [ "main = io (bind (fork (pure \"child\")) (h :" 431 , " await h))" 432 ] 433 final @?= ofString "child" 434 st @?= Leaf 435 436 , testCase "main completion abandons unawaited child" $ do 437 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 438 unlines 439 [ "main = io (bind (fork (pure \"child\")) (_ :" 440 , " pure \"main\"))" 441 ] 442 final @?= ofString "main" 443 444 , testCase "fork captures reader environment at fork point" $ do 445 (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $ 446 unlines 447 [ "main = io (local (env : append env \"-local\")" 448 , " (bind (fork (bind ask (env : pure env))) (h :" 449 , " await h)))" 450 ] 451 final @?= ofString "root-local" 452 453 , testCase "fork inside local captures child env and parent restores env" $ do 454 (final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $ 455 unlines 456 [ "main = io (bind" 457 , " (local (env : append env \"-local\")" 458 , " (fork (bind ask (env : pure env))))" 459 , " (h : bind ask (after :" 460 , " bind (await h) (child :" 461 , " pure (pair after child)))))" 462 ] 463 final @?= Fork (ofString "root") (ofString "root-local") 464 465 , testCase "fork copies state and child state does not merge" $ do 466 (final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $ 467 unlines 468 [ "main = io (bind (put 1) (_ :" 469 , " bind (fork (bind (put 99) (_ : bind get (s : pure s)))) (h :" 470 , " bind (put 2) (_ :" 471 , " bind (await h) (childState :" 472 , " bind get (parentState :" 473 , " pure (pair childState parentState)))))))" 474 ] 475 final @?= Fork (ofNumber 99) (ofNumber 2) 476 st @?= ofNumber 2 477 478 , testCase "multiple awaiters receive same completed value" $ do 479 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 480 unlines 481 [ "main = io (bind (fork (pure \"done\")) (h :" 482 , " bind (await h) (a :" 483 , " bind (await h) (b :" 484 , " pure (pair a b)))))" 485 ] 486 final @?= Fork (ofString "done") (ofString "done") 487 488 , testCase "self await returns async error" $ do 489 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 490 unlines 491 [ "main = io (await (pair \"task\" 0))" 492 ] 493 final @?= ioErrResult "self await" 494 495 , testCase "await invalid handle returns async error" $ do 496 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 497 unlines 498 [ "main = io (await 123)" 499 ] 500 final @?= ioErrResult "invalid task handle" 501 502 , testCase "yield returns unit and resumes continuation" $ do 503 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 504 unlines 505 [ "main = io (bind yield (_ : pure \"after\"))" 506 ] 507 final @?= ofString "after" 508 509 , testCase "sleep resumes continuation" $ do 510 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 511 unlines 512 [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" 513 ] 514 final @?= ofString "awake" 515 516 , testCase "await waits for sleeping child" $ do 517 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 518 unlines 519 [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"awake\"))) (h :" 520 , " await h))" 521 ] 522 final @?= ofString "awake" 523 524 , testCase "await waits for sleeping child and returns child value" $ do 525 (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ 526 unlines 527 [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :" 528 , " await h))" 529 ] 530 final @?= ofString "child done" 531 st @?= Leaf 532 533 , testCase "sleep inside bind resumes as unit" $ do 534 (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ 535 unlines 536 [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" 537 ] 538 final @?= ofString "awake" 539 st @?= Leaf 540 541 , testCase "fork await returns child value" $ do 542 (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ 543 unlines 544 [ "main = io (bind (fork (pure \"child done\")) (h :" 545 , " await h))" 546 ] 547 final @?= ofString "child done" 548 st @?= Leaf 549 550 -- Scheduler hardening tests 551 , testCase "runIO rejects non-IO tree with sentinel error" $ do 552 result <- runIO unsafePerms (ofString "not an io program") 553 case result of 554 Left _ -> return () 555 Right _ -> assertFailure "Expected Left for invalid sentinel" 556 557 , testCase "cyclic await returns error instead of hanging" $ do 558 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 559 unlines 560 [ "main = io (bind (fork (await (pair \"task\" 0))) (h :" 561 , " await h))" 562 ] 563 final @?= ioErrResult "cyclic await" 564 565 , testCase "source file UTF-8 returns exact bytes and scalar characters" $ 566 withSystemTempDirectory "tricu-source-utf8" $ \dir -> do 567 let path = dir ++ "/source.tri" 568 samples = ["main = 42\n", "-- \233\8364\128512\nmain = \"\233\8364\128512\"\n", 569 "-- embedded \xfeff and decomposed e\x301\r\n", 570 "\0\x80\x7ff\x800\xd7ff\xe000\xffff\x10000\x10ffff"] 571 forM_ samples $ \text -> do 572 let bytes = encodeUtf8 (pack text) 573 BS.writeFile path bytes 574 let action = Fork (ofNumber 37) (ofString path) 575 program = Fork (ofString "tricuIO") (Fork (ofNumber 1) action) 576 actual <- runIO unsafePerms program 577 actual @?= Right (ioOkResult (Fork (ofBytes bytes) (ofString text))) 578 binary <- runIO unsafePerms 579 (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 20) (ofString path)))) 580 binary @?= Right (ioOkResult (ofBytes bytes)) 581 encoded <- runIO unsafePerms 582 (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) (ofString text)))) 583 encoded @?= Right (ioOkResult (ofBytes bytes)) 584 585 , testCase "source UTF-8 rejects malformed sequences and initial BOM" $ 586 withSystemTempDirectory "tricu-source-invalid" $ \dir -> do 587 let path = dir ++ "/bad.tri" 588 malformed = [[0x80], [0xc0,0xaf], [0xc1,0xbf], [0xc2], [0xe2,0x82], 589 [0xf0,0x9f,0x98], [0xe0,0x80,0xaf], [0xed,0xa0,0x80], 590 [0xf0,0x80,0x80,0xaf], [0xf4,0x90,0x80,0x80], 591 [0xf5,0x80,0x80,0x80], [0xff], [0xc2,0x41], [0xef,0xbb,0xbf]] 592 forM_ malformed $ \bytes -> do 593 BS.writeFile path (BS.pack bytes) 594 actual <- runIO unsafePerms 595 (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString path)))) 596 case actual of 597 Right (Fork Leaf (Fork diagnostic Leaf)) -> case toString diagnostic of 598 Right message -> do 599 assertBool "source path in diagnostic" (path `isInfixOf` message) 600 assertBool "UTF-8 diagnostic" ("UTF-8" `isInfixOf` message) 601 _ -> assertFailure "non-string diagnostic" 602 _ -> assertFailure ("accepted malformed source: " ++ show bytes) 603 604 , testCase "source read permission and scalar encoding controls" $ do 605 denied <- runIO defaultPerms 606 (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 37) (ofString "denied.tri")))) 607 case denied of 608 Right (Fork Leaf _) -> pure () 609 _ -> assertFailure "source read bypassed permission" 610 forM_ [0xd800, 0xdfff, 0x110000] $ \scalar -> do 611 actual <- runIO unsafePerms 612 (Fork (ofString "tricuIO") (Fork (ofNumber 1) 613 (Fork (ofNumber 38) (ofList [ofNumber scalar])))) 614 actual @?= Right (ioErrResult "invalid source scalar list") 615 616 , testCase "source encoder rejects improper lists and noncanonical scalar naturals" $ do 617 forM_ [Stem Leaf, Fork (ofNumber 65) (Stem Leaf), 618 ofList [Fork Leaf Leaf], ofList [Fork (Stem Leaf) (Fork Leaf Leaf)]] $ \value -> do 619 actual <- runIO unsafePerms 620 (Fork (ofString "tricuIO") (Fork (ofNumber 1) (Fork (ofNumber 38) value))) 621 actual @?= Right (ioErrResult "invalid source scalar list") 622 623 , testCase "writeBytes and readFile roundtrip binary data" $ 624 withSystemTempDirectory "tricu-io-bytes" $ \dir -> do 625 let path = dir ++ "/binary.bin" 626 final <- runIOSource $ 627 unlines 628 [ "main = io (bind (writeBytes \"" ++ path ++ "\" [(0) (255) (128) (1)])" 629 , " (_ : readFile \"" ++ path ++ "\"))" 630 ] 631 final @?= ioOkResult (ofBytes (BS.pack [0, 255, 128, 1])) 632 633 , testCase "stress test: many concurrent sleepers complete promptly" $ do 634 let n = 5000 635 (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $ 636 unlines 637 [ "spawner = y (self n acc : if (equal? n 0) (pure acc) (bind (fork (sleep 1)) (h : self (pred n) (pair h acc))))" 638 , "awaitAll = y (self hs : matchList (pure \"done\") (h r : bind (await h) (_ : self r)) hs)" 639 , "main = io (bind (spawner " ++ show n ++ " t) (hs : awaitAll hs))" 640 ] 641 final @?= ofString "done" 642 643 , testCase "long fork await loop does not leak" $ do 644 let awaited = actionT 1 (Fork (actionT 60 (actionT 0 (ofString "x"))) 645 (fixtureExports "io" Map.! "await")) 646 action = foldr (\_ next -> thenAction awaited next) (actionT 0 (ofString "done")) [1..200 :: Int] 647 (final, _) <- runActionWith unsafePerms Leaf Leaf action 648 final @?= ofString "done" 649 650 , testGroup "Socket primitives" 651 [ testCase "socket returns ok result with valid handle" $ do 652 final <- runIOSource "main = io socket" 653 final @?= ioOkResult (Fork (ofString "sock") (ofNumber 0)) 654 655 , testCase "closeSocket on invalid handle returns error" $ do 656 final <- runIOSource "main = io (closeSocket (pair \"sock\" 99999))" 657 final @?= ioErrResult "invalid socket handle" 658 659 , testCase "bindSocket and listen succeed on loopback port 0" $ do 660 final <- runIOSource $ 661 unlines 662 [ "main = io (" 663 , " onOk socket (server rest :" 664 , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :" 665 , " bind (listen server 1) (listenResult :" 666 , " pure listenResult))))" 667 ] 668 final @?= ioOkResult Leaf 669 670 , testCase "connect to non-listening port returns error" $ do 671 final <- runIOSource "main = io (onOk socket (sock rest : connect sock \"127.0.0.1\" 1))" 672 case final of 673 Fork Leaf (Fork _ Leaf) -> return () 674 other -> assertFailure $ "Expected error result, got: " ++ show other 675 676 , testCase "accept and recv receive bytes from forked client" $ 677 withFreePort $ \port -> do 678 final <- runIOSource $ 679 unlines 680 [ "client = port :" 681 , " onOk socket (sock rest :" 682 , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" 683 , " send sock [104 105]))" 684 , "" 685 , "main = io (" 686 , " onOk socket (server rest :" 687 , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" 688 , " onOk (listen server 1) (_ rest :" 689 , " bind (fork (client " ++ show port ++ ")) (_ :" 690 , " onOk (accept server) (accepted rest :" 691 , " recv (fst accepted) 2))))))" 692 ] 693 final @?= ioOkResult (ofBytes (BS.pack [104, 105])) 694 695 , testCase "client recv receives server response via accepted socket" $ 696 withFreePort $ \port -> do 697 final <- runIOSource $ 698 unlines 699 [ "serverTask = (server :" 700 , " onOk (accept server) (accepted rest :" 701 , " onOk (recv (fst accepted) 4) (msg rest :" 702 , " send (fst accepted) [112 111 110 103])))" 703 , "" 704 , "clientTask = (port :" 705 , " onOk socket (sock rest :" 706 , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" 707 , " bind (send sock [112 105 110 103]) (_ :" 708 , " recv sock 4))))" 709 , "" 710 , "main = io (" 711 , " onOk socket (server rest :" 712 , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" 713 , " onOk (listen server 1) (_ rest :" 714 , " bind (fork (serverTask server)) (_ :" 715 , " clientTask " ++ show port ++ ")))))" 716 ] 717 final @?= ioOkResult (ofBytes (BS.pack [112, 111, 110, 103])) 718 719 , testCase "recv on closed peer returns connection closed" $ 720 withFreePort $ \port -> do 721 final <- runIOSource $ 722 unlines 723 [ "clientTask = port :" 724 , " onOk socket (sock rest :" 725 , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" 726 , " closeSocket sock))" 727 , "" 728 , "main = io (" 729 , " onOk socket (server rest :" 730 , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" 731 , " onOk (listen server 1) (_ rest :" 732 , " bind (fork (clientTask " ++ show port ++ ")) (_ :" 733 , " onOk (accept server) (accepted rest :" 734 , " bind (yield) (_ :" 735 , " recv (fst accepted) 1)))))))" 736 ] 737 final @?= ioErrResult "connection closed" 738 739 , testCase "accept invalid socket handle returns error" $ do 740 final <- runIOSource "main = io (accept (pair \"sock\" 99999))" 741 final @?= ioErrResult "invalid socket handle" 742 743 , testCase "recv invalid socket handle returns error" $ do 744 final <- runIOSource "main = io (recv (pair \"sock\" 99999) 1)" 745 final @?= ioErrResult "invalid socket handle" 746 747 , testCase "send invalid socket handle returns error" $ do 748 final <- runIOSource "main = io (send (pair \"sock\" 99999) [(1)])" 749 final @?= ioErrResult "invalid socket handle" 750 751 , testCase "socket conveniences close acquired handles on failures and preserve replies" $ do 752 let env = fixtureExports "socket" 753 let call name = foldl apply (env Map.! name) 754 sock = ofNumber 7 755 primitive tag payload = Fork (ofNumber tag) payload 756 create = primitive 70 Leaf 757 close = primitive 71 sock 758 address = ofString "127.0.0.1" 759 port = ofNumber 9050 760 bound = primitive 72 (Fork sock (Fork address port)) 761 listening = primitive 73 (Fork sock (ofNumber 128)) 762 connected = primitive 75 (Fork sock (Fork address port)) 763 acquired = parserOk sock (ofNumber 23) 764 ready = parserOk (ofNumber 19) (ofNumber 29) 765 failed = parserErr (ofString "denied") (ofString "opaque remainder") 766 closeFailed = parserErr (ofString "close failed") (ofNumber 41) 767 listener = call "listenSocket" [address, port, ofNumber 128] 768 client = call "connectTo" [address, port] 769 forM_ [listener, client] $ \action -> 770 runScriptedEffects action [(create, failed)] >>= (@?= failed) 771 runScriptedEffects listener [(create, acquired), (bound, ready), (listening, ready)] 772 >>= (@?= parserOk sock Leaf) 773 runScriptedEffects client [(create, acquired), (connected, ready)] 774 >>= (@?= parserOk sock (ofNumber 29)) 775 forM_ [ready, closeFailed] $ \closed -> do 776 runScriptedEffects listener [(create, acquired), (bound, failed), (close, closed)] 777 >>= (@?= failed) 778 runScriptedEffects listener [(create, acquired), (bound, ready), (listening, failed), (close, closed)] 779 >>= (@?= failed) 780 runScriptedEffects client [(create, acquired), (connected, failed), (close, closed)] 781 >>= (@?= failed) 782 783 , testCase "listenSocket creates a live listener whose ownership transfers to the caller" $ do 784 final <- runIOSource "main = io (onOk_ (listenSocket \"127.0.0.1\" 0 1) (server : finally (getSocketName server) (closeSocket_ server)))" 785 case final of 786 Fork (Stem Leaf) (Fork value Leaf) -> case toNumber value of 787 Right port -> assertBool "positive bound port" (port > 0) 788 Left problem -> assertFailure problem 789 other -> assertFailure $ "expected bound port: " ++ show other 790 791 , testCase "getSocketName returns positive port after bind 0" $ do 792 final <- runIOSource $ 793 unlines 794 [ "main = io (" 795 , " onOk socket (server rest :" 796 , " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :" 797 , " bind (getSocketName server) (nameResult :" 798 , " pure nameResult))))" 799 ] 800 case final of 801 Fork (Stem Leaf) (Fork val Leaf) -> 802 case toNumber val of 803 Right port | port > 0 -> return () 804 Right 0 -> assertFailure "Expected positive port, got 0" 805 Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val 806 other -> assertFailure $ "Expected ok result, got: " ++ show other 807 808 , testCase "connectTo creates connected socket" $ 809 withFreePort $ \port -> do 810 final <- runIOSource $ 811 unlines 812 [ "clientTask = port :" 813 , " onOk (connectTo \"127.0.0.1\" port) (client rest :" 814 , " onOk (send client [104 105]) (_ rest :" 815 , " pure t))" 816 , "" 817 , "main = io (" 818 , " onOk socket (server rest :" 819 , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" 820 , " onOk (listen server 1) (_ rest :" 821 , " bind (fork (clientTask " ++ show port ++ ")) (_ :" 822 , " onOk (accept server) (accepted rest :" 823 , " onOk (recv (fst accepted) 2) (msg rest :" 824 , " pure msg)))))))" 825 ] 826 final @?= ofBytes (BS.pack [104, 105]) 827 828 , testCase "serveOnce handles a single client connection" $ 829 withFreePort $ \port -> do 830 final <- runIOSource $ 831 unlines 832 [ "echoHandler = (client peer :" 833 , " onOk (recv client 2) (msg rest :" 834 , " onOk (send client msg) (_ rest :" 835 , " pure t)))" 836 , "" 837 , "clientTask = (port :" 838 , " onOk socket (sock rest :" 839 , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" 840 , " onOk (send sock [104 105]) (_ rest :" 841 , " onOk (recv sock 2) (msg rest :" 842 , " pure msg)))))" 843 , "" 844 , "main = io (" 845 , " onOk socket (server rest :" 846 , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" 847 , " onOk (listen server 1) (_ rest :" 848 , " bind (fork (serveOnce server echoHandler)) (_ :" 849 , " clientTask " ++ show port ++ ")))))" 850 ] 851 final @?= ofBytes (BS.pack [104, 105]) 852 853 , testCase "finally preserves successful action result" $ do 854 final <- runIOSource $ 855 unlines 856 [ "main = io (finally (pure 42) (pure 99))" 857 ] 858 final @?= ofNumber 42 859 860 , testCase "finally runs cleanup after successful action" $ 861 withSystemTempDirectory "tricu-finally" $ \dir -> do 862 let cleanupPath = dir ++ "/cleanup.txt" 863 final <- runIOSource $ 864 unlines 865 [ "main = io (finally" 866 , " (pure 42)" 867 , " (writeFile \"" ++ cleanupPath ++ "\" \"cleaned\"))" 868 ] 869 final @?= ofNumber 42 870 contents <- readFile cleanupPath 871 contents @?= "cleaned" 872 873 , testCase "bracket passes acquired resource to use" $ do 874 final <- runIOSource $ 875 unlines 876 [ "main = io (bracket (pure (ok 41 7)) (_ : pure t) (r : pure (succ r)))" 877 ] 878 final @?= ofNumber 42 879 880 , testCase "bracket preserves successful use result over release result" $ do 881 final <- runIOSource $ 882 unlines 883 [ "main = io (bracket (pure (ok \"res\" 7)) (_ : pure 123) (_ : pure 99))" 884 ] 885 final @?= ofNumber 99 886 887 , testCase "bracket runs release on successful use" $ 888 withSystemTempDirectory "tricu-bracket" $ \dir -> do 889 let releasePath = dir ++ "/release.txt" 890 final <- runIOSource $ 891 unlines 892 [ "main = io (bracket" 893 , " (pure (ok \"" ++ releasePath ++ "\" 7))" 894 , " (path : writeFile path \"released\")" 895 , " (path : pure 99))" 896 ] 897 final @?= ofNumber 99 898 contents <- readFile releasePath 899 contents @?= "released" 900 901 , testCase "bracket passes acquired resource to release" $ 902 withSystemTempDirectory "tricu-bracket-release-resource" $ \dir -> do 903 let releasePath = dir ++ "/release.txt" 904 final <- runIOSource $ 905 unlines 906 [ "main = io (bracket" 907 , " (pure (ok \"" ++ releasePath ++ "\" 7))" 908 , " (path : writeFile path \"released\")" 909 , " (_ : pure 99))" 910 ] 911 final @?= ofNumber 99 912 contents <- readFile releasePath 913 contents @?= "released" 914 915 -- Directory and file management primitives 916 , testGroup "listDirectory" 917 [ testCase "listDirectory returns entry names" $ 918 withSystemTempDirectory "tricu-listdir" $ \dir -> do 919 writeFile (dir ++ "/a.txt") "a" 920 writeFile (dir ++ "/b.txt") "b" 921 final <- runIOSource $ 922 unlines 923 [ "main = io (onListDirectory \"" ++ dir ++ "\"" 924 , " (err rest : pure false)" 925 , " (entries rest :" 926 , " pure (pair (lExist? \"a.txt\" entries) (lExist? \"b.txt\" entries))))" 927 ] 928 final @?= Fork (Stem Leaf) (Stem Leaf) 929 930 , testCase "listDirectory missing path returns does not exist" $ do 931 final <- runIOSource $ 932 unlines 933 [ "main = io (onListDirectory \"/nonexistent/path/12345\"" 934 , " (err rest : pure err)" 935 , " (_ rest : pure \"ok\"))" 936 ] 937 final @?= ofString "does not exist" 938 939 , testCase "listDirectory on file returns not a directory" $ 940 withSystemTempDirectory "tricu-listdir-file" $ \dir -> do 941 let path = dir ++ "/file.txt" 942 writeFile path "x" 943 final <- runIOSource $ 944 unlines 945 [ "main = io (onListDirectory \"" ++ path ++ "\"" 946 , " (err rest : pure err)" 947 , " (_ rest : pure \"ok\"))" 948 ] 949 final @?= ofString "not a directory" 950 951 , testCase "listDirectory denied path returns permission denied" $ 952 withSystemTempDirectory "tricu-listdir-denied" $ \dir -> do 953 let allowedDir = dir ++ "/allowed" 954 deniedDir = dir ++ "/denied" 955 createDirectory allowedDir 956 createDirectory deniedDir 957 let perms = defaultPerms { allowRead = [allowedDir] } 958 final <- runIOSourceWithPerms perms $ 959 unlines 960 [ "main = io (listDirectory \"" ++ deniedDir ++ "\")" 961 ] 962 final @?= ioErrResult "permission denied" 963 ] 964 965 , testCase "listDirectory excludes dot entries" $ 966 withSystemTempDirectory "tricu-listdir-dot" $ \dir -> do 967 final <- runIOSource $ 968 unlines 969 [ "main = io (onListDirectory \"" ++ dir ++ "\"" 970 , " (err rest : pure false)" 971 , " (entries rest :" 972 , " pure (pair (lExist? \".\" entries) (lExist? \"..\" entries))))" 973 ] 974 final @?= Fork Leaf Leaf 975 976 , testGroup "renameFile" 977 [ testCase "renameFile moves file atomically" $ 978 withSystemTempDirectory "tricu-rename" $ \dir -> do 979 let oldPath = dir ++ "/old.txt" 980 newPath = dir ++ "/new.txt" 981 writeFile oldPath "contents" 982 final <- runIOSource $ 983 unlines 984 [ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\"" 985 , " (err rest : pure err)" 986 , " (_ rest : pure \"ok\"))" 987 ] 988 final @?= ofString "ok" 989 newExists <- doesFileExist newPath 990 oldExists <- doesFileExist oldPath 991 newExists @?= True 992 oldExists @?= False 993 994 , testCase "renameFile missing source returns does not exist" $ do 995 final <- runIOSource $ 996 unlines 997 [ "main = io (onRenameFile \"/nonexistent/old.txt\" \"/nonexistent/new.txt\"" 998 , " (err rest : pure err)" 999 , " (_ rest : pure \"ok\"))" 1000 ] 1001 final @?= ofString "does not exist" 1002 1003 , testCase "renameFile denied destination returns permission denied" $ 1004 withSystemTempDirectory "tricu-rename-denied" $ \dir -> do 1005 let allowedDir = dir ++ "/allowed" 1006 deniedDir = dir ++ "/denied" 1007 createDirectory allowedDir 1008 createDirectory deniedDir 1009 let oldPath = allowedDir ++ "/old.txt" 1010 newPath = deniedDir ++ "/new.txt" 1011 writeFile oldPath "contents" 1012 let perms = defaultPerms { allowWrite = [allowedDir] } 1013 final <- runIOSourceWithPerms perms $ 1014 unlines 1015 [ "main = io (renameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\")" 1016 ] 1017 final @?= ioErrResult "permission denied" 1018 1019 , testCase "renameFile replaces existing destination atomically" $ 1020 withSystemTempDirectory "tricu-rename-replace" $ \dir -> do 1021 let oldPath = dir ++ "/old.txt" 1022 newPath = dir ++ "/new.txt" 1023 writeFile oldPath "new" 1024 writeFile newPath "old" 1025 final <- runIOSource $ 1026 unlines 1027 [ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\"" 1028 , " (err rest : pure err)" 1029 , " (_ rest : pure \"ok\"))" 1030 ] 1031 final @?= ofString "ok" 1032 readFile newPath >>= (@?= "new") 1033 oldExists <- doesFileExist oldPath 1034 oldExists @?= False 1035 ] 1036 1037 , testGroup "createDirectory" 1038 [ testCase "createDirectory creates new directory" $ 1039 withSystemTempDirectory "tricu-mkdir" $ \dir -> do 1040 let newDir = dir ++ "/subdir" 1041 final <- runIOSource $ 1042 unlines 1043 [ "main = io (onCreateDirectory \"" ++ newDir ++ "\"" 1044 , " (err rest : pure err)" 1045 , " (_ rest : pure \"ok\"))" 1046 ] 1047 final @?= ofString "ok" 1048 exists <- doesDirectoryExist newDir 1049 exists @?= True 1050 1051 , testCase "createDirectory is idempotent for existing directory" $ 1052 withSystemTempDirectory "tricu-mkdir-idempotent" $ \dir -> do 1053 let existingDir = dir ++ "/exists" 1054 createDirectory existingDir 1055 final <- runIOSource $ 1056 unlines 1057 [ "main = io (onCreateDirectory \"" ++ existingDir ++ "\"" 1058 , " (err rest : pure err)" 1059 , " (_ rest : pure \"ok\"))" 1060 ] 1061 final @?= ofString "ok" 1062 1063 , testCase "createDirectory on existing file returns already exists" $ 1064 withSystemTempDirectory "tricu-mkdir-file" $ \dir -> do 1065 let path = dir ++ "/file.txt" 1066 writeFile path "x" 1067 final <- runIOSource $ 1068 unlines 1069 [ "main = io (onCreateDirectory \"" ++ path ++ "\"" 1070 , " (err rest : pure err)" 1071 , " (_ rest : pure \"ok\"))" 1072 ] 1073 final @?= ofString "already exists" 1074 1075 , testCase "createDirectory missing parent returns does not exist" $ do 1076 final <- runIOSource $ 1077 unlines 1078 [ "main = io (onCreateDirectory \"/nonexistent/path/12345/sub\"" 1079 , " (err rest : pure err)" 1080 , " (_ rest : pure \"ok\"))" 1081 ] 1082 final @?= ofString "does not exist" 1083 1084 , testCase "createDirectory denied path returns permission denied" $ 1085 withSystemTempDirectory "tricu-mkdir-denied" $ \dir -> do 1086 let allowedDir = dir ++ "/allowed" 1087 deniedDir = dir ++ "/denied" 1088 createDirectory allowedDir 1089 createDirectory deniedDir 1090 let perms = defaultPerms { allowWrite = [allowedDir] } 1091 final <- runIOSourceWithPerms perms $ 1092 unlines 1093 [ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")" 1094 ] 1095 final @?= ioErrResult "permission denied" 1096 , testCase "createDirectory with file parent returns not a directory or does not exist" $ 1097 withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do 1098 let parentFile = dir ++ "/file" 1099 child = parentFile ++ "/sub" 1100 writeFile parentFile "x" 1101 final <- runIOSource $ 1102 unlines 1103 [ "main = io (onCreateDirectory \"" ++ child ++ "\"" 1104 , " (err rest : pure err)" 1105 , " (_ rest : pure \"ok\"))" 1106 ] 1107 final @?= ofString "not a directory" 1108 ] 1109 1110 , testGroup "deleteFile" 1111 [ testCase "deleteFile removes file" $ 1112 withSystemTempDirectory "tricu-delete" $ \dir -> do 1113 let path = dir ++ "/del.txt" 1114 writeFile path "x" 1115 final <- runIOSource $ 1116 unlines 1117 [ "main = io (onDeleteFile \"" ++ path ++ "\"" 1118 , " (err rest : pure err)" 1119 , " (_ rest : pure \"ok\"))" 1120 ] 1121 final @?= ofString "ok" 1122 exists <- doesFileExist path 1123 exists @?= False 1124 1125 , testCase "deleteFile is idempotent for missing file" $ do 1126 final <- runIOSource $ 1127 unlines 1128 [ "main = io (onDeleteFile \"/nonexistent/path/12345.txt\"" 1129 , " (err rest : pure err)" 1130 , " (_ rest : pure \"ok\"))" 1131 ] 1132 final @?= ofString "ok" 1133 1134 , testCase "deleteFile on directory returns is a directory" $ 1135 withSystemTempDirectory "tricu-delete-dir" $ \dir -> do 1136 let subDir = dir ++ "/subdir" 1137 createDirectory subDir 1138 final <- runIOSource $ 1139 unlines 1140 [ "main = io (onDeleteFile \"" ++ subDir ++ "\"" 1141 , " (err rest : pure err)" 1142 , " (_ rest : pure \"ok\"))" 1143 ] 1144 final @?= ofString "is a directory" 1145 1146 , testCase "deleteFile denied path returns permission denied" $ 1147 withSystemTempDirectory "tricu-delete-denied" $ \dir -> do 1148 let allowedDir = dir ++ "/allowed" 1149 deniedDir = dir ++ "/denied" 1150 createDirectory allowedDir 1151 createDirectory deniedDir 1152 let path = deniedDir ++ "/file.txt" 1153 writeFile path "x" 1154 let perms = defaultPerms { allowWrite = [allowedDir] } 1155 final <- fmap fst $ runActionWith perms Leaf Leaf (actionT 26 (ofString path)) 1156 final @?= ioErrResult "permission denied" 1157 ] 1158 1159 , testGroup "fileExists" 1160 [ testCase "fileExists true for existing file" $ 1161 withSystemTempDirectory "tricu-exists" $ \dir -> do 1162 let path = dir ++ "/file.txt" 1163 writeFile path "x" 1164 final <- runIOSource $ 1165 unlines 1166 [ "main = io (onFileExists \"" ++ path ++ "\"" 1167 , " (err rest : pure err)" 1168 , " (exists rest : pure exists))" 1169 ] 1170 final @?= Stem Leaf 1171 1172 , testCase "fileExists false for missing path" $ do 1173 final <- runIOSource $ 1174 unlines 1175 [ "main = io (onFileExists \"/nonexistent/path/12345.txt\"" 1176 , " (err rest : pure err)" 1177 , " (exists rest : pure exists))" 1178 ] 1179 final @?= Leaf 1180 1181 , testCase "fileExists denied path returns permission denied" $ 1182 withSystemTempDirectory "tricu-exists-denied" $ \dir -> do 1183 let allowedDir = dir ++ "/allowed" 1184 deniedDir = dir ++ "/denied" 1185 createDirectory allowedDir 1186 createDirectory deniedDir 1187 let path = deniedDir ++ "/file.txt" 1188 writeFile path "x" 1189 let perms = defaultPerms { allowRead = [allowedDir] } 1190 final <- fmap fst $ runActionWith perms Leaf Leaf (actionT 27 (ofString path)) 1191 final @?= ioErrResult "permission denied" 1192 ] 1193 1194 , testGroup "sha256Hex" 1195 [ testCase "sha256Hex returns lowercase hex digest" $ do 1196 final <- runIOSource $ 1197 unlines 1198 [ "main = io (onSha256Hex [(104) (105)]" 1199 , " (err rest : pure err)" 1200 , " (hex rest : pure hex))" 1201 ] 1202 final @?= ofString "8f434346648f6b96df89dda901c5176b10a6d83961dd3c1ac88b59b2dc327aa4" 1203 1204 , testCase "sha256Hex empty bytes returns empty digest" $ do 1205 final <- runIOSource $ 1206 unlines 1207 [ "main = io (onSha256Hex []" 1208 , " (err rest : pure err)" 1209 , " (hex rest : pure hex))" 1210 ] 1211 final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 1212 1213 , testCase "sha256Hex hashes raw bytes" $ do 1214 final <- runIOSource $ 1215 unlines 1216 [ "main = io (onSha256Hex [(0) (255) (1)]" 1217 , " (err rest : pure err)" 1218 , " (hex rest : pure hex))" 1219 ] 1220 final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123" 1221 ] 1222 1223 , testGroup "currentTime" 1224 [ testCase "currentTime returns a positive integer" $ do 1225 final <- runIOSource $ 1226 unlines 1227 [ "main = io (onCurrentTime" 1228 , " (err rest : pure 0)" 1229 , " (v rest : pure v))" 1230 ] 1231 case toNumber final of 1232 Right n | n > 1600000000 -> return () -- after ~Sep 2020 1233 Right n -> assertFailure $ "Expected recent timestamp, got: " ++ show n 1234 Left err -> assertFailure $ "Expected number, got error: " ++ err 1235 ] 1236 ] 1237 ] 1238 1239 withFreePort :: (Int -> IO a) -> IO a 1240 withFreePort action = 1241 bracket 1242 (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) 1243 NS.close 1244 (\s -> do 1245 NS.setSocketOption s NS.ReuseAddr 1 1246 NS.bind s (NS.SockAddrInet 0 (NS.tupleToHostAddress (127, 0, 0, 1))) 1247 port <- NS.socketPort s 1248 action (fromIntegral port)) 1249 1250 -- Explicit IO/prelude/socket interfaces only; the retained portable compiler 1251 -- owns source sequencing. No ambient imports, recovery kernel or source loader. 1252 compileIO :: String -> IO T 1253 compileIO source = do 1254 env <- compileFixtureDefinitions (Map.unions (map fixtureExports ["io", "prelude", "socket"])) source 1255 maybe (assertFailure "IO program has no main" >> pure Leaf) pure (Map.lookup "main" env) 1256 1257 runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T) 1258 runIOSourceWith perms readerEnv initialState source = do 1259 fullTree <- compileIO source 1260 runEnvelopeWith perms readerEnv initialState fullTree 1261 1262 -- Direct ABI construction is independent of the library/compiler under test. 1263 actionT :: Integer -> T -> T 1264 actionT tag = Fork (ofNumber tag) 1265 envelope :: T -> T 1266 envelope action = Fork (ofString "tricuIO") (Fork (ofNumber 1) action) 1267 thenAction :: T -> T -> T 1268 thenAction left right = actionT 1 (Fork left (Fork Leaf right)) 1269 1270 runEnvelopeWith :: IOPermissions -> T -> T -> T -> IO (T, T) 1271 runEnvelopeWith perms readerEnv initialState fullTree = do 1272 result <- runIOWith perms readerEnv initialState fullTree 1273 case result of 1274 Left err -> assertFailure ("IO runtime error: " ++ err) 1275 Right pair -> pure pair 1276 1277 runActionWith :: IOPermissions -> T -> T -> T -> IO (T, T) 1278 runActionWith perms readerEnv initialState = runEnvelopeWith perms readerEnv initialState . envelope 1279 runAction :: T -> IO T 1280 runAction = fmap fst . runActionWith unsafePerms Leaf Leaf 1281 1282 runIOSource :: String -> IO T 1283 runIOSource source = fmap fst $ runIOSourceWith unsafePerms Leaf Leaf source 1284 1285 runIOSourceWithPerms :: IOPermissions -> String -> IO T 1286 runIOSourceWithPerms perms source = fmap fst $ runIOSourceWith perms Leaf Leaf source 1287 1288 runIOSourceWithEnv :: IOPermissions -> T -> String -> IO T 1289 runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms readerEnv Leaf source 1290 1291 ioOkResult :: T -> T 1292 ioOkResult val = Fork (Stem Leaf) (Fork val Leaf) 1293 1294 ioErrResult :: String -> T 1295 ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf) 1296 1297 parserOk, parserErr :: T -> T -> T 1298 parserOk value rest = Fork (Stem Leaf) (Fork value rest) 1299 parserErr diagnostic rest = Fork Leaf (Fork diagnostic rest)