{-# LANGUAGE CPP #-}
module Codec.Picture.Png.Internal.Type( PngIHdr( .. )
, PngFilter( .. )
, PngInterlaceMethod( .. )
, PngPalette
, PngImageType( .. )
, PngPhysicalDimension( .. )
, PngGamma( .. )
, PngUnit( .. )
, APngAnimationControl( .. )
, APngFrameDisposal( .. )
, APngBlendOp( .. )
, APngFrameControl( .. )
, parsePalette
, pngComputeCrc
, pngSignature
, iHDRSignature
, pLTESignature
, iDATSignature
, iENDSignature
, tRNSSignature
, tEXtSignature
, zTXtSignature
, gammaSignature
, pHYsSignature
, animationControlSignature
, 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
type ChunkSignature = L.ByteString
data PngIHdr = PngIHdr
{ PngIHdr -> Word32
width :: !Word32
, PngIHdr -> Word32
height :: !Word32
, PngIHdr -> Word8
bitDepth :: !Word8
, PngIHdr -> PngImageType
colourType :: !PngImageType
, PngIHdr -> Word8
compressionMethod :: !Word8
, PngIHdr -> Word8
filterMethod :: !Word8
, PngIHdr -> PngInterlaceMethod
interlaceMethod :: !PngInterlaceMethod
}
deriving Int -> PngIHdr -> ShowS
[PngIHdr] -> ShowS
PngIHdr -> String
(Int -> PngIHdr -> ShowS)
-> (PngIHdr -> String) -> ([PngIHdr] -> ShowS) -> Show PngIHdr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PngIHdr -> ShowS
showsPrec :: Int -> PngIHdr -> ShowS
$cshow :: PngIHdr -> String
show :: PngIHdr -> String
$cshowList :: [PngIHdr] -> ShowS
showList :: [PngIHdr] -> ShowS
Show
data PngUnit
= PngUnitUnknown
| PngUnitMeter
instance Binary PngUnit where
get :: Get PngUnit
get = do
Word8
v <- Get Word8
getWord8
PngUnit -> Get PngUnit
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PngUnit -> Get PngUnit) -> PngUnit -> Get PngUnit
forall a b. (a -> b) -> a -> b
$ case Word8
v of
Word8
0 -> PngUnit
PngUnitUnknown
Word8
1 -> PngUnit
PngUnitMeter
Word8
_ -> PngUnit
PngUnitUnknown
put :: PngUnit -> Put
put PngUnit
v = case PngUnit
v of
PngUnit
PngUnitUnknown -> Word8 -> Put
putWord8 Word8
0
PngUnit
PngUnitMeter -> Word8 -> Put
putWord8 Word8
1
data PngPhysicalDimension = PngPhysicalDimension
{ PngPhysicalDimension -> Word32
pngDpiX :: !Word32
, PngPhysicalDimension -> Word32
pngDpiY :: !Word32
, PngPhysicalDimension -> PngUnit
pngUnit :: !PngUnit
}
instance Binary PngPhysicalDimension where
get :: Get PngPhysicalDimension
get = Word32 -> Word32 -> PngUnit -> PngPhysicalDimension
PngPhysicalDimension (Word32 -> Word32 -> PngUnit -> PngPhysicalDimension)
-> Get Word32 -> Get (Word32 -> PngUnit -> PngPhysicalDimension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be Get (Word32 -> PngUnit -> PngPhysicalDimension)
-> Get Word32 -> Get (PngUnit -> PngPhysicalDimension)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32be Get (PngUnit -> PngPhysicalDimension)
-> Get PngUnit -> Get PngPhysicalDimension
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get PngUnit
forall t. Binary t => Get t
get
put :: PngPhysicalDimension -> Put
put (PngPhysicalDimension Word32
dpx Word32
dpy PngUnit
unit) =
Word32 -> Put
putWord32be Word32
dpx Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be Word32
dpy Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PngUnit -> Put
forall t. Binary t => t -> Put
put PngUnit
unit
newtype PngGamma = PngGamma { PngGamma -> Double
getPngGamma :: Double }
instance Binary PngGamma where
get :: Get PngGamma
get = Double -> PngGamma
PngGamma (Double -> PngGamma) -> (Word32 -> Double) -> Word32 -> PngGamma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100000) (Double -> Double) -> (Word32 -> Double) -> Word32 -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> PngGamma) -> Get Word32 -> Get PngGamma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
put :: PngGamma -> Put
put = Word32 -> Put
putWord32be (Word32 -> Put) -> (PngGamma -> Word32) -> PngGamma -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word32
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Word32) -> (PngGamma -> Double) -> PngGamma -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
100000 Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Double) -> (PngGamma -> Double) -> PngGamma -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngGamma -> Double
getPngGamma
data APngAnimationControl = APngAnimationControl
{ APngAnimationControl -> Word32
animationFrameCount :: !Word32
, APngAnimationControl -> Word32
animationPlayCount :: !Word32
}
deriving Int -> APngAnimationControl -> ShowS
[APngAnimationControl] -> ShowS
APngAnimationControl -> String
(Int -> APngAnimationControl -> ShowS)
-> (APngAnimationControl -> String)
-> ([APngAnimationControl] -> ShowS)
-> Show APngAnimationControl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> APngAnimationControl -> ShowS
showsPrec :: Int -> APngAnimationControl -> ShowS
$cshow :: APngAnimationControl -> String
show :: APngAnimationControl -> String
$cshowList :: [APngAnimationControl] -> ShowS
showList :: [APngAnimationControl] -> ShowS
Show
data APngFrameDisposal
= APngDisposeNone
| APngDisposeBackground
| APngDisposePrevious
deriving Int -> APngFrameDisposal -> ShowS
[APngFrameDisposal] -> ShowS
APngFrameDisposal -> String
(Int -> APngFrameDisposal -> ShowS)
-> (APngFrameDisposal -> String)
-> ([APngFrameDisposal] -> ShowS)
-> Show APngFrameDisposal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> APngFrameDisposal -> ShowS
showsPrec :: Int -> APngFrameDisposal -> ShowS
$cshow :: APngFrameDisposal -> String
show :: APngFrameDisposal -> String
$cshowList :: [APngFrameDisposal] -> ShowS
showList :: [APngFrameDisposal] -> ShowS
Show
data APngBlendOp
= APngBlendSource
| APngBlendOver
deriving Int -> APngBlendOp -> ShowS
[APngBlendOp] -> ShowS
APngBlendOp -> String
(Int -> APngBlendOp -> ShowS)
-> (APngBlendOp -> String)
-> ([APngBlendOp] -> ShowS)
-> Show APngBlendOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> APngBlendOp -> ShowS
showsPrec :: Int -> APngBlendOp -> ShowS
$cshow :: APngBlendOp -> String
show :: APngBlendOp -> String
$cshowList :: [APngBlendOp] -> ShowS
showList :: [APngBlendOp] -> ShowS
Show
data APngFrameControl = APngFrameControl
{ APngFrameControl -> Word32
frameSequenceNum :: !Word32
, APngFrameControl -> Word32
frameWidth :: !Word32
, APngFrameControl -> Word32
frameHeight :: !Word32
, APngFrameControl -> Word32
frameLeft :: !Word32
, APngFrameControl -> Word32
frameTop :: !Word32
, APngFrameControl -> Word16
frameDelayNumerator :: !Word16
, APngFrameControl -> Word16
frameDelayDenuminator :: !Word16
, APngFrameControl -> APngFrameDisposal
frameDisposal :: !APngFrameDisposal
, APngFrameControl -> APngBlendOp
frameBlending :: !APngBlendOp
}
deriving Int -> APngFrameControl -> ShowS
[APngFrameControl] -> ShowS
APngFrameControl -> String
(Int -> APngFrameControl -> ShowS)
-> (APngFrameControl -> String)
-> ([APngFrameControl] -> ShowS)
-> Show APngFrameControl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> APngFrameControl -> ShowS
showsPrec :: Int -> APngFrameControl -> ShowS
$cshow :: APngFrameControl -> String
show :: APngFrameControl -> String
$cshowList :: [APngFrameControl] -> ShowS
showList :: [APngFrameControl] -> ShowS
Show
data PngImageType =
PngGreyscale
| PngTrueColour
| PngIndexedColor
| PngGreyscaleWithAlpha
| PngTrueColourWithAlpha
deriving Int -> PngImageType -> ShowS
[PngImageType] -> ShowS
PngImageType -> String
(Int -> PngImageType -> ShowS)
-> (PngImageType -> String)
-> ([PngImageType] -> ShowS)
-> Show PngImageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PngImageType -> ShowS
showsPrec :: Int -> PngImageType -> ShowS
$cshow :: PngImageType -> String
show :: PngImageType -> String
$cshowList :: [PngImageType] -> ShowS
showList :: [PngImageType] -> ShowS
Show
data PngRawImage = PngRawImage
{ :: PngIHdr
, PngRawImage -> [PngRawChunk]
chunks :: [PngRawChunk]
}
type PngPalette = Palette' PixelRGB8
parsePalette :: PngRawChunk -> Either String PngPalette
parsePalette :: PngRawChunk -> Either String PngPalette
parsePalette PngRawChunk
plte
| PngRawChunk -> Word32
chunkLength PngRawChunk
plte Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` Word32
3 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 = String -> Either String PngPalette
forall a b. a -> Either a b
Left String
"Invalid palette size"
| Bool
otherwise = Int -> Vector (PixelBaseComponent PixelRGB8) -> PngPalette
forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' Int
pixelCount (Vector Word8 -> PngPalette)
-> ([Word8] -> Vector Word8) -> [Word8] -> PngPalette
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word8] -> Vector Word8
forall a. Storable a => Int -> [a] -> Vector a
V.fromListN (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixelCount) ([Word8] -> PngPalette)
-> Either String [Word8] -> Either String PngPalette
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String [Word8]
pixels
where pixelUnpacker :: Get [Word8]
pixelUnpacker = Int -> Get Word8 -> Get [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pixelCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) Get Word8
forall t. Binary t => Get t
get
pixelCount :: Int
pixelCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngRawChunk -> Word32
chunkLength PngRawChunk
plte Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
3
pixels :: Either String [Word8]
pixels = Get [Word8] -> ChunkSignature -> Either String [Word8]
forall a. Get a -> ChunkSignature -> Either String a
runGet Get [Word8]
pixelUnpacker (PngRawChunk -> ChunkSignature
chunkData PngRawChunk
plte)
data PngRawChunk = PngRawChunk
{ PngRawChunk -> Word32
chunkLength :: Word32
, PngRawChunk -> ChunkSignature
chunkType :: ChunkSignature
, PngRawChunk -> Word32
chunkCRC :: Word32
, PngRawChunk -> ChunkSignature
chunkData :: L.ByteString
}
mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk
mkRawChunk :: ChunkSignature -> ChunkSignature -> PngRawChunk
mkRawChunk ChunkSignature
sig ChunkSignature
binaryData = PngRawChunk
{ chunkLength :: Word32
chunkLength = Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ChunkSignature -> Int64
L.length ChunkSignature
binaryData
, chunkType :: ChunkSignature
chunkType = ChunkSignature
sig
, chunkCRC :: Word32
chunkCRC = [ChunkSignature] -> Word32
pngComputeCrc [ChunkSignature
sig, ChunkSignature
binaryData]
, chunkData :: ChunkSignature
chunkData = ChunkSignature
binaryData
}
data PngChunk = PngChunk
{ PngChunk -> ChunkSignature
pngChunkData :: L.ByteString
, PngChunk -> ChunkSignature
pngChunkSignature :: ChunkSignature
}
data PngLowLevel a = PngLowLevel
{ forall a. PngLowLevel a -> Image a
pngImage :: Image a
, forall a. PngLowLevel a -> [PngChunk]
pngChunks :: [PngChunk]
}
data PngFilter =
FilterNone
| FilterSub
| FilterUp
| FilterAverage
| FilterPaeth
deriving (Int -> PngFilter
PngFilter -> Int
PngFilter -> [PngFilter]
PngFilter -> PngFilter
PngFilter -> PngFilter -> [PngFilter]
PngFilter -> PngFilter -> PngFilter -> [PngFilter]
(PngFilter -> PngFilter)
-> (PngFilter -> PngFilter)
-> (Int -> PngFilter)
-> (PngFilter -> Int)
-> (PngFilter -> [PngFilter])
-> (PngFilter -> PngFilter -> [PngFilter])
-> (PngFilter -> PngFilter -> [PngFilter])
-> (PngFilter -> PngFilter -> PngFilter -> [PngFilter])
-> Enum PngFilter
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PngFilter -> PngFilter
succ :: PngFilter -> PngFilter
$cpred :: PngFilter -> PngFilter
pred :: PngFilter -> PngFilter
$ctoEnum :: Int -> PngFilter
toEnum :: Int -> PngFilter
$cfromEnum :: PngFilter -> Int
fromEnum :: PngFilter -> Int
$cenumFrom :: PngFilter -> [PngFilter]
enumFrom :: PngFilter -> [PngFilter]
$cenumFromThen :: PngFilter -> PngFilter -> [PngFilter]
enumFromThen :: PngFilter -> PngFilter -> [PngFilter]
$cenumFromTo :: PngFilter -> PngFilter -> [PngFilter]
enumFromTo :: PngFilter -> PngFilter -> [PngFilter]
$cenumFromThenTo :: PngFilter -> PngFilter -> PngFilter -> [PngFilter]
enumFromThenTo :: PngFilter -> PngFilter -> PngFilter -> [PngFilter]
Enum, Int -> PngFilter -> ShowS
[PngFilter] -> ShowS
PngFilter -> String
(Int -> PngFilter -> ShowS)
-> (PngFilter -> String)
-> ([PngFilter] -> ShowS)
-> Show PngFilter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PngFilter -> ShowS
showsPrec :: Int -> PngFilter -> ShowS
$cshow :: PngFilter -> String
show :: PngFilter -> String
$cshowList :: [PngFilter] -> ShowS
showList :: [PngFilter] -> ShowS
Show)
data PngInterlaceMethod =
PngNoInterlace
| PngInterlaceAdam7
deriving (Int -> PngInterlaceMethod
PngInterlaceMethod -> Int
PngInterlaceMethod -> [PngInterlaceMethod]
PngInterlaceMethod -> PngInterlaceMethod
PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
(PngInterlaceMethod -> PngInterlaceMethod)
-> (PngInterlaceMethod -> PngInterlaceMethod)
-> (Int -> PngInterlaceMethod)
-> (PngInterlaceMethod -> Int)
-> (PngInterlaceMethod -> [PngInterlaceMethod])
-> (PngInterlaceMethod
-> PngInterlaceMethod -> [PngInterlaceMethod])
-> (PngInterlaceMethod
-> PngInterlaceMethod -> [PngInterlaceMethod])
-> (PngInterlaceMethod
-> PngInterlaceMethod
-> PngInterlaceMethod
-> [PngInterlaceMethod])
-> Enum PngInterlaceMethod
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PngInterlaceMethod -> PngInterlaceMethod
succ :: PngInterlaceMethod -> PngInterlaceMethod
$cpred :: PngInterlaceMethod -> PngInterlaceMethod
pred :: PngInterlaceMethod -> PngInterlaceMethod
$ctoEnum :: Int -> PngInterlaceMethod
toEnum :: Int -> PngInterlaceMethod
$cfromEnum :: PngInterlaceMethod -> Int
fromEnum :: PngInterlaceMethod -> Int
$cenumFrom :: PngInterlaceMethod -> [PngInterlaceMethod]
enumFrom :: PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromThen :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFromThen :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromTo :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFromTo :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromThenTo :: PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFromThenTo :: PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
Enum, Int -> PngInterlaceMethod -> ShowS
[PngInterlaceMethod] -> ShowS
PngInterlaceMethod -> String
(Int -> PngInterlaceMethod -> ShowS)
-> (PngInterlaceMethod -> String)
-> ([PngInterlaceMethod] -> ShowS)
-> Show PngInterlaceMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PngInterlaceMethod -> ShowS
showsPrec :: Int -> PngInterlaceMethod -> ShowS
$cshow :: PngInterlaceMethod -> String
show :: PngInterlaceMethod -> String
$cshowList :: [PngInterlaceMethod] -> ShowS
showList :: [PngInterlaceMethod] -> ShowS
Show)
instance Binary PngFilter where
put :: PngFilter -> Put
put = Word8 -> Put
putWord8 (Word8 -> Put) -> (PngFilter -> Word8) -> PngFilter -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (PngFilter -> Int) -> PngFilter -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngFilter -> Int
forall a. Enum a => a -> Int
fromEnum
get :: Get PngFilter
get = Get Word8
getWord8 Get Word8 -> (Word8 -> Get PngFilter) -> Get PngFilter
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
w -> case Word8
w of
Word8
0 -> PngFilter -> Get PngFilter
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterNone
Word8
1 -> PngFilter -> Get PngFilter
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterSub
Word8
2 -> PngFilter -> Get PngFilter
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterUp
Word8
3 -> PngFilter -> Get PngFilter
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterAverage
Word8
4 -> PngFilter -> Get PngFilter
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterPaeth
Word8
_ -> String -> Get PngFilter
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid scanline filter"
instance Binary PngRawImage where
put :: PngRawImage -> Put
put PngRawImage
img = do
ChunkSignature -> Put
putLazyByteString ChunkSignature
pngSignature
PngIHdr -> Put
forall t. Binary t => t -> Put
put (PngIHdr -> Put) -> PngIHdr -> Put
forall a b. (a -> b) -> a -> b
$ PngRawImage -> PngIHdr
header PngRawImage
img
(PngRawChunk -> Put) -> [PngRawChunk] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PngRawChunk -> Put
forall t. Binary t => t -> Put
put ([PngRawChunk] -> Put) -> [PngRawChunk] -> Put
forall a b. (a -> b) -> a -> b
$ PngRawImage -> [PngRawChunk]
chunks PngRawImage
img
get :: Get PngRawImage
get = Get PngRawImage
parseRawPngImage
instance Binary PngRawChunk where
put :: PngRawChunk -> Put
put PngRawChunk
chunk = do
Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ PngRawChunk -> Word32
chunkLength PngRawChunk
chunk
ChunkSignature -> Put
putLazyByteString (ChunkSignature -> Put) -> ChunkSignature -> Put
forall a b. (a -> b) -> a -> b
$ PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk
Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PngRawChunk -> Word32
chunkLength PngRawChunk
chunk Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0)
(ChunkSignature -> Put
putLazyByteString (ChunkSignature -> Put) -> ChunkSignature -> Put
forall a b. (a -> b) -> a -> b
$ PngRawChunk -> ChunkSignature
chunkData PngRawChunk
chunk)
Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ PngRawChunk -> Word32
chunkCRC PngRawChunk
chunk
get :: Get PngRawChunk
get = do
Word32
size <- Get Word32
getWord32be
ChunkSignature
chunkSig <- Int64 -> Get ChunkSignature
getLazyByteString (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ ChunkSignature -> Int64
L.length ChunkSignature
iHDRSignature)
ChunkSignature
imgData <- if Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
then ChunkSignature -> Get ChunkSignature
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ChunkSignature
L.empty
else Int64 -> Get ChunkSignature
getLazyByteString (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)
Word32
crc <- Get Word32
getWord32be
let computedCrc :: Word32
computedCrc = [ChunkSignature] -> Word32
pngComputeCrc [ChunkSignature
chunkSig, ChunkSignature
imgData]
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
computedCrc Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
crc Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0)
(String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid CRC : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
computedCrc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
crc)
PngRawChunk -> Get PngRawChunk
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngRawChunk {
chunkLength :: Word32
chunkLength = Word32
size,
chunkData :: ChunkSignature
chunkData = ChunkSignature
imgData,
chunkCRC :: Word32
chunkCRC = Word32
crc,
chunkType :: ChunkSignature
chunkType = ChunkSignature
chunkSig
}
instance Binary PngIHdr where
put :: PngIHdr -> Put
put PngIHdr
hdr = do
Word32 -> Put
putWord32be Word32
13
let inner :: ChunkSignature
inner = Put -> ChunkSignature
runPut (Put -> ChunkSignature) -> Put -> ChunkSignature
forall a b. (a -> b) -> a -> b
$ do
ChunkSignature -> Put
putLazyByteString ChunkSignature
iHDRSignature
Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
Word32 -> Put
putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr
Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
bitDepth PngIHdr
hdr
PngImageType -> Put
forall t. Binary t => t -> Put
put (PngImageType -> Put) -> PngImageType -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> PngImageType
colourType PngIHdr
hdr
Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
compressionMethod PngIHdr
hdr
Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
filterMethod PngIHdr
hdr
PngInterlaceMethod -> Put
forall t. Binary t => t -> Put
put (PngInterlaceMethod -> Put) -> PngInterlaceMethod -> Put
forall a b. (a -> b) -> a -> b
$ PngIHdr -> PngInterlaceMethod
interlaceMethod PngIHdr
hdr
crc :: Word32
crc = [ChunkSignature] -> Word32
pngComputeCrc [ChunkSignature
inner]
ChunkSignature -> Put
putLazyByteString ChunkSignature
inner
Word32 -> Put
putWord32be Word32
crc
get :: Get PngIHdr
get = do
Word32
_size <- Get Word32
getWord32be
ChunkSignature
ihdrSig <- Int64 -> Get ChunkSignature
getLazyByteString (ChunkSignature -> Int64
L.length ChunkSignature
iHDRSignature)
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChunkSignature
ihdrSig ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
/= ChunkSignature
iHDRSignature)
(String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid PNG file, wrong ihdr")
Word32
w <- Get Word32
getWord32be
Word32
h <- Get Word32
getWord32be
Word8
depth <- Get Word8
forall t. Binary t => Get t
get
PngImageType
colorType <- Get PngImageType
forall t. Binary t => Get t
get
Word8
compression <- Get Word8
forall t. Binary t => Get t
get
Word8
filtermethod <- Get Word8
forall t. Binary t => Get t
get
PngInterlaceMethod
interlace <- Get PngInterlaceMethod
forall t. Binary t => Get t
get
Word32
_crc <- Get Word32
getWord32be
PngIHdr -> Get PngIHdr
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngIHdr {
width :: Word32
width = Word32
w,
height :: Word32
height = Word32
h,
bitDepth :: Word8
bitDepth = Word8
depth,
colourType :: PngImageType
colourType = PngImageType
colorType,
compressionMethod :: Word8
compressionMethod = Word8
compression,
filterMethod :: Word8
filterMethod = Word8
filtermethod,
interlaceMethod :: PngInterlaceMethod
interlaceMethod = PngInterlaceMethod
interlace
}
parseChunks :: Get [PngRawChunk]
parseChunks :: Get [PngRawChunk]
parseChunks = do
PngRawChunk
chunk <- Get PngRawChunk
forall t. Binary t => Get t
get
if PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkSignature
iENDSignature
then [PngRawChunk] -> Get [PngRawChunk]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return [PngRawChunk
chunk]
else (PngRawChunk
chunkPngRawChunk -> [PngRawChunk] -> [PngRawChunk]
forall a. a -> [a] -> [a]
:) ([PngRawChunk] -> [PngRawChunk])
-> Get [PngRawChunk] -> Get [PngRawChunk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [PngRawChunk]
parseChunks
instance Binary PngInterlaceMethod where
get :: Get PngInterlaceMethod
get = Get Word8
getWord8 Get Word8
-> (Word8 -> Get PngInterlaceMethod) -> Get PngInterlaceMethod
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
w -> case Word8
w of
Word8
0 -> PngInterlaceMethod -> Get PngInterlaceMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngInterlaceMethod
PngNoInterlace
Word8
1 -> PngInterlaceMethod -> Get PngInterlaceMethod
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngInterlaceMethod
PngInterlaceAdam7
Word8
_ -> String -> Get PngInterlaceMethod
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid interlace method"
put :: PngInterlaceMethod -> Put
put PngInterlaceMethod
PngNoInterlace = Word8 -> Put
putWord8 Word8
0
put PngInterlaceMethod
PngInterlaceAdam7 = Word8 -> Put
putWord8 Word8
1
parseRawPngImage :: Get PngRawImage
parseRawPngImage :: Get PngRawImage
parseRawPngImage = do
ChunkSignature
sig <- Int64 -> Get ChunkSignature
getLazyByteString (ChunkSignature -> Int64
L.length ChunkSignature
pngSignature)
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChunkSignature
sig ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
/= ChunkSignature
pngSignature)
(String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid PNG file, signature broken")
PngIHdr
ihdr <- Get PngIHdr
forall t. Binary t => Get t
get
[PngRawChunk]
chunkList <- Get [PngRawChunk]
parseChunks
PngRawImage -> Get PngRawImage
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngRawImage { header :: PngIHdr
header = PngIHdr
ihdr, chunks :: [PngRawChunk]
chunks = [PngRawChunk]
chunkList }
pngSignature :: ChunkSignature
pngSignature :: ChunkSignature
pngSignature = [Word8] -> ChunkSignature
L.pack [Word8
137, Word8
80, Word8
78, Word8
71, Word8
13, Word8
10, Word8
26, Word8
10]
signature :: String -> ChunkSignature
signature :: String -> ChunkSignature
signature = String -> ChunkSignature
LS.pack
iHDRSignature :: ChunkSignature
iHDRSignature :: ChunkSignature
iHDRSignature = String -> ChunkSignature
signature String
"IHDR"
pLTESignature :: ChunkSignature
pLTESignature :: ChunkSignature
pLTESignature = String -> ChunkSignature
signature String
"PLTE"
iDATSignature :: ChunkSignature
iDATSignature :: ChunkSignature
iDATSignature = String -> ChunkSignature
signature String
"IDAT"
iENDSignature :: ChunkSignature
iENDSignature :: ChunkSignature
iENDSignature = String -> ChunkSignature
signature String
"IEND"
tRNSSignature :: ChunkSignature
tRNSSignature :: ChunkSignature
tRNSSignature = String -> ChunkSignature
signature String
"tRNS"
gammaSignature :: ChunkSignature
gammaSignature :: ChunkSignature
gammaSignature = String -> ChunkSignature
signature String
"gAMA"
pHYsSignature :: ChunkSignature
pHYsSignature :: ChunkSignature
pHYsSignature = String -> ChunkSignature
signature String
"pHYs"
tEXtSignature :: ChunkSignature
tEXtSignature :: ChunkSignature
tEXtSignature = String -> ChunkSignature
signature String
"tEXt"
zTXtSignature :: ChunkSignature
zTXtSignature :: ChunkSignature
zTXtSignature = String -> ChunkSignature
signature String
"zTXt"
animationControlSignature :: ChunkSignature
animationControlSignature :: ChunkSignature
animationControlSignature = String -> ChunkSignature
signature String
"acTL"
instance Binary PngImageType where
put :: PngImageType -> Put
put PngImageType
PngGreyscale = Word8 -> Put
putWord8 Word8
0
put PngImageType
PngTrueColour = Word8 -> Put
putWord8 Word8
2
put PngImageType
PngIndexedColor = Word8 -> Put
putWord8 Word8
3
put PngImageType
PngGreyscaleWithAlpha = Word8 -> Put
putWord8 Word8
4
put PngImageType
PngTrueColourWithAlpha = Word8 -> Put
putWord8 Word8
6
get :: Get PngImageType
get = Get Word8
forall t. Binary t => Get t
get Get Word8 -> (Word8 -> Get PngImageType) -> Get PngImageType
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get PngImageType
imageTypeOfCode
imageTypeOfCode :: Word8 -> Get PngImageType
imageTypeOfCode :: Word8 -> Get PngImageType
imageTypeOfCode Word8
0 = PngImageType -> Get PngImageType
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngGreyscale
imageTypeOfCode Word8
2 = PngImageType -> Get PngImageType
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngTrueColour
imageTypeOfCode Word8
3 = PngImageType -> Get PngImageType
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngIndexedColor
imageTypeOfCode Word8
4 = PngImageType -> Get PngImageType
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngGreyscaleWithAlpha
imageTypeOfCode Word8
6 = PngImageType -> Get PngImageType
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngTrueColourWithAlpha
imageTypeOfCode Word8
_ = String -> Get PngImageType
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid png color code"
pngCrcTable :: Vector Word32
pngCrcTable :: Vector Word32
pngCrcTable = Int -> [Word32] -> Vector Word32
forall a. Unbox a => Int -> [a] -> Vector a
fromListN Int
256 [ (Word32 -> Int -> Word32) -> Word32 -> [Int] -> Word32
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> Int -> Word32
forall {p}. Word32 -> p -> Word32
updateCrcConstant Word32
c [Int
zero .. Int
7] | Word32
c <- [Word32
0 .. Word32
255] ]
where zero :: Int
zero = Int
0 :: Int
updateCrcConstant :: Word32 -> p -> Word32
updateCrcConstant Word32
c p
_ | Word32
c Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 = Word32
magicConstant Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` (Word32
c Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1)
| Bool
otherwise = Word32
c Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1
magicConstant :: Word32
magicConstant = Word32
0xedb88320 :: Word32
pngComputeCrc :: [L.ByteString] -> Word32
pngComputeCrc :: [ChunkSignature] -> Word32
pngComputeCrc = (Word32
0xFFFFFFFF Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor`) (Word32 -> Word32)
-> ([ChunkSignature] -> Word32) -> [ChunkSignature] -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Word8 -> Word32) -> Word32 -> ChunkSignature -> Word32
forall a. (a -> Word8 -> a) -> a -> ChunkSignature -> a
L.foldl' Word32 -> Word8 -> Word32
forall {p}. Integral p => Word32 -> p -> Word32
updateCrc Word32
0xFFFFFFFF (ChunkSignature -> Word32)
-> ([ChunkSignature] -> ChunkSignature)
-> [ChunkSignature]
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChunkSignature] -> ChunkSignature
L.concat
where updateCrc :: Word32 -> p -> Word32
updateCrc Word32
crc p
val =
let u32Val :: Word32
u32Val = p -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
val
lutVal :: Word32
lutVal = Vector Word32
pngCrcTable Vector Word32 -> Int -> Word32
forall a. Unbox a => Vector a -> Int -> a
! (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
crc Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
u32Val) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF))
in Word32
lutVal Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` (Word32
crc Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8)
chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString]
chunksWithSig :: PngRawImage -> ChunkSignature -> [ChunkSignature]
chunksWithSig PngRawImage
rawImg ChunkSignature
sig =
[PngRawChunk -> ChunkSignature
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg, PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk ChunkSignature -> ChunkSignature -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkSignature
sig]