JuicyPixels-blp 0.4.0.0 → 0.4.1.0

raw patch · 11 files changed

+384/−76 lines, 11 filesdep +QuickCheckdep +tasty-quickcheckdep ~JuicyPixelsdep ~attoparsecdep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-quickcheck

Dependency ranges changed: JuicyPixels, attoparsec, binary, bytestring, deepseq, directory, filepath, optparse-simple, transformers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +33/−2
• JuicyPixels-blp.cabal +17/−11
• README.md +12/−4
• blp2any/Convert.hs +31/−12
• blp2any/Main.hs +8/−1
• blp2any/Statistics.hs +4/−4
• docs/format.md +6/−4
• src/Codec/Picture/Blp.hs +68/−6
• test/Fixture.hs +10/−10
• test/Main.hs +51/−22
• test/Properties.hs +144/−0

@@ -1,3 +1,33 @@+0.4.1.0 (2026-10-15)+====================++- Decoding refuses images above `blpMaxPixels` pixels, 8192x8192 by default,+  before allocating anything. `decodeBlpWith` and `decodeBlpMipmapsWith` take+  `BlpDecodeOptions` to set the limit. The 0.4.0.0 notes claimed that small+  files could no longer demand gigabytes; that was wrong. A JPEG frame+  smaller than its level is padded to the level size, and the level size+  comes from the header, so a 493-byte file claiming 65535x65535 pixels+  still made the decoder allocate about 17 GB.+- `blpInfo` reads the header (content type, size, alpha bits, usable mip+  levels) without decoding any pixels, so callers can reject textures+  before decoding them.+- `BlpCompression` is exported from `Codec.Picture.Blp`.+- blp2any:+  - `--timeout SECONDS` gives up on a file that takes too long, so a corrupt+    JPEG that makes decoding hang no longer stalls a batch.+  - An output name with an unknown extension is an error; it used to be+    written as PNG regardless, and `.tif` output really was PNG.+  - It refuses to write over its input, rejects `-q` outside 1..100, prints+    encoding errors in words, and `stats` finds `*.BLP` in upper case.+- Lower bounds now match the oldest versions CI tests: JuicyPixels 3.3.6,+  vector 0.12.3, attoparsec 0.14.4, binary 0.8.9, bytestring 0.11.5 and+  deepseq 1.4.8 (and for blp2any directory 1.3.7, filepath 1.4.2,+  optparse-simple 0.1, transformers 0.5.6), and a CI job builds and tests+  with exactly those. The old bounds allowed versions that were never+  tested.+- Fixed the documentation of `decodeBlpMipmaps`, which rendered as "Element+  @ is always mip level @".+ 0.4.0.0 (2026-10-15) ==================== @@ -41,8 +71,9 @@ - Width and height must be between 1 and 65535. Larger values used to   overflow the size checks and leave an exception in the decoded image. - Each JPEG level's frame size is read before decoding. A frame larger than-  the level is rejected, so an 800-byte file can no longer demand gigabytes;-  a smaller one is padded with transparent black.+  the level is rejected; a smaller one is padded with transparent black.+  (This was described as stopping small files from demanding gigabytes;+  it did not, see 0.4.1.0.) - Mipmap slots are read by index. A missing or garbage slot ends the chain   instead of shifting the later levels, and a garbage slot that points into   the palette no longer breaks the file.

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                JuicyPixels-blp-version:             0.4.0.0+version:             0.4.1.0 synopsis:            BLP format decoder/encoder over JuicyPixels library description:   Read and write BLP1, the texture format of Warcraft III, with images as@@ -48,12 +48,12 @@   default-language:    Haskell2010   build-depends:       base                  >= 4.17   && < 5-    , attoparsec            >= 0.12   && < 0.15-    , binary                >= 0.8    && < 0.10-    , bytestring            >= 0.10   && < 0.13-    , deepseq               >= 1.4    && < 1.6-    , JuicyPixels           >= 3.2    && < 3.4-    , vector                >= 0.10   && < 0.14+    , attoparsec            >= 0.14.4 && < 0.15+    , binary                >= 0.8.9  && < 0.10+    , bytestring            >= 0.11.5 && < 0.13+    , deepseq               >= 1.4.8  && < 1.6+    , JuicyPixels           >= 3.3.6  && < 3.4+    , vector                >= 0.12.3 && < 0.14    default-extensions:     BangPatterns@@ -79,12 +79,12 @@       base     , bytestring     , containers            >= 0.6    && < 0.9-    , directory             >= 1.2    && < 1.4-    , filepath              >= 1.4    && < 1.6+    , directory             >= 1.3.7  && < 1.4+    , filepath              >= 1.4.2  && < 1.6     , JuicyPixels     , JuicyPixels-blp-    , optparse-simple       >= 0.0.3  && < 0.2-    , transformers          >= 0.5    && < 0.7+    , optparse-simple       >= 0.1    && < 0.2+    , transformers          >= 0.5.6  && < 0.7    default-extensions:     RecordWildCards@@ -109,9 +109,12 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Main.hs+  -- No test needs more; a decoder that allocates without bound fails loudly.+  ghc-options:         -rtsopts -with-rtsopts=-M1g   other-modules:     Deprecated     Fixture+    Properties   default-language:    Haskell2010   build-depends:       base@@ -121,7 +124,10 @@     , JuicyPixels     , JuicyPixels-blp     , tasty                 >= 1.4    && < 1.6+    , deepseq+    , QuickCheck            >= 2.14   && < 2.17     , tasty-hunit           >= 0.10   && < 0.11+    , tasty-quickcheck      >= 0.10.2 && < 0.12    default-extensions:     OverloadedStrings

