bmp-1.2.6.3: Codec/BMP.hs
-- | Reading and writing uncompressed BMP files.
--
-- Supports uncompressed 24bit RGB and 32bit RGBA
-- WindowsV3, WindowsV4 and WindowsV5 formats.
--
-- 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.
--
-- To write a file do something like:
--
-- > do let rgba = Data.ByteString.pack [some list of Word8s]
-- > let bmp = packRGBA32ToBMP width height rgba
-- > writeBMP fileName bmp
--
-- To read a file do something like:
--
-- > do Right bmp <- readBMP fileName
-- > let rgba = unpackBMPToRGBA32 bmp
-- > let (width, height) = bmpDimensions bmp
-- > ...
--
-- Release Notes:
--
-- > * bmp 1.2.5
-- > Add support for writing uncompressed 32-bit files.
-- >
-- > * bmp 1.2.4
-- > Update to use binary 0.6.
-- >
-- > * 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.
--
module Codec.BMP
( -- * Data Structures
BMP (..)
, FileHeader (..)
, BitmapInfo (..)
, BitmapInfoV3 (..)
, BitmapInfoV4 (..)
, BitmapInfoV5 (..)
, Compression (..)
, CIEXYZ (..)
, Error (..)
-- * Reading
, readBMP, hGetBMP, parseBMP
-- * Writing
, writeBMP, hPutBMP, renderBMP
-- * Pack and Unpack
, packRGBA32ToBMP
, packRGBA32ToBMP32
, packRGBA32ToBMP24
, unpackBMPToRGBA32
, bmpDimensions)
where
import Codec.BMP.Base
import Codec.BMP.Error
import Codec.BMP.Unpack
import Codec.BMP.Pack
import Codec.BMP.FileHeader
import Codec.BMP.BitmapInfo
import Codec.BMP.BitmapInfoV3
import Codec.BMP.BitmapInfoV4
import Codec.BMP.BitmapInfoV5
import System.IO
import Data.ByteString.Lazy as BSL
import Data.Binary
import Data.Binary.Get
-- 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.
hGetBMP :: Handle -> IO (Either Error BMP)
hGetBMP h
= do -- lazily load the whole file
buf <- BSL.hGetContents h
return $ parseBMP buf
-- | 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)
parseBMP2 buf fileHeader
-- Check the magic before doing anything else.
| fileHeaderType fileHeader /= bmpMagic
= Left $ ErrorBadMagic (fileHeaderType fileHeader)
| otherwise
= let -- Next comes the image header.
-- The first word tells us how long it is.
sizeHeader = runGet getWord32le buf
-- split off the image header
(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.
physicalBufferSize
= (fromIntegral $ BSL.length bufRest) :: Word32
in if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader
then Left ErrorImageHeaderTruncated
else parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize
parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize
| BSL.length bufImageHeader == 40
= let info = decode bufImageHeader
in case checkBitmapInfoV3 info physicalBufferSize of
Just err -> Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV3 info
-> parseBMP4 fileHeader (InfoV3 info) bufRest imageSize
| otherwise
-> Left $ ErrorInternalErrorPleaseReport
| BSL.length bufImageHeader == 108
= let info = decode bufImageHeader
in case checkBitmapInfoV4 info physicalBufferSize of
Just err -> Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV4 info
-> parseBMP4 fileHeader (InfoV4 info) bufRest imageSize
| otherwise
-> Left $ ErrorInternalErrorPleaseReport
| BSL.length bufImageHeader == 124
= let info = decode bufImageHeader
in case checkBitmapInfoV5 info physicalBufferSize of
Just err -> Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV5 info
-> parseBMP4 fileHeader (InfoV5 info) bufRest imageSize
| otherwise
-> Left $ ErrorInternalErrorPleaseReport
| otherwise
= Left $ ErrorUnhandledBitmapHeaderSize
$ fromIntegral $ BSL.length bufImageHeader
parseBMP4 fileHeader imageHeader bufImage (sizeImage :: Int)
= let bufLen = fromIntegral $ BSL.length bufImage
in if bufLen < sizeImage
then Left $ ErrorImageDataTruncated sizeImage bufLen
else Right $ BMP
{ bmpFileHeader = fileHeader
, bmpBitmapInfo = imageHeader
, bmpRawImageData = BSL.toStrict bufImage }
-- Writing --------------------------------------------------------------------
-- | Wrapper for `hPutBMP`
writeBMP :: FilePath -> BMP -> IO ()
writeBMP fileName bmp
= do h <- openBinaryFile fileName WriteMode
hPutBMP h bmp
hFlush h
hClose h
-- | Put a BMP image to a file handle.
hPutBMP :: Handle -> BMP -> IO ()
hPutBMP h 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.
-- It's better to use this function than to access the headers directly.
bmpDimensions :: BMP -> (Int, Int)
bmpDimensions bmp
= let info = getBitmapInfoV3 $ bmpBitmapInfo bmp
in ( fromIntegral $ dib3Width info
, fromIntegral $ dib3Height info)