content: {-# 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 = foldMap
  #endif
  
  getGamma :: [L.ByteString] -> Metadatas
  getGamma [] = mempty
  getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g
    where
      unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma)
  
  getDpis :: [L.ByteString] -> Metadatas
  getDpis [] = mempty
  getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b
    where
      unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } =
        Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72
      unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } =
        Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy
          where
            dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy
            dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy
  
  data PngText = PngText
    { pngKeyword :: !L.ByteString
    , pngData    :: !L.ByteString
    }
    deriving Show
  
  instance Binary PngText where
    get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes
    put (PngText kw pdata) = do
      putLazyByteString kw
      putWord8 0
      putLazyByteString pdata
  
  data PngZText = PngZText
    { pngZKeyword :: !L.ByteString
    , pngZData    :: !L.ByteString
    }
    deriving Show
  
  instance Binary PngZText where
    get = PngZText <$> getLazyByteStringNul <* getCompressionType <*> (Z.decompress <$> getRemainingLazyBytes)
      where
        getCompressionType = do
          0 <- getWord8
          return ()
    put (PngZText kw pdata) = do
      putLazyByteString kw
      putWord8 0
      putWord8 0 -- compression type
      putLazyByteString (Z.compress pdata)
  
  aToMetadata :: (a -> L.ByteString) -> (a -> L.ByteString) -> a -> Metadatas
  aToMetadata pkeyword pdata ptext = case pkeyword ptext of
    "Title" -> strValue Met.Title
    "Author" -> strValue Met.Author
    "Description" -> strValue Met.Description
    "Copyright" -> strValue Met.Copyright
    {-"Creation Time" -> strValue Creation-}
    "Software" -> strValue Met.Software
    "Disclaimer" -> strValue Met.Disclaimer
    "Warning" -> strValue Met.Warning
    "Source" -> strValue Met.Source
    "Comment" -> strValue Met.Comment
    other -> 
      Met.singleton
        (Met.Unknown $ L.unpack other)
        (Met.String . L.unpack $ pdata ptext)
    where
      strValue k = Met.singleton k . L.unpack $ pdata ptext
  
  textToMetadata :: PngText -> Metadatas
  textToMetadata = aToMetadata pngKeyword pngData
  
  ztxtToMetadata :: PngZText -> Metadatas
  ztxtToMetadata = aToMetadata pngZKeyword pngZData
  
  getTexts :: [L.ByteString] -> Metadatas
  getTexts = foldMap (eitherFoldMap textToMetadata . runGet get)
  
  getZTexts :: [L.ByteString] -> Metadatas
  getZTexts = foldMap (eitherFoldMap ztxtToMetadata . runGet get)
  
  extractMetadatas :: PngRawImage -> Metadatas
  extractMetadatas img = getDpis (chunksOf pHYsSignature)
                      <> getGamma (chunksOf gammaSignature)
                      <> getTexts (chunksOf tEXtSignature)
                      <> getZTexts (chunksOf zTXtSignature)
    where
      chunksOf = chunksWithSig img
  
  encodePhysicalMetadata :: Metadatas -> [PngRawChunk]
  encodePhysicalMetadata metas = fromMaybe [] $ do
    dx <- Met.lookup Met.DpiX metas
    dy <- Met.lookup Met.DpiY metas
    let to = fromIntegral . Met.dotPerInchToDotsPerMeter
        dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter
    pure [mkRawChunk pHYsSignature $ encode dim]
  
  encodeSingleMetadata :: Metadatas -> [PngRawChunk]
  encodeSingleMetadata = Met.foldMap go where
    go :: Elem Met.Keys -> [PngRawChunk]
    go v = case v of
      Met.Exif _ :=> _ -> mempty
      Met.DpiX :=> _ -> mempty
      Met.DpiY :=> _ -> mempty
      Met.Width :=> _ -> mempty
      Met.Height :=> _ -> mempty
      Met.Format :=> _ -> mempty
      Met.Gamma       :=> g ->
        pure $ mkRawChunk gammaSignature . encode $ PngGamma g
      Met.ColorSpace  :=> _ -> mempty
      Met.Title       :=> tx -> txt "Title" (L.pack tx)
      Met.Description :=> tx -> txt "Description" (L.pack tx)
      Met.Author      :=> tx -> txt "Author" (L.pack tx)
      Met.Copyright   :=> tx -> txt "Copyright" (L.pack tx)
      Met.Software    :=> tx -> txt "Software" (L.pack tx)
      Met.Comment     :=> tx -> txt "Comment" (L.pack tx)
      Met.Disclaimer  :=> tx -> txt "Disclaimer" (L.pack tx)
      Met.Source      :=> tx -> txt "Source" (L.pack tx)
      Met.Warning     :=> tx -> txt "Warning" (L.pack tx)
      Met.Unknown k   :=> Met.String tx -> txt (L.pack k) (L.pack tx)
      Met.Unknown _   :=> _ -> mempty
  
    txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c
  
  encodeMetadatas :: Metadatas -> [PngRawChunk]
  encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m
  
  