{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Codec.Picture.Png.Internal.Metadata( extractMetadatas
, encodeMetadatas
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>), (<*>), pure )
import Data.Monoid( Monoid, mempty )
import Data.Foldable( foldMap )
#endif
import Data.Maybe( fromMaybe )
import Data.Binary( Binary( get, put ), encode )
import Data.Binary.Get( getLazyByteStringNul, getWord8 )
import Data.Binary.Put( putLazyByteString, putWord8 )
import qualified Data.ByteString.Lazy.Char8 as L
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
import qualified Codec.Compression.Zlib as Z
import Codec.Picture.InternalHelper
import qualified Codec.Picture.Metadata as Met
import Codec.Picture.Metadata ( Metadatas
, dotsPerMeterToDotPerInch
, Elem( (:=>) ) )
import Codec.Picture.Png.Internal.Type
#if !MIN_VERSION_base(4,7,0)
eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap f v = case v of
Left _ -> mempty
Right a -> f a
#else
eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap :: forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
#endif
getGamma :: [L.ByteString] -> Metadatas
getGamma :: [ByteString] -> Metadatas
getGamma [] = forall a. Monoid a => a
mempty
getGamma (ByteString
g:[ByteString]
_) = forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngGamma -> Metadatas
unpackGamma forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> Either String a
runGet forall t. Binary t => Get t
get ByteString
g
where
unpackGamma :: PngGamma -> Metadatas
unpackGamma PngGamma
gamma = forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Double
Met.Gamma (PngGamma -> Double
getPngGamma PngGamma
gamma)
getDpis :: [L.ByteString] -> Metadatas
getDpis :: [ByteString] -> Metadatas
getDpis [] = forall a. Monoid a => a
mempty
getDpis (ByteString
b:[ByteString]
_) = forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngPhysicalDimension -> Metadatas
unpackPhys forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> Either String a
runGet forall t. Binary t => Get t
get ByteString
b
where
unpackPhys :: PngPhysicalDimension -> Metadatas
unpackPhys PngPhysicalDimension { pngUnit :: PngPhysicalDimension -> PngUnit
pngUnit = PngUnit
PngUnitUnknown } =
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys Word
Met.DpiX Word
72 forall a b. (a -> b) -> a -> b
$ forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.DpiY Word
72
unpackPhys phy :: PngPhysicalDimension
phy@PngPhysicalDimension { pngUnit :: PngPhysicalDimension -> PngUnit
pngUnit = PngUnit
PngUnitMeter } =
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys Word
Met.DpiX Word
dpx forall a b. (a -> b) -> a -> b
$ forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.DpiY Word
dpy
where
dpx :: Word
dpx = Word -> Word
dotsPerMeterToDotPerInch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PngPhysicalDimension -> Word32
pngDpiX PngPhysicalDimension
phy
dpy :: Word
dpy = Word -> Word
dotsPerMeterToDotPerInch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PngPhysicalDimension -> Word32
pngDpiY PngPhysicalDimension
phy
data PngText = PngText
{ PngText -> ByteString
pngKeyword :: !L.ByteString
, PngText -> ByteString
pngData :: !L.ByteString
}
deriving Int -> PngText -> ShowS
[PngText] -> ShowS
PngText -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngText] -> ShowS
$cshowList :: [PngText] -> ShowS
show :: PngText -> String
$cshow :: PngText -> String
showsPrec :: Int -> PngText -> ShowS
$cshowsPrec :: Int -> PngText -> ShowS
Show
instance Binary PngText where
get :: Get PngText
get = ByteString -> ByteString -> PngText
PngText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getRemainingLazyBytes
put :: PngText -> Put
put (PngText ByteString
kw ByteString
pdata) = do
ByteString -> Put
putLazyByteString ByteString
kw
Word8 -> Put
putWord8 Word8
0
ByteString -> Put
putLazyByteString ByteString
pdata
data PngZText = PngZText
{ PngZText -> ByteString
pngZKeyword :: !L.ByteString
, PngZText -> ByteString
pngZData :: !L.ByteString
}
deriving Int -> PngZText -> ShowS
[PngZText] -> ShowS
PngZText -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PngZText] -> ShowS
$cshowList :: [PngZText] -> ShowS
show :: PngZText -> String
$cshow :: PngZText -> String
showsPrec :: Int -> PngZText -> ShowS
$cshowsPrec :: Int -> PngZText -> ShowS
Show
instance Binary PngZText where
get :: Get PngZText
get = ByteString -> ByteString -> PngZText
PngZText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Get ()
getCompressionType forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> ByteString
Z.decompress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getRemainingLazyBytes)
where
getCompressionType :: Get ()
getCompressionType = do
Word8
0 <- Get Word8
getWord8
forall (m :: * -> *) a. Monad m => a -> m a
return ()
put :: PngZText -> Put
put (PngZText ByteString
kw ByteString
pdata) = do
ByteString -> Put
putLazyByteString ByteString
kw
Word8 -> Put
putWord8 Word8
0
Word8 -> Put
putWord8 Word8
0
ByteString -> Put
putLazyByteString (ByteString -> ByteString
Z.compress ByteString
pdata)
aToMetadata :: (a -> L.ByteString) -> (a -> L.ByteString) -> a -> Metadatas
aToMetadata :: forall a. (a -> ByteString) -> (a -> ByteString) -> a -> Metadatas
aToMetadata a -> ByteString
pkeyword a -> ByteString
pdata a
ptext = case a -> ByteString
pkeyword a
ptext of
ByteString
"Title" -> Keys String -> Metadatas
strValue Keys String
Met.Title
ByteString
"Author" -> Keys String -> Metadatas
strValue Keys String
Met.Author
ByteString
"Description" -> Keys String -> Metadatas
strValue Keys String
Met.Description
ByteString
"Copyright" -> Keys String -> Metadatas
strValue Keys String
Met.Copyright
ByteString
"Software" -> Keys String -> Metadatas
strValue Keys String
Met.Software
ByteString
"Disclaimer" -> Keys String -> Metadatas
strValue Keys String
Met.Disclaimer
ByteString
"Warning" -> Keys String -> Metadatas
strValue Keys String
Met.Warning
ByteString
"Source" -> Keys String -> Metadatas
strValue Keys String
Met.Source
ByteString
"Comment" -> Keys String -> Metadatas
strValue Keys String
Met.Comment
ByteString
other ->
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton
(String -> Keys Value
Met.Unknown forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
other)
(String -> Value
Met.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L.unpack forall a b. (a -> b) -> a -> b
$ a -> ByteString
pdata a
ptext)
where
strValue :: Keys String -> Metadatas
strValue Keys String
k = forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys String
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L.unpack forall a b. (a -> b) -> a -> b
$ a -> ByteString
pdata a
ptext
textToMetadata :: PngText -> Metadatas
textToMetadata :: PngText -> Metadatas
textToMetadata = forall a. (a -> ByteString) -> (a -> ByteString) -> a -> Metadatas
aToMetadata PngText -> ByteString
pngKeyword PngText -> ByteString
pngData
ztxtToMetadata :: PngZText -> Metadatas
ztxtToMetadata :: PngZText -> Metadatas
ztxtToMetadata = forall a. (a -> ByteString) -> (a -> ByteString) -> a -> Metadatas
aToMetadata PngZText -> ByteString
pngZKeyword PngZText -> ByteString
pngZData
getTexts :: [L.ByteString] -> Metadatas
getTexts :: [ByteString] -> Metadatas
getTexts = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngText -> Metadatas
textToMetadata forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> ByteString -> Either String a
runGet forall t. Binary t => Get t
get)
getZTexts :: [L.ByteString] -> Metadatas
getZTexts :: [ByteString] -> Metadatas
getZTexts = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngZText -> Metadatas
ztxtToMetadata forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> ByteString -> Either String a
runGet forall t. Binary t => Get t
get)
extractMetadatas :: PngRawImage -> Metadatas
PngRawImage
img = [ByteString] -> Metadatas
getDpis (ByteString -> [ByteString]
chunksOf ByteString
pHYsSignature)
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Metadatas
getGamma (ByteString -> [ByteString]
chunksOf ByteString
gammaSignature)
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Metadatas
getTexts (ByteString -> [ByteString]
chunksOf ByteString
tEXtSignature)
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Metadatas
getZTexts (ByteString -> [ByteString]
chunksOf ByteString
zTXtSignature)
where
chunksOf :: ByteString -> [ByteString]
chunksOf = PngRawImage -> ByteString -> [ByteString]
chunksWithSig PngRawImage
img
encodePhysicalMetadata :: Metadatas -> [PngRawChunk]
encodePhysicalMetadata :: Metadatas -> [PngRawChunk]
encodePhysicalMetadata Metadatas
metas = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Word
dx <- forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
Met.DpiX Metadatas
metas
Word
dy <- forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
Met.DpiY Metadatas
metas
let to :: Word -> Word32
to = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
Met.dotPerInchToDotsPerMeter
dim :: PngPhysicalDimension
dim = Word32 -> Word32 -> PngUnit -> PngPhysicalDimension
PngPhysicalDimension (Word -> Word32
to Word
dx) (Word -> Word32
to Word
dy) PngUnit
PngUnitMeter
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
pHYsSignature forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
encode PngPhysicalDimension
dim]
encodeSingleMetadata :: Metadatas -> [PngRawChunk]
encodeSingleMetadata :: Metadatas -> [PngRawChunk]
encodeSingleMetadata = forall m. Monoid m => (Elem Keys -> m) -> Metadatas -> m
Met.foldMap Elem Keys -> [PngRawChunk]
go where
go :: Elem Met.Keys -> [PngRawChunk]
go :: Elem Keys -> [PngRawChunk]
go Elem Keys
v = case Elem Keys
v of
Met.Exif ExifTag
_ :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.DpiX :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.DpiY :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.Width :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.Height :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.Format :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.Gamma :=> a
g ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
gammaSignature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ Double -> PngGamma
PngGamma a
g
Keys a
Met.ColorSpace :=> a
_ -> forall a. Monoid a => a
mempty
Keys a
Met.Title :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Title" (String -> ByteString
L.pack a
tx)
Keys a
Met.Description :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Description" (String -> ByteString
L.pack a
tx)
Keys a
Met.Author :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Author" (String -> ByteString
L.pack a
tx)
Keys a
Met.Copyright :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Copyright" (String -> ByteString
L.pack a
tx)
Keys a
Met.Software :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Software" (String -> ByteString
L.pack a
tx)
Keys a
Met.Comment :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Comment" (String -> ByteString
L.pack a
tx)
Keys a
Met.Disclaimer :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Disclaimer" (String -> ByteString
L.pack a
tx)
Keys a
Met.Source :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Source" (String -> ByteString
L.pack a
tx)
Keys a
Met.Warning :=> a
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Warning" (String -> ByteString
L.pack a
tx)
Met.Unknown String
k :=> Met.String String
tx -> forall {f :: * -> *}.
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt (String -> ByteString
L.pack String
k) (String -> ByteString
L.pack String
tx)
Met.Unknown String
_ :=> a
_ -> forall a. Monoid a => a
mempty
txt :: ByteString -> ByteString -> f PngRawChunk
txt ByteString
k ByteString
c = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
tEXtSignature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> PngText
PngText ByteString
k ByteString
c
encodeMetadatas :: Metadatas -> [PngRawChunk]
encodeMetadatas :: Metadatas -> [PngRawChunk]
encodeMetadatas Metadatas
m = Metadatas -> [PngRawChunk]
encodePhysicalMetadata Metadatas
m forall a. Semigroup a => a -> a -> a
<> Metadatas -> [PngRawChunk]
encodeSingleMetadata Metadatas
m