{-# LANGUAGE CPP #-}
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
, 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngIHdr] -> ShowS
$cshowList :: [PngIHdr] -> ShowS
show :: PngIHdr -> String
$cshow :: PngIHdr -> String
showsPrec :: Int -> PngIHdr -> ShowS
$cshowsPrec :: Int -> PngIHdr -> ShowS
Show
data PngUnit
= PngUnitUnknown
| PngUnitMeter
instance Binary PngUnit where
get :: Get PngUnit
get = do
Word8
v <- Get Word8
getWord8
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32be forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
put :: PngPhysicalDimension -> Put
put (PngPhysicalDimension Word32
dpx Word32
dpy PngUnit
unit) =
Word32 -> Put
putWord32be Word32
dpx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be Word32
dpy forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ Double
100000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
put :: PngGamma -> Put
put = Word32 -> Put
putWord32be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
100000 forall a. Num a => a -> a -> a
*) 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [APngAnimationControl] -> ShowS
$cshowList :: [APngAnimationControl] -> ShowS
show :: APngAnimationControl -> String
$cshow :: APngAnimationControl -> String
showsPrec :: Int -> APngAnimationControl -> ShowS
$cshowsPrec :: Int -> APngAnimationControl -> ShowS
Show
data APngFrameDisposal
= APngDisposeNone
| APngDisposeBackground
| APngDisposePrevious
deriving Int -> APngFrameDisposal -> ShowS
[APngFrameDisposal] -> ShowS
APngFrameDisposal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [APngFrameDisposal] -> ShowS
$cshowList :: [APngFrameDisposal] -> ShowS
show :: APngFrameDisposal -> String
$cshow :: APngFrameDisposal -> String
showsPrec :: Int -> APngFrameDisposal -> ShowS
$cshowsPrec :: Int -> APngFrameDisposal -> ShowS
Show
data APngBlendOp
= APngBlendSource
| APngBlendOver
deriving Int -> APngBlendOp -> ShowS
[APngBlendOp] -> ShowS
APngBlendOp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [APngBlendOp] -> ShowS
$cshowList :: [APngBlendOp] -> ShowS
show :: APngBlendOp -> String
$cshow :: APngBlendOp -> String
showsPrec :: Int -> APngBlendOp -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [APngFrameControl] -> ShowS
$cshowList :: [APngFrameControl] -> ShowS
show :: APngFrameControl -> String
$cshow :: APngFrameControl -> String
showsPrec :: Int -> APngFrameControl -> ShowS
$cshowsPrec :: Int -> APngFrameControl -> ShowS
Show
data PngImageType =
PngGreyscale
| PngTrueColour
| PngIndexedColor
| PngGreyscaleWithAlpha
| PngTrueColourWithAlpha
deriving Int -> PngImageType -> ShowS
[PngImageType] -> ShowS
PngImageType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngImageType] -> ShowS
$cshowList :: [PngImageType] -> ShowS
show :: PngImageType -> String
$cshow :: PngImageType -> String
showsPrec :: Int -> PngImageType -> ShowS
$cshowsPrec :: Int -> 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 forall a. Integral a => a -> a -> a
`mod` Word32
3 forall a. Eq a => a -> a -> Bool
/= Word32
0 = forall a b. a -> Either a b
Left String
"Invalid palette size"
| Bool
otherwise = forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' Int
pixelCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Int -> [a] -> Vector a
V.fromListN (Int
3 forall a. Num a => a -> a -> a
* Int
pixelCount) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String [Word8]
pixels
where pixelUnpacker :: Get [Word8]
pixelUnpacker = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pixelCount forall a. Num a => a -> a -> a
* Int
3) forall t. Binary t => Get t
get
pixelCount :: Int
pixelCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PngRawChunk -> Word32
chunkLength PngRawChunk
plte forall a. Integral a => a -> a -> a
`div` Word32
3
pixels :: Either String [Word8]
pixels = 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PngFilter -> PngFilter -> PngFilter -> [PngFilter]
$cenumFromThenTo :: PngFilter -> PngFilter -> PngFilter -> [PngFilter]
enumFromTo :: PngFilter -> PngFilter -> [PngFilter]
$cenumFromTo :: PngFilter -> PngFilter -> [PngFilter]
enumFromThen :: PngFilter -> PngFilter -> [PngFilter]
$cenumFromThen :: PngFilter -> PngFilter -> [PngFilter]
enumFrom :: PngFilter -> [PngFilter]
$cenumFrom :: PngFilter -> [PngFilter]
fromEnum :: PngFilter -> Int
$cfromEnum :: PngFilter -> Int
toEnum :: Int -> PngFilter
$ctoEnum :: Int -> PngFilter
pred :: PngFilter -> PngFilter
$cpred :: PngFilter -> PngFilter
succ :: PngFilter -> PngFilter
$csucc :: PngFilter -> PngFilter
Enum, Int -> PngFilter -> ShowS
[PngFilter] -> ShowS
PngFilter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngFilter] -> ShowS
$cshowList :: [PngFilter] -> ShowS
show :: PngFilter -> String
$cshow :: PngFilter -> String
showsPrec :: Int -> PngFilter -> ShowS
$cshowsPrec :: Int -> PngFilter -> ShowS
Show)
data PngInterlaceMethod =
PngNoInterlace
| PngInterlaceAdam7
deriving (Int -> PngInterlaceMethod
PngInterlaceMethod -> Int
PngInterlaceMethod -> [PngInterlaceMethod]
PngInterlaceMethod -> PngInterlaceMethod
PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [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
enumFromThenTo :: PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromThenTo :: PngInterlaceMethod
-> PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFromTo :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromTo :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFromThen :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFromThen :: PngInterlaceMethod -> PngInterlaceMethod -> [PngInterlaceMethod]
enumFrom :: PngInterlaceMethod -> [PngInterlaceMethod]
$cenumFrom :: PngInterlaceMethod -> [PngInterlaceMethod]
fromEnum :: PngInterlaceMethod -> Int
$cfromEnum :: PngInterlaceMethod -> Int
toEnum :: Int -> PngInterlaceMethod
$ctoEnum :: Int -> PngInterlaceMethod
pred :: PngInterlaceMethod -> PngInterlaceMethod
$cpred :: PngInterlaceMethod -> PngInterlaceMethod
succ :: PngInterlaceMethod -> PngInterlaceMethod
$csucc :: PngInterlaceMethod -> PngInterlaceMethod
Enum, Int -> PngInterlaceMethod -> ShowS
[PngInterlaceMethod] -> ShowS
PngInterlaceMethod -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngInterlaceMethod] -> ShowS
$cshowList :: [PngInterlaceMethod] -> ShowS
show :: PngInterlaceMethod -> String
$cshow :: PngInterlaceMethod -> String
showsPrec :: Int -> PngInterlaceMethod -> ShowS
$cshowsPrec :: Int -> PngInterlaceMethod -> ShowS
Show)
instance Binary PngFilter where
put :: PngFilter -> Put
put = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
get :: Get PngFilter
get = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
w -> case Word8
w of
Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterNone
Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterSub
Word8
2 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterUp
Word8
3 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterAverage
Word8
4 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngFilter
FilterPaeth
Word8
_ -> 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
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ PngRawImage -> PngIHdr
header PngRawImage
img
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
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 forall a b. (a -> b) -> a -> b
$ PngRawChunk -> Word32
chunkLength PngRawChunk
chunk
ChunkSignature -> Put
putLazyByteString forall a b. (a -> b) -> a -> b
$ PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PngRawChunk -> Word32
chunkLength PngRawChunk
chunk forall a. Eq a => a -> a -> Bool
/= Word32
0)
(ChunkSignature -> Put
putLazyByteString forall a b. (a -> b) -> a -> b
$ PngRawChunk -> ChunkSignature
chunkData PngRawChunk
chunk)
Word32 -> Put
putWord32be 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ChunkSignature -> Int64
L.length ChunkSignature
iHDRSignature)
ChunkSignature
imgData <- if Word32
size forall a. Eq a => a -> a -> Bool
== Word32
0
then forall (m :: * -> *) a. Monad m => a -> m a
return ChunkSignature
L.empty
else Int64 -> Get ChunkSignature
getLazyByteString (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]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
computedCrc forall a. Bits a => a -> a -> a
`xor` Word32
crc forall a. Eq a => a -> a -> Bool
/= Word32
0)
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid CRC : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
computedCrc forall a. [a] -> [a] -> [a]
++ String
", "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
crc)
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 forall a b. (a -> b) -> a -> b
$ do
ChunkSignature -> Put
putLazyByteString ChunkSignature
iHDRSignature
Word32 -> Put
putWord32be forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
Word32 -> Put
putWord32be forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr
Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
bitDepth PngIHdr
hdr
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ PngIHdr -> PngImageType
colourType PngIHdr
hdr
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
compressionMethod PngIHdr
hdr
forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word8
filterMethod PngIHdr
hdr
forall t. Binary t => t -> Put
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)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChunkSignature
ihdrSig forall a. Eq a => a -> a -> Bool
/= ChunkSignature
iHDRSignature)
(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 <- forall t. Binary t => Get t
get
PngImageType
colorType <- forall t. Binary t => Get t
get
Word8
compression <- forall t. Binary t => Get t
get
Word8
filtermethod <- forall t. Binary t => Get t
get
PngInterlaceMethod
interlace <- forall t. Binary t => Get t
get
Word32
_crc <- Get Word32
getWord32be
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 <- forall t. Binary t => Get t
get
if PngRawChunk -> ChunkSignature
chunkType PngRawChunk
chunk forall a. Eq a => a -> a -> Bool
== ChunkSignature
iENDSignature
then forall (m :: * -> *) a. Monad m => a -> m a
return [PngRawChunk
chunk]
else (PngRawChunk
chunkforall a. a -> [a] -> [a]
:) 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
w -> case Word8
w of
Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngInterlaceMethod
PngNoInterlace
Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return PngInterlaceMethod
PngInterlaceAdam7
Word8
_ -> 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)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChunkSignature
sig forall a. Eq a => a -> a -> Bool
/= ChunkSignature
pngSignature)
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid PNG file, signature broken")
PngIHdr
ihdr <- forall t. Binary t => Get t
get
[PngRawChunk]
chunkList <- Get [PngRawChunk]
parseChunks
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 = forall t. Binary t => Get t
get 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 = forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngGreyscale
imageTypeOfCode Word8
2 = forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngTrueColour
imageTypeOfCode Word8
3 = forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngIndexedColor
imageTypeOfCode Word8
4 = forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngGreyscaleWithAlpha
imageTypeOfCode Word8
6 = forall (m :: * -> *) a. Monad m => a -> m a
return PngImageType
PngTrueColourWithAlpha
imageTypeOfCode Word8
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid png color code"
pngCrcTable :: Vector Word32
pngCrcTable :: Vector Word32
pngCrcTable = forall a. Unbox a => Int -> [a] -> Vector a
fromListN Int
256 [ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 forall a. Bits a => a -> a -> a
.&. Word32
1 forall a. Eq a => a -> a -> Bool
/= Word32
0 = Word32
magicConstant forall a. Bits a => a -> a -> a
`xor` (Word32
c forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1)
| Bool
otherwise = Word32
c 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 forall a. Bits a => a -> a -> a
`xor`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ChunkSignature -> a
L.foldl' forall {p}. Integral p => Word32 -> p -> Word32
updateCrc Word32
0xFFFFFFFF 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
val
lutVal :: Word32
lutVal = Vector Word32
pngCrcTable forall a. Unbox a => Vector a -> Int -> a
! (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
crc forall a. Bits a => a -> a -> a
`xor` Word32
u32Val) forall a. Bits a => a -> a -> a
.&. Word32
0xFF))
in Word32
lutVal forall a. Bits a => a -> a -> a
`xor` (Word32
crc 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 forall a. Eq a => a -> a -> Bool
== ChunkSignature
sig]