{-# 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
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
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
exifOffsetIfd = ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
TagExifOffset
  , ifdCount :: Word32
ifdCount = Word32
1
  , ifdType :: IfdType
ifdType = IfdType
TypeLong
  , ifdOffset :: Word32
ifdOffset = Word32
0
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }

typeOfData :: ExifData -> IfdType
typeOfData :: ExifData -> IfdType
typeOfData ExifData
d = case ExifData
d of
  ExifData
ExifNone -> [Char] -> IfdType
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible - typeOfData : ExifNone"
  ExifIFD [(ExifTag, ExifData)]
_exifs -> [Char] -> IfdType
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible - typeOfData : ExifIFD"
  ExifLong Word32
_l -> IfdType
TypeLong
  ExifLongs Vector Word32
_l -> IfdType
TypeLong
  ExifShort Word16
_s -> IfdType
TypeShort
  ExifShorts Vector Word16
_s -> IfdType
TypeShort
  ExifString ByteString
_str -> IfdType
TypeAscii
  ExifUndefined ByteString
_undef -> IfdType
TypeUndefined
  ExifRational Word32
_r1 Word32
_r2 -> IfdType
TypeRational
  ExifSignedRational Int32
_sr1 Int32
_sr2 -> IfdType
TypeSignedRational

makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
makeIfd ExifTag
t (ExifShort Word16
v) = ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = IfdType
TypeShort
  , ifdCount :: Word32
ifdCount = Word32
1
  , ifdOffset :: Word32
ifdOffset = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }
makeIfd ExifTag
t (ExifLong Word32
v) = ImageFileDirectory 
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = IfdType
TypeLong
  , ifdCount :: Word32
ifdCount = Word32
1
  , ifdOffset :: Word32
ifdOffset = Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }
makeIfd ExifTag
t d :: ExifData
d@(ExifShorts Vector Word16
v)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
2 = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeShort
    , ifdCount :: Word32
ifdCount = Word32
2
    , ifdOffset :: Word32
ifdOffset = Word32
combined
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  | Bool
otherwise = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeShort
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = Word32
0
    , ifdExtended :: ExifData
ifdExtended = ExifData
d
    }
  where
    size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Word16 -> Int
forall a. Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Vector Word16
v
    at :: Int -> b
at Int
i = Word16 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> b) -> Word16 -> b
forall a b. (a -> b) -> a -> b
$ Vector Word16
v Vector Word16 -> Int -> Word16
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
V.! Int
i
    combined :: Word32
combined = (Int -> Word32
forall {b}. Num b => Int -> b
at Int
0  Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall {b}. Num b => Int -> b
at Int
1
makeIfd ExifTag
t d :: ExifData
d@(ExifLongs Vector Word32
v)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeLong
    , ifdCount :: Word32
ifdCount = Word32
1
    , ifdOffset :: Word32
ifdOffset = Vector Word32
v Vector Word32 -> Int -> Word32
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
V.! Int
0
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  | Bool
otherwise = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeLong
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = Word32
0
    , ifdExtended :: ExifData
ifdExtended = ExifData
d
    }
  where size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Word32 -> Int
forall a. Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Vector Word32
v
makeIfd ExifTag
t s :: ExifData
s@(ExifString ByteString
str) = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeAscii
    , ifdCount :: Word32
ifdCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BC.length ByteString
str
    , ifdOffset :: Word32
ifdOffset = Word32
0
    , ifdExtended :: ExifData
ifdExtended = ExifData
s
    }
makeIfd ExifTag
t s :: ExifData
s@(ExifUndefined ByteString
str)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
4 = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeUndefined
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = Word32
0
    , ifdExtended :: ExifData
ifdExtended = ExifData
s
    }
  | Bool
otherwise = ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeUndefined
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = Word32
ofs
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  where
    size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BC.length ByteString
str
    at :: Int -> b
at Int
ix
      | Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
size = Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> b) -> Word8 -> b
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
str Int
ix Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ix))
      | Bool
otherwise = b
0
    ofs :: Word32