@@ -64,7 +64,10 @@     one onwards; a damaged full size image still fails the file.    The decoder reports malformed input as `Left`, including errors raised-  inside JuicyPixels' JPEG decoder. One known exception: some corrupt JPEG+  inside JuicyPixels' JPEG decoder. Memory use follows the size in the file+  header, so decoding refuses images above 8192×8192 by default; check+  untrusted files with `blpInfo` and set your own limit with+  `decodeBlpWith (BlpDecodeOptions n)`. One known exception: some corrupt JPEG   streams make JuicyPixels loop forever   ([Juicy.Pixels#230](https://github.com/haskell-github-trust/Juicy.Pixels/issues/230)),   so decoding untrusted files needs a timeout.@@ -86,18 +89,21 @@ ``` blp2any convert INPUT_PATH OUTPUT_PATH [-i FORMAT] [-f FORMAT] [-q QUALITY]                 [-b jpg|uncompressedWithAlpha|uncompressedWithoutAlpha]-                [--min-mipmap-size N] [-s|--shallow] [-p|--flatten]+                [--min-mipmap-size N] [-s|--shallow] [-p|--flatten] [--timeout SECONDS] blp2any stats DIRECTORY OUTPUT_PATH ```  - **`convert`** turns a file or a whole directory from one format into-  another. Supported formats are `blp`, `png`, `jpg`, `tiff`, `gif` and-  `bmp`.+  another. Supported formats are `blp`, `png`, `jpg`, `tiff` (`tif`), `gif`+  and `bmp`.   - Formats are inferred from the file names, or given with `-i` and `-f`.   - With a directory it recurses unless `-s` is given, and it recreates the     subdirectories unless `-p` (`--flatten`) is given. A file that fails is     reported on stderr and skipped; at the end it prints how many files were     converted and failed, and exits with status 1 if any failed.+  - `--timeout SECONDS` gives up on a file that takes longer; use it on+    untrusted input, where some corrupt JPEG data makes decoding hang. The+    output never overwrites its input.   - When writing BLP, `-b` picks the internal format (JPEG by default) and     `--min-mipmap-size` the smallest mip level to keep. The default is 1,     which writes every level down to 1×1. A larger value leaves textures@@ -113,6 +119,8 @@ ```  ## Building and testing++See [CONTRIBUTING.md](CONTRIBUTING.md) for what a pull request needs.  With [Nix](https://nixos.org) (flakes enabled), each supported GHC has its own development shell:

@@ -20,6 +20,7 @@ import System.Exit import System.FilePath import System.IO+import System.Timeout (timeout)  import qualified Data.ByteString as BS @@ -63,6 +64,7 @@   "jfif" -> Just Jpeg   "jfi" -> Just Jpeg   "tiff" -> Just Tiff+  "tif" -> Just Tiff   "gif" -> Just Gif   "bmp" -> Just Bmp   _ -> Nothing@@ -76,7 +78,7 @@   Blp -> [".blp"]   Png -> [".png"]   Jpeg -> [".jpeg", ".jpg", ".jpe", ".jif", ".jfif", ".jfi"]-  Tiff -> [".tiff"]+  Tiff -> [".tiff", ".tif"]   Gif -> [".gif"]   Bmp -> [".bmp"]   UnspecifiedFormat -> []@@ -94,13 +96,14 @@ , convertShallow        :: Bool , convertBlpKind        :: BlpKind , convertBlpMinMipSize  :: Int+, convertTimeout        :: Maybe Int }  convertFiles :: ConvertOptions -> IO () convertFiles opts@ConvertOptions{..} = do   isFile <- doesFileExist convertInput   isDir <- doesDirectoryExist convertInput-  if | isFile -> convertFile opts False convertInput >>= either (failWith . ((convertInput ++ ": ") ++)) putStrLn+  if | isFile -> withTimeout convertTimeout (convertFile opts False convertInput) >>= either (failWith . ((convertInput ++ ": ") ++)) putStrLn      | isDir -> do          putStrLn $ "Converting all files from " ++ convertInput ++ " folder"          (converted, failed) <- forEachFile (not convertShallow) convertInput fileFilter step (0 :: Int, 0 :: Int)@@ -109,7 +112,7 @@      | otherwise -> failWith $ "Given path " ++ convertInput ++ " doesn't exist!"   where     step (!converted, !failed) inputFile = do-      result <- tryAll (convertFile opts True inputFile)+      result <- tryAll (withTimeout convertTimeout (convertFile opts True inputFile))       case join result of         Right msg -> putStrLn msg >> return (converted + 1, failed)         Left err -> hPutStrLn stderr (inputFile ++ ": " ++ err) >> return (converted, failed + 1)@@ -142,25 +145,41 @@ convertFile :: ConvertOptions -> Bool -> FilePath -> IO (Either String String) convertFile ConvertOptions{..} isDir inputFile = runExceptT $ do   img <- ExceptT $ readInputFile inputFile convertInputFormat-  let distFormat = case convertFormat of-        UnspecifiedFormat -> if isDir then defaultFormat-          else case guessFormat convertOutput of-            Just f -> f-            Nothing -> defaultFormat-        _ -> convertFormat--      outputName = takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat)+  distFormat <- case convertFormat of+    UnspecifiedFormat+      | isDir -> pure defaultFormat+      | otherwise -> maybe+          (throwE $ "cannot tell the output format from " <> convertOutput <> "; give it with -f")+          pure (guessFormat convertOutput)+    _ -> pure convertFormat+  let outputName = takeBaseName inputFile <> fromMaybe "" (listToMaybe $ formatExtension distFormat)       -- Keep the input's subdirectory unless asked to flatten the output.       outputFile         | not isDir = convertOutput         | convertPreservesDirs = convertOutput </> makeRelative convertInput (takeDirectory inputFile) </> outputName         | otherwise = convertOutput </> outputName+  sameFile <- liftIO $ equalFilePath <$> makeAbsolute inputFile <*> makeAbsolute outputFile+  when sameFile . throwE $ "the output " <> outputFile <> " would overwrite the input"   liftIO . createDirectoryIfMissing True $ takeDirectory outputFile    let mipsCount = mipMapsUpTo convertBlpMinMipSize img   ExceptT $ convertionFunction distFormat convertQuality convertBlpKind outputFile mipsCount img   pure $ inputFile <> ": Success" +-- | A readable message for an encoding error.+describeEncodeError :: BlpEncodeError -> String+describeEncodeError e = case e of+  BlpEmptyImage -> "the image is empty"+  BlpImageTooLarge w h -> "the image is " <> show w <> "x" <> show h <> ", above the 65535 pixel limit of BLP"+  BlpInvalidJpegQuality q -> "JPEG quality must be 1 to 100, got " <> show q+  BlpFileTooLarge -> "the BLP file would be larger than 4 GiB"++-- | Run a conversion, giving up after the given number of seconds.+withTimeout :: Maybe Int -> IO (Either String a) -> IO (Either String a)+withTimeout Nothing action = action+withTimeout (Just seconds) action =+  fromMaybe (Left $ "gave up after " <> show seconds <> " s") <$> timeout (seconds * 1000000) action+ convertionFunction :: ConvertFormat -> Int -> BlpKind -> FilePath -> Int -> DynamicImage -> IO (Either String ()) convertionFunction f quality blpKind path mipsCount img = case f of   Blp -> do@@ -169,7 +188,7 @@           BlpUncompressedWithAlpha -> BlpFormatPaletted True           BlpUncompressedWithoutAlpha -> BlpFormatPaletted False     res <- writeBlpWith path (BlpEncodeOptions format mipsCount) img-    pure $ either (Left . show) Right res+    pure $ either (Left . describeEncodeError) Right res   Png -> do     res <- writeDynamicPng path img     pure $ void res

