IOStandardTests.hs (7804B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOStandardTests (ioStandardTests) where 3 4 import qualified IO.Resources as R 5 import qualified Data.ByteString as BS 6 import Control.Concurrent 7 import Control.Concurrent.STM 8 import GHC.Conc (threadStatus, ThreadStatus(..)) 9 import Control.Exception 10 import Control.Monad 11 import System.IO 12 import System.IO.Temp 13 import System.Posix.IO (createPipe, fdToHandle) 14 import System.Timeout (timeout) 15 import Test.Tasty 16 import Test.Tasty.HUnit 17 18 right :: Show e => Either e a -> IO a 19 right = either (\e -> assertFailure (show e) >> error "assertion") pure 20 category name result = case result of 21 Left p -> R.category p @?= name 22 _ -> assertFailure ("expected " ++ name) 23 pipe = bracket (createPipe >>= \(r,w) -> (,) <$> fdToHandle r <*> fdToHandle w) 24 (\(r,w) -> hClose r >> (hClose w `catch` (\(_ :: IOException) -> pure ()))) 25 withStreams use = withSystemTempDirectory "v2-standard" $ \dir -> 26 bracket (openBinaryFile (dir++"/in") ReadWriteMode) hClose $ \input -> 27 bracket (openBinaryFile (dir++"/out") ReadWriteMode) hClose $ \output -> 28 bracket (openBinaryFile (dir++"/err") ReadWriteMode) hClose $ \diagnostic -> 29 bracket (R.newRuntimeWithStreams input output diagnostic) (\r -> void (R.closeScope r 0)) 30 (\r -> use r input output diagnostic) 31 32 ioStandardTests = localOption (mkTimeout 30000000) $ testGroup "IO inherited streams" 33 [ testCase "fixed aliases, root borrowing, no close or transfer, bounded entries" $ 34 withStreams $ \r _ output _ -> do 35 child <- R.childScope r 0 >>= right 36 token <- R.standardStream r child R.StandardOutput >>= right 37 replicateM_ 1000 (R.standardStream r 0 R.StandardOutput >>= (@?= Right token)) 38 R.liveCounts r >>= (@?= (2,3)) 39 R.closeResource r child token >>= category "borrowed-resource" 40 atomically (R.reserveChildSTM r 0 [token]) >>= category "borrowed-resource" 41 R.liveCounts r >>= (@?= (2,3)) 42 owned <- R.acquire r 0 (pure (R.Writer (pure . BS.length) (pure ()))) >>= right 43 atomically (R.reserveChildSTM r 0 [owned, token]) >>= category "borrowed-resource" 44 R.liveCounts r >>= (@?= (2,4)) 45 R.writeSome r 0 owned (BS.singleton 97) >>= (@?= Right 1) 46 R.closeResource r 0 owned >>= (@?= Right ()) 47 R.closeScope r child >>= (@?= []) 48 R.writeSome r 0 token (BS.pack [0,255,65]) >>= (@?= Right 3) 49 R.closeScope r 0 >>= (@?= []) 50 hIsClosed output >>= (@?= False) 51 hSeek output AbsoluteSeek 0 52 BS.hGet output 3 >>= (@?= BS.pack [0,255,65]) 53 R.writeSome r 0 token (BS.singleton 1) >>= category "stale-handle" 54 R.liveCounts r >>= (@?= (0,0)) 55 , testCase "first lookup during root joining remains available to existing children" $ 56 withStreams $ \r _ _ _ -> do 57 child <- R.childScope r 0 >>= right 58 atomically (R.beginCloseScopeSTM r 0) 59 token <- R.standardStream r child R.StandardError >>= right 60 R.writeSome r child token (BS.singleton 255) >>= (@?= Right 1) 61 R.closeScope r child >>= (@?= []) 62 R.standardStream r child R.StandardError >>= category "out-of-scope" 63 , testCase "binary reads, explicit EOF, wrong kinds and cross-run references" $ 64 withStreams $ \r input _ _ -> do 65 BS.hPut input (BS.pack [0,255,13,10]); hSeek input AbsoluteSeek 0 66 reader <- R.standardStream r 0 R.StandardInput >>= right 67 writer <- R.standardStream r 0 R.StandardOutput >>= right 68 R.readSome r 0 reader 4 >>= (@?= Right (BS.pack [0,255,13,10])) 69 R.readSome r 0 reader 1 >>= (@?= Right BS.empty) 70 R.readSome r 0 writer 1 >>= category "wrong-kind" 71 R.writeSome r 0 reader (BS.singleton 1) >>= category "wrong-kind" 72 withStreams $ \other _ _ _ -> R.readSome other 0 reader 1 >>= category "stale-handle" 73 , testCase "shared pending-read lease and cancellation leave inherited pipe open" $ 74 pipe $ \(input, producer) -> withStreams $ \_ _ output diagnostic -> 75 bracket (R.newRuntimeWithStreams input output diagnostic) (\r -> void (R.closeScope r 0)) $ \r -> do 76 reader <- R.standardStream r 0 R.StandardInput >>= right 77 started <- newEmptyMVar; finished <- newEmptyMVar 78 let work = putMVar started () >> void (R.readSome r 0 reader 1) 79 waitBlocked worker = do 80 status <- threadStatus worker 81 case status of ThreadBlocked _ -> pure (); _ -> yield >> waitBlocked worker 82 bracket (forkFinally work (\_ -> putMVar finished ())) 83 (\worker -> killThread worker >> void (timeout 3000000 (readMVar finished))) $ \worker -> do 84 takeMVar started 85 -- A second read cannot be used as the barrier: it could win the 86 -- race and block. Observe the actual worker's blocked state. 87 timeout 3000000 (waitBlocked worker) >>= (@?= Just ()) 88 alias <- R.standardStream r 0 R.StandardInput >>= right 89 R.readSome r 0 alias 1 >>= category "busy" 90 killThread worker 91 timeout 3000000 (readMVar finished) >>= (@?= Just ()) 92 BS.hPut producer (BS.singleton 97); hFlush producer 93 R.readSome r 0 reader 1 >>= (@?= Right (BS.singleton 97)) 94 R.closeScope r 0 >>= (@?= []) 95 hIsClosed input >>= (@?= False) 96 , testCase "cancelled blocked output poisons the borrowed writer without closing it" $ 97 pipe $ \(consumer, output) -> withStreams $ \_ input _ diagnostic -> 98 bracket (R.newRuntimeWithStreams input output diagnostic) (\r -> void (R.closeScope r 0)) $ \r -> do 99 writer <- R.standardStream r 0 R.StandardOutput >>= right 100 finished <- newEmptyMVar 101 let work = forever (R.writeSome r 0 writer (BS.replicate 4096 97) >>= right) 102 waitBlocked worker = do 103 status <- threadStatus worker 104 case status of ThreadBlocked _ -> pure (); _ -> yield >> waitBlocked worker 105 bracket (forkFinally work (\_ -> putMVar finished ())) 106 (\worker -> killThread worker >> void (timeout 3000000 (readMVar finished)) >> hClose consumer) $ \worker -> do 107 timeout 3000000 (waitBlocked worker) >>= (@?= Just ()) 108 alias <- R.standardStream r 0 R.StandardOutput >>= right 109 R.writeSome r 0 alias (BS.singleton 98) >>= category "busy" 110 killThread worker 111 timeout 3000000 (readMVar finished) >>= (@?= Just ()) 112 R.writeSome r 0 writer (BS.singleton 98) >>= category "invalid-state" 113 R.closeScope r 0 >>= (@?= []) 114 hIsClosed output >>= (@?= False) 115 , testCase "broken pipes report uncertain progress without closing inherited output" $ 116 pipe $ \(consumer, output) -> withStreams $ \_ input _ diagnostic -> do 117 hClose consumer 118 bracket (R.newRuntimeWithStreams input output diagnostic) (\r -> void (R.closeScope r 0)) $ \r -> do 119 writer <- R.standardStream r 0 R.StandardOutput >>= right 120 result <- R.writeSome r 0 writer (BS.singleton 97) 121 case result of 122 Left p -> do { R.category p @?= "io-error"; R.progress p @?= "unknown" } 123 Right _ -> assertFailure "broken pipe acknowledged" 124 R.writeSome r 0 writer (BS.singleton 98) >>= category "invalid-state" 125 hIsClosed output >>= (@?= False) 126 , testCase "output acknowledgement flushes without altering host buffering" $ 127 withStreams $ \r _ output _ -> do 128 hSetBuffering output (BlockBuffering (Just 8192)) 129 writer <- R.standardStream r 0 R.StandardOutput >>= right 130 R.writeSome r 0 writer (BS.pack [0,255]) >>= (@?= Right 2) 131 hGetBuffering output >>= (@?= BlockBuffering (Just 8192)) 132 hFileSize output >>= (@?= 2) 133 ]