{-# 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 -- compression type

    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
  {-"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 -> 
    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
extractMetadatas :: PngRawImage -> Metadatas
extractMetadatas 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