SnapshotTests.hs (17815B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module SnapshotTests (snapshotTests) where 3 4 import qualified IO.Driver as Driver 5 import qualified IO.Codec as Codec 6 import qualified IO.Resources as R 7 import ContentStore.Snapshot 8 import ContentStore.Indexed 9 import Wire 10 import Runtime (T(..), ofList, ofString, ofNumber) 11 import qualified Data.Sequence as Seq 12 import qualified Data.Text as Text 13 import System.Mem.StableName (makeStableName) 14 import ContentStore.Object 15 import Control.Concurrent 16 import Control.Concurrent.STM (atomically) 17 import Control.Exception 18 import Control.Monad (forM_, when) 19 import qualified Data.ByteString as BS 20 import Data.IORef 21 import Data.List (isInfixOf) 22 import System.Directory (listDirectory) 23 import System.FilePath ((</>)) 24 import System.IO 25 import System.IO.Temp (withSystemTempDirectory) 26 import System.Timeout (timeout) 27 import Test.Tasty 28 import Test.Tasty.HUnit 29 30 showDigest = Text.unpack . hashObject domain 31 32 domain = Domain "arboricx.indexed-tree.v1" 33 withTemp = withSystemTempDirectory "tricu-snapshot-test" 34 stream bytes = do 35 input <- newIORef bytes 36 pure $ \count -> atomicModifyIORef' input $ \rest -> 37 let (chunk, after) = BS.splitAt count rest in (after, chunk) 38 expect fault action = do 39 reply <- try action 40 case reply of 41 Left actual -> actual @?= fault 42 Right _ -> assertFailure ("expected " ++ show fault) 43 run directory bytes reader consume = withAuthenticatedSnapshot directory 44 (toInteger (BS.length bytes)) (toInteger (BS.length bytes)) domain (hashObject domain bytes) reader consume 45 46 snapshotTests = localOption (mkTimeout 30000000) $ testGroup "Authenticated codec snapshots" 47 [ testCase "empty frame authenticates without reading; no named temporary survives" $ withTemp $ \directory -> do 48 run directory BS.empty (\_ -> assertFailure "empty frame read input" >> pure BS.empty) $ \snapshot -> do 49 snapshotLength snapshot @?= 0 50 readSnapshot snapshot 0 4096 >>= (@?= BS.empty) 51 listDirectory directory >>= (@?= []) 52 listDirectory directory >>= (@?= []) 53 , testCase "fragmented binary frame is exact and independently authenticated" $ withTemp $ \directory -> do 54 let bytes = BS.pack [0..255] 55 -- Independently calculated SHA-256(domain UTF-8 + NUL + bytes). 56 digest = "22a44bda752e0deff262ff8cc11de009209bb196484becdae0fb4995d99c6383" 57 input <- newIORef (bytes <> "next frame") 58 requests <- newIORef [] 59 let receive count = do 60 modifyIORef' requests (count:) 61 atomicModifyIORef' input $ \rest -> 62 let (chunk,after) = BS.splitAt (min 7 count) rest in (after,chunk) 63 withAuthenticatedSnapshot directory 256 256 domain digest receive $ \snapshot -> do 64 readSnapshot snapshot 0 4096 >>= (@?= bytes) 65 readSnapshot snapshot 200 56 >>= (@?= BS.drop 200 bytes) 66 readSnapshot snapshot 256 1 >>= (@?= BS.empty) 67 listDirectory directory >>= (@?= []) 68 readIORef input >>= (@?= "next frame") 69 readIORef requests >>= assertBool "positive bounded reads" . all (\n -> n > 0 && n <= 256) 70 , testCase "bad bounds and digests reject before filesystem or reader IO" $ do 71 let unopened = "/nonexistent-tricu-snapshot-directory" 72 receive _ = assertFailure "invalid request read input" >> pure BS.empty 73 consume _ = assertFailure "invalid request called decoder" 74 forM_ [(-1,0),(0,-1),(1,2),(2^(63::Int),0)] $ \(limit,size) -> 75 expect InvalidSnapshotBound (withAuthenticatedSnapshot unopened limit size domain 76 (hashObject domain BS.empty) receive consume) 77 forM_ ["", "ABCD", "../bad"] $ \digest -> 78 expect InvalidSnapshotDigest (withAuthenticatedSnapshot unopened 1 1 domain digest receive consume) 79 , testCase "digest mismatch never invokes decoder" $ withTemp $ \directory -> do 80 reader <- stream "bad" 81 expect SnapshotDigestMismatch $ run directory "abc" reader (\_ -> assertFailure "unauthenticated decoder") 82 listDirectory directory >>= (@?= []) 83 , testCase "domain separation is included in authentication" $ withTemp $ \directory -> do 84 reader <- stream "abc" 85 expect SnapshotDigestMismatch $ withAuthenticatedSnapshot directory 3 3 domain 86 (hashObject (Domain "other") "abc") reader (\_ -> assertFailure "wrong domain accepted") 87 , testCase "truncation and oversized backend chunks fail before decode" $ withTemp $ \directory -> do 88 reader <- stream "ab" 89 expect SnapshotTruncated $ run directory "abc" reader (\_ -> assertFailure "truncated decode") 90 expect SnapshotReaderExceededBound $ run directory "abc" (\_ -> pure "abcd") 91 (\_ -> assertFailure "oversized decode") 92 listDirectory directory >>= (@?= []) 93 , testCase "changing the original inode cannot change authenticated snapshot" $ withTemp $ \directory -> do 94 let path = directory </> "input" 95 BS.writeFile path "original" 96 bracket (openBinaryFile path ReadMode) hClose $ \input -> do 97 run directory "original" (BS.hGetSome input) $ \snapshot -> do 98 -- Close the public input, then overwrite THAT inode, not a pathname replacement. 99 hClose input 100 BS.writeFile path "modified" 101 readSnapshot snapshot 0 4096 >>= (@?= "original") 102 BS.readFile path >>= (@?= "modified") 103 , testCase "decoder errors close the snapshot, and escaped readers cannot use it" $ withTemp $ \directory -> do 104 escaped <- newIORef Nothing 105 reader <- stream "abc" 106 result <- try $ run directory "abc" reader $ \snapshot -> do 107 writeIORef escaped (Just snapshot) 108 throwIO (ErrorCall "decoder failure") 109 case result of Left (ErrorCall message) -> message @?= "decoder failure"; Right () -> assertFailure "lost fault" 110 Just snapshot <- readIORef escaped 111 closed <- try (readSnapshot snapshot 0 1) 112 case closed of Left (_ :: IOException) -> pure (); Right _ -> assertFailure "snapshot leaked" 113 listDirectory directory >>= (@?= []) 114 , testCase "cancellation during receipt closes unlinked file without decoding" $ withTemp $ \directory -> do 115 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 116 worker <- forkFinally (run directory "abc" 117 (\_ -> putMVar entered () >> takeMVar gate) 118 (\_ -> assertFailure "cancelled decode")) (putMVar done) 119 takeMVar entered 120 listDirectory directory >>= (@?= []) 121 killThread worker 122 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 123 Just (Left err) -> case fromException err of 124 Just ThreadKilled -> pure () 125 _ -> assertFailure (show err) 126 _ -> assertFailure "cancellation did not settle" 127 listDirectory directory >>= (@?= []) 128 , testCase "cancellation in decoder closes the authenticated snapshot" $ withTemp $ \directory -> do 129 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 130 reader <- stream "abc" 131 worker <- forkFinally (run directory "abc" reader $ \snapshot -> 132 putMVar entered snapshot >> takeMVar gate) (putMVar done) 133 snapshot <- takeMVar entered 134 killThread worker 135 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 136 Just (Left _) -> pure () 137 _ -> assertFailure "decoder cancellation did not settle" 138 closed <- try (readSnapshot snapshot 0 1) 139 case closed of Left (_ :: IOException) -> pure (); Right _ -> assertFailure "snapshot leaked" 140 , testCase "indexed decoding preserves exponentially shared trees and exact encoding" $ withTemp $ \directory -> do 141 let tree = iterate (\child -> Fork child child) Leaf !! 200 142 bytes <- encodeIndexedTree tree 143 reader <- stream bytes 144 run directory bytes reader $ \snapshot -> do 145 decoded <- decodeIndexedSnapshot 64 65536 snapshot 146 case decoded of 147 Left message -> assertFailure message 148 Right value -> do 149 let check Leaf = pure () 150 check (Fork left right) = do 151 l <- evaluate left >>= makeStableName 152 r <- evaluate right >>= makeStableName 153 assertBool "lost physical sharing" (l == r) 154 check left 155 check _ = assertFailure "wrong tree" 156 check value 157 encodeIndexedTree value >>= (@?= bytes) 158 , testCase "authenticated malformed DAGs retain independent validation controls" $ withTemp $ \directory -> do 159 original <- buildBundleShared [("root", Stem Leaf)] 160 let invalid = 161 [ original { bundleNodes = Seq.fromList [BNLeaf, BNLeaf] } 162 , original { bundleNodes = Seq.fromList [BNLeaf, BNStem 1] } 163 , original { bundleNodes = Seq.fromList [BNLeaf, BNFork 0 99] } 164 , original { bundleNodes = Seq.empty } 165 , original { bundleNodes = Seq.singleton BNLeaf } 166 ] 167 rejected bytes = do 168 reader <- stream bytes 169 run directory bytes reader $ \snapshot -> do 170 decoded <- decodeIndexedSnapshot 64 65536 snapshot 171 case decoded of Left _ -> pure (); Right _ -> assertFailure "malformed DAG accepted" 172 forM_ invalid (rejected . encodeBundle) 173 let bytes = encodeBundle original 174 replace offset value = BS.take offset bytes <> value <> BS.drop (offset + BS.length value) bytes 175 forM_ [replace 24 (BS.replicate 8 255), replace 44 (BS.replicate 8 255), 176 replace 52 (BS.replicate 8 255), replace 12 (BS.replicate 4 255), 177 BS.take 31 bytes, BS.init bytes] rejected 178 , testCase "metadata bounds and small trees agree with whole-value decoder" $ withTemp $ \directory -> do 179 forM_ [Leaf, Stem Leaf, Fork Leaf (Stem Leaf), iterate Stem Leaf !! 1000] $ \tree -> do 180 bytes <- encodeIndexedTree tree 181 reader <- stream bytes 182 run directory bytes reader $ \snapshot -> do 183 decodeIndexedSnapshot 64 65536 snapshot >>= (@?= decodeIndexedTree bytes) 184 forM_ [(1,65536),(64,0),(-1,65536),(64,-1)] $ \(sections,metadata) -> do 185 decoded <- decodeIndexedSnapshot sections metadata snapshot 186 case decoded of Left _ -> pure (); Right _ -> assertFailure "metadata limit ignored" 187 , testCase "native framed reader cleans each snapshot and preserves following data" $ withTemp $ \directory -> do 188 runtime <- R.newRuntime 189 bytes <- encodeIndexedTree (Stem Leaf) 190 receive <- stream (bytes <> "next") 191 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader receive (pure ()))) 192 counts <- R.liveCounts runtime 193 Codec.readIndexed runtime R.rootScope reader directory 65536 (toInteger (BS.length bytes)) 194 (showDigest bytes) >>= (@?= Right (Stem Leaf)) 195 R.liveCounts runtime >>= (@?= counts) 196 R.readSome runtime R.rootScope reader 4 >>= (@?= Right "next") 197 R.closeScope runtime R.rootScope >>= (@?= []) 198 , testCase "native digest failure is ordinary, consumes exactly its frame, and cleans spool" $ withTemp $ \directory -> do 199 runtime <- R.newRuntime 200 receive <- stream "badnext" 201 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader receive (pure ()))) 202 counts <- R.liveCounts runtime 203 Codec.readIndexed runtime R.rootScope reader directory 3 3 (showDigest "abc") >>= \reply -> case reply of 204 Left p -> do R.category p @?= "integrity-failed"; R.progress p @?= "unknown" 205 _ -> assertFailure "bad digest accepted" 206 R.liveCounts runtime >>= (@?= counts) 207 R.readSome runtime R.rootScope reader 4 >>= (@?= Right "next") 208 R.closeScope runtime R.rootScope >>= (@?= []) 209 , testCase "native whole-frame lease survives chunk boundaries and cancellation settles lexically" $ withTemp $ \directory -> do 210 runtime <- R.newRuntime 211 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 212 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader 213 (\_ -> putMVar entered () >> takeMVar gate) (pure ()))) 214 worker <- forkFinally (Codec.readIndexed runtime R.rootScope reader directory 3 3 (showDigest "abc")) (putMVar done) 215 takeMVar entered 216 let R.Token identity key = reader 217 guessed = R.Token identity (key+1) 218 R.readSome runtime R.rootScope guessed 1 >>= \reply -> case reply of 219 Left p -> R.category p @?= "wrong-kind" 220 _ -> assertFailure "private snapshot exposed" 221 R.closeResource runtime R.rootScope guessed >>= \reply -> case reply of 222 Left p -> R.category p @?= "internal-resource" 223 _ -> assertFailure "private snapshot closed" 224 atomically (R.reserveChildSTM runtime R.rootScope [guessed]) >>= \reply -> case reply of 225 Left p -> R.category p @?= "internal-resource" 226 _ -> assertFailure "private snapshot transferred" 227 R.readSome runtime R.rootScope reader 1 >>= \reply -> case reply of 228 Left p -> R.category p @?= "busy" 229 _ -> assertFailure "lost frame lease" 230 killThread worker 231 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 232 Just (Left err) -> case fromException err of 233 Just ThreadKilled -> pure () 234 _ -> assertFailure (show err) 235 _ -> assertFailure "lost cancellation" 236 -- The private snapshot remains registered for lexical release; cancellation 237 -- must not run an untracked finalizer that can replace its primary fault. 238 R.liveCounts runtime >>= (@?= (1,5)) 239 R.closeScope runtime R.rootScope >>= (@?= []) 240 R.liveCounts runtime >>= (@?= (0,0)) 241 listDirectory directory >>= (@?= []) 242 , testCase "native cleanup errors preserve ordinary primary diagnostics" $ withTemp $ \directory -> do 243 runtime <- R.newRuntime 244 receive <- stream "bad" 245 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader receive (pure ()))) 246 let release handle = hClose handle >> ioError (userError "injected close failure") 247 Codec.readIndexedWith release runtime R.rootScope reader directory 3 3 (showDigest "abc") >>= \reply -> case reply of 248 Left p -> do 249 R.category p @?= "integrity-failed" 250 assertBool "primary lost" ("CAS digest mismatch" `isInfixOf` R.detail p) 251 assertBool "cleanup lost" ("injected close failure" `isInfixOf` R.detail p) 252 _ -> assertFailure "release failure lost" 253 R.liveCounts runtime >>= (@?= (1,4)) 254 R.closeScope runtime R.rootScope >>= (@?= []) 255 , testCase "cancelled native snapshot retains failing release for scope diagnostics" $ withTemp $ \directory -> do 256 runtime <- R.newRuntime 257 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 258 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader 259 (\_ -> putMVar entered () >> takeMVar gate) (pure ()))) 260 let release handle = hClose handle >> ioError (userError "injected close failure") 261 worker <- forkFinally (Codec.readIndexedWith release runtime R.rootScope reader directory 3 3 (showDigest "abc")) (putMVar done) 262 takeMVar entered 263 killThread worker 264 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 265 Just (Left err) -> case fromException err of 266 Just ThreadKilled -> pure () 267 _ -> assertFailure (show err) 268 _ -> assertFailure "cleanup replaced cancellation" 269 errors <- R.closeScope runtime R.rootScope 270 case errors of 271 [p] -> assertBool "missing cleanup diagnostic" ("injected close failure" `isInfixOf` R.detail p) 272 _ -> assertFailure (show errors) 273 R.liveCounts runtime >>= (@?= (0,0)) 274 , testCase "snapshot acquisition fails before consumption; invalid bounds allocate nothing" $ withTemp $ \directory -> do 275 runtime <- R.newRuntime 276 Right reader <- R.acquire runtime R.rootScope (pure (R.Reader 277 (\_ -> assertFailure "invalid acquisition consumed input" >> pure BS.empty) (pure ()))) 278 forM_ [(directory </> "missing",3,3,"not-found"), (directory,2,3,"invalid-bound")] $ \(path,limit,size,category) -> 279 Codec.readIndexed runtime R.rootScope reader path limit size (showDigest "abc") >>= \reply -> case reply of 280 Left p -> R.category p @?= category 281 _ -> assertFailure "invalid acquisition succeeded" 282 R.liveCounts runtime >>= (@?= (1,4)) 283 R.closeScope runtime R.rootScope >>= (@?= []) 284 , testCase "wire digest bound rejects excess without demanding its element or tail" $ do 285 let digest = foldr Fork (Fork (error "excess digest character") (error "excess digest tail")) 286 (replicate 64 (ofNumber 97)) 287 reader = ofList [ofString "io.v2.resource", ofNumber 0, ofNumber 1] 288 action = Fork (ofNumber 10) (Fork (ofString "indexed-tree") (Fork (ofNumber 1) 289 (Fork (ofString "read") (ofList [reader,ofString ".",ofNumber 1,ofNumber 1,digest])))) 290 Driver.runDetailed action >>= \outcome -> case outcome of 291 Driver.Completed value -> value @?= Fork Leaf (Fork 292 (ofList (map ofString ["invalid-argument","indexed-tree/read","","none"])) Leaf) 293 _ -> assertFailure "invalid digest performed IO" 294 , testCase "increasing frames retain bounded receive and snapshot reads" $ withTemp $ \directory -> do 295 forM_ [4095,4096,4097,1048576] $ \size -> do 296 let bytes = BS.replicate size 173 297 reader <- stream bytes 298 run directory bytes (\count -> do 299 assertBool "unbounded receive" (count > 0 && count <= 4096) 300 reader count) $ \snapshot -> do 301 forM_ [0,4096..size-1] $ \offset -> 302 readSnapshot snapshot (toInteger offset) 4096 >>= (@?= BS.take 4096 (BS.drop offset bytes)) 303 forM_ [(-1,1),(0,-1),(0,4097),(toInteger size+1,1)] $ \(offset,count) -> 304 expect InvalidSnapshotRange (readSnapshot snapshot offset count) 305 listDirectory directory >>= (@?= []) 306 ]