diff --git a/Codec/BMP.hs b/Codec/BMP.hs --- a/Codec/BMP.hs +++ b/Codec/BMP.hs @@ -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. diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs --- a/Codec/BMP/Pack.hs +++ b/Codec/BMP/Pack.hs @@ -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) diff --git a/Codec/BMP/Unpack.hs b/Codec/BMP/Unpack.hs --- a/Codec/BMP/Unpack.hs +++ b/Codec/BMP/Unpack.hs @@ -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 diff --git a/bmp.cabal b/bmp.cabal --- a/bmp.cabal +++ b/bmp.cabal @@ -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