snappy-hs-0.1.2.0: test/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import Control.Monad (forM_, unless)
import qualified Data.ByteString as BS
import Data.IORef
import Data.Word (Word8, Word64)
import Snappy
import System.Exit (exitFailure)

main :: IO ()
main = do
    fails <- newIORef (0 :: Int)
    let roundTrip label bs = case decompress (compress bs) of
            Left e            -> bad fails (label ++ ": decode error: " ++ show e)
            Right d
                | d == bs     -> putStrLn ("OK: " ++ label)
                | otherwise   -> bad fails (label ++ ": round-trip mismatch")
        rejects label bs = case decompress bs of
            Left _  -> putStrLn ("OK: " ++ label)
            Right _ -> bad fails (label ++ ": expected decode error, got success")

    -- Original smoke cases.
    roundTrip "short repetitive" (BS.replicate 100 65)
    roundTrip "single byte" "x"
    roundTrip "short string" "Hello, world!"
    roundTrip "longer repetitive" (BS.replicate 1000 65)
    roundTrip "varied" "Hello, Snappy! Hello, Snappy! ABCDEFGHIJKLMNOP 1234567890"
    roundTrip "already compressed-like" (BS.pack [0..255])

    -- Sizes around the literal/copy/word-copy boundaries exercised by the fast
    -- paths (60-byte literal tag, 16-byte wide copy, 2KB copy-offset classes).
    forM_ [0,1,2,3,4,5,15,16,17,59,60,61,63,64,65,255,256,257,2047,2048,2049
          ,65535,65536,65537,200000] $ \n -> do
        roundTrip ("run " ++ show n)        (BS.replicate n 88)
        roundTrip ("periodic " ++ show n)   (BS.take n (cycleBS "abcdefgh/" n))
        roundTrip ("incompressible " ++ show n) (lcg n)

    -- A long, highly self-similar input drives overlapping copies of every class.
    roundTrip "mixed large" (BS.concat (replicate 4000 "the quick brown fox 0123456789 "))

    -- Malformed streams must error, never crash.
    rejects "empty" BS.empty
    rejects "truncated varint" (BS.pack [0x80])
    rejects "copy offset past output" (BS.pack [0x08, 0xfc, 0x00])
    rejects "literal length exceeds input" (BS.pack [0x04, 0xf0])
    rejects "truncated 4-byte literal" (BS.pack [0xfe, 0x00, 0x00])

    n <- readIORef fails
    if n == 0
        then putStrLn "All tests passed."
        else putStrLn (show n ++ " tests failed.") >> exitFailure

bad :: IORef Int -> String -> IO ()
bad ref msg = modifyIORef' ref (+ 1) >> putStrLn ("FAIL: " ++ msg)

-- Repeat @pat@ until at least @n@ bytes are available.
cycleBS :: BS.ByteString -> Int -> BS.ByteString
cycleBS pat n
    | BS.null pat = BS.empty
    | otherwise   = BS.concat (replicate (n `div` BS.length pat + 1) pat)

-- Deterministic pseudo-random bytes (LCG); no external deps.
lcg :: Int -> BS.ByteString
lcg n = fst (BS.unfoldrN n step 0x2545F4914F6CDD1D)
  where
    step :: Word64 -> Maybe (Word8, Word64)
    step s =
        let s' = s * 6364136223846793005 + 1442695040888963407
        in Just (fromIntegral (s' `div` 0x100000000), s')