{-# LANGUAGE CPP #-} module Codec.Picture.Tiff.Internal.Metadata ( extractTiffMetadata , encodeTiffStringMetadata , exifOffsetIfd ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) import Data.Foldable( foldMap ) import Control.Applicative( (<$>) ) #endif import Data.Bits( unsafeShiftL, (.|.) ) import Data.Foldable( find ) import Data.List( sortBy ) import Data.Function( on ) import qualified Data.Foldable as F import Data.Monoid( (<>) ) import Codec.Picture.Metadata( Metadatas ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Codec.Picture.Metadata as Met import qualified Data.Vector.Generic as V import Codec.Picture.Tiff.Internal.Types import Codec.Picture.Metadata( extractExifMetas ) import Codec.Picture.Metadata.Exif exifOffsetIfd :: ImageFileDirectory exifOffsetIfd = ImageFileDirectory { ifdIdentifier = TagExifOffset , ifdCount = 1 , ifdType = TypeLong , ifdOffset = 0 , ifdExtended = ExifNone } typeOfData :: ExifData -> IfdType typeOfData d = case d of ExifNone -> error "Impossible - typeOfData : ExifNone" ExifIFD _exifs -> error "Impossible - typeOfData : ExifIFD" ExifLong _l -> TypeLong ExifLongs _l -> TypeLong ExifShort _s -> TypeShort ExifShorts _s -> TypeShort ExifString _str -> TypeAscii ExifUndefined _undef -> TypeUndefined ExifRational _r1 _r2 -> TypeRational ExifSignedRational _sr1 _sr2 -> TypeSignedRational makeIfd :: ExifTag -> ExifData -> ImageFileDirectory makeIfd t (ExifShort v) = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeShort , ifdCount = 1 , ifdOffset = fromIntegral v `unsafeShiftL` 16 , ifdExtended = ExifNone } makeIfd t (ExifLong v) = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeLong , ifdCount = 1 , ifdOffset = fromIntegral v , ifdExtended = ExifNone } makeIfd t d@(ExifShorts v) | size == 2 = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeShort , ifdCount = 2 , ifdOffset = combined , ifdExtended = ExifNone } | otherwise = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeShort , ifdCount = size , ifdOffset = 0 , ifdExtended = d } where size = fromIntegral $ F.length v at i = fromIntegral $ v V.! i combined = (at 0 `unsafeShiftL` 16) .|. at 1 makeIfd t d@(ExifLongs v) | size == 1 = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeLong , ifdCount = 1 , ifdOffset = v V.! 0 , ifdExtended = ExifNone } | otherwise = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeLong , ifdCount = size , ifdOffset = 0 , ifdExtended = d } where size = fromIntegral $ F.length v makeIfd t s@(ExifString str) = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeAscii , ifdCount = fromIntegral $ BC.length str , ifdOffset = 0 , ifdExtended = s } makeIfd t s@(ExifUndefined str) | size > 4 = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeUndefined , ifdCount = size , ifdOffset = 0 , ifdExtended = s } | otherwise = ImageFileDirectory { ifdIdentifier = t , ifdType = TypeUndefined , ifdCount = size , ifdOffset = ofs , ifdExtended = ExifNone } where size = fromIntegral $ BC.length str at ix | fromIntegral ix < size = fromIntegral $ B.index str ix `unsafeShiftL` (4 - (8 * ix)) | otherwise = 0 ofs = at 0 .|. at 1 .|. at 2 .|. at 3 makeIfd t d = ImageFileDirectory { ifdIdentifier = t , ifdType = typeOfData d , ifdCount = 1 , ifdOffset = 0 , ifdExtended = d } encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory] encodeTiffStringMetadata metas = sortBy (compare `on` word16OfTag . ifdIdentifier) $ allTags where keyStr tag k = case Met.lookup k metas of Nothing -> mempty Just v -> pure . makeIfd tag . ExifString $ BC.pack v allTags = copyright <> artist <> title <> description <> software <> allPureExif allPureExif = fmap (uncurry makeIfd) $ extractExifMetas metas copyright = keyStr TagCopyright Met.Copyright artist = keyStr TagArtist Met.Author title = keyStr TagDocumentName Met.Title description = keyStr TagImageDescription Met.Description software = keyStr TagSoftware Met.Software extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where strMeta k = Met.singleton k . BC.unpack exif ifd = Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd inserter acc (k, v) = Met.insert (Met.Exif k) v acc exifShort ifd = Met.singleton (Met.Exif $ ifdIdentifier ifd) . (ExifShort . fromIntegral) $ ifdOffset ifd go :: ImageFileDirectory -> Metadatas go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of (TagArtist, ExifString v) -> strMeta Met.Author v (TagBitsPerSample, _) -> mempty (TagColorMap, _) -> mempty (TagCompression, _) -> mempty (TagCopyright, ExifString v) -> strMeta Met.Copyright v (TagDocumentName, ExifString v) -> strMeta Met.Title v (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst (TagImageDescription, ExifString v) -> strMeta Met.Description v (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd (TagJPEGACTables, _) -> mempty (TagJPEGDCTables, _) -> mempty (TagJPEGInterchangeFormat, _) -> mempty (TagJPEGInterchangeFormatLength, _) -> mempty (TagJPEGLosslessPredictors, _) -> mempty (TagJPEGPointTransforms, _) -> mempty (TagJPEGQTables, _) -> mempty (TagJPEGRestartInterval, _) -> mempty (TagJpegProc, _) -> mempty (TagModel, v) -> Met.singleton (Met.Exif TagModel) v (TagMake, v) -> Met.singleton (Met.Exif TagMake) v (TagOrientation, _) -> exifShort ifd (TagResolutionUnit, _) -> mempty (TagRowPerStrip, _) -> mempty (TagSamplesPerPixel, _) -> mempty (TagSoftware, ExifString v) -> strMeta Met.Software v (TagStripByteCounts, _) -> mempty (TagStripOffsets, _) -> mempty (TagTileByteCount, _) -> mempty (TagTileLength, _) -> mempty (TagTileOffset, _) -> mempty (TagTileWidth, _) -> mempty (TagUnknown _, _) -> exif ifd (TagXResolution, _) -> mempty (TagYCbCrCoeff, _) -> mempty (TagYCbCrPositioning, _) -> mempty (TagYCbCrSubsampling, _) -> mempty (TagYResolution, _) -> mempty _ -> 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