@@ -22,6 +22,12 @@ convertFormatR :: ReadM ConvertFormat convertFormatR = readMPure "format" readConvertFormat +-- | JPEG quality, 1 to 100.+qualityR :: ReadM Int+qualityR = do+  q <- auto+  if q >= 1 && q <= 100 then return q else fail "quality must be 1 to 100"+ -- | How to parse BlpKind blpKindR :: ReadM BlpKind blpKindR = readMPure "blp format" readBlpKind@@ -34,11 +40,12 @@       <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)")       <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.")       <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.")-      <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)")+      <*> option qualityR (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression, 1 to 100 (default 90)")       <*> fmap not (switch (long "flatten" <> long "notPreserveStructure" <> short 'p' <> help "Write every converted file straight into OUTPUT_PATH instead of recreating subfolders (files with the same name overwrite each other)"))       <*> switch (long "shallow" <> short 's' <> help "Only convert files directly in INPUT_PATH, not in its subfolders")       <*> option blpKindR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")       <*> option auto (long "min-mipmap-size" <> value 1 <> help "Smallest mipmap side to keep when writing BLP (default 1)")+      <*> optional (option auto (long "timeout" <> metavar "SECONDS" <> help "Give up on a file after this many seconds; some corrupt JPEG data makes decoding hang"))     addCommand "stats" "Groups the BLPs in a folder by header values and saves one example of each group" (uncurry collectStatistics) $ (,)       <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)")       <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored")

@@ -6,7 +6,8 @@  import Codec.Picture.Blp.Internal.Data import Codec.Picture.Blp.Internal.Parser-import Control.Monad +import Control.Monad+import Data.Char (toLower) import Data.Word  import System.Directory import System.FilePath@@ -27,7 +28,7 @@ collectSamples dir = do    f <- doesDirectoryExist dir   unless f $ fail $ "Provided directory " ++ dir ++ " doesn't exists!"-  forEachFile True dir ((".blp" ==) . takeExtension) collectSample M.empty+  forEachFile True dir ((".blp" ==) . map toLower . takeExtension) collectSample M.empty  collectSample :: StatMap -> FilePath -> IO StatMap collectSample stats inputFile = do@@ -55,8 +56,7 @@     createDirectoryIfMissing True dir     forM_ (M.toList stats) $ \((compression, alphaBits, extra, hasMipmaps), (path, i)) -> do        let postfix = L.intercalate "-" [show compression, "alpha" ++ show alphaBits, "extra" ++ show extra, "mips" ++ show hasMipmaps]-      copyFile path $ dir ++ "/" ++ dropExtension (takeFileName path) ++ "-"-        ++ postfix ++ ".blp"+      copyFile path $ dir </> dropExtension (takeFileName path) ++ "-" ++ postfix ++ ".blp"       putStrLn $ postfix ++ ": " ++ show i ++ " images"  collectStatistics :: FilePath -> FilePath -> IO ()

