-- | 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 :: FilePath -> IO (Either Error BMP)
readBMP FilePath
fileName
 = do   Handle
h       <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
fileName IOMode
ReadMode
        Handle -> IO (Either Error BMP)
hGetBMP Handle
h
        
-- | Get a BMP image from a file handle.
hGetBMP :: Handle -> IO (Either Error BMP)
hGetBMP :: Handle -> IO (Either Error BMP)
hGetBMP Handle
h
 = do   -- lazily load the whole file
        ByteString
buf     <- Handle -> IO ByteString
BSL.hGetContents Handle
h
        Either Error BMP -> IO (Either Error BMP)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error BMP -> IO (Either Error BMP))
-> Either Error BMP -> IO (Either Error BMP)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Error BMP
parseBMP ByteString
buf


-- | Parse a BMP image from a lazy `ByteString`
parseBMP :: BSL.ByteString -> Either Error BMP
parseBMP :: ByteString -> Either Error BMP
parseBMP ByteString
buf
 = let  -- split off the file header
        (ByteString
bufFileHeader, ByteString
bufRest) 
               = Int64 -> ByteString -> (ByteString, ByteString)
BSL.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeOfFileHeader) ByteString
buf

   in   if (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
bufFileHeader) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
sizeOfFileHeader
         then   Error -> Either Error BMP
forall a b. a -> Either a b
Left Error
ErrorFileHeaderTruncated
         else   ByteString -> FileHeader -> Either Error BMP
parseBMP2 ByteString
bufRest (ByteString -> FileHeader
forall a. Binary a => ByteString -> a
decode ByteString
bufFileHeader)
        
parseBMP2 :: ByteString -> FileHeader -> Either Error BMP
parseBMP2 ByteString
buf FileHeader
fileHeader
 -- Check the magic before doing anything else.
 | FileHeader -> Word16
fileHeaderType FileHeader
fileHeader Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
bmpMagic
 = Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Word16 -> Error
ErrorBadMagic (FileHeader -> Word16
fileHeaderType FileHeader
fileHeader)
        
 | Bool
otherwise
 = let  -- Next comes the image header. 
        -- The first word tells us how long it is.
        sizeHeader :: Word32
sizeHeader      = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32le ByteString
buf

        -- Split off the image header
        bufImageHeader :: ByteString
bufImageHeader  = Int64 -> ByteString -> ByteString
BSL.take (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
sizeHeader) ByteString
buf
        bufRest :: ByteString
bufRest         = Int64 -> ByteString -> ByteString
BSL.drop (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileHeader -> Word32
fileHeaderOffset FileHeader
fileHeader) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sizeOfFileHeader)) ByteString
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 :: Word32
physicalBufferSize
                = (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
bufRest) :: Word32

   in if (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
bufImageHeader) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
sizeHeader
         then   Error -> Either Error BMP
forall a b. a -> Either a b
Left Error
ErrorImageHeaderTruncated
         else   FileHeader
-> ByteString -> ByteString -> Word32 -> Either Error BMP
parseBMP3 FileHeader
fileHeader ByteString
bufImageHeader ByteString
bufRest Word32
physicalBufferSize


parseBMP3 :: FileHeader
-> ByteString -> ByteString -> Word32 -> Either Error BMP
parseBMP3 FileHeader
fileHeader ByteString
bufImageHeader ByteString
bufRest Word32
physicalBufferSize
        | ByteString -> Int64
BSL.length ByteString
bufImageHeader Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
40 
        = let info :: BitmapInfoV3
info      = ByteString -> BitmapInfoV3
forall a. Binary a => ByteString -> a
decode ByteString
bufImageHeader
          in  case BitmapInfoV3 -> Word32 -> Maybe Error
checkBitmapInfoV3 BitmapInfoV3
info Word32
physicalBufferSize of
                 Just Error
err       -> Error -> Either Error BMP
forall a b. a -> Either a b
Left Error
err
                 Maybe Error
Nothing
                  |  Just Int
imageSize      <- BitmapInfoV3 -> Maybe Int
imageSizeFromBitmapInfoV3 BitmapInfoV3
info
                  -> FileHeader -> BitmapInfo -> ByteString -> Int -> Either Error BMP
parseBMP4 FileHeader
fileHeader (BitmapInfoV3 -> BitmapInfo
InfoV3 BitmapInfoV3
info) ByteString
bufRest Int
imageSize

                  |  Bool
otherwise
                  -> Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Error
ErrorInternalErrorPleaseReport

        | ByteString -> Int64
BSL.length ByteString
bufImageHeader Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
108
        = let info :: BitmapInfoV4
info      = ByteString -> BitmapInfoV4
forall a. Binary a => ByteString -> a
decode ByteString
bufImageHeader
          in  case BitmapInfoV4 -> Word32 -> Maybe Error
checkBitmapInfoV4 BitmapInfoV4
info Word32
physicalBufferSize of
                 Just Error
err       -> Error -> Either Error BMP
forall a b. a -> Either a b
Left Error
err
                 Maybe Error
Nothing        
                  | Just Int
imageSize      <- BitmapInfoV4 -> Maybe Int
imageSizeFromBitmapInfoV4 BitmapInfoV4
info
                  -> FileHeader -> BitmapInfo -> ByteString -> Int -> Either Error BMP
