IOBoundaryTests.hs (6697B)
1 module IOBoundaryTests (ioBoundaryTests) where 2 3 import IODriver 4 import Runtime 5 import Control.Exception (bracket, try, IOException) 6 import Control.Monad (forM_) 7 import Control.Concurrent (threadDelay) 8 import System.Posix.Files (createNamedPipe) 9 import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(ReadOnly), OpenFileFlags(..), fdRead) 10 import qualified Data.ByteString as BS 11 import qualified Network.Socket as NS 12 import System.Directory (createDirectory, createDirectoryLink, doesFileExist) 13 import System.IO.Error (isEOFError, isFullError, isAlreadyInUseError) 14 import System.IO.Temp (withSystemTempDirectory) 15 import qualified System.Timeout as Timeout 16 import Test.Tasty 17 import Test.Tasty.HUnit 18 19 ioBoundaryTests :: TestTree 20 ioBoundaryTests = testGroup "IO ownership and path boundaries" 21 [ testCase "new file through escaping parent symlink is denied" $ 22 withSystemTempDirectory "io-path" $ \dir -> do 23 let allowed = dir ++ "/allowed" 24 outside = dir ++ "/outside" 25 target = allowed ++ "/link/new" 26 createDirectory allowed 27 createDirectory outside 28 createDirectoryLink outside (allowed ++ "/link") 29 reply <- runIO (IOPermissions [allowed] [allowed] False False) 30 (envelope (act 21 (Fork (ofString target) (ofString "escape")))) 31 reply @?= Right (Fork Leaf (Fork (ofString "permission denied") Leaf)) 32 doesFileExist (outside ++ "/new") >>= (@?= False) 33 , testCase "new file below allowed parent still succeeds" $ 34 withSystemTempDirectory "io-path" $ \dir -> do 35 let target = dir ++ "/new" 36 reply <- runIO (IOPermissions [dir] [dir] False False) 37 (envelope (act 21 (Fork (ofString target) (ofString "ok")))) 38 reply @?= Right (Fork (Stem Leaf) (Fork Leaf Leaf)) 39 BS.readFile target >>= (@?= "ok") 40 , testCase "CAS validation and permission denial do not force publication trees" $ 41 forM_ [36, 52] $ \tag -> do 42 let tree = error "denied tree was forced" 43 request path pin = envelope (act tag (Fork path (Fork pin tree))) 44 denied message = Right (Fork Leaf (Fork (ofString message) Leaf)) 45 runIO defaultPerms (request (ofString "/denied") (ofString (replicate 64 '0'))) 46 >>= (@?= denied "permission denied") 47 runIO defaultPerms (request (ofString "/denied") (ofString "BAD")) 48 >>= (@?= denied "invalid CAS digest") 49 runIO defaultPerms (request (Stem Leaf) (error "unused digest was forced")) 50 >>= (@?= denied "invalid string") 51 , testCase "root completion closes unclosed listening sockets" $ socketExit (act 0 Leaf) (Just (Right Leaf)) 52 , testCase "abort closes unclosed listening sockets" $ socketExit (act 2 (ofString "stop")) (Just (Left "execution aborted: stop")) 53 , testCase "timeout closes unclosed listening sockets" $ socketExit (act 63 (ofNumber 60000)) Nothing 54 , testCase "root completion joins blocked file workers" $ workerExit (act 0 Leaf) (Just (Right (Leaf, Leaf))) 55 , testCase "abort joins blocked file workers" $ workerExit (act 2 (ofString "stop")) (Just (Left "execution aborted: stop")) 56 , testCase "timeout joins blocked file workers" $ workerExit (act 63 (ofNumber 60000)) Nothing 57 , testCase "timeout interrupts blocked socket accept" $ socketExit 58 (act 74 (Fork (ofString "sock") (ofNumber 0))) Nothing 59 ] 60 61 -- The reader consumes one byte to prove the OS writer started, then stops 62 -- draining until run exit. Cancellation must stop the blocked writer: draining 63 -- afterward must reach EOF without receiving the entire payload. 64 workerExit :: T -> Maybe (Either String (T, T)) -> Assertion 65 workerExit final expected = withSystemTempDirectory "io-worker" $ \dir -> do 66 let fifo = dir ++ "/fifo" 67 size = 262144 68 createNamedPipe fifo 0o600 69 bracket (openFd fifo ReadOnly (defaultFileFlags { nonBlock = True })) closeFd $ \reader -> do 70 let readSome count = do 71 result <- try (fdRead reader count) 72 case result of 73 Right (bytes, _) -> pure bytes 74 Left (err :: IOException) | isEOFError err -> pure "" 75 | isFullError err -> threadDelay 1000 >> readSome count 76 | otherwise -> ioError err 77 started = do 78 bytes <- readSome 1 79 if null bytes then threadDelay 1000 >> started else pure () 80 hook = do 81 ready <- Timeout.timeout 5000000 started 82 ready @?= Just () 83 drain total = do 84 bytes <- readSome 65536 85 if null bytes then pure total else drain (total + length bytes) 86 payload = ofList (replicate size (ofNumber 120)) 87 action = thenDo (act 60 (act 22 (Fork (ofString fifo) payload))) $ 88 thenDo (act 62 Leaf) final 89 outcome <- Timeout.timeout 6000000 (runIOWithYieldHook hook unsafePerms Leaf Leaf (envelope action)) 90 outcome @?= expected 91 drained <- Timeout.timeout 5000000 (drain 1) 92 case drained of 93 Nothing -> assertFailure "writer did not terminate" 94 Just count -> assertBool "worker continued writing after run exit" (count < size) 95 96 -- SockId 0 belongs to this run. The independent probe keeps no driver handles. 97 socketExit :: T -> Maybe (Either String T) -> Assertion 98 socketExit final expected = do 99 port <- bracket (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) NS.close $ \sock -> do 100 NS.bind sock (NS.SockAddrInet 0 (NS.tupleToHostAddress (127,0,0,1))) 101 NS.SockAddrInet p _ <- NS.getSocketName sock 102 pure p 103 let handle = Fork (ofString "sock") (ofNumber 0) 104 action = thenDo (act 70 Leaf) $ thenDo 105 (act 72 (Fork handle (Fork (ofString "127.0.0.1") (ofNumber (fromIntegral port))))) $ 106 thenDo (act 73 (Fork handle (ofNumber 4))) (thenDo (act 62 Leaf) final) 107 hook = bracket (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) NS.close $ \probe -> do 108 bound <- try (NS.bind probe (NS.SockAddrInet port (NS.tupleToHostAddress (127,0,0,1)))) 109 case bound of 110 Left (err :: IOException) -> assertBool (show err) (isAlreadyInUseError err) 111 Right () -> assertFailure "driver did not bind its listening socket" 112 outcome <- Timeout.timeout 100000 (runIOWithYieldHook hook unsafePerms Leaf Leaf (envelope action)) 113 fmap (fmap fst) outcome @?= expected 114 bracket (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) NS.close $ \probe -> 115 NS.bind probe (NS.SockAddrInet port (NS.tupleToHostAddress (127,0,0,1))) 116 117 act :: Integer -> T -> T 118 act tag = Fork (ofNumber tag) 119 envelope :: T -> T 120 envelope action = Fork (ofString "tricuIO") (Fork (ofNumber 1) action) 121 thenDo :: T -> T -> T 122 thenDo action next = act 1 (Fork action (Fork Leaf next))