@@ -112,10 +112,12 @@   across unchanged ([#11](https://github.com/NCrashed/JuicyPixels-blp/pull/11),   [#17](https://github.com/NCrashed/JuicyPixels-blp/issues/17)). - **Frame size.** The decoder reads each level's frame size before decoding-  it. A frame larger than the level is treated as damage, which also stops a-  forged frame header from making the decoder allocate gigabytes. A smaller-  frame is padded with transparent black to the level size, as Warcraft III-  does.+  it. A frame larger than the level is treated as damage, and a smaller one+  is padded with transparent black to the level size, as Warcraft III does.+  The level size comes from the BLP header, which a forged file controls as+  well, so the decoder also refuses full size images above `blpMaxPixels`+  (8192×8192 by default) before allocating anything. `blpInfo` reads the+  size without decoding. - **JuicyPixels.** The JPEG streams themselves are decoded by JuicyPixels.   Errors it raises are turned into `Left`, but some corrupt streams make it   loop forever

@@ -19,10 +19,21 @@ -} module Codec.Picture.Blp(   -- * Decoding+  -- | Decoding allocates the full size image, whose size comes from the+  -- file. For untrusted input, check it first with 'blpInfo' or lower+  -- 'blpMaxPixels'.     readBlp   , readBlpMipmaps   , decodeBlp   , decodeBlpMipmaps+  , decodeBlpWith+  , decodeBlpMipmapsWith+  , BlpDecodeOptions(..)+  , defaultBlpDecodeOptions+  -- * Inspecting+  , blpInfo+  , BlpInfo(..)+  , BlpCompression(..)   -- * Encoding   , encodeBlpWith   , writeBlpWith@@ -45,6 +56,7 @@ import Codec.Picture import Control.DeepSeq (force) import Control.Exception+import Control.Monad (when) import Data.Bits ((.&.), shiftR) import Data.ByteString (ByteString) import System.IO.Unsafe (unsafeDupablePerformIO)@@ -68,24 +80,49 @@ readBlpMipmaps :: FilePath -> IO (Either String [DynamicImage]) readBlpMipmaps fp = decodeBlpMipmaps `fmap` BS.readFile fp --- | Decode the full size image of a BLP file. The result is 'ImageRGBA8'.+-- | Decode the full size image of a BLP file with 'defaultBlpDecodeOptions'.+-- The result is 'ImageRGBA8'. decodeBlp :: ByteString -> Either String DynamicImage-decodeBlp bs = do-  is <- decodeBlpMipmaps bs+decodeBlp = decodeBlpWith defaultBlpDecodeOptions++-- | Decode the full size image of a BLP file. The result is 'ImageRGBA8'.+decodeBlpWith :: BlpDecodeOptions -> ByteString -> Either String DynamicImage+decodeBlpWith opts bs = do+  is <- decodeBlpMipmapsWith opts bs   case is of     i : _ -> Right i     [] -> Left "No data in BLP" +-- | Decode the full size image followed by its mipmaps with+-- 'defaultBlpDecodeOptions'. See 'decodeBlpMipmapsWith'.+decodeBlpMipmaps :: ByteString -> Either String [DynamicImage]+decodeBlpMipmaps = decodeBlpMipmapsWith defaultBlpDecodeOptions++-- | Options for decoding.+newtype BlpDecodeOptions = BlpDecodeOptions {+  -- | Largest full size image to decode, in pixels. Larger files are+  -- rejected before anything is allocated; decoding takes about four bytes+  -- per pixel.+  blpMaxPixels :: Int+} deriving (Eq, Show)++-- | Up to 8192x8192 pixels, about 256 MiB for the full size image.+defaultBlpDecodeOptions :: BlpDecodeOptions+defaultBlpDecodeOptions = BlpDecodeOptions { blpMaxPixels = 8192 * 8192 }+ -- | Decode the full size image followed by its mipmaps, all 'ImageRGBA8'. ----- Element @ is always mip level @. Mipmaps are decoded lazily, and the+-- Element @i@ is always mip level @i@. Mipmaps are decoded lazily, and the -- list stops at the first one that is damaged, so a broken mipmap never -- costs the levels before it. A damaged full size image fails the file.-decodeBlpMipmaps :: ByteString -> Either String [DynamicImage]-decodeBlpMipmaps bs = do+decodeBlpMipmapsWith :: BlpDecodeOptions -> ByteString -> Either String [DynamicImage]+decodeBlpMipmapsWith opts bs = do   blp <- parseBlp bs   let width = fromIntegral $ blpWidth blp       height = fromIntegral $ blpHeight blp+  when (width * height > blpMaxPixels opts) . Left $+    "Image size " ++ show width ++ "x" ++ show height ++ " is above the limit of "+    ++ show (blpMaxPixels opts) ++ " pixels"   case blpExt blp of     BlpJpeg {..} -> case blpJpegData of       [] -> Left "No JPEG mipmap data in BLP"@@ -151,6 +188,31 @@     Left e       | Just async <- fromException e -> throwIO (async :: SomeAsyncException)       | otherwise -> return . Left $ "JPEG decoding failed: " ++ displayException (e :: SomeException)++-- | What a BLP file holds, read from its header without decoding any pixels.+data BlpInfo = BlpInfo {+    blpInfoCompression :: !BlpCompression -- ^ JPEG or paletted content+  , blpInfoWidth :: !Int -- ^ Width of the full size image+  , blpInfoHeight :: !Int -- ^ Height of the full size image+  , blpInfoAlphaBits :: !Int -- ^ The @alphaBits@ header field, as stored+  , blpInfoMipLevels :: !Int -- ^ Mip levels with usable slots, the full size image included+  } deriving (Eq, Show)++-- | Read the header of a BLP file. This checks what 'decodeBlp' checks before+-- decoding (format, size, mipmap slots) but decodes no pixels, so it is cheap+-- on any input. Use it to reject textures that are too large.+blpInfo :: ByteString -> Either String BlpInfo+blpInfo bs = do+  blp <- parseBlp bs+  return BlpInfo {+      blpInfoCompression = blpCompression blp+    , blpInfoWidth = fromIntegral $ blpWidth blp+    , blpInfoHeight = fromIntegral $ blpHeight blp+    , blpInfoAlphaBits = fromIntegral $ blpAlphaBits blp+    , blpInfoMipLevels = case blpExt blp of+        BlpJpeg {..} -> length blpJpegData+        BlpPaletted {..} -> length blpPalettedMipMaps+    }  -- | Bytes a paletted mip level of @n@ pixels takes: the index list and the -- alpha list.

@@ -15,7 +15,7 @@   , setDword   , offsetSlot   , sizeSlot-  , pictureTypeOffset+  , extraOffset   ) where  import Data.Bits@@ -26,22 +26,22 @@  data Header = Header {   hCompression :: Word32-, hFlags       :: Word32+, hAlphaBits   :: Word32 , hWidth       :: Word32 , hHeight      :: Word32-, hPictureType :: Word32-, hSubType     :: Word32+, hExtra       :: Word32+, hHasMipmaps  :: Word32 }  -- | Uncompressed, with-alpha 4x4 header; override fields as needed. defHeader :: Header defHeader = Header {     hCompression = 1-  , hFlags       = 8+  , hAlphaBits   = 8   , hWidth       = 4   , hHeight      = 4-  , hPictureType = 4-  , hSubType     = 5+  , hExtra       = 4+  , hHasMipmaps  = 5   }  -- | Size of the fixed BLP1 header: tag, six dwords, 16 offsets, 16 sizes.@@ -53,7 +53,7 @@ blpFile :: Header -> [(Word32, Word32)] -> ByteString -> ByteString blpFile Header{..} slots body = BS.concat   [ "BLP1"-  , dwords [hCompression, hFlags, hWidth, hHeight, hPictureType, hSubType]+  , dwords [hCompression, hAlphaBits, hWidth, hHeight, hExtra, hHasMipmaps]   , dwords (map fst slots') , dwords (map snd slots')   , body   ]@@ -89,8 +89,8 @@ setDword o v bs = BS.take o bs <> dword v <> BS.drop (o + 4) bs  -- | File offsets of the header fields that tests patch.-pictureTypeOffset :: Int-pictureTypeOffset = 20+extraOffset :: Int+extraOffset = 20  offsetSlot, sizeSlot :: Int -> Int offsetSlot i = 28 + 4 * i

@@ -18,6 +18,7 @@ import qualified Data.ByteString.Lazy as BSL  import Deprecated+import Properties import Fixture  main :: IO ()@@ -25,9 +26,11 @@   [ uncompressedTests   , malformedTests   , jpegTests+  , limitTests   , encoderTests   , fileTests   , deprecatedTests+  , propertyTests   ]  -- | 4x4 test texture: pixel (x, y) is palette index @y*4+x@.@@ -49,10 +52,10 @@ withoutAlphaPixel k = PixelRGBA8 (k * 16) (255 - k * 16) (k * 3) 255  withAlphaFile :: Word32 -> ByteString-withAlphaFile ptype = uncompressed defHeader { hPictureType = ptype } (palette 256) [indices <> alphaPlane]+withAlphaFile ptype = uncompressed defHeader { hExtra = ptype } (palette 256) [indices <> alphaPlane]  withoutAlphaFile :: ByteString-withoutAlphaFile = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices]+withoutAlphaFile = uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [indices]  pixelsOf :: Image PixelRGBA8 -> [PixelRGBA8] pixelsOf img = [pixelAt img x y | y <- [0 .. imageHeight img - 1], x <- [0 .. imageWidth img - 1]]@@ -80,32 +83,32 @@   , testCase "with alpha, picture type 3" $ assertPixels withAlphaPixel (withAlphaFile 3)   , testCase "picture type 0 decodes as with alpha (#10)" $ assertPixels withAlphaPixel (withAlphaFile 0)   , testCase "alphaBits 8 keeps alpha whatever extra says (#25)" $-      assertPixels withAlphaPixel $ uncompressed defHeader { hPictureType = 5 } (palette 256) [indices <> alphaPlane]+      assertPixels withAlphaPixel $ uncompressed defHeader { hExtra = 5 } (palette 256) [indices <> alphaPlane]   , testCase "extra has no effect (#25)" $       forM_ [0, 1, 2, 3, 4, 5, 6, 7, 99] $ \extra ->         assertPixels withAlphaPixel (withAlphaFile extra)   , testCase "alphaBits 0 ignores a trailing alpha list (#25)" $-      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 4 } (palette 256) [indices <> alphaPlane]+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hAlphaBits = 0, hExtra = 4 } (palette 256) [indices <> alphaPlane]   , testCase "1-bit alpha, least significant bit first (#25)" $ do-      let bs = uncompressed defHeader { hFlags = 1 } (palette 256) [indices <> BS.pack [0x0f, 0xf0]]+      let bs = uncompressed defHeader { hAlphaBits = 1 } (palette 256) [indices <> BS.pack [0x0f, 0xf0]]           on k = k < 4 || k >= 12       assertPixels (\k -> setAlpha (if on k then 255 else 0) (withoutAlphaPixel k)) bs   , testCase "4-bit alpha, low nibble first (#25)" $ do       let nibbles = BS.pack [fromIntegral (2 * j) + 16 * fromIntegral (2 * j + 1) | j <- [0 .. 7 :: Int]]-          bs = uncompressed defHeader { hFlags = 4 } (palette 256) [indices <> nibbles]+          bs = uncompressed defHeader { hAlphaBits = 4 } (palette 256) [indices <> nibbles]       assertPixels (\k -> setAlpha (k * 17) (withoutAlphaPixel k)) bs   , testCase "invalid alphaBits counts as no alpha (#25)" $-      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 3 } (palette 256) [indices <> alphaPlane]+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hAlphaBits = 3 } (palette 256) [indices <> alphaPlane]   , testCase "without alpha, picture type 5" $ assertPixels withoutAlphaPixel withoutAlphaFile   , testCase "without alpha ignores the palette's fourth byte (#14)" $-      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 5 }+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hAlphaBits = 0, hExtra = 5 }         [(b, g, r, 255) | (b, g, r, _) <- palette 256] [indices]   , testCase "labelled with alpha, mip 0 holds only indices (#8)" $       assertPixels withoutAlphaPixel $ uncompressed defHeader (palette 256) [indices]   , testCase "labelled with alpha, mip 0 between one and two planes (#8)" $       assertPixels withoutAlphaPixel $ uncompressed defHeader (palette 256) [indices <> "pad"]   , testCase "palette shorter than 256 entries (#6)" $-      assertPixels withoutAlphaPixel $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 16) [indices]+      assertPixels withoutAlphaPixel $ uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 16) [indices]   , testCase "mipmap slot past the end of the file is skipped (#7)" $ do       let bs = setDword (offsetSlot 1) 100000 . setDword (sizeSlot 1) 16 $ withAlphaFile 4       assertPixels withAlphaPixel bs@@ -125,21 +128,21 @@       pixelsOf (levels !! 1) @?= [PixelRGBA8 (k * 16) (255 - k * 16) (k * 3) (k + 4) | k <- [1 .. 4]]       pixelsOf (levels !! 2) @?= [PixelRGBA8 144 111 27 10]   , testCase "without alpha mip levels have their own sizes (#13)" $ do-      let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices, "\1\2\3\4", "\9"]+      let bs = uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [indices, "\1\2\3\4", "\9"]       levels <- decodeLevels bs       sizes levels @?= [(4, 4), (2, 2), (1, 1)]       pixelsOf (levels !! 1) @?= map withoutAlphaPixel [1 .. 4]   , testCase "non-square texture halves each side down to 1 (#13)" $ do-      let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5, hWidth = 4, hHeight = 2 } (palette 256)+      let bs = uncompressed defHeader { hAlphaBits = 0, hExtra = 5, hWidth = 4, hHeight = 2 } (palette 256)             [BS.take 8 indices, "\1\2", "\3"]       levels <- decodeLevels bs       sizes levels @?= [(4, 2), (2, 1), (1, 1)]   , testCase "mip level shorter than its size ends the list (#13)" $ do-      let bs = uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [indices, "\1\2", "\9"]+      let bs = uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [indices, "\1\2", "\9"]       levels <- decodeLevels bs       sizes levels @?= [(4, 4)]   , testCase "mip 0 shorter than the image is an error, not an exception (#13)" $-      assertLeft "too short" . decodeBlp $ uncompressed defHeader { hFlags = 0, hPictureType = 5 } (palette 256) [BS.take 8 indices]+      assertLeft "too short" . decodeBlp $ uncompressed defHeader { hAlphaBits = 0, hExtra = 5 } (palette 256) [BS.take 8 indices]   ]  malformedTests :: TestTree@@ -157,7 +160,7 @@   , testCase "JPEG header longer than the file" $       assertLeft "jpeg header" . decodeBlp $ setDword headerSize 100000 jpegFile   , testCase "width or height outside 1..65535 is an error" $ do-      let sized w h = uncompressed defHeader { hFlags = 0, hWidth = w, hHeight = h } (palette 256) [BS.replicate 4 0]+      let sized w h = uncompressed defHeader { hAlphaBits = 0, hWidth = w, hHeight = h } (palette 256) [BS.replicate 4 0]       assertLeft "Invalid image size" . decodeBlp $ sized 0xFFFFFFFF 0xFFFFFFFF       assertLeft "Invalid image size" . decodeBlp $ sized 0 4       assertLeft "Invalid image size" . decodeBlp $ sized 4 65536@@ -210,7 +213,7 @@       assertBool "every pixel opaque" $ all (\(PixelRGBA8 _ _ _ a) -> a == 255) (pixelsOf img)   , testCase "picture type 6 decodes like the original (#5)" $ do       orig <- decodeRGBA jpegFile-      img <- decodeRGBA (setDword pictureTypeOffset 6 jpegFile)+      img <- decodeRGBA (setDword extraOffset 6 jpegFile)       pixelsOf img @?= pixelsOf orig   , testCase "broken middle mip keeps only the levels before it (#9)" $ do       levels <- decodeLevels (setDword (sizeSlot 1) 12 jpegFile)@@ -246,7 +249,7 @@   , testCase "three-component JPEG decodes to RGBA" $ do       let rgb = generateImage (\x y -> PixelRGB8 (fromIntegral $ x * 16) (fromIntegral $ y * 16) 128) 16 16           jpeg = BSL.toStrict . encodeJpeg $ (convertImage rgb :: Image PixelYCbCr8)-          bs = blpFile defHeader { hCompression = 0, hFlags = 0, hWidth = 16, hHeight = 16, hPictureType = 2 }+          bs = blpFile defHeader { hCompression = 0, hAlphaBits = 0, hWidth = 16, hHeight = 16, hExtra = 2 }             [(fromIntegral headerSize + 4, fromIntegral $ BS.length jpeg)] ("\0\0\0\0" <> jpeg)       dyn <- either (assertFailure . ("decodeBlp: " ++)) return $ decodeBlp bs       case dyn of@@ -286,12 +289,12 @@   [ testCase "with alpha writes the expected header" $ do       let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 3 (ImageRGBA8 gradient)       map (`getDword` bs) [4, 8, 12, 16] @?= [1, 8, 16, 16]-      getDword pictureTypeOffset bs @?= 3+      getDword extraOffset bs @?= 3       map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [512, 128, 32]   , testCase "without alpha writes the expected header" $ do       let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 3 (ImageRGB8 $ convertRGB8 (ImageRGBA8 gradient))       map (`getDword` bs) [4, 8] @?= [1, 0]-      getDword pictureTypeOffset bs @?= 5+      getDword extraOffset bs @?= 5       map (\i -> getDword (sizeSlot i) bs) [0 .. 2] @?= [256, 64, 16]   , testCase "with alpha round-trips mip 0" $ do       img <- decodeRGBA . BSL.toStrict $ enc (BlpFormatPaletted True) 1 (ImageRGBA8 gradient)@@ -307,7 +310,7 @@       sizes levels @?= [(16, 16), (8, 8), (4, 4)]   , testCase "JPEG alpha flag and picture type follow the input format" $ do       let header dyn = let bs = BSL.toStrict $ enc (BlpFormatJpeg 90) 1 dyn-                       in (getDword 8 bs, getDword pictureTypeOffset bs)+                       in (getDword 8 bs, getDword extraOffset bs)           rgba = convertRGBA8 (ImageRGBA8 gradient)       header (ImageY8 $ pixelMap (\(PixelRGBA8 r _ _ _) -> r) rgba) @?= (0, 5)       header (ImageYA8 $ pixelMap (\(PixelRGBA8 r _ _ a) -> PixelYA8 r a) rgba) @?= (8, 3)@@ -315,13 +318,13 @@       header (ImageRGBA16 $ pixelMap (\(PixelRGBA8 r g b a) -> PixelRGBA16 (w16 r) (w16 g) (w16 b) (w16 a)) rgba) @?= (8, 3)   , testCase "without alpha drops the alpha of an RGBA input" $ do       let bs = BSL.toStrict $ enc (BlpFormatPaletted False) 1 (ImageRGBA8 gradient)-      (getDword 8 bs, getDword pictureTypeOffset bs) @?= (0, 5)+      (getDword 8 bs, getDword extraOffset bs) @?= (0, 5)       img <- decodeRGBA bs       let d = maxDiff opaqueGradient img       assertBool ("max channel difference " ++ show d) (d <= 8)   , testCase "with alpha keeps an alpha plane for an RGB input" $ do       let bs = BSL.toStrict $ enc (BlpFormatPaletted True) 1 (ImageRGB8 $ convertRGB8 (ImageRGBA8 opaqueGradient))-      (getDword 8 bs, getDword pictureTypeOffset bs) @?= (8, 3)+      (getDword 8 bs, getDword extraOffset bs) @?= (8, 3)       img <- decodeRGBA bs       let d = maxDiff opaqueGradient img       assertBool ("max channel difference " ++ show d) (d <= 8)@@ -457,7 +460,7 @@ -- | JPEG BLP without alpha and with an empty shared header, holding the given -- streams as its mip levels. jpegBlp :: Word32 -> Word32 -> [ByteString] -> ByteString-jpegBlp w h mips = blpFile defHeader { hCompression = 0, hFlags = 0, hWidth = w, hHeight = h } slots ("\0\0\0\0" <> BS.concat mips)+jpegBlp w h mips = blpFile defHeader { hCompression = 0, hAlphaBits = 0, hWidth = w, hHeight = h } slots ("\0\0\0\0" <> BS.concat mips)   where     sizes' = map (fromIntegral . BS.length) mips     slots = zip (scanl (+) (fromIntegral headerSize + 4) sizes') sizes'@@ -470,3 +473,29 @@ -- | Write a file with two mip levels, failing the test on an encoding error. writeOk :: FilePath -> BlpFormat -> DynamicImage -> IO () writeOk path format img = writeBlpWith path (BlpEncodeOptions format 2) img >>= either (assertFailure . show) return++-- | A 1x1 JPEG texture whose header claims the given size.+inflated :: Word32 -> ByteString+inflated side = setDword 12 side . setDword 16 side . BSL.toStrict $+  enc (BlpFormatJpeg 90) 1 (ImageRGBA8 $ generateImage (\_ _ -> PixelRGBA8 1 2 3 255) 1 1)++limitTests :: TestTree+limitTests = testGroup "limits and inspection"+  [ testCase "a small file claiming a huge size is rejected before allocating" $+      assertLeft "above the limit" . decodeBlp $ inflated 16384+  , testCase "blpMaxPixels is checked for JPEG and paletted content" $ do+      let limited n = decodeBlpWith (BlpDecodeOptions n)+      assertLeft "above the limit" $ limited 255 jpegFile+      assertBool "16x16 JPEG fits 256 pixels" . either (const False) (const True) $ limited 256 jpegFile+      assertLeft "above the limit" $ limited 15 (withAlphaFile 4)+      assertBool "4x4 paletted fits 16 pixels" . either (const False) (const True) $ limited 16 (withAlphaFile 4)+  , testCase "blpInfo reads the header" $ do+      blpInfo jpegFile @?= Right (BlpInfo BlpCompressionJPEG 16 16 8 3)+      blpInfo (withAlphaFile 4) @?= Right (BlpInfo BlpCompressionUncompressed 4 4 8 1)+      blpInfo withoutAlphaFile @?= Right (BlpInfo BlpCompressionUncompressed 4 4 0 1)+  , testCase "blpInfo decodes no pixels" $+      fmap (\i -> (blpInfoWidth i, blpInfoHeight i)) (blpInfo (inflated 16384)) @?= Right (16384, 16384)+  , testCase "blpInfo rejects what decodeBlp rejects" $ do+      assertLeft "BLP1" . blpInfo $ "BLP2" <> BS.drop 4 (withAlphaFile 4)+      assertLeft "Invalid image size" . blpInfo $ setDword 12 0 (withAlphaFile 4)+  ]

