module Codec.BMP
( BMP (..)
, FileHeader (..)
, BitmapInfo (..)
, BitmapInfoV3 (..)
, BitmapInfoV4 (..)
, BitmapInfoV5 (..)
, Compression (..)
, CIEXYZ (..)
, Error (..)
, readBMP
, writeBMP
, hGetBMP
, hPutBMP
, packRGBA32ToBMP
, 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 as BS
import Data.ByteString.Lazy as BSL
import Data.Binary
import Data.Binary.Get
readBMP :: FilePath -> IO (Either Error BMP)
readBMP fileName
= do h <- openBinaryFile fileName ReadMode
hGetBMP h
hGetBMP :: Handle -> IO (Either Error BMP)
hGetBMP h
= do
buf <- BSL.hGetContents h
let (bufFileHeader, bufRest)
= BSL.splitAt (fromIntegral sizeOfFileHeader) buf
if (fromIntegral $ BSL.length bufFileHeader) /= sizeOfFileHeader
then return $ Left ErrorFileHeaderTruncated
else hGetBMP2 bufRest (decode bufFileHeader)
hGetBMP2 buf fileHeader
| fileHeaderType fileHeader /= bmpMagic
= return $ Left $ ErrorBadMagic (fileHeaderType fileHeader)
| otherwise
= do
let sizeHeader = runGet getWord32le buf
let (bufImageHeader, bufRest)
= BSL.splitAt (fromIntegral sizeHeader) buf
let physicalBufferSize
= (fromIntegral $ BSL.length bufRest) :: Word32
if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader
then return $ Left ErrorImageHeaderTruncated
else hGetBMP3 fileHeader bufImageHeader bufRest physicalBufferSize
hGetBMP3 fileHeader bufImageHeader bufRest physicalBufferSize
| BSL.length bufImageHeader == 40
= do let info = decode bufImageHeader
case checkBitmapInfoV3 info physicalBufferSize of
Just err -> return $ Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV3 info
-> hGetBMP4 fileHeader (InfoV3 info) bufRest imageSize
| otherwise
-> return $ Left $ ErrorInternalErrorPleaseReport
| BSL.length bufImageHeader == 108
= do let info = decode bufImageHeader
case checkBitmapInfoV4 info physicalBufferSize of
Just err -> return $ Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV4 info
-> hGetBMP4 fileHeader (InfoV4 info) bufRest imageSize
| otherwise
-> return $ Left $ ErrorInternalErrorPleaseReport
| BSL.length bufImageHeader == 124
= do let info = decode bufImageHeader
case checkBitmapInfoV5 info physicalBufferSize of
Just err -> return $ Left err
Nothing
| Just imageSize <- imageSizeFromBitmapInfoV5 info
-> hGetBMP4 fileHeader (InfoV5 info) bufRest imageSize
| otherwise
-> return $ Left $ ErrorInternalErrorPleaseReport
| otherwise
= return $ Left
$ ErrorUnhandledBitmapHeaderSize
$ fromIntegral $ BSL.length bufImageHeader
hGetBMP4 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
{ bmpFileHeader = fileHeader
, bmpBitmapInfo = imageHeader
, bmpRawImageData = BS.concat $ BSL.toChunks bufImage }
writeBMP :: FilePath -> BMP -> IO ()
writeBMP fileName bmp
= do h <- openBinaryFile fileName WriteMode
hPutBMP h bmp
hFlush h
hClose h
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
bmpDimensions :: BMP -> (Int, Int)
bmpDimensions bmp
= let info = getBitmapInfoV3 $ bmpBitmapInfo bmp
in ( fromIntegral $ dib3Width info
, fromIntegral $ dib3Height info)