module Codec.Picture.Tiff.Metadata( extractTiffMetadata ) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
import Data.Foldable( foldMap )
import Control.Applicative( (<$>) )
#endif
import Data.Foldable( find )
import qualified Data.Foldable as F
import Data.Monoid( (<>) )
import Codec.Picture.Metadata( Metadatas )
import qualified Data.ByteString.Char8 as B
import qualified Codec.Picture.Metadata as Met
import Codec.Picture.Tiff.Types
import Codec.Picture.Metadata.Exif
extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where
strMeta k = Met.singleton k . B.unpack
exif ifd =
Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd
inserter acc (k, v) = Met.insert (Met.Exif k) v acc
go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of
(TagUnknown _, _) -> exif ifd
(TagCopyright, ExifString v) -> strMeta Met.Copyright v
(TagArtist, ExifString v) -> strMeta Met.Author v
(TagDocumentName, ExifString v) -> strMeta Met.Title v
(TagSoftware, ExifString v) -> strMeta Met.Software v
(TagImageDescription, ExifString v) -> strMeta Met.Description v
(TagCompression, _) -> mempty
(TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd
(TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd
(TagXResolution, _) -> mempty
(TagYResolution, _) -> mempty
(TagResolutionUnit, _) -> mempty
(TagRowPerStrip, _) -> mempty
(TagStripByteCounts, _) -> mempty
(TagStripOffsets, _) -> mempty
(TagBitsPerSample, _) -> mempty
(TagColorMap, _) -> mempty
(TagTileWidth, _) -> mempty
(TagTileLength, _) -> mempty
(TagTileOffset, _) -> mempty
(TagTileByteCount, _) -> mempty
(TagSamplesPerPixel, _) -> mempty
(TagYCbCrCoeff, _) -> mempty
(TagYCbCrSubsampling, _) -> mempty
(TagYCbCrPositioning, _) -> mempty
(TagJpegProc, _) -> mempty
(TagJPEGInterchangeFormat, _) -> mempty
(TagJPEGInterchangeFormatLength, _) -> mempty
(TagJPEGRestartInterval, _) -> mempty
(TagJPEGLosslessPredictors, _) -> mempty
(TagJPEGPointTransforms, _) -> mempty
(TagJPEGQTables, _) -> mempty
(TagJPEGDCTables, _) -> mempty
(TagJPEGACTables, _) -> mempty
(TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst
_ -> mempty
byTag :: ExifTag -> ImageFileDirectory -> Bool
byTag t ifd = ifdIdentifier ifd == t
data TiffResolutionUnit
= ResolutionUnitUnknown
| ResolutionUnitInch
| ResolutionUnitCentimeter
unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of
(TypeShort, 1) -> ResolutionUnitUnknown
(TypeShort, 2) -> ResolutionUnitInch
(TypeShort, 3) -> ResolutionUnitCentimeter
_ -> ResolutionUnitUnknown
extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata lst = go where
go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of
Nothing -> mempty
Just ResolutionUnitUnknown -> mempty
Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty
Just ResolutionUnitInch -> findDpis id mempty
findDpis toDpi =
findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi
findDpi k tag toDpi metas = case find (byTag tag) lst of
Nothing -> metas
Just ImageFileDirectory { ifdExtended = ExifRational num den } ->
Met.insert k (toDpi . fromIntegral $ num `div` den) metas
Just _ -> metas
extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst