/src/Codec/Picture/Png/Internal/Type.hs
Haskell | 450 lines | 318 code | 64 blank | 68 comment | 7 complexity | 78520f18bf8dbf051473ea3019f7b66e MD5 | raw file
Possible License(s): BSD-3-Clause
- {-# LANGUAGE CPP #-}
- -- | Low level png module, you should import 'Codec.Picture.Png.Internal' instead.
- module Codec.Picture.Png.Internal.Type( PngIHdr( .. )
- , PngFilter( .. )
- , PngInterlaceMethod( .. )
- , PngPalette
- , PngImageType( .. )
- , PngPhysicalDimension( .. )
- , PngGamma( .. )
- , PngUnit( .. )
- , APngAnimationControl( .. )
- , APngFrameDisposal( .. )
- , APngBlendOp( .. )
- , APngFrameControl( .. )
- , parsePalette
- , pngComputeCrc
- , pLTESignature
- , iDATSignature
- , iENDSignature
- , tRNSSignature
- , tEXtSignature
- , zTXtSignature
- , gammaSignature
- , pHYsSignature
- , animationControlSignature
- -- * Low level types
- , ChunkSignature
- , PngRawImage( .. )
- , PngChunk( .. )
- , PngRawChunk( .. )
- , PngLowLevel( .. )
- , chunksWithSig
- , mkRawChunk
- ) where
-
- #if !MIN_VERSION_base(4,8,0)
- import Control.Applicative( (<$>), (<*>), pure )
- #endif
-
- import Control.Monad( when, replicateM )
- import Data.Bits( xor, (.&.), unsafeShiftR )
- import Data.Binary( Binary(..), Get, get )
- import Data.Binary.Get( getWord8
- , getWord32be
- , getLazyByteString
- )
- import Data.Binary.Put( runPut
- , putWord8
- , putWord32be
- , putLazyByteString
- )
- import Data.Vector.Unboxed( Vector, fromListN, (!) )
- import qualified Data.Vector.Storable as V
- import Data.List( foldl' )
- import Data.Word( Word32, Word16, Word8 )
- import qualified Data.ByteString.Lazy as L
- import qualified Data.ByteString.Lazy.Char8 as LS
-
- import Codec.Picture.Types
- import Codec.Picture.InternalHelper
-
- --------------------------------------------------
- ---- Types
- --------------------------------------------------
-
- -- | Value used to identify a png chunk, must be 4 bytes long.
- type ChunkSignature = L.ByteString
-
- -- | Generic header used in PNG images.
- data PngIHdr = PngIHdr
- { width :: !Word32 -- ^ Image width in number of pixel
- , height :: !Word32 -- ^ Image height in number of pixel
- , bitDepth :: !Word8 -- ^ Number of bit per sample
- , colourType :: !PngImageType -- ^ Kind of png image (greyscale, true color, indexed...)
- , compressionMethod :: !Word8 -- ^ Compression method used
- , filterMethod :: !Word8 -- ^ Must be 0
- , interlaceMethod :: !PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering)
- }
- deriving Show
-
- data PngUnit
- = PngUnitUnknown -- ^ 0 value
- | PngUnitMeter -- ^ 1 value
-
- instance Binary PngUnit where
- get = do
- v <- getWord8
- pure $ case v of
- 0 -> PngUnitUnknown
- 1 -> PngUnitMeter
- _ -> PngUnitUnknown
-
- put v = case v of
- PngUnitUnknown -> putWord8 0
- PngUnitMeter -> putWord8 1
-
- data PngPhysicalDimension = PngPhysicalDimension
- { pngDpiX :: !Word32
- , pngDpiY :: !Word32
- , pngUnit :: !PngUnit
- }
-
- instance Binary PngPhysicalDimension where
- get = PngPhysicalDimension <$> getWord32be <*> getWord32be <*> get
- put (PngPhysicalDimension dpx dpy unit) =
- putWord32be dpx >> putWord32be dpy >> put unit
-
- newtype PngGamma = PngGamma { getPngGamma :: Double }
-
- instance Binary PngGamma where
- get = PngGamma . (/ 100000) . fromIntegral <$> getWord32be
- put = putWord32be . ceiling . (100000 *) . getPngGamma
-
- data APngAnimationControl = APngAnimationControl
- { animationFrameCount :: !Word32
- , animationPlayCount :: !Word32
- }
- deriving Show
-
- -- | Encoded in a Word8
- data APngFrameDisposal
- -- | No disposal is done on this frame before rendering the
- -- next; the contents of the output buffer are left as is.
- -- Has Value 0
- = APngDisposeNone
- -- | The frame's region of the output buffer is to be cleared
- -- to fully transparent black before rendering the next frame.
- -- Has Value 1
- | APngDisposeBackground
- -- | the frame's region of the output buffer is to be reverted
- -- to the previous contents before rendering the next frame.
- -- Has Value 2
- | APngDisposePrevious
- deriving Show
-
- -- | Encoded in a Word8
- data APngBlendOp
- -- | Overwrite output buffer. has value '0'
- = APngBlendSource
- -- | Alpha blend to the output buffer. Has value '1'
- | APngBlendOver
- deriving Show
-
- data APngFrameControl = APngFrameControl
- { frameSequenceNum :: !Word32 -- ^ Starting from 0
- , frameWidth :: !Word32 -- ^ Width of the following frame
- , frameHeight :: !Word32 -- ^ Height of the following frame
- , frameLeft :: !Word32 -- X position where to render the frame.
- , frameTop :: !Word32 -- Y position where to render the frame.
- , frameDelayNumerator :: !Word16
- , frameDelayDenuminator :: !Word16
- , frameDisposal :: !APngFrameDisposal
- , frameBlending :: !APngBlendOp
- }
- deriving Show
-
- -- | What kind of information is encoded in the IDAT section
- -- of the PngFile
- data PngImageType =
- PngGreyscale
- | PngTrueColour
- | PngIndexedColor
- | PngGreyscaleWithAlpha
- | PngTrueColourWithAlpha
- deriving Show
-
- -- | Raw parsed image which need to be decoded.
- data PngRawImage = PngRawImage
- { header :: PngIHdr
- , chunks :: [PngRawChunk]
- }
-
- -- | Palette with indices beginning at 0 to elemcount - 1
- type PngPalette = Palette' PixelRGB8
-
- -- | Parse a palette from a png chunk.
- parsePalette :: PngRawChunk -> Either String PngPalette
- parsePalette plte
- | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size"
- | otherwise = Palette' pixelCount . V.fromListN (3 * pixelCount) <$> pixels
- where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get
- pixelCount = fromIntegral $ chunkLength plte `div` 3
- pixels = runGet pixelUnpacker (chunkData plte)
-
- -- | Data structure during real png loading/parsing
- data PngRawChunk = PngRawChunk
- { chunkLength :: Word32
- , chunkType :: ChunkSignature
- , chunkCRC :: Word32
- , chunkData :: L.ByteString
- }
-
- mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk
- mkRawChunk sig binaryData = PngRawChunk
- { chunkLength = fromIntegral $ L.length binaryData
- , chunkType = sig
- , chunkCRC = pngComputeCrc [sig, binaryData]
- , chunkData = binaryData
- }
-
- -- | PNG chunk representing some extra information found in the parsed file.
- data PngChunk = PngChunk
- { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk
- , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk.
- }
-
- -- | Low level access to PNG information
- data PngLowLevel a = PngLowLevel
- { pngImage :: Image a -- ^ The real uncompressed image
- , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present.
- }
-
- -- | The pixels value should be :
- -- +---+---+
- -- | c | b |
- -- +---+---+
- -- | a | x |
- -- +---+---+
- -- x being the current filtered pixel
- data PngFilter =
- -- | Filt(x) = Orig(x), Recon(x) = Filt(x)
- FilterNone
- -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a)
- | FilterSub
- -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b)
- | FilterUp
- -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2),
- -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2)
- | FilterAverage
- -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)),
- -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c))
- | FilterPaeth
- deriving (Enum, Show)
-
- -- | Different known interlace methods for PNG image
- data PngInterlaceMethod =
- -- | No interlacing, basic data ordering, line by line
- -- from left to right.
- PngNoInterlace
-
- -- | Use the Adam7 ordering, see `adam7Reordering`
- | PngInterlaceAdam7
- deriving (Enum, Show)
-
- --------------------------------------------------
- ---- Instances
- --------------------------------------------------
- instance Binary PngFilter where
- put = putWord8 . toEnum . fromEnum
- get = getWord8 >>= \w -> case w of
- 0 -> return FilterNone
- 1 -> return FilterSub
- 2 -> return FilterUp
- 3 -> return FilterAverage
- 4 -> return FilterPaeth
- _ -> fail "Invalid scanline filter"
-
- instance Binary PngRawImage where
- put img = do
- putLazyByteString pngSignature
- put $ header img
- mapM_ put $ chunks img
-
- get = parseRawPngImage
-
- instance Binary PngRawChunk where
- put chunk = do
- putWord32be $ chunkLength chunk
- putLazyByteString $ chunkType chunk
- when (chunkLength chunk /= 0)
- (putLazyByteString $ chunkData chunk)
- putWord32be $ chunkCRC chunk
-
- get = do
- size <- getWord32be
- chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature)
- imgData <- if size == 0
- then return L.empty
- else getLazyByteString (fromIntegral size)
- crc <- getWord32be
-
- let computedCrc = pngComputeCrc [chunkSig, imgData]
- when (computedCrc `xor` crc /= 0)
- (fail $ "Invalid CRC : " ++ show computedCrc ++ ", "
- ++ show crc)
- return PngRawChunk {
- chunkLength = size,
- chunkData = imgData,
- chunkCRC = crc,
- chunkType = chunkSig
- }
-
- instance Binary PngIHdr where
- put hdr = do
- putWord32be 13
- let inner = runPut $ do
- putLazyByteString iHDRSignature
- putWord32be $ width hdr
- putWord32be $ height hdr
- putWord8 $ bitDepth hdr
- put $ colourType hdr
- put $ compressionMethod hdr
- put $ filterMethod hdr
- put $ interlaceMethod hdr
- crc = pngComputeCrc [inner]
- putLazyByteString inner
- putWord32be crc
-
- get = do
- _size <- getWord32be
- ihdrSig <- getLazyByteString (L.length iHDRSignature)
- when (ihdrSig /= iHDRSignature)
- (fail "Invalid PNG file, wrong ihdr")
- w <- getWord32be
- h <- getWord32be
- depth <- get
- colorType <- get
- compression <- get
- filtermethod <- get
- interlace <- get
- _crc <- getWord32be
- return PngIHdr {
- width = w,
- height = h,
- bitDepth = depth,
- colourType = colorType,
- compressionMethod = compression,
- filterMethod = filtermethod,
- interlaceMethod = interlace
- }
-
- -- | Parse method for a png chunk, without decompression.
- parseChunks :: Get [PngRawChunk]
- parseChunks = do
- chunk <- get
-
- if chunkType chunk == iENDSignature
- then return [chunk]
- else (chunk:) <$> parseChunks
-
-
- instance Binary PngInterlaceMethod where
- get = getWord8 >>= \w -> case w of
- 0 -> return PngNoInterlace
- 1 -> return PngInterlaceAdam7
- _ -> fail "Invalid interlace method"
-
- put PngNoInterlace = putWord8 0
- put PngInterlaceAdam7 = putWord8 1
-
- -- | Implementation of the get method for the PngRawImage,
- -- unpack raw data, without decompressing it.
- parseRawPngImage :: Get PngRawImage
- parseRawPngImage = do
- sig <- getLazyByteString (L.length pngSignature)
- when (sig /= pngSignature)
- (fail "Invalid PNG file, signature broken")
-
- ihdr <- get
-
- chunkList <- parseChunks
- return PngRawImage { header = ihdr, chunks = chunkList }
-
- --------------------------------------------------
- ---- functions
- --------------------------------------------------
-
- -- | Signature signalling that the following data will be a png image
- -- in the png bit stream
- pngSignature :: ChunkSignature
- pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10]
-
- -- | Helper function to help pack signatures.
- signature :: String -> ChunkSignature
- signature = LS.pack
-
- -- | Signature for the header chunk of png (must be the first)
- iHDRSignature :: ChunkSignature
- iHDRSignature = signature "IHDR"
-
- -- | Signature for a palette chunk in the pgn file. Must
- -- occure before iDAT.
- pLTESignature :: ChunkSignature
- pLTESignature = signature "PLTE"
-
- -- | Signature for a data chuck (with image parts in it)
- iDATSignature :: ChunkSignature
- iDATSignature = signature "IDAT"
-
- -- | Signature for the last chunk of a png image, telling
- -- the end.
- iENDSignature :: ChunkSignature
- iENDSignature = signature "IEND"
-
- tRNSSignature :: ChunkSignature
- tRNSSignature = signature "tRNS"
-
- gammaSignature :: ChunkSignature
- gammaSignature = signature "gAMA"
-
- pHYsSignature :: ChunkSignature
- pHYsSignature = signature "pHYs"
-
- tEXtSignature :: ChunkSignature
- tEXtSignature = signature "tEXt"
-
- zTXtSignature :: ChunkSignature
- zTXtSignature = signature "zTXt"
-
- animationControlSignature :: ChunkSignature
- animationControlSignature = signature "acTL"
-
- instance Binary PngImageType where
- put PngGreyscale = putWord8 0
- put PngTrueColour = putWord8 2
- put PngIndexedColor = putWord8 3
- put PngGreyscaleWithAlpha = putWord8 4
- put PngTrueColourWithAlpha = putWord8 6
-
- get = get >>= imageTypeOfCode
-
- imageTypeOfCode :: Word8 -> Get PngImageType
- imageTypeOfCode 0 = return PngGreyscale
- imageTypeOfCode 2 = return PngTrueColour
- imageTypeOfCode 3 = return PngIndexedColor
- imageTypeOfCode 4 = return PngGreyscaleWithAlpha
- imageTypeOfCode 6 = return PngTrueColourWithAlpha
- imageTypeOfCode _ = fail "Invalid png color code"
-
- -- | From the Annex D of the png specification.
- pngCrcTable :: Vector Word32
- pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ]
- where zero = 0 :: Int -- To avoid defaulting to Integer
- updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1)
- | otherwise = c `unsafeShiftR` 1
- magicConstant = 0xedb88320 :: Word32
-
- -- | Compute the CRC of a raw buffer, as described in annex D of the PNG
- -- specification.
- pngComputeCrc :: [L.ByteString] -> Word32
- pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat
- where updateCrc crc val =
- let u32Val = fromIntegral val
- lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF))
- in lutVal `xor` (crc `unsafeShiftR` 8)
-
- chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString]
- chunksWithSig rawImg sig =
- [chunkData chunk | chunk <- chunks rawImg, chunkType chunk == sig]
-