IOV2PositionTests.hs (11001B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOV2PositionTests (ioV2PositionTests) where 3 import qualified IOV2.Resources as R 4 import qualified IOV2.Driver as V 5 import qualified Data.ByteString as BS 6 import Control.Concurrent 7 import Control.Concurrent.STM 8 import Control.Exception 9 import Control.Monad 10 import Data.IORef 11 import Foreign.Ptr (castPtr) 12 import qualified System.Posix.IO as P 13 import System.Directory (renameFile) 14 import System.IO.Temp (withSystemTempDirectory) 15 import System.Timeout (timeout) 16 import Runtime (T(..), ofNumber, ofString, ofList) 17 import Test.Tasty 18 import Test.Tasty.HUnit 19 20 right :: Show e => Either e a -> IO a 21 right = either (\e -> assertFailure (show e) >> error "assertion") pure 22 category name result = case result of 23 Left p -> R.category p @?= name 24 _ -> assertFailure ("expected " ++ name) 25 fixture use = withSystemTempDirectory "v2-position" $ \dir -> 26 bracket R.newRuntime (\r -> void (R.closeScope r 0)) (\r -> use r (dir++"/file")) 27 write r token bytes = R.writeSome r 0 token (BS.pack bytes) >>= (@?= Right (length bytes)) 28 wait done = timeout 3000000 (readMVar done) >>= maybe (assertFailure "timeout" >> error "timeout") pure 29 fake = R.FileOps Nothing Nothing Nothing Nothing (pure 0) Nothing Nothing (pure ()) 30 31 ioV2PositionTests = localOption (mkTimeout 30000000) $ testGroup "IO v2 positioned files" 32 [ testCase "update preserves bytes; logical cursor switches read/write correctly" $ fixture $ \r path -> do 33 BS.writeFile path (BS.pack [0..9]) 34 f <- R.openUpdate r 0 path >>= right 35 R.fileSize r 0 f >>= (@?= Right 10) 36 R.readSome r 0 f 2 >>= (@?= Right (BS.pack [0,1])) 37 R.filePosition r 0 f >>= (@?= Right 2) 38 write r f [255,254] 39 R.filePosition r 0 f >>= (@?= Right 4) 40 R.readSome r 0 f 2 >>= (@?= Right (BS.pack [4,5])) 41 R.seekFile r 0 f 0 >>= (@?= Right ()) 42 R.readSome r 0 f 10 >>= (@?= Right (BS.pack [0,1,255,254,4,5,6,7,8,9])) 43 R.closeResource r 0 f >>= (@?= Right ()) 44 BS.readFile path >>= (@?= BS.pack [0,1,255,254,4,5,6,7,8,9]) 45 , testCase "resize discards read ahead, preserves cursor and zero-fills growth" $ fixture $ \r path -> do 46 BS.writeFile path (BS.pack [0..99]) 47 f <- R.openUpdate r 0 path >>= right 48 R.readSome r 0 f 3 >>= (@?= Right (BS.pack [0,1,2])) 49 R.resizeFile r 0 f 2 >>= (@?= Right ()) 50 R.filePosition r 0 f >>= (@?= Right 3) 51 R.readSome r 0 f 1 >>= (@?= Right BS.empty) 52 R.resizeFile r 0 f 8 >>= (@?= Right ()) 53 R.filePosition r 0 f >>= (@?= Right 3) 54 R.readSome r 0 f 5 >>= (@?= Right (BS.replicate 5 0)) 55 R.seekFile r 0 f 12 >>= (@?= Right ()) 56 write r f [255] 57 R.fileSize r 0 f >>= (@?= Right 13) 58 R.closeResource r 0 f >>= (@?= Right ()) 59 BS.readFile path >>= (@?= BS.pack ([0,1]++replicate 10 0++[255])) 60 , testCase "new update/append files and wide sparse offsets" $ fixture $ \r path -> do 61 f <- R.openUpdate r 0 path >>= right 62 R.fileSize r 0 f >>= (@?= Right 0) 63 R.seekFile r 0 f 4294967296 >>= (@?= Right ()) 64 write r f [255] 65 R.filePosition r 0 f >>= (@?= Right 4294967297) 66 R.fileSize r 0 f >>= (@?= Right 4294967297) 67 R.seekFile r 0 f 4294967294 >>= (@?= Right ()) 68 R.readSome r 0 f 3 >>= (@?= Right (BS.pack [0,0,255])) 69 R.resizeFile r 0 f 0 >>= (@?= Right ()) 70 R.closeResource r 0 f >>= (@?= Right ()) 71 BS.readFile path >>= (@?= BS.empty) 72 appended <- R.openAppender r 0 (path++"-append") >>= right 73 write r appended [0,255] 74 R.closeResource r 0 appended >>= (@?= Right ()) 75 BS.readFile (path++"-append") >>= (@?= BS.pack [0,255]) 76 , testCase "append is at each write's EOF, not an open-time seek" $ fixture $ \r path -> do 77 BS.writeFile path (BS.pack [1,2]) 78 f <- R.openAppender r 0 path >>= right 79 -- Separate POSIX fd models an external writer, bypassing GHC Handle locks. 80 bracket (P.openFd path P.WriteOnly (P.defaultFileFlags {P.append=True})) P.closeFd $ \fd -> 81 BS.useAsCStringLen (BS.pack [3,4]) $ \(ptr,n) -> 82 P.fdWriteBuf fd (castPtr ptr) (fromIntegral n) >>= (@?= 2) 83 write r f [5,255] 84 R.fileSize r 0 f >>= (@?= Right 6) 85 R.seekFile r 0 f 0 >>= category "unsupported" 86 R.filePosition r 0 f >>= category "unsupported" 87 R.resizeFile r 0 f 0 >>= category "unsupported" 88 R.readSome r 0 f 1 >>= category "wrong-kind" 89 R.closeResource r 0 f >>= (@?= Right ()) 90 BS.readFile path >>= (@?= BS.pack [1,2,3,4,5,255]) 91 , testCase "reader mode and unrelated resource kinds cannot mutate files" $ fixture $ \r path -> do 92 BS.writeFile path (BS.pack [1,2,3]) 93 f <- R.openReader r 0 path >>= right 94 R.resizeFile r 0 f 0 >>= category "unsupported" 95 R.writeSome r 0 f (BS.singleton 4) >>= category "wrong-kind" 96 R.seekFile r 0 f 2 >>= (@?= Right ()) 97 R.readSome r 0 f 2 >>= (@?= Right (BS.singleton 3)) 98 standard <- R.standardStream r 0 R.StandardInput >>= right 99 R.fileSize r 0 standard >>= category "wrong-kind" 100 R.seekFile r 0 standard 0 >>= category "wrong-kind" 101 R.closeResource r 0 f >>= (@?= Right ()) 102 R.filePosition r 0 f >>= category "stale-handle" 103 BS.readFile path >>= (@?= BS.pack [1,2,3]) 104 , testCase "host Handle locking rejects conflicting opens without changing content" $ fixture $ \r path -> do 105 BS.writeFile path (BS.pack [1,2,3]) 106 reader <- R.openReader r 0 path >>= right 107 R.openUpdate r 0 path >>= category "io-error" 108 R.openAppender r 0 path >>= category "io-error" 109 R.readSome r 0 reader 3 >>= (@?= Right (BS.pack [1,2,3])) 110 R.closeResource r 0 reader >>= (@?= Right ()) 111 BS.readFile path >>= (@?= BS.pack [1,2,3]) 112 , testCase "size is queried on the opened file, not its replaced pathname" $ fixture $ \r path -> do 113 BS.writeFile path (BS.pack [1,2,3]) 114 f <- R.openReader r 0 path >>= right 115 renameFile path (path++"-old") 116 BS.writeFile path (BS.replicate 10 7) 117 R.fileSize r 0 f >>= (@?= Right 3) 118 R.readSome r 0 f 4 >>= (@?= Right (BS.pack [1,2,3])) 119 , testCase "position transfers with ownership and old aliases become stale" $ fixture $ \r path -> do 120 BS.writeFile path (BS.pack [0..9]) 121 f <- R.openUpdate r 0 path >>= right 122 R.seekFile r 0 f 7 >>= (@?= Right ()) 123 (child, moved) <- atomically (R.reserveChildSTM r 0 [f]) >>= right 124 case moved of 125 [fresh] -> do 126 R.filePosition r child fresh >>= (@?= Right 7) 127 R.seekFile r child fresh 3 >>= (@?= Right ()) 128 R.readSome r child fresh 1 >>= (@?= Right (BS.singleton 3)) 129 _ -> assertFailure "bad transfer" 130 R.fileSize r 0 f >>= category "stale-handle" 131 R.closeScope r child >>= (@?= []) 132 R.liveCounts r >>= (@?= (1,3)) 133 , testCase "bounds rejected before effects; bad backend positions cannot escape" $ fixture $ \r _ -> do 134 calls <- newIORef (0::Int) 135 let methods = fake {R.fileSeekAction=Just (\_ -> modifyIORef' calls (+1)), 136 R.fileResizeAction=Just (\_ -> modifyIORef' calls (+1)), 137 R.filePositionAction=Just (pure (-1)), R.fileSizeAction=pure (-1)} 138 f <- R.acquire r 0 (pure (R.File methods)) >>= right 139 forM_ [-1,9223372036854775808] $ \n -> do 140 R.seekFile r 0 f n >>= category "invalid-bound" 141 R.resizeFile r 0 f n >>= category "invalid-bound" 142 readIORef calls >>= (@?= 0) 143 R.filePosition r 0 f >>= category "unsupported" 144 R.fileSize r 0 f >>= category "unsupported" 145 R.seekFile r 0 f 9223372036854775807 >>= (@?= Right ()) 146 readIORef calls >>= (@?= 1) 147 , testCase "position IO shares read/write lease; cancellation drains it before release" $ fixture $ \r _ -> do 148 entered <- newEmptyMVar; blocked <- newEmptyMVar; finished <- newEmptyMVar 149 released <- newIORef False 150 let methods = fake {R.fileSeekAction=Just (\_ -> putMVar entered () >> takeMVar blocked), 151 R.fileReadAction=Just (const (pure BS.empty)), 152 R.fileWriteAction=Just (pure . BS.length), 153 R.fileReleaseAction=writeIORef released True} 154 f <- R.acquire r 0 (pure (R.File methods)) >>= right 155 bracket (forkFinally (R.seekFile r 0 f 2) (putMVar finished)) 156 (\worker -> killThread worker >> void (wait finished)) $ \worker -> do 157 takeMVar entered 158 R.fileSize r 0 f >>= category "busy" 159 R.readSome r 0 f 1 >>= category "busy" 160 R.writeSome r 0 f (BS.singleton 1) >>= category "busy" 161 atomically (R.reserveChildSTM r 0 [f]) >>= category "busy" 162 readIORef released >>= (@?= False) 163 killThread worker 164 wait finished >>= \outcome -> case outcome of 165 Left _ -> pure () 166 Right _ -> assertFailure "cancelled seek resumed" 167 R.closeResource r 0 f >>= (@?= Right ()) 168 readIORef released >>= (@?= True) 169 , testCase "backend mutation errors report unknown state, not no progress" $ fixture $ \r _ -> do 170 let methods = fake {R.fileSeekAction=Just (\_ -> ioError (userError "seek fault")), 171 R.fileResizeAction=Just (\_ -> ioError (userError "resize fault"))} 172 f <- R.acquire r 0 (pure (R.File methods)) >>= right 173 forM_ [R.seekFile r 0 f 0,R.resizeFile r 0 f 0] $ \action -> action >>= \reply -> case reply of 174 Left problem -> R.progress problem @?= "unknown" 175 Right _ -> assertFailure "fault succeeded" 176 , testCase "wire preserves the entire signed-64 positive offset range" $ fixture $ \r _ -> do 177 observed <- newIORef (-1) 178 f@(R.Token identity key) <- R.acquire r 0 (pure (R.File 179 (fake {R.fileSeekAction=Just (writeIORef observed)}))) >>= right 180 let token = ofList [ofString "io.v2.resource",ofNumber identity,ofNumber key] 181 action = Fork (ofNumber 10) (Fork (ofString "file") (Fork (ofNumber 1) 182 (Fork (ofString "seek") (Fork token (ofNumber 9223372036854775807))))) 183 V.runInRuntime r action >>= \outcome -> case outcome of 184 V.Completed value -> value @?= Fork (Stem Leaf) (Fork Leaf Leaf) 185 _ -> assertFailure "wide offset failed" 186 readIORef observed >>= (@?= 9223372036854775807) 187 R.filePosition r 0 f >>= category "stale-handle" 188 , testCase "wire rejects overlong offset without demanding excess bits" $ fixture $ \r _ -> do 189 identity <- R.runtimeIdentity r 190 let token = ofList [ofString "io.v2.resource",ofNumber identity,ofNumber 1] 191 offset = foldr Fork (Stem (error "excess bits demanded")) (replicate 63 Leaf) 192 action = Fork (ofNumber 10) (Fork (ofString "file") (Fork (ofNumber 1) 193 (Fork (ofString "seek") (Fork token offset)))) 194 V.runInRuntime r action >>= \outcome -> case outcome of 195 V.Completed (Fork Leaf (Fork problem Leaf)) -> problem @?= 196 ofList (map ofString ["invalid-argument","file/seek","","none"]) 197 _ -> assertFailure "invalid offset executed" 198 ]