IOProcessTests.hs (10928B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOProcessTests (ioProcessTests) where 3 import qualified IO.Process as P 4 import qualified IO.Driver as V 5 import qualified IO.Protocol as Protocol 6 import qualified IO.Resources as R 7 import qualified IO.Tasks as S 8 import Runtime (T(..), ofString, ofList, ofNumber) 9 import Control.Concurrent 10 import Control.Exception 11 import Data.IORef 12 import Control.Monad 13 import qualified Data.ByteString as BS 14 import qualified Data.ByteString.Char8 as B 15 import System.Directory (findExecutable) 16 import System.Posix.Signals (signalProcess, nullSignal) 17 import System.IO.Error (isDoesNotExistError) 18 import Test.Tasty 19 import Test.Tasty.HUnit 20 21 right (Right x) = pure x 22 right (Left e) = assertFailure (show e) >> error "failed" 23 withGroup action = do 24 runtime <- R.newRuntime 25 scheduler <- S.newScheduler runtime 26 group <- S.rootGroup scheduler 27 outcome <- S.runGroup group (action runtime group) 28 R.liveCounts runtime >>= (@?= (0,0)) 29 S.liveCounts scheduler >>= (@?= (0,0,0)) 30 pure outcome 31 success (S.Completed Leaf) = pure () 32 success other = assertFailure (show other) 33 program name = findExecutable name >>= maybe (assertFailure ("missing test executable: " ++ name) >> error "missing") pure 34 readAll runtime owner token = do 35 chunk <- R.readSome runtime owner token 4096 >>= right 36 if BS.null chunk then pure BS.empty else BS.append chunk <$> readAll runtime owner token 37 joined group task wanted = S.join group task >>= \value -> case value of 38 Right (S.Completed actual) -> actual @?= wanted 39 other -> assertFailure (show other) 40 exit n = ofList [ofString "exit",ofNumber n] 41 42 ioProcessTests = localOption (mkTimeout 15000000) $ testGroup "IO direct child processes" 43 [ testCase "argv is literal; environment and cwd are explicit; nonzero exit is data" $ do 44 shell <- program "sh" 45 withGroup (\runtime group -> do 46 (task,[input,output,errors]) <- P.launch runtime group 47 (P.Spec shell ["-c","printf '%s|%s|%s' \"$1\" \"$VALUE\" \"$PWD\"; exit 7", "test", "$(not-a-command); *"] (Just "/") (Just [("VALUE","literal")]) 20) >>= right 48 R.closeResource runtime (S.scopeOf group) input >>= right 49 readAll runtime (S.scopeOf group) output >>= (@?= B.pack "$(not-a-command); *|literal|/") 50 readAll runtime (S.scopeOf group) errors >>= (@?= BS.empty) 51 joined group task (exit 7) 52 pure (S.Completed Leaf)) >>= success 53 , testCase "stream a binary pipeline while draining concurrently" $ do 54 cat <- program "cat" 55 let bytes = BS.pack (take 262144 (cycle [0..255])) 56 withGroup (\runtime group -> do 57 (task,[input,output,errors]) <- P.launch runtime group (P.Spec cat [] Nothing Nothing 20) >>= right 58 drained <- newEmptyMVar 59 _ <- forkIO $ (try (readAll runtime (S.scopeOf group) output) :: IO (Either SomeException BS.ByteString)) >>= putMVar drained 60 let write remaining | BS.null remaining = pure () 61 | otherwise = do 62 let (chunk,rest) = BS.splitAt 4096 remaining 63 R.writeSome runtime (S.scopeOf group) input chunk >>= right >>= (@?= BS.length chunk) 64 write rest 65 write bytes 66 R.closeResource runtime (S.scopeOf group) input >>= right 67 takeMVar drained >>= either throwIO (@?= bytes) 68 readAll runtime (S.scopeOf group) errors >>= (@?= BS.empty) 69 joined group task (exit 0) 70 pure (S.Completed Leaf)) >>= success 71 , testCase "missing executable is an ordinary error, settled without leaked tickets" $ do 72 withGroup (\runtime group -> do 73 result <- P.launch runtime group (P.Spec "/definitely-absent-tricu-process" [] Nothing Nothing 0) 74 case result of Left _ -> pure (); _ -> assertFailure "launch succeeded" 75 pure (S.Completed Leaf)) >>= success 76 , testCase "normal scope exit joins an unconsumed process result" $ do 77 shell <- program "sh" 78 withGroup (\runtime group -> do 79 -- Output fits the pipe, so implicit joining does not require buffering it. 80 _ <- P.launch runtime group (P.Spec shell ["-c","printf done; exit 3"] Nothing Nothing 20) >>= right 81 pure (S.Completed Leaf)) >>= success 82 , testCase "cancellation while scope joins escalates TERM-ignoring child and reaps" $ do 83 shell <- program "sh" 84 withGroup (\runtime root -> do 85 entered <- newEmptyMVar 86 parent <- S.spawn root True True [] (\group _ -> do 87 (_,[_input,output,_errors]) <- P.launch runtime group 88 (P.Spec shell ["-c","trap '' TERM; printf '%s\\n' \"$$\"; while :; do :; done"] Nothing Nothing 20) >>= right 89 bytes <- R.readSome runtime (S.scopeOf group) output 4096 >>= right 90 let pid = read (B.unpack bytes) 91 putMVar entered (pid,S.scopeOf group) 92 pure (S.Completed Leaf)) >>= right 93 (pid,owner) <- takeMVar entered 94 -- Observe closed admission, rather than guessing the phase from a delay. 95 -- A still-live process child means this scope cannot yet be Releasing. 96 let joining = do 97 admitted <- R.acquire runtime owner (pure (R.Internal (pure ()))) 98 case admitted of 99 Left problem -> R.category problem @?= "closed-scope" 100 Right token -> R.closeInternalResource runtime owner token >>= right >> threadDelay 1000 >> joining 101 joining 102 signalProcess nullSignal pid 103 S.cancel root parent (ofString "stop") >>= right 104 result <- S.join root parent 105 case result of Right (S.Cancelled reason []) -> reason @?= ofString "stop"; _ -> assertFailure (show result) 106 alive <- try (signalProcess nullSignal pid) 107 case alive of Left (e :: IOException) -> assertBool "reaped PID" (isDoesNotExistError e); Right _ -> assertFailure "child remains live or zombie" 108 pure (S.Completed Leaf)) >>= success 109 , testCase "failure cancels a blocked pipe child and preserves the primary" $ do 110 cat <- program "cat" 111 outcome <- withGroup (\runtime group -> do 112 _ <- P.launch runtime group (P.Spec cat [] Nothing Nothing 20) >>= right 113 pure (S.Failed (ofString "primary") [])) 114 case outcome of S.Failed problem [] -> problem @?= ofString "primary"; _ -> assertFailure (show outcome) 115 , testCase "repeated implicit joins release pipes, private handles, scopes and tickets" $ do 116 shell <- program "sh" 117 withGroup (\runtime group -> do 118 baseline <- R.liveCounts runtime 119 replicateM_ 30 $ do 120 S.nested group (\child -> do 121 _ <- P.launch runtime child (P.Spec shell ["-c","exit 0"] Nothing Nothing 20) >>= right 122 pure (S.Completed Leaf)) >>= success 123 R.liveCounts runtime >>= (@?= baseline) 124 pure (S.Completed Leaf)) >>= success 125 , testCase "failed pipe writes poison subsequent attempts instead of replay" $ do 126 shell <- program "sh" 127 withGroup (\runtime group -> do 128 (task,[input,_,_]) <- P.launch runtime group (P.Spec shell ["-c","exit 0"] Nothing Nothing 0) >>= right 129 joined group task (exit 0) 130 first <- R.writeSome runtime (S.scopeOf group) input (B.pack "x") 131 case first of Left _ -> pure (); _ -> assertFailure "write to exited child succeeded" 132 second <- R.writeSome runtime (S.scopeOf group) input (B.pack "x") 133 case second of Left problem -> R.category problem @?= "invalid-state"; _ -> assertFailure "failed pipe was reused" 134 -- hClose may report the buffered failed write; keep that cleanup failure 135 -- visible instead of insisting that the parent must complete successfully. 136 pure (S.Completed Leaf)) >>= \outcome -> case outcome of 137 S.Completed Leaf -> pure () 138 S.Failed _ _ -> pure () 139 _ -> assertFailure (show outcome) 140 , testCase "termination failures still attempt escalation and reaping exactly once" $ do 141 forM_ [[],["term"],["kill"],["term","kill","reap"]] $ \failures -> do 142 calls <- newIORef [] 143 let action name = modifyIORef' calls (++[name]) >> when (name `elem` failures) (ioError (userError name)) 144 ops = P.TerminationOps (pure False) (action "term") (action "kill") (action "reap") (pure 0) (action "pause") 145 outcome <- try (P.terminateWith ops 0) :: IO (Either SomeException ()) 146 readIORef calls >>= (@?= ["term","kill","reap"]) 147 case (failures,outcome) of ([],Right ()) -> pure (); (_:_,Left _) -> pure (); _ -> assertFailure "wrong cleanup result" 148 , testCase "relative grace survives monotonic Word64 wrap" $ do 149 samples <- newIORef [18446744073709551606,5,1000000] 150 calls <- newIORef [] 151 let now = atomicModifyIORef' samples (\(x:xs) -> (xs,x)) 152 action name = modifyIORef' calls (++[name]) 153 ops = P.TerminationOps (pure False) (action "term") (action "kill") (action "reap") now (action "pause") 154 P.terminateWith ops 1 155 readIORef calls >>= (@?= ["term","pause","kill","reap"]) 156 , testCase "raw pipe cleanup failure does not skip process settlement" $ do 157 settled <- newIORef False 158 outcome <- try (P.cleanupAll [ioError (userError "pipe-close"), writeIORef settled True]) :: IO (Either SomeException ()) 159 readIORef settled >>= (@?= True) 160 case outcome of Left _ -> pure (); _ -> assertFailure "cleanup error lost" 161 , testCase "wire bounds reject excess arguments/text without demanding the extra element" $ do 162 let args n tail = foldr Fork tail (replicate n (ofString "a")) 163 text n tail = foldr Fork tail (replicate n (ofNumber 97)) 164 excess = Fork (error "excess element demanded") Leaf 165 inherit = ofList [ofString "inherit"] 166 payload arguments = ofList [ofString "/not-executed",arguments,inherit,inherit,ofNumber 0] 167 request arguments = Fork (ofNumber 10) (Fork (ofString "process") (Fork (ofNumber 1) (Fork (ofString "spawn") arguments))) 168 expected = Fork Leaf (Fork (ofList (map ofString ["invalid-argument","process/spawn","","none"])) Leaf) 169 forM_ [payload (args 256 excess),payload (ofList [text 4096 excess])] $ \value -> 170 V.runDetailed (request value) >>= \outcome -> case outcome of 171 S.Completed actual -> actual @?= expected 172 _ -> assertFailure (show outcome) 173 Protocol.inspectAction (request (error "inspection demanded process spec")) @?= 174 Right (ofList [ofString "facility",ofString "process",ofNumber 1,ofString "spawn",ofString "available"]) 175 , testCase "invalid launch values are rejected before admission" $ do 176 forM_ [P.Spec "" [] Nothing Nothing 0, P.Spec "x" [] Nothing Nothing (-1), 177 P.Spec "x" [] Nothing (Just [("X","1"),("X","2")]) 0, 178 P.Spec "x" ["a\0b"] Nothing Nothing 0, 179 P.Spec "x" (replicate 257 "a") Nothing Nothing 0] $ \spec -> 180 assertBool (show spec) (not (P.validSpec spec)) 181 ]