@@ -0,0 +1,144 @@+-- | Property tests: the decoder on damaged files, and encode/decode round+-- trips on random images.+module Properties(propertyTests) where++import Codec.Picture+import Codec.Picture.Blp+import Control.DeepSeq (force)+import Control.Exception (SomeAsyncException, SomeException, evaluate, fromException, throwIO, try)+import Data.Bits+import Data.ByteString (ByteString)+import Data.Word+import System.Timeout (timeout)+import Test.QuickCheck+import Test.QuickCheck.Monadic (assert, monadicIO, monitor, run)+import Test.Tasty+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++propertyTests :: TestTree+propertyTests = testGroup "properties"+  [ testGroup "fuzz"+    [ testProperty "decoding a damaged file never throws" decodingNeverThrows+    , testProperty "blpInfo on a damaged file never throws" infoNeverThrows+    ]+  , testProperty "every level has its expected size" levelSizes+  , testProperty "images with few colours survive the palette exactly" fewColoursExact+  ]++-- | Valid files of every kind, to be damaged.+seeds :: [ByteString]+seeds =+  [ encode (BlpFormatJpeg 90) 16 (texture 16 8)+  , encode (BlpFormatJpeg 50) 1 (texture 5 7)+  , encode (BlpFormatJpeg 90) 16 (opaque 8 8)+  , encode (BlpFormatPaletted True) 16 (texture 16 16)+  , encode (BlpFormatPaletted False) 16 (texture 9 4)+  ]+  where+    opaque w h = ImageRGBA8 . pixelMap (\(PixelRGBA8 r g b _) -> PixelRGBA8 r g b 255) . convertRGBA8 $ texture w h++texture :: Int -> Int -> DynamicImage+texture w h = ImageRGBA8 $ generateImage px w h+  where+    px x y = PixelRGBA8 (fromIntegral $ x * 37) (fromIntegral $ y * 59) (fromIntegral $ x * y) (fromIntegral $ 255 - x * 13)++encode :: BlpFormat -> Int -> DynamicImage -> ByteString+encode format levels = BSL.toStrict . either (error . show) id . encodeBlpWith (BlpEncodeOptions format levels)++-- | One way of damaging a file.+data Damage+  = Flip Int Word8 -- ^ XOR a byte+  | Truncate Int -- ^ Keep only a prefix+  | SetDword Int Word32 -- ^ Overwrite a header dword+  deriving Show++damage :: ByteString -> Damage -> ByteString+damage bs d = case d of+  Flip i v+    | i < BS.length bs -> BS.take i bs <> BS.singleton (BS.index bs i `xor` v) <> BS.drop (i + 1) bs+    | otherwise -> bs+  Truncate n -> BS.take n bs+  SetDword o v+    | o + 4 <= BS.length bs -> BS.take o bs <> BS.pack [fromIntegral (v `shiftR` (8 * k)) | k <- [0 .. 3]] <> BS.drop (o + 4) bs+    | otherwise -> bs++-- | A seed file and a few kinds of damage to apply to it.+damagedFile :: Gen (ByteString, [Damage])+damagedFile = do+  seed <- elements seeds+  let len = BS.length seed+      flipAny = Flip <$> choose (0, len - 1) <*> choose (1, 255)+      truncate' = Truncate <$> choose (0, len)+      -- Header fields and mipmap slots, set to small, boundary and huge values.+      header = SetDword+        <$> elements [4, 8 .. 152]+        <*> oneof [choose (0, 2000), elements [0xFF, 0xFFFF, 0x10000, 0x7FFFFFFF, 0xFFFFFFFF]]+  ds <- resize 4 . listOf1 $ frequency [(5, flipAny), (1, truncate'), (3, header)]+  return (seed, ds)++-- | Decode fully. JuicyPixels loops forever on some corrupt JPEG data+-- (haskell-github-trust/Juicy.Pixels#230); such cases are counted, not+-- failed. Anything thrown is a failure.+decodingNeverThrows :: Property+decodingNeverThrows = forAllShow damagedFile showCase $ \(seed, ds) -> monadicIO $ do+  let file = foldl damage seed ds+  result <- run . timeout 1000000 . trySync . evaluate . force $+    fmap (map (imageData . convertRGBA8)) (decodeBlpMipmaps file)+  case result of+    Nothing -> monitor (label "JuicyPixels hang (Juicy.Pixels#230)")+    Just (Left e) -> do+      monitor (counterexample $ "threw: " ++ show (e :: SomeException))+      assert False+    Just (Right decoded) -> monitor (label $ either (const "Left") (const "Right") decoded)++infoNeverThrows :: Property+infoNeverThrows = forAllShow damagedFile showCase $ \(seed, ds) -> monadicIO $ do+  result <- run . trySync . evaluate . force $ either Left (Right . show) (blpInfo (foldl damage seed ds))+  case result of+    Left e -> monitor (counterexample $ "threw: " ++ show (e :: SomeException)) >> assert False+    Right _ -> return ()++-- | Like 'try', but lets asynchronous exceptions through, so that 'timeout'+-- still sees its own.+trySync :: IO a -> IO (Either SomeException a)+trySync action = try action >>= either rethrowAsync (return . Right)+  where+    rethrowAsync e = case fromException e of+      Just async -> throwIO (async :: SomeAsyncException)+      Nothing -> return (Left e)++showCase :: (ByteString, [Damage]) -> String+showCase (seed, ds) = "seed of " ++ show (BS.length seed) ++ " bytes, damage " ++ show ds++-- | Level l of a w x h texture is max 1 (w >> l) by max 1 (h >> l), down to+-- 1x1, at most 16 levels.+levelSizes :: Property+levelSizes = forAll ((,,) <$> choose (1, 40) <*> choose (1, 40) <*> format) $ \(w, h, f) ->+  let expected = take 16 (chain w h)+      decoded = decodeBlpMipmaps (encode f 16 (texture w h))+  in either (const []) (map (\i -> (dynamicMap imageWidth i, dynamicMap imageHeight i))) decoded === expected+  where+    format = elements [BlpFormatJpeg 90, BlpFormatPaletted True, BlpFormatPaletted False]+    chain w h = go 0+      where+        go l = let s = (max 1 (w `shiftR` l), max 1 (h `shiftR` l))+               in s : if s == (1, 1) then [] else go (l + 1)++-- | An opaque image with at most 16 colours fits the palette, so mip 0 comes+-- back exactly.+fewColoursExact :: Property+fewColoursExact = forAll gen $ \(w, h, colours, picks) ->+  let img = generateImage (\x y -> colours !! (picks !! (y * w + x))) w h+      decoded = decodeBlp (encode (BlpFormatPaletted False) 1 (ImageRGBA8 img))+  in fmap (imageData . convertRGBA8) decoded === Right (imageData img)+  where+    gen = do+      w <- choose (1, 24)+      h <- choose (1, 24)+      n <- choose (1, 16)+      colours <- vectorOf n (PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> pure 255)+      picks <- vectorOf (w * h) (choose (0, n - 1))+      return (w, h, colours, picks)