parseBMP4 FileHeader
fileHeader (BitmapInfoV4 -> BitmapInfo
InfoV4 BitmapInfoV4
info) ByteString
bufRest Int
imageSize

                  | Bool
otherwise
                  -> Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Error
ErrorInternalErrorPleaseReport
                
        | ByteString -> Int64
BSL.length ByteString
bufImageHeader Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
124
        = let info :: BitmapInfoV5
info      = ByteString -> BitmapInfoV5
forall a. Binary a => ByteString -> a
decode ByteString
bufImageHeader
          in  case BitmapInfoV5 -> Word32 -> Maybe Error
checkBitmapInfoV5 BitmapInfoV5
info Word32
physicalBufferSize of
                 Just Error
err       -> Error -> Either Error BMP
forall a b. a -> Either a b
Left Error
err
                 Maybe Error
Nothing        
                  | Just Int
imageSize      <- BitmapInfoV5 -> Maybe Int
imageSizeFromBitmapInfoV5 BitmapInfoV5
info
                  -> FileHeader -> BitmapInfo -> ByteString -> Int -> Either Error BMP
parseBMP4 FileHeader
fileHeader (BitmapInfoV5 -> BitmapInfo
InfoV5 BitmapInfoV5
info) ByteString
bufRest Int
imageSize

                  | Bool
otherwise
                  -> Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Error
ErrorInternalErrorPleaseReport
                
        | Bool
otherwise
        = Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Word32 -> Error
ErrorUnhandledBitmapHeaderSize 
               (Word32 -> Error) -> Word32 -> Error
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
bufImageHeader


parseBMP4 :: FileHeader -> BitmapInfo -> ByteString -> Int -> Either Error BMP
parseBMP4 FileHeader
fileHeader BitmapInfo
imageHeader ByteString
bufImage (Int
sizeImage :: Int)
 = let  bufLen :: Int
bufLen  = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
bufImage
   in   if Int
bufLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sizeImage
         then Error -> Either Error BMP
forall a b. a -> Either a b
Left (Error -> Either Error BMP) -> Error -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Error
ErrorImageDataTruncated Int
sizeImage Int
bufLen
         else BMP -> Either Error BMP
forall a b. b -> Either a b
Right (BMP -> Either Error BMP) -> BMP -> Either Error BMP
forall a b. (a -> b) -> a -> b
$ BMP 
                { bmpFileHeader :: FileHeader
bmpFileHeader         = FileHeader
fileHeader
                , bmpBitmapInfo :: BitmapInfo
bmpBitmapInfo         = BitmapInfo
imageHeader
                , bmpRawImageData :: ByteString
bmpRawImageData       = ByteString -> ByteString
BSL.toStrict ByteString
bufImage }


-- Writing --------------------------------------------------------------------
-- | Wrapper for `hPutBMP`
writeBMP :: FilePath -> BMP -> IO ()
writeBMP :: FilePath -> BMP -> IO ()
writeBMP FilePath
fileName BMP
bmp
 = do   Handle
h       <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
fileName IOMode
WriteMode
        Handle -> BMP -> IO ()
hPutBMP Handle
h BMP
bmp
        Handle -> IO ()
hFlush Handle
h
        Handle -> IO ()
hClose Handle
h


-- | Put a BMP image to a file handle.
hPutBMP :: Handle -> BMP -> IO ()
hPutBMP :: Handle -> BMP -> IO ()
hPutBMP Handle
h BMP
bmp
        = Handle -> ByteString -> IO ()
BSL.hPut Handle
h (BMP -> ByteString
renderBMP BMP
bmp)


-- | Render a BMP image to a lazy `ByteString`.
renderBMP :: BMP -> BSL.ByteString
renderBMP :: BMP -> ByteString
renderBMP BMP
bmp
        = ByteString -> ByteString -> ByteString
BSL.append    (FileHeader -> ByteString
forall a. Binary a => a -> ByteString
encode (FileHeader -> ByteString) -> FileHeader -> ByteString
forall a b. (a -> b) -> a -> b
$ BMP -> FileHeader
bmpFileHeader BMP
bmp)
        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
BSL.append    (BitmapInfo -> ByteString
forall a. Binary a => a -> ByteString
encode (BitmapInfo -> ByteString) -> BitmapInfo -> ByteString
forall a b. (a -> b) -> a -> b
$ BMP -> BitmapInfo
bmpBitmapInfo BMP
bmp)
        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict (BMP -> ByteString
bmpRawImageData BMP
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 -> (Int, Int)
bmpDimensions BMP
bmp       
 = let  info :: BitmapInfoV3
info    = BitmapInfo -> BitmapInfoV3
getBitmapInfoV3 (BitmapInfo -> BitmapInfoV3) -> BitmapInfo -> BitmapInfoV3
forall a b. (a -> b) -> a -> b
$ BMP -> BitmapInfo
bmpBitmapInfo BMP
bmp
   in   ( Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BitmapInfoV3 -> Word32
dib3Width BitmapInfoV3
info
        , Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BitmapInfoV3 -> Word32
dib3Height BitmapInfoV3
info)