nova-cache-0.8.0.0: test/XzTest.hs

-- | Tests for the bounded xz decoder.  A separate suite because it
-- exists only under the @xz@ flag; 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)