nova-cache-0.10.0.0: test/XzTest.hs
-- | Tests for the bounded xz decoder. A separate suite because the
-- decoder lives in the nova-cache:xz sublibrary; the fixtures are real @xz -6@
-- output embedded as hex, so no external tool runs at test time.
module Main (main) where
import Control.Exception (try)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char (isDigit)
import Data.IORef (newIORef, readIORef, writeIORef)
import qualified NovaCache.Xz as Xz
import System.Exit (exitFailure, exitSuccess)
import System.IO (hFlush, stdout)
-- ---------------------------------------------------------------------------
-- Harness (mirrors test/Main.hs)
-- ---------------------------------------------------------------------------
test :: String -> IO Bool -> IO Bool
test name action = do
putStr (" " ++ name ++ "... ")
hFlush stdout
result <- action
putStrLn (if result then "OK" else "FAILED")
pure result
assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool
assertEqual label expected actual
| expected == actual = pure True
| otherwise = do
putStrLn ""
putStrLn (" " ++ label)
putStrLn (" expected: " ++ show expected)
putStrLn (" actual: " ++ show actual)
pure False
assertTrue :: String -> Bool -> IO Bool
assertTrue _ True = pure True
assertTrue label False = do
putStrLn ""
putStrLn (" " ++ label ++ ": expected True")
pure False
-- ---------------------------------------------------------------------------
-- Fixtures
-- ---------------------------------------------------------------------------
-- | Decode a hex fixture literal. Fixtures are constants, so a
-- malformed one decodes short and the assertions fail loudly.
unhex :: String -> ByteString
unhex = BS.pack . pairs
where
pairs (hi : lo : rest) = case (hexVal hi, hexVal lo) of
(Just h, Just l) -> fromIntegral (h * 16 + l) : pairs rest
_ -> []
pairs _ = []
hexVal c
| isDigit c = Just (fromEnum c - fromEnum '0')
| c >= 'a' && c <= 'f' = Just (fromEnum c - fromEnum 'a' + 10)
| otherwise = Nothing
-- | @xz -6@ of "nova-cache xz fixture\n" (22 bytes of output).
textXz :: ByteString
textXz =
unhex
"fd377a585a000004e6d6b44604c01a162101160000000000000000001caa3b74\
\0100156e6f76612d636163686520787a20666978747572650a0000002c84d5d2\
\3c233719000136160f914e5d1fb6f37d010000000004595a"
-- | The bytes 'textXz' decompresses to.
textPlain :: ByteString
textPlain = "nova-cache xz fixture\n"
-- | @xz -6@ of 65536 zero bytes: 148 bytes in, 64 KiB out - the
-- expansion shape the output bound exists for. The stream declares
-- an 8 MiB dictionary, which the memory-bound test leans on.
zerosXz :: ByteString
zerosXz =
unhex
"fd377a585a000004e6d6b44604c05480800421011600000000000000e6b515ff\
\e0ffff004c5d00006ffdffffa3b7ff473e481572396151b89228e6a38607f9ee\
\e41e82d32fc53a3c014bb17ec98a8a4d2fa30dd97fa6e38c231153e05918c575\
\8ae277f8b6947f0c6ac0de7449645c9e3ad100005e654f49ca09af2600017080\
\800400006977c193b1c467fb020000000004595a"
-- | Output size of 'zerosXz'.
zerosLength :: Word
zerosLength = 65536
-- | Generous limits for the happy paths.
openLimits :: Xz.XzLimits
openLimits =
Xz.XzLimits
{ Xz.xzMaxOutputBytes = 1024 * 1024,
Xz.xzMaxDecoderMemoryBytes = Xz.defaultXzDecoderMemoryBytes
}
-- | 'openLimits' with the output bound replaced.
boundedTo :: Word -> Xz.XzLimits
boundedTo bound = openLimits {Xz.xzMaxOutputBytes = fromIntegral bound}
-- | Split a byte string into fixed-size pieces.
chunksOf :: Int -> ByteString -> [ByteString]
chunksOf n bs
| BS.null bs = []
| otherwise = case BS.splitAt n bs of
(piece, rest) -> piece : chunksOf n rest
-- | A chunk source over a fixed list (empty chunk on exhaustion), for
-- feeding 'Xz.withXzSource'.
listSource :: [ByteString] -> IO (IO ByteString)
listSource chunks = do
remaining <- newIORef chunks
pure $ do
held <- readIORef remaining
case held of
[] -> pure BS.empty
(c : cs) -> do
writeIORef remaining cs
pure c
-- ---------------------------------------------------------------------------
-- Tests
-- ---------------------------------------------------------------------------
main :: IO ()
main = do
putStrLn "nova-cache xz test suite"
putStrLn "========================"
results <-
sequence
[ test "roundtrip under the exact output bound" $
-- NarSize is exact, so output == bound must pass.
assertEqual
"text fixture"
(Right textPlain)
(Xz.decompress (boundedTo (fromIntegral (BS.length textPlain))) textXz),
test "high-expansion input inflates fully under an open bound" $
case Xz.decompress openLimits zerosXz of
Left err -> do
putStrLn (" unexpected error: " ++ show err)
pure False
Right out -> do
ok1 <- assertEqual "length" zerosLength (fromIntegral (BS.length out))
ok2 <- assertTrue "all zero" (BS.all (== 0) out)
pure (ok1 && ok2),
test "output over the bound is refused" $
assertEqual
"far bound"
(Left (Xz.XzOutputOverBound 1000))
(Xz.decompress (boundedTo 1000) zerosXz),
test "one byte under the true size is refused" $
assertEqual
"tight bound"
(Left (Xz.XzOutputOverBound (fromIntegral (zerosLength - 1))))
(Xz.decompress (boundedTo (zerosLength - 1)) zerosXz),
test "garbage input is a stream error" $
assertTrue "garbage" (isStreamError (Xz.decompress openLimits "not an xz stream")),
test "a truncated stream is a stream error" $
assertTrue "truncated" (isStreamError (Xz.decompress openLimits (BS.take 40 textXz))),
test "concatenated streams decode as one output" $
-- Upstream decodes with LZMA_CONCATENATED; two streams
-- back-to-back are one valid input.
assertEqual
"two text streams"
(Right (textPlain <> textPlain))
(Xz.decompress openLimits (textXz <> textXz)),
test "trailing garbage after the stream is refused" $
assertTrue
"trailing garbage"
(isStreamError (Xz.decompress openLimits (textXz <> "garbage!"))),
test "a dictionary past the memory bound is refused" $
-- zerosXz declares an 8 MiB dictionary; cap the decoder at 1 MiB.
assertEqual
"memory bound"
(Left (Xz.XzMemoryOverBound smallMemory))
(Xz.decompress openLimits {Xz.xzMaxDecoderMemoryBytes = smallMemory} zerosXz),
test "withXzSource decompresses a chunked source" $ do
source <- listSource (chunksOf 7 textXz)
out <- Xz.withXzSource openLimits source drainSource
assertEqual "streamed output" textPlain out,
test "withXzSource throws past the output bound" $ do
source <- listSource (chunksOf 16 zerosXz)
outcome <-
try (Xz.withXzSource (boundedTo 1000) source drainSource) ::
IO (Either Xz.XzError ByteString)
assertEqual "thrown" (Left (Xz.XzOutputOverBound 1000)) outcome,
test "withXzSource keeps returning empty after the end" $ do
source <- listSource [textXz]
ends <- Xz.withXzSource openLimits source $ \pull -> do
_ <- drainSource pull
endA <- pull
endB <- pull
pure (endA, endB)
assertEqual "stable end" ("", "") ends
]
if and results
then do
putStrLn ""
putStrLn ("All " ++ show (length results) ++ " tests passed.")
exitSuccess
else do
putStrLn ""
putStrLn "Some tests FAILED."
exitFailure
where
smallMemory = 1024 * 1024
isStreamError outcome = case outcome of
Left (Xz.XzStreamError _) -> True
_ -> False
drainSource pull = go []
where
go acc = do
chunk <- pull
if BS.null chunk
then pure (BS.concat (reverse acc))
else go (chunk : acc)