ofs = Int -> Word32
forall {b}. Num b => Int -> b
at Int
0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall {b}. Num b => Int -> b
at Int
1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall {b}. Num b => Int -> b
at Int
2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall {b}. Num b => Int -> b
at Int
3
makeIfd ExifTag
t ExifData
d = ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = ExifData -> IfdType
typeOfData ExifData
d
  , ifdCount :: Word32
ifdCount = Word32
1
  , ifdOffset :: Word32
ifdOffset = Word32
0
  , ifdExtended :: ExifData
ifdExtended = ExifData
d
  }

encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata Metadatas
metas = (ImageFileDirectory -> ImageFileDirectory -> Ordering)
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Word16 -> Word16 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word16 -> Word16 -> Ordering)
-> (ImageFileDirectory -> Word16)
-> ImageFileDirectory
-> ImageFileDirectory
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ExifTag -> Word16
word16OfTag (ExifTag -> Word16)
-> (ImageFileDirectory -> ExifTag) -> ImageFileDirectory -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImageFileDirectory -> ExifTag
ifdIdentifier) ([ImageFileDirectory] -> [ImageFileDirectory])
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a b. (a -> b) -> a -> b
$ [ImageFileDirectory]
allTags where
  keyStr :: ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
tag Keys [Char]
k = case Keys [Char] -> Metadatas -> Maybe [Char]
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys [Char]
k Metadatas
metas of
    Maybe [Char]
Nothing -> f ImageFileDirectory
forall a. Monoid a => a
mempty
    Just [Char]
v -> ImageFileDirectory -> f ImageFileDirectory
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImageFileDirectory -> f ImageFileDirectory)
-> (ByteString -> ImageFileDirectory)
-> ByteString
-> f ImageFileDirectory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExifTag -> ExifData -> ImageFileDirectory
makeIfd ExifTag
tag (ExifData -> ImageFileDirectory)
-> (ByteString -> ExifData) -> ByteString -> ImageFileDirectory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ExifData
ExifString (ByteString -> f ImageFileDirectory)
-> ByteString -> f ImageFileDirectory
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
v
  allTags :: [ImageFileDirectory]
allTags = [ImageFileDirectory]
copyright [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
artist [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
title [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
description [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
software [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
allPureExif

  allPureExif :: [ImageFileDirectory]
allPureExif = ((ExifTag, ExifData) -> ImageFileDirectory)
-> [(ExifTag, ExifData)] -> [ImageFileDirectory]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ExifTag -> ExifData -> ImageFileDirectory)
-> (ExifTag, ExifData) -> ImageFileDirectory
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ExifTag -> ExifData -> ImageFileDirectory
makeIfd) ([(ExifTag, ExifData)] -> [ImageFileDirectory])
-> [(ExifTag, ExifData)] -> [ImageFileDirectory]
forall a b. (a -> b) -> a -> b
$ Metadatas -> [(ExifTag, ExifData)]
extractExifMetas Metadatas
metas

  copyright :: [ImageFileDirectory]
copyright = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall {f :: * -> *}.
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagCopyright Keys [Char]
Met.Copyright
  artist :: [ImageFileDirectory]
artist = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall {f :: * -> *}.
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagArtist Keys [Char]
Met.Author
  title :: [ImageFileDirectory]
title = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall {f :: * -> *}.
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagDocumentName Keys [Char]
Met.Title
  description :: [ImageFileDirectory]
description = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall {f :: * -> *}.
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagImageDescription Keys [Char]
Met.Description
  software :: [ImageFileDirectory]
software = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall {f :: * -> *}.
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagSoftware Keys [Char]
Met.Software

extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata = Keys SourceFormat -> SourceFormat -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys SourceFormat
Met.Format SourceFormat
Met.SourceTiff (Metadatas -> Metadatas)
-> ([ImageFileDirectory] -> Metadatas)
-> [ImageFileDirectory]
-> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImageFileDirectory -> Metadatas)
-> [ImageFileDirectory] -> Metadatas
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ImageFileDirectory -> Metadatas
go where
  strMeta :: Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
k = Keys [Char] -> [Char] -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys [Char]
k ([Char] -> Metadatas)
-> (ByteString -> [Char]) -> ByteString -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BC.unpack
  exif :: ImageFileDirectory -> Metadatas
exif ImageFileDirectory
ifd =
    Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif (ExifTag -> Keys ExifData) -> ExifTag -> Keys ExifData
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd) (ExifData -> Metadatas) -> ExifData -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
ifd
  inserter :: Metadatas -> (ExifTag, ExifData) -> Metadatas
inserter Metadatas
acc (ExifTag
k, ExifData
v) = Keys ExifData -> ExifData -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert (ExifTag -> Keys ExifData
Met.Exif ExifTag
k) ExifData
v Metadatas
acc
  exifShort :: ImageFileDirectory -> Metadatas
exifShort ImageFileDirectory
ifd =
    Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif (ExifTag -> Keys ExifData) -> ExifTag -> Keys ExifData
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd) (ExifData -> Metadatas)
-> (Word32 -> ExifData) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> ExifData
ExifShort (Word16 -> ExifData) -> (Word32 -> Word16) -> Word32 -> ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd

  go :: ImageFileDirectory -> Metadatas
  go :: ImageFileDirectory -> Metadatas
