bmp 1.2.2.1 → 1.2.3.1
raw patch · 4 files changed
+102/−68 lines, 4 filesdep ~binarydep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: binary, bytestring
API changes (from Hackage documentation)
+ Codec.BMP: parseBMP :: ByteString -> Either Error BMP
+ Codec.BMP: renderBMP :: BMP -> ByteString
Files
- Codec/BMP.hs +88/−60
- Codec/BMP/Pack.hs +2/−1
- Codec/BMP/Unpack.hs +10/−5
- bmp.cabal +2/−2
Codec/BMP.hs view
@@ -8,7 +8,8 @@ -- Writing is limited to the uncompressed 24bit RGB WindowsV3 format. -- -- We don't support the plain OS/2 BitmapCoreHeader--- and BitmapCoreHeader2 image headers, but I haven't yet seen one of these in the wild.+-- and BitmapCoreHeader2 image headers, but I haven't yet seen one of+-- these in the wild. -- -- To write a file do something like: --@@ -25,15 +26,26 @@ -- -- Release Notes: --+-- > * bmp 1.2.3+-- > Add pure parseBMP / renderBMP API.+-- >+-- > * bmp 1.2.2+-- > Allow the physical image buffer to be larger than the image+-- > size stated in the header, to accept output of foolish Win7 codec.+-- >+-- > * bmp 1.2.1+-- > Fix slow ByteString conversion via lists. +-- > -- > * bmp 1.2.0 -- > Accept files with zero padding on the end of the file. -- > Accept RGBA files with V3 headers.---+-- > -- > * bmp 1.1.2 -- > Accept files with the image size field set to zero. -- module Codec.BMP- ( BMP (..)+ ( -- * Data Structures+ BMP (..) , FileHeader (..) , BitmapInfo (..) , BitmapInfoV3 (..)@@ -42,10 +54,14 @@ , Compression (..) , CIEXYZ (..) , Error (..)- , readBMP- , writeBMP- , hGetBMP- , hPutBMP++ -- * Reading+ , readBMP, hGetBMP, parseBMP++ -- * Writing+ , writeBMP, hPutBMP, renderBMP++ -- * Pack and Unpack , packRGBA32ToBMP , unpackBMPToRGBA32 , bmpDimensions)@@ -65,104 +81,110 @@ import Data.Binary import Data.Binary.Get --- Reading ------------------------------------------------------------------------------------------- | Wrapper for `hGetBMP`+-- Reading --------------------------------------------------------------------+-- | Read a BMP from a file.+-- The file is checked for problems and unsupported features when read.+-- If there is anything wrong this gives an `Error` instead. readBMP :: FilePath -> IO (Either Error BMP) readBMP fileName = do h <- openBinaryFile fileName ReadMode hGetBMP h -- | Get a BMP image from a file handle.--- The file is checked for problems and unsupported features when read.--- If there is anything wrong this gives an `Error` instead. hGetBMP :: Handle -> IO (Either Error BMP) hGetBMP h = do -- lazily load the whole file buf <- BSL.hGetContents h+ return $ parseBMP buf - -- split off the file header- let (bufFileHeader, bufRest) - = BSL.splitAt (fromIntegral sizeOfFileHeader) buf- - if (fromIntegral $ BSL.length bufFileHeader) /= sizeOfFileHeader- then return $ Left ErrorFileHeaderTruncated- else hGetBMP2 bufRest (decode bufFileHeader)++-- | Parse a BMP image from a lazy `ByteString`+parseBMP :: BSL.ByteString -> Either Error BMP+parseBMP buf+ = let -- split off the file header+ (bufFileHeader, bufRest) + = BSL.splitAt (fromIntegral sizeOfFileHeader) buf++ in if (fromIntegral $ BSL.length bufFileHeader) /= sizeOfFileHeader+ then Left ErrorFileHeaderTruncated+ else parseBMP2 bufRest (decode bufFileHeader) - -hGetBMP2 buf fileHeader+parseBMP2 buf fileHeader -- Check the magic before doing anything else. | fileHeaderType fileHeader /= bmpMagic- = return $ Left $ ErrorBadMagic (fileHeaderType fileHeader)+ = Left $ ErrorBadMagic (fileHeaderType fileHeader) | otherwise- = do -- Next comes the image header. + = let -- Next comes the image header. -- The first word tells us how long it is.- let sizeHeader = runGet getWord32le buf+ sizeHeader = runGet getWord32le buf -- split off the image header- let (bufImageHeader, bufRest)+ (bufImageHeader, bufRest) = BSL.splitAt (fromIntegral sizeHeader) buf -- How much non-header data is present in the file.- -- For uncompressed data without a colour table, the remaining data should- -- be the image, but there may also be padding bytes on the end.- let physicalBufferSize+ -- For uncompressed data without a colour table, the remaining data+ -- should be the image, but there may also be padding bytes on the+ -- end.+ physicalBufferSize = (fromIntegral $ BSL.length bufRest) :: Word32 - if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader- then return $ Left ErrorImageHeaderTruncated- else hGetBMP3 fileHeader bufImageHeader bufRest physicalBufferSize+ in if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader+ then Left ErrorImageHeaderTruncated+ else parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize - -hGetBMP3 fileHeader bufImageHeader bufRest physicalBufferSize++parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize | BSL.length bufImageHeader == 40 - = do let info = decode bufImageHeader- case checkBitmapInfoV3 info physicalBufferSize of- Just err -> return $ Left err+ = let info = decode bufImageHeader+ in case checkBitmapInfoV3 info physicalBufferSize of+ Just err -> Left err Nothing- | Just imageSize <- imageSizeFromBitmapInfoV3 info- -> hGetBMP4 fileHeader (InfoV3 info) bufRest imageSize- | otherwise- -> return $ Left $ ErrorInternalErrorPleaseReport+ | Just imageSize <- imageSizeFromBitmapInfoV3 info+ -> parseBMP4 fileHeader (InfoV3 info) bufRest imageSize + | otherwise+ -> Left $ ErrorInternalErrorPleaseReport+ | BSL.length bufImageHeader == 108- = do let info = decode bufImageHeader- case checkBitmapInfoV4 info physicalBufferSize of- Just err -> return $ Left err+ = let info = decode bufImageHeader+ in case checkBitmapInfoV4 info physicalBufferSize of+ Just err -> Left err Nothing | Just imageSize <- imageSizeFromBitmapInfoV4 info- -> hGetBMP4 fileHeader (InfoV4 info) bufRest imageSize+ -> parseBMP4 fileHeader (InfoV4 info) bufRest imageSize+ | otherwise- -> return $ Left $ ErrorInternalErrorPleaseReport+ -> Left $ ErrorInternalErrorPleaseReport | BSL.length bufImageHeader == 124- = do let info = decode bufImageHeader- case checkBitmapInfoV5 info physicalBufferSize of- Just err -> return $ Left err+ = let info = decode bufImageHeader+ in case checkBitmapInfoV5 info physicalBufferSize of+ Just err -> Left err Nothing | Just imageSize <- imageSizeFromBitmapInfoV5 info- -> hGetBMP4 fileHeader (InfoV5 info) bufRest imageSize+ -> parseBMP4 fileHeader (InfoV5 info) bufRest imageSize+ | otherwise- -> return $ Left $ ErrorInternalErrorPleaseReport+ -> Left $ ErrorInternalErrorPleaseReport | otherwise- = return $ Left - $ ErrorUnhandledBitmapHeaderSize - $ fromIntegral $ BSL.length bufImageHeader+ = Left $ ErrorUnhandledBitmapHeaderSize + $ fromIntegral $ BSL.length bufImageHeader -hGetBMP4 fileHeader imageHeader bufImage (sizeImage :: Int)+parseBMP4 fileHeader imageHeader bufImage (sizeImage :: Int) = let bufLen = fromIntegral $ BSL.length bufImage in if bufLen < sizeImage- then return $ Left $ ErrorImageDataTruncated sizeImage bufLen- else return - $ Right $ BMP + then Left $ ErrorImageDataTruncated sizeImage bufLen+ else Right $ BMP { bmpFileHeader = fileHeader , bmpBitmapInfo = imageHeader , bmpRawImageData = BS.concat $ BSL.toChunks bufImage } --- Writing ----------------------------------------------------------------------------------------+-- Writing -------------------------------------------------------------------- -- | Wrapper for `hPutBMP` writeBMP :: FilePath -> BMP -> IO () writeBMP fileName bmp@@ -175,9 +197,15 @@ -- | Put a BMP image to a file handle. hPutBMP :: Handle -> BMP -> IO () hPutBMP h bmp- = do BSL.hPut h (encode $ bmpFileHeader bmp)- BSL.hPut h (encode $ bmpBitmapInfo bmp)- BS.hPut h $ bmpRawImageData bmp+ = BSL.hPut h (renderBMP bmp)+++-- | Render a BMP image to a lazy `ByteString`.+renderBMP :: BMP -> BSL.ByteString+renderBMP bmp+ = BSL.append (encode $ bmpFileHeader bmp)+ $ BSL.append (encode $ bmpBitmapInfo bmp)+ $ BSL.fromStrict (bmpRawImageData bmp) -- | Get the width and height of an image.
Codec/BMP/Pack.hs view
@@ -99,7 +99,8 @@ in unsafePerformIO $ allocaBytes sizeDest $ \bufDest -> BS.unsafeUseAsCString str $ \bufSrc ->- do packRGBA32ToRGB24' width height padPerLine (castPtr bufSrc) (castPtr bufDest)+ do packRGBA32ToRGB24' width height padPerLine+ (castPtr bufSrc) (castPtr bufDest) bs <- packCStringLen (bufDest, sizeDest) return (bs, padPerLine)
Codec/BMP/Unpack.hs view
@@ -29,8 +29,10 @@ _ -> error "Codec.BMP.unpackBMPToRGBA32: unhandled bitcount." --- | Unpack raw, uncompressed 24 bit BMP image data to a string of RGBA component values.--- The alpha component is set to 255 for every pixel.+-- | Unpack raw, uncompressed 24 bit BMP image data to a string of+-- RGBA component values.+--+-- The alpha component is set to 255 for every pixel. packRGB24ToRGBA32 :: Int -- Width of image. -> Int -- Height of image.@@ -48,7 +50,8 @@ else unsafePerformIO $ allocaBytes sizeDest $ \bufDest -> BS.unsafeUseAsCString str $ \bufSrc ->- do packRGB24ToRGBA32' width height padPerLine (castPtr bufSrc) (castPtr bufDest)+ do packRGB24ToRGBA32' width height padPerLine+ (castPtr bufSrc) (castPtr bufDest) packCStringLen (bufDest, sizeDest) @@ -81,7 +84,8 @@ --- | Unpack raw, uncompressed 32 bit BMP image data to a string of RGBA component values.+-- | Unpack raw, uncompressed 32 bit BMP image data to a string of+-- RGBA component values. -- Note in the BMP file the components are arse-around ABGR instead of RGBA. -- The 'unpacking' here is really just flipping the components around. packRGB32ToRGBA32@@ -97,7 +101,8 @@ else unsafePerformIO $ allocaBytes sizeDest $ \bufDest -> BS.unsafeUseAsCString str $ \bufSrc ->- do packRGB32ToRGBA32' width height (castPtr bufSrc) (castPtr bufDest)+ do packRGB32ToRGBA32' width height+ (castPtr bufSrc) (castPtr bufDest) packCStringLen (bufDest, sizeDest) -- We're doing this via Ptrs because we don't want to take the
bmp.cabal view
@@ -1,5 +1,5 @@ Name: bmp-Version: 1.2.2.1+Version: 1.2.3.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -22,7 +22,7 @@ Build-Depends: base >= 4 && < 5, bytestring >= 0.9.1.5 && < 1.0.0.0,- binary >= 0.5.0.2 && < 0.6.0.0+ binary >= 0.5.0.2 && < 0.7.0.0 ghc-options: -Wall -fno-warn-missing-signatures