{-# 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 :: (a -> m) -> Either e a -> m
eitherFoldMap = (a -> m) -> Either e a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
#endif

getGamma :: [L.ByteString] -> Metadatas
getGamma :: [ByteString] -> Metadatas
getGamma [] = Metadatas
forall a. Monoid a => a
mempty
getGamma (ByteString
g:[ByteString]
_) = (PngGamma -> Metadatas) -> Either String PngGamma -> Metadatas
forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngGamma -> Metadatas
unpackGamma (Either String PngGamma -> Metadatas)
-> Either String PngGamma -> Metadatas
forall a b. (a -> b) -> a -> b
$ Get PngGamma -> ByteString -> Either String PngGamma
forall a. Get a -> ByteString -> Either String a
runGet Get PngGamma
forall t. Binary t => Get t
get ByteString
g
  where
    unpackGamma :: PngGamma -> Metadatas
unpackGamma PngGamma
gamma = Keys Double -> Double -> Metadatas
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 [] = Metadatas
forall a. Monoid a => a
mempty
getDpis (ByteString
b:[ByteString]
_) = (PngPhysicalDimension -> Metadatas)
-> Either String PngPhysicalDimension -> Metadatas
forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngPhysicalDimension -> Metadatas
unpackPhys (Either String PngPhysicalDimension -> Metadatas)
-> Either String PngPhysicalDimension -> Metadatas
forall a b. (a -> b) -> a -> b
$ Get PngPhysicalDimension
-> ByteString -> Either String PngPhysicalDimension
forall a. Get a -> ByteString -> Either String a
runGet Get PngPhysicalDimension
forall t. Binary t => Get t
get ByteString
b
  where
    unpackPhys :: PngPhysicalDimension -> Metadatas
unpackPhys PngPhysicalDimension { pngUnit :: PngPhysicalDimension -> PngUnit
pngUnit = PngUnit
PngUnitUnknown } =
      Keys Word -> Word -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys Word
Met.DpiX Word
72 (Metadatas -> Metadatas) -> Metadatas -> Metadatas
forall a b. (a -> b) -> a -> b
$ Keys Word -> Word -> Metadatas
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 } =
      Keys Word -> Word -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys Word
Met.DpiX Word
dpx (Metadatas -> Metadatas) -> Metadatas -> Metadatas
forall a b. (a -> b) -> a -> b
$ Keys Word -> Word -> Metadatas
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 (Word -> Word) -> (Word32 -> Word) -> Word32 -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word) -> Word32 -> Word
forall a b. (a -> b) -> a -> b
$ PngPhysicalDimension -> Word32
pngDpiX PngPhysicalDimension
phy
          dpy :: Word