go ImageFileDirectory
ifd = case (ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd, ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
ifd) of
    (ExifTag
TagArtist, ExifString ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Author ByteString
v
    (ExifTag
TagBitsPerSample, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagColorMap, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagCompression, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagCopyright, ExifString ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Copyright ByteString
v
    (ExifTag
TagDocumentName, ExifString ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Title ByteString
v
    (ExifTag
TagExifOffset, ExifIFD [(ExifTag, ExifData)]
lst) -> (Metadatas -> (ExifTag, ExifData) -> Metadatas)
-> Metadatas -> [(ExifTag, ExifData)] -> Metadatas
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Metadatas -> (ExifTag, ExifData) -> Metadatas
inserter Metadatas
forall a. Monoid a => a
mempty [(ExifTag, ExifData)]
lst
    (ExifTag
TagImageDescription, ExifString ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Description ByteString
v
    (ExifTag
TagImageLength, ExifData
_) -> Keys Word -> Word -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.Height (Word -> Metadatas) -> (Word32 -> Word) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd
    (ExifTag
TagImageWidth, ExifData
_) -> Keys Word -> Word -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.Width (Word -> Metadatas) -> (Word32 -> Word) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd
    (ExifTag
TagJPEGACTables, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGDCTables, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGInterchangeFormat, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGInterchangeFormatLength, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGLosslessPredictors, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGPointTransforms, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGQTables, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJPEGRestartInterval, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagJpegProc, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagModel, ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif ExifTag
TagModel) ExifData
v
    (ExifTag
TagMake, ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif ExifTag
TagMake) ExifData
v
    (ExifTag
TagOrientation, ExifData
_) -> ImageFileDirectory -> Metadatas
exifShort ImageFileDirectory
ifd
    (ExifTag
TagResolutionUnit, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagRowPerStrip, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagSamplesPerPixel, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagSoftware, ExifString ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Software ByteString
v
    (ExifTag
TagStripByteCounts, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagStripOffsets, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagTileByteCount, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagTileLength, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagTileOffset, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagTileWidth, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (TagUnknown Word16
_, ExifData
_) -> ImageFileDirectory -> Metadatas
exif ImageFileDirectory
ifd
    (ExifTag
TagXResolution, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagYCbCrCoeff, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagYCbCrPositioning, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagYCbCrSubsampling, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag
TagYResolution, ExifData
_) -> Metadatas
forall a. Monoid a => a
mempty
    (ExifTag, ExifData)
_ -> Metadatas
forall a. Monoid a => a
mempty

byTag :: ExifTag -> ImageFileDirectory -> Bool
byTag :: ExifTag -> ImageFileDirectory -> Bool
byTag ExifTag
t ImageFileDirectory
ifd = ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
t

data TiffResolutionUnit
  = ResolutionUnitUnknown
  | ResolutionUnitInch
  | ResolutionUnitCentimeter

unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
unitOfIfd ImageFileDirectory
ifd = case (ImageFileDirectory -> IfdType
ifdType ImageFileDirectory
ifd, ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd) of
  (IfdType
TypeShort, Word32
1) -> TiffResolutionUnit
ResolutionUnitUnknown
  (IfdType
TypeShort, Word32
2) -> TiffResolutionUnit
ResolutionUnitInch
  (IfdType
TypeShort, Word32
3) -> TiffResolutionUnit
ResolutionUnitCentimeter
  (IfdType, Word32)
_ -> TiffResolutionUnit
ResolutionUnitUnknown

extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata [ImageFileDirectory]
lst = Metadatas
go where
  go :: Metadatas
go = case ImageFileDirectory -> TiffResolutionUnit
unitOfIfd (ImageFileDirectory -> TiffResolutionUnit)
-> Maybe ImageFileDirectory -> Maybe TiffResolutionUnit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ImageFileDirectory -> Bool)
-> [ImageFileDirectory] -> Maybe ImageFileDirectory
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ExifTag -> ImageFileDirectory -> Bool
byTag ExifTag
TagResolutionUnit) [ImageFileDirectory]
lst of
    Maybe TiffResolutionUnit
Nothing -> Metadatas
forall a. Monoid a => a
mempty
    Just TiffResolutionUnit
ResolutionUnitUnknown -> Metadatas
forall a. Monoid a => a
mempty
    Just TiffResolutionUnit
ResolutionUnitCentimeter -> (Word -> Word) -> Metadatas -> Metadatas
forall {b}. Num b => (b -> Word) -> Metadatas -> Metadatas
findDpis Word -> Word
Met.dotsPerCentiMeterToDotPerInch Metadatas
forall a. Monoid a => a
mempty
    Just TiffResolutionUnit
ResolutionUnitInch -> (Word -> Word) -> Metadatas -> Metadatas
forall {b}. Num b => (b -> Word) -> Metadatas -> Metadatas
findDpis Word -> Word
forall a. a -> a
id Metadatas
forall a. Monoid a => a
mempty

  findDpis :: (b -> Word) -> Metadatas -> Metadatas
findDpis b -> Word
toDpi =
     Keys Word -> ExifTag -> (b -> Word) -> Metadatas -> Metadatas
forall {a} {b}.
(Show a, NFData a, Num b) =>
Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi Keys Word
Met.DpiX ExifTag
TagXResolution b -> Word
toDpi (Metadatas -> Metadatas)
-> (Metadatas -> Metadatas) -> Metadatas -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keys Word -> ExifTag -> (b -> Word) -> Metadatas -> Metadatas
forall {a} {b}.
(Show a, NFData a, Num b) =>
Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi Keys Word
Met.DpiY ExifTag
TagYResolution b -> Word
toDpi

  findDpi :: Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi Keys a
k ExifTag
tag b -> a
toDpi Metadatas
metas = case (ImageFileDirectory -> Bool)
-> [ImageFileDirectory] -> Maybe ImageFileDirectory
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ExifTag -> ImageFileDirectory -> Bool
byTag ExifTag
tag) [ImageFileDirectory]
lst of
    Maybe ImageFileDirectory
Nothing -> Metadatas
metas
    Just ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifRational Word32
num Word32
den } ->
      Keys a -> a -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys a
k (b -> a
toDpi (b -> a) -> (Word32 -> b) -> Word32 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> a) -> Word32 -> a
forall a b. (a -> b) -> a -> b
$ Word32
num Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
den) Metadatas
metas
    Just ImageFileDirectory
_ -> Metadatas
metas

extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffMetadata [ImageFileDirectory]
lst = [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata [ImageFileDirectory]
lst Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata [ImageFileDirectory]
lst