IndexedWriterTests.hs (7757B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IndexedWriterTests (indexedWriterTests) where 3 4 import qualified IO.Codec as C 5 import qualified IO.Resources as R 6 import ContentStore.Indexed 7 import ContentStore.Object 8 import Runtime (T(..)) 9 import Wire 10 import Control.Concurrent 11 import Control.Concurrent.STM (atomically) 12 import Control.Exception 13 import Control.Monad (forM_, when) 14 import qualified Data.ByteString as BS 15 import qualified Data.Text as Text 16 import Data.IORef 17 import Test.Tasty 18 import Test.Tasty.HUnit 19 import System.Timeout (timeout) 20 21 pin = Text.unpack . hashObject indexedTreeDomain 22 category wanted reply = case reply of 23 Left p -> R.category p @?= wanted 24 Right _ -> assertFailure ("expected " ++ wanted) 25 26 indexedWriterTests = localOption (mkTimeout 30000000) $ testGroup "Bounded indexed writer" 27 [ testCase "chunked emission matches historical canonical bytes at every boundary" $ do 28 forM_ [Leaf, Stem Leaf, Fork Leaf (Stem Leaf), iterate Stem Leaf !! 1000] $ \tree -> do 29 bundle <- buildBundleShared [("root",tree)] 30 let expected = encodeBundle bundle 31 bundleEncodedLength bundle @?= toInteger (BS.length expected) 32 forM_ [1,7,13,4096] $ \bound -> do 33 chunks <- newIORef [] 34 emitBundle bound bundle $ \bytes -> do 35 assertBool "bad chunk" (not (BS.null bytes) && BS.length bytes <= bound) 36 modifyIORef' chunks (bytes:) 37 actual <- BS.concat . reverse <$> readIORef chunks 38 actual @?= expected 39 , testCase "native hash preserves shared identity and canonical domain" $ do 40 let shared = iterate (\value -> Fork value value) Leaf !! 200 41 bytes <- encodeIndexedTree shared 42 C.hashIndexed 65536 shared >>= (@?= Right (toInteger (BS.length bytes),pin bytes)) 43 C.hashIndexed (toInteger (BS.length bytes)-1) shared >>= category "invalid-bound" 44 C.hashIndexed (-1) (error "invalid bound forced tree") >>= category "invalid-bound" 45 , testCase "partial native writes produce exactly the canonical frame" $ do 46 runtime <- R.newRuntime 47 chunks <- newIORef [] 48 let tree = iterate Stem Leaf !! 1000 49 bytes <- encodeIndexedTree tree 50 Right writer <- R.acquire runtime R.rootScope $ pure $ R.Writer (\chunk -> do 51 assertBool "write exceeded chunk bound" (BS.length chunk <= 4096) 52 let accepted = BS.take 7 chunk 53 modifyIORef' chunks (accepted:) 54 pure (BS.length accepted)) (pure ()) 55 C.writeIndexed runtime R.rootScope writer 65536 (pin bytes) tree 56 >>= (@?= Right (toInteger (BS.length bytes),pin bytes)) 57 (BS.concat . reverse <$> readIORef chunks) >>= (@?= bytes) 58 R.closeScope runtime R.rootScope >>= (@?= []) 59 , testCase "preflight failures write nothing and invalid headers do not force trees" $ do 60 runtime <- R.newRuntime 61 touched <- newIORef False 62 Right writer <- R.acquire runtime R.rootScope $ pure $ R.Writer 63 (\bytes -> writeIORef touched True >> pure (BS.length bytes)) (pure ()) 64 bytes <- encodeIndexedTree Leaf 65 C.writeIndexed runtime R.rootScope writer 65536 (replicate 64 '0') Leaf >>= category "integrity-failed" 66 C.writeIndexed runtime R.rootScope writer 0 (pin bytes) Leaf >>= category "invalid-bound" 67 C.writeIndexed runtime R.rootScope writer (-1) (pin bytes) (error "bad limit forced tree") >>= category "invalid-bound" 68 C.writeIndexed runtime R.rootScope writer 65536 "bad" (error "bad hash forced tree") >>= category "invalid-argument" 69 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader (\_ -> pure BS.empty) (pure ()))) 70 C.writeIndexed runtime R.rootScope reader 65536 (pin bytes) (error "wrong kind forced tree") >>= category "wrong-kind" 71 readIORef touched >>= (@?= False) 72 R.closeScope runtime R.rootScope >>= (@?= []) 73 , testCase "invalid backend progress stops without replay" $ do 74 forM_ [0,-1,65536] $ \badCount -> do 75 runtime <- R.newRuntime 76 calls <- newIORef (0 :: Int) 77 Right writer <- R.acquire runtime R.rootScope $ pure $ R.Writer 78 (\_ -> modifyIORef' calls (+1) >> pure badCount) (pure ()) 79 bytes <- encodeIndexedTree Leaf 80 C.writeIndexed runtime R.rootScope writer 65536 (pin bytes) Leaf >>= \reply -> case reply of 81 Left p -> do R.category p @?= "io-error"; R.progress p @?= "unknown" 82 Right _ -> assertFailure "invalid progress accepted" 83 readIORef calls >>= (@?= 1) 84 R.closeScope runtime R.rootScope >>= (@?= []) 85 , testCase "failure after acknowledged chunks never retries or reports rollback" $ do 86 runtime <- R.newRuntime 87 calls <- newIORef (0 :: Int) 88 output <- newIORef [] 89 let tree = iterate Stem Leaf !! 1000 90 bytes <- encodeIndexedTree tree 91 Right writer <- R.acquire runtime R.rootScope $ pure $ R.Writer (\chunk -> do 92 n <- atomicModifyIORef' calls (\n -> (n+1,n)) 93 if n == 0 then modifyIORef' output (chunk:) >> pure (BS.length chunk) 94 else ioError (userError "injected uncertain write")) (pure ()) 95 C.writeIndexed runtime R.rootScope writer 65536 (pin bytes) tree >>= \reply -> case reply of 96 Left p -> R.progress p @?= "unknown" 97 Right _ -> assertFailure "failure swallowed" 98 readIORef calls >>= (@?= 2) 99 (BS.concat . reverse <$> readIORef output) >>= (@?= BS.take 4096 bytes) 100 R.closeScope runtime R.rootScope >>= (@?= []) 101 , testCase "exact verification accepts fragmented frames without consuming following data" $ do 102 runtime <- R.newRuntime 103 bytes <- encodeIndexedTree (Stem Leaf) 104 input <- newIORef (bytes <> "next") 105 Right reader <- R.acquire runtime R.rootScope $ pure $ R.Reader (\wanted -> 106 atomicModifyIORef' input (\rest -> let (chunk,after) = BS.splitAt (min wanted 3) rest in (after,chunk))) (pure ()) 107 C.verifyIndexed runtime R.rootScope reader 65536 (Stem Leaf) 108 >>= (@?= Right (toInteger (BS.length bytes),pin bytes)) 109 readIORef input >>= (@?= "next") 110 R.closeScope runtime R.rootScope >>= (@?= []) 111 , testCase "exact verification rejects unequal bytes and truncation" $ do 112 bytes <- encodeIndexedTree Leaf 113 forM_ [BS.init bytes, "X" <> BS.drop 1 bytes] $ \bad -> do 114 runtime <- R.newRuntime 115 input <- newIORef bad 116 Right reader <- R.acquire runtime R.rootScope $ pure $ R.Reader (\wanted -> 117 atomicModifyIORef' input (\rest -> let (chunk,after) = BS.splitAt wanted rest in (after,chunk))) (pure ()) 118 C.verifyIndexed runtime R.rootScope reader 65536 Leaf >>= category "integrity-failed" 119 R.closeScope runtime R.rootScope >>= (@?= []) 120 , testCase "whole-write lease excludes other writers; cancellation releases it" $ do 121 runtime <- R.newRuntime 122 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 123 Right writer <- R.acquire runtime R.rootScope $ pure $ R.Writer 124 (\_ -> putMVar entered () >> takeMVar gate) (pure ()) 125 bytes <- encodeIndexedTree Leaf 126 worker <- forkFinally (C.writeIndexed runtime R.rootScope writer 65536 (pin bytes) Leaf) (putMVar done) 127 takeMVar entered 128 R.writeSome runtime R.rootScope writer "x" >>= category "busy" 129 atomically (R.reserveChildSTM runtime R.rootScope [writer]) >>= category "busy" 130 killThread worker 131 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 132 Just (Left err) -> case fromException err of Just ThreadKilled -> pure (); _ -> assertFailure (show err) 133 _ -> assertFailure "cancellation lost" 134 moved <- atomically (R.reserveChildSTM runtime R.rootScope [writer]) 135 case moved of Right _ -> pure (); Left p -> assertFailure (show p) 136 R.closeScope runtime R.rootScope >>= (@?= []) 137 ]