dpy = Word -> Word
dotsPerMeterToDotPerInch (Word -> Word) -> (Word32 -> Word) -> Word32 -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word) -> Word32 -> Word
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
(Int -> PngText -> ShowS)
-> (PngText -> String) -> ([PngText] -> ShowS) -> Show PngText
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 (ByteString -> ByteString -> PngText)
-> Get ByteString -> Get (ByteString -> PngText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul Get (ByteString -> PngText) -> Get ByteString -> Get PngText
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
(Int -> PngZText -> ShowS)
-> (PngZText -> String) -> ([PngZText] -> ShowS) -> Show PngZText
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 (ByteString -> ByteString -> PngZText)
-> Get ByteString -> Get (ByteString -> PngZText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul Get (ByteString -> PngZText)
-> Get () -> Get (ByteString -> PngZText)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Get ()
getCompressionType Get (ByteString -> PngZText) -> Get ByteString -> Get PngZText
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> ByteString
Z.decompress (ByteString -> ByteString) -> Get ByteString -> Get ByteString
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
        () -> Get ()
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 -- compression type

    ByteString -> Put
putLazyByteString (ByteString -> ByteString
Z.compress ByteString
pdata)

aToMetadata :: (a -> L.ByteString) -> (a -> L.ByteString) -> a -> Metadatas
aToMetadata :: (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
  {-"Creation Time" -> strValue Creation-}
  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 -> 
    Keys Value -> Value -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton
      (String -> Keys Value
Met.Unknown (String -> Keys Value) -> String -> Keys Value
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
other)
      (String -> Value
Met.String (String -> Value) -> (ByteString -> String) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L.unpack (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ a -> ByteString
pdata a
ptext)
  where
    strValue :: Keys String -> Metadatas
strValue Keys String
k = Keys String -> String -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys String
k (String -> Metadatas)
-> (ByteString -> String) -> ByteString -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L.unpack (ByteString -> Metadatas) -> ByteString -> Metadatas
forall a b. (a -> b) -> a -> b
$ a -> ByteString
pdata a
ptext

textToMetadata :: PngText -> Metadatas
textToMetadata :: PngText -> Metadatas
textToMetadata = (PngText -> ByteString)
-> (PngText -> ByteString) -> PngText -> Metadatas
forall a. (a -> ByteString) -> (a -> ByteString) -> a -> Metadatas
aToMetadata PngText -> ByteString
pngKeyword PngText -> ByteString
pngData

ztxtToMetadata :: PngZText -> Metadatas
ztxtToMetadata :: PngZText -> Metadatas
ztxtToMetadata = (PngZText -> ByteString)
-> (PngZText -> ByteString) -> PngZText -> Metadatas
forall a. (a -> ByteString) -> (a -> ByteString) -> a -> Metadatas
aToMetadata PngZText -> ByteString
pngZKeyword PngZText -> ByteString
pngZData

getTexts :: [L.ByteString] -> Metadatas
getTexts :: [ByteString] -> Metadatas
getTexts = (ByteString -> Metadatas) -> [ByteString] -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((PngText -> Metadatas) -> Either String PngText -> Metadatas
forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngText -> Metadatas
textToMetadata (Either String PngText -> Metadatas)
-> (ByteString -> Either String PngText) -> ByteString -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get PngText -> ByteString -> Either String PngText
forall a. Get a -> ByteString -> Either String a
runGet Get PngText
forall t. Binary t => Get t
get)

getZTexts :: [L.ByteString] -> Metadatas
getZTexts :: [ByteString] -> Metadatas
getZTexts = (ByteString -> Metadatas) -> [ByteString] -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((PngZText -> Metadatas) -> Either String PngZText -> Metadatas
forall m a e. Monoid m => (a -> m) -> Either e a -> m
eitherFoldMap PngZText -> Metadatas
ztxtToMetadata (Either String PngZText -> Metadatas)
-> (ByteString -> Either String PngZText)
-> ByteString
-> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get PngZText -> ByteString -> Either String PngZText
forall a. Get a -> ByteString -> Either String a
runGet Get PngZText
forall t. Binary t => Get t
get)

extractMetadatas :: PngRawImage -> Metadatas
extractMetadatas :: PngRawImage -> Metadatas
extractMetadatas PngRawImage
img = [ByteString] -> Metadatas
getDpis (ByteString -> [ByteString]
chunksOf ByteString
pHYsSignature)
                    Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Metadatas
getGamma (ByteString -> [ByteString]
chunksOf ByteString
gammaSignature)
                    Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Metadatas
getTexts (ByteString -> [ByteString]
chunksOf ByteString
tEXtSignature)
                    Metadatas -> Metadatas -> Metadatas
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 = [PngRawChunk] -> Maybe [PngRawChunk] -> [PngRawChunk]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [PngRawChunk] -> [PngRawChunk])
-> Maybe [PngRawChunk] -> [PngRawChunk]
forall a b. (a -> b) -> a -> b
$ do
  Word
dx <- Keys Word -> Metadatas -> Maybe Word
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
Met.DpiX Metadatas
metas
  Word
dy <- Keys Word -> Metadatas -> Maybe Word
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
Met.DpiY Metadatas
metas
  let to :: Word -> Word32
to = Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word32) -> (Word -> Word) -> Word -> Word32
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
  [PngRawChunk] -> Maybe [PngRawChunk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
pHYsSignature (ByteString -> PngRawChunk) -> ByteString -> PngRawChunk
forall a b. (a -> b) -> a -> b
$ PngPhysicalDimension -> ByteString
forall a. Binary a => a -> ByteString
encode PngPhysicalDimension
dim]

encodeSingleMetadata :: Metadatas -> [PngRawChunk]
encodeSingleMetadata :: Metadatas -> [PngRawChunk]
encodeSingleMetadata = (Elem Keys -> [PngRawChunk]) -> Metadatas -> [PngRawChunk]
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
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.DpiX :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.DpiY :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.Width :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.Height :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.Format :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.Gamma       :=> a
g ->
      PngRawChunk -> [PngRawChunk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PngRawChunk -> [PngRawChunk]) -> PngRawChunk -> [PngRawChunk]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
gammaSignature (ByteString -> PngRawChunk)
-> (PngGamma -> ByteString) -> PngGamma -> PngRawChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngGamma -> ByteString
forall a. Binary a => a -> ByteString
encode (PngGamma -> PngRawChunk) -> PngGamma -> PngRawChunk
forall a b. (a -> b) -> a -> b
$ Double -> PngGamma
PngGamma a
Double
g
    Keys a
Met.ColorSpace  :=> a
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty
    Keys a
Met.Title       :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Title" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Description :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Description" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Author      :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Author" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Copyright   :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Copyright" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Software    :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Software" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Comment     :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Comment" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Disclaimer  :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Disclaimer" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Source      :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Source" (String -> ByteString
L.pack a
String
tx)
    Keys a
Met.Warning     :=> a
tx -> ByteString -> ByteString -> [PngRawChunk]
forall (f :: * -> *).
Applicative f =>
ByteString -> ByteString -> f PngRawChunk
txt ByteString
"Warning" (String -> ByteString
L.pack a
String
tx)
    Met.Unknown String
k   :=> Met.String tx -> ByteString -> ByteString -> [PngRawChunk]
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
_ -> [PngRawChunk]
forall a. Monoid a => a
mempty

  txt :: ByteString -> ByteString -> f PngRawChunk
txt ByteString
k ByteString
c = PngRawChunk -> f PngRawChunk
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PngRawChunk -> f PngRawChunk)
-> (PngText -> PngRawChunk) -> PngText -> f PngRawChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
tEXtSignature (ByteString -> PngRawChunk)
-> (PngText -> ByteString) -> PngText -> PngRawChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngText -> ByteString
forall a. Binary a => a -> ByteString
encode (PngText -> f PngRawChunk) -> PngText -> f PngRawChunk
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 [PngRawChunk] -> [PngRawChunk] -> [PngRawChunk]
forall a. Semigroup a => a -> a -> a
<> Metadatas -> [PngRawChunk]
encodeSingleMetadata Metadatas
m