diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.8.3 +Version: 3.2.9 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.8.3 + Tag: v3.2.9 Flag Mmap Description: Enable the file loading via mmap (memory map) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ ![Juicy logo](https://raw.github.com/Twinside/Juicy.Pixels/master/docimages/juicy.png) -[![Build Status](https://travis-ci.org/Twinside/Juicy.Pixels.png?branch=master)](https://travis-ci.org/Twinside/Juicy.Pixels) [![Hackage](https://img.shields.io/hackage/v/JuicyPixels.svg)](http://hackage.haskell.org/package/JuicyPixels) Juicy.Pixels @@ -72,7 +71,8 @@ * Metadata: - Reading and writing DpiX & DpiY from JFIF header. - - Reading EXIF metadata. + - Reading & writing EXIF metadata. No GPS information + can be written now. - Gif (.gif) * Reading single image & animated Gif image, handles interlaced images. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,7 +1,14 @@ Change log ========== -v3.2.9.3 August 2017 +v3.2.9 November 2017 +---------------------- + + * Fix: Adding correct import of Exif Flash for Jpeg (thanks to Alexander Kjeldaas) + * Feature: Jpg Exif writing + + +v3.2.8.3 August 2017 ------------------ * Fix: Jpeg loading of extended sequential jpg, not sure of all diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -999,8 +999,12 @@ encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where !w = imageWidth img !h = imageHeight img + !exifMeta = case encodeTiffStringMetadata metas of + [] -> [] + lst -> [JpgExif lst] finalImage = JpgImage $ encodeMetadatas metas ++ + exifMeta ++ additionalBlocks img ++ [ JpgQuantTable $ quantTableSpec img (fromIntegral quality) , JpgScans JpgBaselineDCTHuffman hdr diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs --- a/src/Codec/Picture/Jpg/Types.hs +++ b/src/Codec/Picture/Jpg/Types.hs @@ -33,6 +33,8 @@ import Control.Monad( when, replicateM, forM, forM_, unless ) import Control.Monad.ST( ST ) import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) +import Data.List( partition ) +import Data.Monoid( (<>) ) import Foreign.Storable ( Storable ) import Data.Vector.Unboxed( (!) ) import qualified Data.Vector as V @@ -60,11 +62,14 @@ , putWord16be , putLazyByteString , putByteString + , runPut ) import Codec.Picture.InternalHelper import Codec.Picture.Jpg.DefaultTable import Codec.Picture.Tiff.Types +import Codec.Picture.Tiff.Metadata( exifOffsetIfd ) +import Codec.Picture.Metadata.Exif {-import Debug.Trace-} import Text.Printf @@ -431,9 +436,7 @@ put (JpgAppSegment 14) >> putWord16be 14 >> put adobe putFrame (JpgJFIF jfif) = put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif -putFrame (JpgExif _exif) = - return () -- TODO - {-put (JpgAppSegment 0) >> put exif-} +putFrame (JpgExif exif) = putExif exif putFrame (JpgAppFrame appCode str) = put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str putFrame (JpgExtension appCode str) = @@ -495,7 +498,28 @@ tiff = B.drop (B.length exifHeader) str go = case runGetStrict (getP tiff) tiff of Left _err -> lst - Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst + Right (_hdr :: TiffHeader, []) -> lst + Right (_hdr :: TiffHeader, ifds : _) -> JpgExif ifds : lst + +putExif :: [ImageFileDirectory] -> Put +putExif ifds = putAll where + hdr = TiffHeader + { hdrEndianness = EndianBig + , hdrOffset = 8 + } + + ifdList = case partition (isInIFD0 . ifdIdentifier) ifds of + (ifd0, []) -> [ifd0] + (ifd0, ifdExif) -> [ifd0 <> pure exifOffsetIfd, ifdExif] + + exifBlob = runPut $ do + putByteString $ BC.pack "Exif\0\0" + putP BC.empty (hdr, ifdList) + + putAll = do + put (JpgAppSegment 1) + putWord16be . fromIntegral $ L.length exifBlob + 2 + putLazyByteString exifBlob parseFrames :: Get [JpgFrame] parseFrames = do diff --git a/src/Codec/Picture/Metadata.hs b/src/Codec/Picture/Metadata.hs --- a/src/Codec/Picture/Metadata.hs +++ b/src/Codec/Picture/Metadata.hs @@ -1,259 +1,270 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} --- | This module expose a common "metadata" storage for various image --- type. Different format can generate different metadatas, and write --- only a part of them. --- --- Since version 3.2.5 --- -module Codec.Picture.Metadata( -- * Types - Metadatas - , Keys( .. ) - , Value( .. ) - , Elem( .. ) - , SourceFormat( .. ) - - -- * Functions - , Codec.Picture.Metadata.lookup - , empty - , insert - , delete - , singleton - - -- * Folding - , foldl' - , Codec.Picture.Metadata.foldMap - - -- * Helper functions - , mkDpiMetadata - , mkSizeMetadata - , basicMetadata - , simpleMetadata - - -- * Conversion functions - , dotsPerMeterToDotPerInch - , dotPerInchToDotsPerMeter - , dotsPerCentiMeterToDotPerInch - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid, mempty, mappend ) -import Data.Word( Word ) -#endif - - -import Control.DeepSeq( NFData( .. ) ) -import qualified Data.Foldable as F - -import Codec.Picture.Metadata.Exif - -#if MIN_VERSION_base(4,7,0) -import Data.Typeable( (:~:)( Refl ) ) -type Equiv = (:~:) -#else -data Equiv a b where - Refl :: Equiv a a -#endif - --- | Type describing the original file format of the ilfe. -data SourceFormat - = SourceJpeg - | SourceGif - | SourceBitmap - | SourceTiff - | SourcePng - | SourceHDR - | SourceTGA - deriving (Eq, Show) - -instance NFData SourceFormat where - rnf a = a `seq` () - --- | Store various additional information about an image. If --- something is not recognized, it can be stored in an unknown tag. --- --- * 'DpiX' Dot per inch on this x axis. --- --- * 'DpiY' Dot per inch on this y axis. --- --- * 'Width' Image width in pixel. Relying on the metadata for this --- information can avoid the full decompression of the image. --- Ignored for image writing. --- --- * 'Height' Image height in pixels. Relyiung on the metadata for this --- information can void the full decomrpession of the image. --- Ignored for image writing. --- --- * 'Unknown' unlikely to be decoded, but usefull for metadata writing --- --- * 'Exif' Exif tag and associated data. --- -data Keys a where - Gamma :: Keys Double - Format :: Keys SourceFormat - DpiX :: Keys Word - DpiY :: Keys Word - Width :: Keys Word - Height :: Keys Word - Title :: Keys String - Description :: Keys String - Author :: Keys String - Copyright :: Keys String - Software :: Keys String - Comment :: Keys String - Disclaimer :: Keys String - Source :: Keys String - Warning :: Keys String - Exif :: !ExifTag -> Keys ExifData - Unknown :: !String -> Keys Value - -deriving instance Show (Keys a) -deriving instance Eq (Keys a) -{-deriving instance Ord (Keys a)-} - --- | Encode values for unknown information -data Value - = Int !Int - | Double !Double - | String !String - deriving (Eq, Show) - -instance NFData Value where - rnf v = v `seq` () -- everything is strict, so it's OK - --- | Element describing a metadata and it's (typed) associated --- value. -data Elem k = - forall a. (Show a, NFData a) => !(k a) :=> a - -deriving instance Show (Elem Keys) - -instance NFData (Elem Keys) where - rnf (_ :=> v) = rnf v `seq` () - -keyEq :: Keys a -> Keys b -> Maybe (Equiv a b) -keyEq a b = case (a, b) of - (Gamma, Gamma) -> Just Refl - (DpiX, DpiX) -> Just Refl - (DpiY, DpiY) -> Just Refl - (Width, Width) -> Just Refl - (Height, Height) -> Just Refl - (Title, Title) -> Just Refl - (Description, Description) -> Just Refl - (Author, Author) -> Just Refl - (Copyright, Copyright) -> Just Refl - (Software, Software) -> Just Refl - (Comment, Comment) -> Just Refl - (Disclaimer, Disclaimer) -> Just Refl - (Source, Source) -> Just Refl - (Warning, Warning) -> Just Refl - (Format, Format) -> Just Refl - (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl - (Exif t1, Exif t2) | t1 == t2 -> Just Refl - _ -> Nothing - --- | Dependent storage used for metadatas. --- All metadatas of a given kind are unique within --- this container. - -- --- The current data structure is based on list, --- so bad performances can be expected. -newtype Metadatas = Metadatas - { getMetadatas :: [Elem Keys] - } - deriving (Show, NFData) - -instance Monoid Metadatas where - mempty = empty - mappend = union - --- | Right based union -union :: Metadatas -> Metadatas -> Metadatas -union m1 = F.foldl' go m1 . getMetadatas where - go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc) - --- | Strict left fold of the metadatas -foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc -foldl' f initAcc = F.foldl' f initAcc . getMetadatas - --- | foldMap equivalent for metadatas. -foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m -foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty - --- | Remove an element of the given keys from the metadatas. --- If not present does nothing. -delete :: Keys a -> Metadatas -> Metadatas -delete k = Metadatas . go . getMetadatas where - go [] = [] - go (el@(k2 :=> _) : rest) = case keyEq k k2 of - Nothing -> el : go rest - Just Refl -> rest - --- | Search a metadata with the given key. -lookup :: Keys a -> Metadatas -> Maybe a -lookup k = go . getMetadatas where - go [] = Nothing - go ((k2 :=> v) : rest) = case keyEq k k2 of - Nothing -> go rest - Just Refl -> Just v - --- | Insert an element in the metadatas, if an element with --- the same key is present, it is overwritten. -insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas -insert k val metas = - Metadatas $ (k :=> val) : getMetadatas (delete k metas) - --- | Create metadatas with a single element. -singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas -singleton k val = Metadatas [k :=> val] - --- | Empty metadatas. Favor 'mempty' -empty :: Metadatas -empty = Metadatas mempty - --- | Conversion from dpm to dpi -dotsPerMeterToDotPerInch :: Word -> Word -dotsPerMeterToDotPerInch z = z * 254 `div` 10000 - --- | Conversion from dpi to dpm -dotPerInchToDotsPerMeter :: Word -> Word -dotPerInchToDotsPerMeter z = (z * 10000) `div` 254 - --- | Conversion dpcm -> dpi -dotsPerCentiMeterToDotPerInch :: Word -> Word -dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100 - --- | Create metadatas indicating the resolution, with DpiX == DpiY -mkDpiMetadata :: Word -> Metadatas -mkDpiMetadata w = - Metadatas [DpiY :=> w, DpiX :=> w] - --- | Create metadatas holding width and height information. -mkSizeMetadata :: Integral n => n -> n -> Metadatas -mkSizeMetadata w h = - Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ] - --- | Create simple metadatas with Format, Width & Height -basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas -basicMetadata f w h = - Metadatas [ Format :=> f - , Width :=> fromIntegral w - , Height :=> fromIntegral h - ] - --- | Create simple metadatas with Format, Width, Height, DpiX & DpiY -simpleMetadata :: (Integral nSize, Integral nDpi) - => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas -simpleMetadata f w h dpiX dpiY = - Metadatas [ Format :=> f - , Width :=> fromIntegral w - , Height :=> fromIntegral h - , DpiX :=> fromIntegral dpiX - , DpiY :=> fromIntegral dpiY - ] - +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +-- | This module expose a common "metadata" storage for various image +-- type. Different format can generate different metadatas, and write +-- only a part of them. +-- +-- Since version 3.2.5 +-- +module Codec.Picture.Metadata( -- * Types + Metadatas + , Keys( .. ) + , Value( .. ) + , Elem( .. ) + , SourceFormat( .. ) + + -- * Functions + , Codec.Picture.Metadata.lookup + , empty + , insert + , delete + , singleton + + -- * Folding + , foldl' + , Codec.Picture.Metadata.foldMap + + -- * Helper functions + , mkDpiMetadata + , mkSizeMetadata + , basicMetadata + , simpleMetadata + , extractExifMetas + + -- * Conversion functions + , dotsPerMeterToDotPerInch + , dotPerInchToDotsPerMeter + , dotsPerCentiMeterToDotPerInch + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid, mempty, mappend ) +import Data.Word( Word ) +#endif + + +import Control.DeepSeq( NFData( .. ) ) +import qualified Data.Foldable as F + +import Codec.Picture.Metadata.Exif + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable( (:~:)( Refl ) ) +type Equiv = (:~:) +#else +data Equiv a b where + Refl :: Equiv a a +#endif + +-- | Type describing the original file format of the ilfe. +data SourceFormat + = SourceJpeg + | SourceGif + | SourceBitmap + | SourceTiff + | SourcePng + | SourceHDR + | SourceTGA + deriving (Eq, Show) + +instance NFData SourceFormat where + rnf a = a `seq` () + +-- | Store various additional information about an image. If +-- something is not recognized, it can be stored in an unknown tag. +-- +-- * 'DpiX' Dot per inch on this x axis. +-- +-- * 'DpiY' Dot per inch on this y axis. +-- +-- * 'Width' Image width in pixel. Relying on the metadata for this +-- information can avoid the full decompression of the image. +-- Ignored for image writing. +-- +-- * 'Height' Image height in pixels. Relyiung on the metadata for this +-- information can void the full decomrpession of the image. +-- Ignored for image writing. +-- +-- * 'Unknown' unlikely to be decoded, but usefull for metadata writing +-- +-- * 'Exif' Exif tag and associated data. +-- +data Keys a where + Gamma :: Keys Double + Format :: Keys SourceFormat + DpiX :: Keys Word + DpiY :: Keys Word + Width :: Keys Word + Height :: Keys Word + Title :: Keys String + Description :: Keys String + Author :: Keys String + Copyright :: Keys String + Software :: Keys String + Comment :: Keys String + Disclaimer :: Keys String + Source :: Keys String + Warning :: Keys String + Exif :: !ExifTag -> Keys ExifData + Unknown :: !String -> Keys Value + +deriving instance Show (Keys a) +deriving instance Eq (Keys a) +{-deriving instance Ord (Keys a)-} + +-- | Encode values for unknown information +data Value + = Int !Int + | Double !Double + | String !String + deriving (Eq, Show) + +instance NFData Value where + rnf v = v `seq` () -- everything is strict, so it's OK + +-- | Element describing a metadata and it's (typed) associated +-- value. +data Elem k = + forall a. (Show a, NFData a) => !(k a) :=> a + +deriving instance Show (Elem Keys) + +instance NFData (Elem Keys) where + rnf (_ :=> v) = rnf v `seq` () + +keyEq :: Keys a -> Keys b -> Maybe (Equiv a b) +keyEq a b = case (a, b) of + (Gamma, Gamma) -> Just Refl + (DpiX, DpiX) -> Just Refl + (DpiY, DpiY) -> Just Refl + (Width, Width) -> Just Refl + (Height, Height) -> Just Refl + (Title, Title) -> Just Refl + (Description, Description) -> Just Refl + (Author, Author) -> Just Refl + (Copyright, Copyright) -> Just Refl + (Software, Software) -> Just Refl + (Comment, Comment) -> Just Refl + (Disclaimer, Disclaimer) -> Just Refl + (Source, Source) -> Just Refl + (Warning, Warning) -> Just Refl + (Format, Format) -> Just Refl + (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl + (Exif t1, Exif t2) | t1 == t2 -> Just Refl + _ -> Nothing + +-- | Dependent storage used for metadatas. +-- All metadatas of a given kind are unique within +-- this container. + -- +-- The current data structure is based on list, +-- so bad performances can be expected. +newtype Metadatas = Metadatas + { getMetadatas :: [Elem Keys] + } + deriving (Show, NFData) + +instance Monoid Metadatas where + mempty = empty + mappend = union + +-- | Right based union +union :: Metadatas -> Metadatas -> Metadatas +union m1 = F.foldl' go m1 . getMetadatas where + go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc) + +-- | Strict left fold of the metadatas +foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc +foldl' f initAcc = F.foldl' f initAcc . getMetadatas + +-- | foldMap equivalent for metadatas. +foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m +foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty + +-- | Remove an element of the given keys from the metadatas. +-- If not present does nothing. +delete :: Keys a -> Metadatas -> Metadatas +delete k = Metadatas . go . getMetadatas where + go [] = [] + go (el@(k2 :=> _) : rest) = case keyEq k k2 of + Nothing -> el : go rest + Just Refl -> rest + +-- | Extract all Exif specific metadatas +extractExifMetas :: Metadatas -> [(ExifTag, ExifData)] +extractExifMetas = go . getMetadatas where + go :: [Elem Keys] -> [(ExifTag, ExifData)] + go [] = [] + go ((k :=> v) : rest) = + case k of + Exif t -> (t, v) : go rest + _ -> go rest + +-- | Search a metadata with the given key. +lookup :: Keys a -> Metadatas -> Maybe a +lookup k = go . getMetadatas where + go [] = Nothing + go ((k2 :=> v) : rest) = case keyEq k k2 of + Nothing -> go rest + Just Refl -> Just v + +-- | Insert an element in the metadatas, if an element with +-- the same key is present, it is overwritten. +insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas +insert k val metas = + Metadatas $ (k :=> val) : getMetadatas (delete k metas) + +-- | Create metadatas with a single element. +singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas +singleton k val = Metadatas [k :=> val] + +-- | Empty metadatas. Favor 'mempty' +empty :: Metadatas +empty = Metadatas mempty + +-- | Conversion from dpm to dpi +dotsPerMeterToDotPerInch :: Word -> Word +dotsPerMeterToDotPerInch z = z * 254 `div` 10000 + +-- | Conversion from dpi to dpm +dotPerInchToDotsPerMeter :: Word -> Word +dotPerInchToDotsPerMeter z = (z * 10000) `div` 254 + +-- | Conversion dpcm -> dpi +dotsPerCentiMeterToDotPerInch :: Word -> Word +dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100 + +-- | Create metadatas indicating the resolution, with DpiX == DpiY +mkDpiMetadata :: Word -> Metadatas +mkDpiMetadata w = + Metadatas [DpiY :=> w, DpiX :=> w] + +-- | Create metadatas holding width and height information. +mkSizeMetadata :: Integral n => n -> n -> Metadatas +mkSizeMetadata w h = + Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ] + +-- | Create simple metadatas with Format, Width & Height +basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas +basicMetadata f w h = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + ] + +-- | Create simple metadatas with Format, Width, Height, DpiX & DpiY +simpleMetadata :: (Integral nSize, Integral nDpi) + => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas +simpleMetadata f w h dpiX dpiY = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + , DpiX :=> fromIntegral dpiX + , DpiY :=> fromIntegral dpiY + ] + diff --git a/src/Codec/Picture/Metadata/Exif.hs b/src/Codec/Picture/Metadata/Exif.hs --- a/src/Codec/Picture/Metadata/Exif.hs +++ b/src/Codec/Picture/Metadata/Exif.hs @@ -1,205 +1,218 @@ --- | This module provide a totally partial and incomplete maping --- of Exif values. Used for Tiff parsing and reused for Exif extraction. -module Codec.Picture.Metadata.Exif ( ExifTag( .. ) - , ExifData( .. ) - - , tagOfWord16 - , word16OfTag - ) where - -import Control.DeepSeq( NFData( .. ) ) -import Data.Int( Int32 ) -import Data.Word( Word16, Word32 ) -import qualified Data.Vector as V -import qualified Data.ByteString as B - --- | Tag values used for exif fields. Completly incomplete -data ExifTag - = TagPhotometricInterpretation - | TagCompression -- ^ Short type - | TagImageWidth -- ^ Short or long type - | TagImageLength -- ^ Short or long type - | TagXResolution -- ^ Rational type - | TagYResolution -- ^ Rational type - | TagResolutionUnit -- ^ Short type - | TagRowPerStrip -- ^ Short or long type - | TagStripByteCounts -- ^ Short or long - | TagStripOffsets -- ^ Short or long - | TagBitsPerSample -- ^ Short - | TagColorMap -- ^ Short - | TagTileWidth - | TagTileLength - | TagTileOffset - | TagTileByteCount - | TagSamplesPerPixel -- ^ Short - | TagArtist - | TagDocumentName - | TagSoftware - | TagPlanarConfiguration -- ^ Short - | TagOrientation - | TagSampleFormat -- ^ Short - | TagInkSet - | TagSubfileType - | TagFillOrder - | TagYCbCrCoeff - | TagYCbCrSubsampling - | TagYCbCrPositioning - | TagReferenceBlackWhite - | TagXPosition - | TagYPosition - | TagExtraSample - | TagImageDescription - | TagPredictor - | TagCopyright - | TagMake - | TagModel - | TagDateTime - | TagGPSInfo - - | TagJpegProc - | TagJPEGInterchangeFormat - | TagJPEGInterchangeFormatLength - | TagJPEGRestartInterval - | TagJPEGLosslessPredictors - | TagJPEGPointTransforms - | TagJPEGQTables - | TagJPEGDCTables - | TagJPEGACTables - - | TagExifOffset - | TagUnknown !Word16 - deriving (Eq, Ord, Show) - --- | Convert a value to it's corresponding Exif tag. --- Will often be written as 'TagUnknown' -tagOfWord16 :: Word16 -> ExifTag -tagOfWord16 v = case v of - 255 -> TagSubfileType - 256 -> TagImageWidth - 257 -> TagImageLength - 258 -> TagBitsPerSample - 259 -> TagCompression - 262 -> TagPhotometricInterpretation - 266 -> TagFillOrder - 269 -> TagDocumentName - 270 -> TagImageDescription - 271 -> TagMake - 272 -> TagModel - 273 -> TagStripOffsets - 274 -> TagOrientation - 277 -> TagSamplesPerPixel - 278 -> TagRowPerStrip - 279 -> TagStripByteCounts - 282 -> TagXResolution - 283 -> TagYResolution - 284 -> TagPlanarConfiguration - 286 -> TagXPosition - 287 -> TagYPosition - 296 -> TagResolutionUnit - 305 -> TagSoftware - 306 -> TagDateTime - 315 -> TagArtist - 317 -> TagPredictor - 320 -> TagColorMap - 322 -> TagTileWidth - 323 -> TagTileLength - 324 -> TagTileOffset - 325 -> TagTileByteCount - 332 -> TagInkSet - 338 -> TagExtraSample - 339 -> TagSampleFormat - 529 -> TagYCbCrCoeff - 512 -> TagJpegProc - 513 -> TagJPEGInterchangeFormat - 514 -> TagJPEGInterchangeFormatLength - 515 -> TagJPEGRestartInterval - 517 -> TagJPEGLosslessPredictors - 518 -> TagJPEGPointTransforms - 519 -> TagJPEGQTables - 520 -> TagJPEGDCTables - 521 -> TagJPEGACTables - 530 -> TagYCbCrSubsampling - 531 -> TagYCbCrPositioning - 532 -> TagReferenceBlackWhite - 33432 -> TagCopyright - 34665 -> TagExifOffset - 34853 -> TagGPSInfo - vv -> TagUnknown vv - --- | Convert a tag to it's corresponding value. -word16OfTag :: ExifTag -> Word16 -word16OfTag t = case t of - TagSubfileType -> 255 - TagImageWidth -> 256 - TagImageLength -> 257 - TagBitsPerSample -> 258 - TagCompression -> 259 - TagPhotometricInterpretation -> 262 - TagFillOrder -> 266 - TagDocumentName -> 269 - TagImageDescription -> 270 - TagMake -> 271 - TagModel -> 272 - TagStripOffsets -> 273 - TagOrientation -> 274 - TagSamplesPerPixel -> 277 - TagRowPerStrip -> 278 - TagStripByteCounts -> 279 - TagXResolution -> 282 - TagYResolution -> 283 - TagPlanarConfiguration -> 284 - TagXPosition -> 286 - TagYPosition -> 287 - TagResolutionUnit -> 296 - TagSoftware -> 305 - TagDateTime -> 306 - TagArtist -> 315 - TagPredictor -> 317 - TagColorMap -> 320 - TagTileWidth -> 322 - TagTileLength -> 323 - TagTileOffset -> 324 - TagTileByteCount -> 325 - TagInkSet -> 332 - TagExtraSample -> 338 - TagSampleFormat -> 339 - TagYCbCrCoeff -> 529 - TagJpegProc -> 512 - TagJPEGInterchangeFormat -> 513 - TagJPEGInterchangeFormatLength -> 514 - TagJPEGRestartInterval -> 515 - TagJPEGLosslessPredictors -> 517 - TagJPEGPointTransforms -> 518 - TagJPEGQTables -> 519 - TagJPEGDCTables -> 520 - TagJPEGACTables -> 521 - TagYCbCrSubsampling -> 530 - TagYCbCrPositioning -> 531 - TagReferenceBlackWhite -> 532 - TagCopyright -> 33432 - TagExifOffset -> 34665 - TagGPSInfo -> 34853 - (TagUnknown v) -> v - --- | Possible data held by an Exif tag -data ExifData - = ExifNone - | ExifLong !Word32 - | ExifShort !Word16 - | ExifString !B.ByteString - | ExifUndefined !B.ByteString - | ExifShorts !(V.Vector Word16) - | ExifLongs !(V.Vector Word32) - | ExifRational !Word32 !Word32 - | ExifSignedRational !Int32 !Int32 - | ExifIFD ![(ExifTag, ExifData)] - deriving Show - -instance NFData ExifTag where - rnf a = a `seq` () - -instance NFData ExifData where - rnf (ExifIFD ifds) = rnf ifds `seq` () - rnf (ExifLongs l) = rnf l `seq` () - rnf (ExifShorts l) = rnf l `seq` () - rnf a = a `seq` () +-- | This module provide a totally partial and incomplete maping +-- of Exif values. Used for Tiff parsing and reused for Exif extraction. +module Codec.Picture.Metadata.Exif ( ExifTag( .. ) + , ExifData( .. ) + + , tagOfWord16 + , word16OfTag + + , isInIFD0 + ) where + +import Control.DeepSeq( NFData( .. ) ) +import Data.Int( Int32 ) +import Data.Word( Word16, Word32 ) +import qualified Data.Vector as V +import qualified Data.ByteString as B + +-- | Tag values used for exif fields. Completly incomplete +data ExifTag + = TagPhotometricInterpretation + | TagCompression -- ^ Short type + | TagImageWidth -- ^ Short or long type + | TagImageLength -- ^ Short or long type + | TagXResolution -- ^ Rational type + | TagYResolution -- ^ Rational type + | TagResolutionUnit -- ^ Short type + | TagRowPerStrip -- ^ Short or long type + | TagStripByteCounts -- ^ Short or long + | TagStripOffsets -- ^ Short or long + | TagBitsPerSample -- ^ Short + | TagColorMap -- ^ Short + | TagTileWidth + | TagTileLength + | TagTileOffset + | TagTileByteCount + | TagSamplesPerPixel -- ^ Short + | TagArtist + | TagDocumentName + | TagSoftware + | TagPlanarConfiguration -- ^ Short + | TagOrientation + | TagSampleFormat -- ^ Short + | TagInkSet + | TagSubfileType + | TagFillOrder + | TagYCbCrCoeff + | TagYCbCrSubsampling + | TagYCbCrPositioning + | TagReferenceBlackWhite + | TagXPosition + | TagYPosition + | TagExtraSample + | TagImageDescription + | TagPredictor + | TagCopyright + | TagMake + | TagModel + | TagDateTime + | TagGPSInfo + | TagLightSource -- ^ Short + | TagFlash -- ^ Short + + | TagJpegProc + | TagJPEGInterchangeFormat + | TagJPEGInterchangeFormatLength + | TagJPEGRestartInterval + | TagJPEGLosslessPredictors + | TagJPEGPointTransforms + | TagJPEGQTables + | TagJPEGDCTables + | TagJPEGACTables + + | TagExifOffset + | TagUnknown !Word16 + deriving (Eq, Ord, Show) + +-- | Convert a value to it's corresponding Exif tag. +-- Will often be written as 'TagUnknown' +tagOfWord16 :: Word16 -> ExifTag +tagOfWord16 v = case v of + 255 -> TagSubfileType + 256 -> TagImageWidth + 257 -> TagImageLength + 258 -> TagBitsPerSample + 259 -> TagCompression + 262 -> TagPhotometricInterpretation + 266 -> TagFillOrder + 269 -> TagDocumentName + 270 -> TagImageDescription + 271 -> TagMake + 272 -> TagModel + 273 -> TagStripOffsets + 274 -> TagOrientation + 277 -> TagSamplesPerPixel + 278 -> TagRowPerStrip + 279 -> TagStripByteCounts + 282 -> TagXResolution + 283 -> TagYResolution + 284 -> TagPlanarConfiguration + 286 -> TagXPosition + 287 -> TagYPosition + 296 -> TagResolutionUnit + 305 -> TagSoftware + 306 -> TagDateTime + 315 -> TagArtist + 317 -> TagPredictor + 320 -> TagColorMap + 322 -> TagTileWidth + 323 -> TagTileLength + 324 -> TagTileOffset + 325 -> TagTileByteCount + 332 -> TagInkSet + 338 -> TagExtraSample + 339 -> TagSampleFormat + 529 -> TagYCbCrCoeff + 512 -> TagJpegProc + 513 -> TagJPEGInterchangeFormat + 514 -> TagJPEGInterchangeFormatLength + 515 -> TagJPEGRestartInterval + 517 -> TagJPEGLosslessPredictors + 518 -> TagJPEGPointTransforms + 519 -> TagJPEGQTables + 520 -> TagJPEGDCTables + 521 -> TagJPEGACTables + 530 -> TagYCbCrSubsampling + 531 -> TagYCbCrPositioning + 532 -> TagReferenceBlackWhite + 33432 -> TagCopyright + 34665 -> TagExifOffset + 34853 -> TagGPSInfo + 37384 -> TagLightSource + 37385 -> TagFlash + vv -> TagUnknown vv + +-- | Convert a tag to it's corresponding value. +word16OfTag :: ExifTag -> Word16 +word16OfTag t = case t of + TagSubfileType -> 255 + TagImageWidth -> 256 + TagImageLength -> 257 + TagBitsPerSample -> 258 + TagCompression -> 259 + TagPhotometricInterpretation -> 262 + TagFillOrder -> 266 + TagDocumentName -> 269 + TagImageDescription -> 270 + TagMake -> 271 + TagModel -> 272 + TagStripOffsets -> 273 + TagOrientation -> 274 + TagSamplesPerPixel -> 277 + TagRowPerStrip -> 278 + TagStripByteCounts -> 279 + TagXResolution -> 282 + TagYResolution -> 283 + TagPlanarConfiguration -> 284 + TagXPosition -> 286 + TagYPosition -> 287 + TagResolutionUnit -> 296 + TagSoftware -> 305 + TagDateTime -> 306 + TagArtist -> 315 + TagPredictor -> 317 + TagColorMap -> 320 + TagTileWidth -> 322 + TagTileLength -> 323 + TagTileOffset -> 324 + TagTileByteCount -> 325 + TagInkSet -> 332 + TagExtraSample -> 338 + TagSampleFormat -> 339 + TagYCbCrCoeff -> 529 + TagJpegProc -> 512 + TagJPEGInterchangeFormat -> 513 + TagJPEGInterchangeFormatLength -> 514 + TagJPEGRestartInterval -> 515 + TagJPEGLosslessPredictors -> 517 + TagJPEGPointTransforms -> 518 + TagJPEGQTables -> 519 + TagJPEGDCTables -> 520 + TagJPEGACTables -> 521 + TagYCbCrSubsampling -> 530 + TagYCbCrPositioning -> 531 + TagReferenceBlackWhite -> 532 + TagCopyright -> 33432 + TagExifOffset -> 34665 + TagGPSInfo -> 34853 + TagLightSource -> 37384 + TagFlash -> 37385 + (TagUnknown v) -> v + +isInIFD0 :: ExifTag -> Bool +isInIFD0 t = word16OfTag t <= lastTag || isRedirectTag where + lastTag = word16OfTag TagCopyright + isRedirectTag = t `elem` [TagExifOffset, TagGPSInfo] + +-- | Possible data held by an Exif tag +data ExifData + = ExifNone + | ExifLong !Word32 + | ExifShort !Word16 + | ExifString !B.ByteString + | ExifUndefined !B.ByteString + | ExifShorts !(V.Vector Word16) + | ExifLongs !(V.Vector Word32) + | ExifRational !Word32 !Word32 + | ExifSignedRational !Int32 !Int32 + | ExifIFD ![(ExifTag, ExifData)] + deriving Show + +instance NFData ExifTag where + rnf a = a `seq` () + +instance NFData ExifData where + rnf (ExifIFD ifds) = rnf ifds `seq` () + rnf (ExifLongs l) = rnf l `seq` () + rnf (ExifShorts l) = rnf l `seq` () + rnf a = a `seq` () diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs --- a/src/Codec/Picture/Tiff.hs +++ b/src/Codec/Picture/Tiff.hs @@ -567,7 +567,7 @@ EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone) instance BinaryParam B.ByteString TiffInfo where - putP rawData nfo = putP rawData (tiffHeader nfo, list) where + putP rawData nfo = putP rawData (tiffHeader nfo, [list]) where endianness = hdrEndianness $ tiffHeader nfo ifdShort = ifdSingleShort endianness @@ -599,9 +599,10 @@ ifdShorts TagYCbCrSubsampling subSampling getP rawData = do - (hdr, cleaned) <- getP rawData + (hdr, cleanedFull :: [[ImageFileDirectory]]) <- getP rawData - let dataFind str tag = findIFDData str tag cleaned + let cleaned = concat cleanedFull + dataFind str tag = findIFDData str tag cleaned dataDefault def tag = findIFDDefaultData def tag cleaned extFind str tag = findIFDExt str tag cleaned extDefault def tag = findIFDExtDefaultData def tag cleaned diff --git a/src/Codec/Picture/Tiff/Metadata.hs b/src/Codec/Picture/Tiff/Metadata.hs --- a/src/Codec/Picture/Tiff/Metadata.hs +++ b/src/Codec/Picture/Tiff/Metadata.hs @@ -1,98 +1,237 @@ -{-# LANGUAGE CPP #-} -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 - +{-# LANGUAGE CPP #-} +module Codec.Picture.Tiff.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.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 + diff --git a/src/Codec/Picture/Tiff/Types.hs b/src/Codec/Picture/Tiff/Types.hs --- a/src/Codec/Picture/Tiff/Types.hs +++ b/src/Codec/Picture/Tiff/Types.hs @@ -1,465 +1,483 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -module Codec.Picture.Tiff.Types - ( BinaryParam( .. ) - , Endianness( .. ) - , TiffHeader( .. ) - , TiffPlanarConfiguration( .. ) - , TiffCompression( .. ) - , IfdType( .. ) - , TiffColorspace( .. ) - , TiffSampleFormat( .. ) - , ImageFileDirectory( .. ) - , ExtraSample( .. ) - , Predictor( .. ) - - , planarConfgOfConstant - , constantToPlaneConfiguration - , unpackSampleFormat - , word16OfTag - , unpackPhotometricInterpretation - , packPhotometricInterpretation - , codeOfExtraSample - , unPackCompression - , packCompression - , predictorOfConstant - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>), pure ) -#endif - -import Control.Monad( when, replicateM, ) -import Data.Bits( (.&.), unsafeShiftR ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , getWord16le, getWord16be - , getWord32le, getWord32be - , bytesRead - , skip - , getByteString - ) -import Data.Binary.Put( Put - , putWord16le, putWord16be - , putWord32le, putWord32be - , putByteString - ) -import Data.Function( on ) -import Data.List( sortBy, mapAccumL ) -import qualified Data.Vector as V -import qualified Data.ByteString as B -import Data.Int( Int32 ) -import Data.Word( Word16, Word32 ) - -import Codec.Picture.Metadata.Exif -{-import Debug.Trace-} - -data Endianness - = EndianLittle - | EndianBig - deriving (Eq, Show) - -instance Binary Endianness where - put EndianLittle = putWord16le 0x4949 - put EndianBig = putWord16le 0x4D4D - - get = do - tag <- getWord16le - case tag of - 0x4949 -> return EndianLittle - 0x4D4D -> return EndianBig - _ -> fail "Invalid endian tag value" - --- | Because having a polymorphic get with endianness is to nice --- to pass on, introducing this helper type class, which is just --- a superset of Binary, but formalising a parameter passing --- into it. -class BinaryParam a b where - getP :: a -> Get b - putP :: a -> b -> Put - -data TiffHeader = TiffHeader - { hdrEndianness :: !Endianness - , hdrOffset :: {-# UNPACK #-} !Word32 - } - deriving (Eq, Show) - -instance BinaryParam Endianness Word16 where - putP EndianLittle = putWord16le - putP EndianBig = putWord16be - - getP EndianLittle = getWord16le - getP EndianBig = getWord16be - -instance BinaryParam Endianness Int32 where - putP en v = putP en $ (fromIntegral v :: Word32) - getP en = fromIntegral <$> (getP en :: Get Word32) - -instance BinaryParam Endianness Word32 where - putP EndianLittle = putWord32le - putP EndianBig = putWord32be - - getP EndianLittle = getWord32le - getP EndianBig = getWord32be - -instance Binary TiffHeader where - put hdr = do - let endian = hdrEndianness hdr - put endian - putP endian (42 :: Word16) - putP endian $ hdrOffset hdr - - get = do - endian <- get - magic <- getP endian - let magicValue = 42 :: Word16 - when (magic /= magicValue) - (fail "Invalid TIFF magic number") - TiffHeader endian <$> getP endian - -data TiffPlanarConfiguration - = PlanarConfigContig -- = 1 - | PlanarConfigSeparate -- = 2 - -planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration -planarConfgOfConstant 0 = pure PlanarConfigContig -planarConfgOfConstant 1 = pure PlanarConfigContig -planarConfgOfConstant 2 = pure PlanarConfigSeparate -planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" - -constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 -constantToPlaneConfiguration PlanarConfigContig = 1 -constantToPlaneConfiguration PlanarConfigSeparate = 2 - -data TiffCompression - = CompressionNone -- 1 - | CompressionModifiedRLE -- 2 - | CompressionLZW -- 5 - | CompressionJPEG -- 6 - | CompressionPackBit -- 32273 - -data IfdType - = TypeByte - | TypeAscii - | TypeShort - | TypeLong - | TypeRational - | TypeSByte - | TypeUndefined - | TypeSignedShort - | TypeSignedLong - | TypeSignedRational - | TypeFloat - | TypeDouble - deriving Show - -instance BinaryParam Endianness IfdType where - getP endianness = getP endianness >>= conv where - conv :: Word16 -> Get IfdType - conv v = case v of - 1 -> return TypeByte - 2 -> return TypeAscii - 3 -> return TypeShort - 4 -> return TypeLong - 5 -> return TypeRational - 6 -> return TypeSByte - 7 -> return TypeUndefined - 8 -> return TypeSignedShort - 9 -> return TypeSignedLong - 10 -> return TypeSignedRational - 11 -> return TypeFloat - 12 -> return TypeDouble - _ -> fail "Invalid TIF directory type" - - putP endianness = putP endianness . conv where - conv :: IfdType -> Word16 - conv v = case v of - TypeByte -> 1 - TypeAscii -> 2 - TypeShort -> 3 - TypeLong -> 4 - TypeRational -> 5 - TypeSByte -> 6 - TypeUndefined -> 7 - TypeSignedShort -> 8 - TypeSignedLong -> 9 - TypeSignedRational -> 10 - TypeFloat -> 11 - TypeDouble -> 12 - -instance BinaryParam Endianness ExifTag where - getP endianness = tagOfWord16 <$> getP endianness - putP endianness = putP endianness . word16OfTag - -data Predictor - = PredictorNone -- 1 - | PredictorHorizontalDifferencing -- 2 - deriving Eq - -predictorOfConstant :: Word32 -> Get Predictor -predictorOfConstant 1 = pure PredictorNone -predictorOfConstant 2 = pure PredictorHorizontalDifferencing -predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")" - -instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where - putP (endianness, _, _) = dump - where - dump ExifNone = pure () - dump (ExifLong _) = pure () - dump (ExifShort _) = pure () - dump (ExifIFD _) = pure () - dump (ExifString bstr) = putByteString bstr - dump (ExifUndefined bstr) = putByteString bstr - -- wrong if length == 2 - dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts - dump (ExifLongs longs) = V.mapM_ (putP endianness) longs - dump (ExifRational a b) = putP endianness a >> putP endianness b - dump (ExifSignedRational a b) = putP endianness a >> putP endianness b - - getP (endianness, maxi, ifd) = fetcher ifd - where - align ImageFileDirectory { ifdOffset = offset } act = do - readed <- bytesRead - let delta = fromIntegral offset - readed - if offset >= fromIntegral maxi || fromIntegral readed > offset then - pure ExifNone - else do - skip $ fromIntegral delta - act - - getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - getVec count = V.replicateM (fromIntegral count) - - fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset - , ifdType = TypeLong - , ifdCount = 1 } = do - align ifd $ do - let byOffset = sortBy (compare `on` ifdOffset) - cleansIfds = fmap (cleanImageFileDirectory endianness) - subIfds <- cleansIfds . byOffset <$> getP endianness - cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds - pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] - {- - fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo - , ifdType = TypeLong - , ifdCount = 1 } = do - align ifd - subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness - cleaned <- fetchExtended endianness subIfds - pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] - -} - fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 = - align ifd $ ExifUndefined <$> getByteString (fromIntegral count) - fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } = - pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd) - [fromIntegral $ ofs .&. 0xFF000000 `unsafeShiftR` (3 * 8) - ,fromIntegral $ ofs .&. 0x00FF0000 `unsafeShiftR` (2 * 8) - ,fromIntegral $ ofs .&. 0x0000FF00 `unsafeShiftR` (1 * 8) - ,fromIntegral $ ofs .&. 0x000000FF - ] - fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = - align ifd $ ExifString <$> getByteString (fromIntegral count) - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = - pure . ExifShorts $ V.fromListN 2 valList - where high = fromIntegral $ ofs `unsafeShiftR` 16 - low = fromIntegral $ ofs .&. 0xFFFF - valList = case endianness of - EndianLittle -> [low, high] - EndianBig -> [high, low] - fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do - align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle - fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do - align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } = - pure . ExifShort . fromIntegral $ ifdOffset ifd - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = - align ifd $ ExifShorts <$> getVec count getE - fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } = - pure . ExifLong . fromIntegral $ ifdOffset ifd - fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = - align ifd $ ExifLongs <$> getVec count getE - fetcher _ = pure ExifNone - -cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory -cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd - where - aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } - aux _ = ifd -cleanImageFileDirectory _ ifd = ifd - -fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory] -fetchExtended endian maxi = mapM $ \ifd -> do - v <- getP (endian, maxi, ifd) - pure $ ifd { ifdExtended = v } - --- | All the IFD must be written in order according to the tag --- value of the IFD. To avoid getting to much restriction in the --- serialization code, just sort it. -orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] -orderIfdByTag = sortBy comparer where - comparer a b = compare t1 t2 where - t1 = word16OfTag $ ifdIdentifier a - t2 = word16OfTag $ ifdIdentifier b - --- | Given an official offset and a list of IFD, update the offset information --- of the IFD with extended data. -setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> [ImageFileDirectory] -setupIfdOffsets initialOffset lst = snd $ mapAccumL updater startExtended lst - where ifdElementCount = fromIntegral $ length lst - ifdSize = 12 - ifdCountSize = 2 - nextOffsetSize = 4 - startExtended = initialOffset - + ifdElementCount * ifdSize - + ifdCountSize + nextOffsetSize - - updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) = - (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v }) - | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) - , ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v }) - | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) - , ifd { ifdOffset = ix }) - updater ix ifd = (ix, ifd) - -instance BinaryParam B.ByteString (TiffHeader, [ImageFileDirectory]) where - putP rawData (hdr, ifds) = do - put hdr - putByteString rawData - let endianness = hdrEndianness hdr - list = setupIfdOffsets (hdrOffset hdr) $ orderIfdByTag ifds - putP endianness list - mapM_ (\ifd -> putP (endianness, (0::Int), ifd) $ ifdExtended ifd) list - - getP raw = do - hdr <- get - readed <- bytesRead - skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed - let endian = hdrEndianness hdr - byOffset = sortBy (compare `on` ifdOffset) - cleanIfds = fmap (cleanImageFileDirectory endian) - - ifd <- cleanIfds . byOffset <$> getP endian - cleaned <- fetchExtended endian (B.length raw) ifd - return (hdr, cleaned) - -data TiffSampleFormat - = TiffSampleUint - | TiffSampleInt - | TiffSampleDouble - | TiffSampleUnknown - deriving Eq - -unpackSampleFormat :: Word32 -> Get TiffSampleFormat -unpackSampleFormat v = case v of - 1 -> pure TiffSampleUint - 2 -> pure TiffSampleInt - 3 -> pure TiffSampleDouble - 4 -> pure TiffSampleUnknown - vv -> fail $ "Undefined data format (" ++ show vv ++ ")" - -data ImageFileDirectory = ImageFileDirectory - { ifdIdentifier :: !ExifTag - , ifdType :: !IfdType - , ifdCount :: !Word32 - , ifdOffset :: !Word32 - , ifdExtended :: !ExifData - } - deriving Show - -instance BinaryParam Endianness ImageFileDirectory where - getP endianness = - ImageFileDirectory <$> getE <*> getE <*> getE <*> getE - <*> pure ExifNone - where getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - putP endianness ifd =do - let putE :: (BinaryParam Endianness a) => a -> Put - putE = putP endianness - putE $ ifdIdentifier ifd - putE $ ifdType ifd - putE $ ifdCount ifd - putE $ ifdOffset ifd - -instance BinaryParam Endianness [ImageFileDirectory] where - getP endianness = do - count <- getP endianness :: Get Word16 - rez <- replicateM (fromIntegral count) $ getP endianness - _ <- getP endianness :: Get Word32 - pure rez - - putP endianness lst = do - let count = fromIntegral $ length lst :: Word16 - putP endianness count - mapM_ (putP endianness) lst - putP endianness (0 :: Word32) - -data TiffColorspace - = TiffMonochromeWhite0 -- ^ 0 - | TiffMonochrome -- ^ 1 - | TiffRGB -- ^ 2 - | TiffPaleted -- ^ 3 - | TiffTransparencyMask -- ^ 4 - | TiffCMYK -- ^ 5 - | TiffYCbCr -- ^ 6 - | TiffCIELab -- ^ 8 - - -packPhotometricInterpretation :: TiffColorspace -> Word16 -packPhotometricInterpretation v = case v of - TiffMonochromeWhite0 -> 0 - TiffMonochrome -> 1 - TiffRGB -> 2 - TiffPaleted -> 3 - TiffTransparencyMask -> 4 - TiffCMYK -> 5 - TiffYCbCr -> 6 - TiffCIELab -> 8 - -unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace -unpackPhotometricInterpretation v = case v of - 0 -> pure TiffMonochromeWhite0 - 1 -> pure TiffMonochrome - 2 -> pure TiffRGB - 3 -> pure TiffPaleted - 4 -> pure TiffTransparencyMask - 5 -> pure TiffCMYK - 6 -> pure TiffYCbCr - 8 -> pure TiffCIELab - vv -> fail $ "Unrecognized color space " ++ show vv - -data ExtraSample - = ExtraSampleUnspecified -- ^ 0 - | ExtraSampleAssociatedAlpha -- ^ 1 - | ExtraSampleUnassociatedAlpha -- ^ 2 - -codeOfExtraSample :: ExtraSample -> Word16 -codeOfExtraSample v = case v of - ExtraSampleUnspecified -> 0 - ExtraSampleAssociatedAlpha -> 1 - ExtraSampleUnassociatedAlpha -> 2 - -unPackCompression :: Word32 -> Get TiffCompression -unPackCompression v = case v of - 0 -> pure CompressionNone - 1 -> pure CompressionNone - 2 -> pure CompressionModifiedRLE - 5 -> pure CompressionLZW - 6 -> pure CompressionJPEG - 32773 -> pure CompressionPackBit - vv -> fail $ "Unknown compression scheme " ++ show vv - -packCompression :: TiffCompression -> Word16 -packCompression v = case v of - CompressionNone -> 1 - CompressionModifiedRLE -> 2 - CompressionLZW -> 5 - CompressionJPEG -> 6 - CompressionPackBit -> 32773 - +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Codec.Picture.Tiff.Types + ( BinaryParam( .. ) + , Endianness( .. ) + , TiffHeader( .. ) + , TiffPlanarConfiguration( .. ) + , TiffCompression( .. ) + , IfdType( .. ) + , TiffColorspace( .. ) + , TiffSampleFormat( .. ) + , ImageFileDirectory( .. ) + , ExtraSample( .. ) + , Predictor( .. ) + + , planarConfgOfConstant + , constantToPlaneConfiguration + , unpackSampleFormat + , word16OfTag + , unpackPhotometricInterpretation + , packPhotometricInterpretation + , codeOfExtraSample + , unPackCompression + , packCompression + , predictorOfConstant + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.Monad( forM_, when, replicateM, ) +import Data.Bits( (.&.), unsafeShiftR ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord16le, getWord16be + , getWord32le, getWord32be + , bytesRead + , skip + , getByteString + ) +import Data.Binary.Put( Put + , putWord16le, putWord16be + , putWord32le, putWord32be + , putByteString + ) +import Data.Function( on ) +import Data.List( sortBy, mapAccumL ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import Data.Int( Int32 ) +import Data.Word( Word8, Word16, Word32 ) + +import Codec.Picture.Metadata.Exif +{-import Debug.Trace-} + +data Endianness + = EndianLittle + | EndianBig + deriving (Eq, Show) + +instance Binary Endianness where + put EndianLittle = putWord16le 0x4949 + put EndianBig = putWord16le 0x4D4D + + get = do + tag <- getWord16le + case tag of + 0x4949 -> return EndianLittle + 0x4D4D -> return EndianBig + _ -> fail "Invalid endian tag value" + +-- | Because having a polymorphic get with endianness is to nice +-- to pass on, introducing this helper type class, which is just +-- a superset of Binary, but formalising a parameter passing +-- into it. +class BinaryParam a b where + getP :: a -> Get b + putP :: a -> b -> Put + +data TiffHeader = TiffHeader + { hdrEndianness :: !Endianness + , hdrOffset :: {-# UNPACK #-} !Word32 + } + deriving (Eq, Show) + +instance BinaryParam Endianness Word16 where + putP EndianLittle = putWord16le + putP EndianBig = putWord16be + + getP EndianLittle = getWord16le + getP EndianBig = getWord16be + +instance BinaryParam Endianness Int32 where + putP en v = putP en $ (fromIntegral v :: Word32) + getP en = fromIntegral <$> (getP en :: Get Word32) + +instance BinaryParam Endianness Word32 where + putP EndianLittle = putWord32le + putP EndianBig = putWord32be + + getP EndianLittle = getWord32le + getP EndianBig = getWord32be + +instance Binary TiffHeader where + put hdr = do + let endian = hdrEndianness hdr + put endian + putP endian (42 :: Word16) + putP endian $ hdrOffset hdr + + get = do + endian <- get + magic <- getP endian + let magicValue = 42 :: Word16 + when (magic /= magicValue) + (fail "Invalid TIFF magic number") + TiffHeader endian <$> getP endian + +data TiffPlanarConfiguration + = PlanarConfigContig -- = 1 + | PlanarConfigSeparate -- = 2 + +planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration +planarConfgOfConstant 0 = pure PlanarConfigContig +planarConfgOfConstant 1 = pure PlanarConfigContig +planarConfgOfConstant 2 = pure PlanarConfigSeparate +planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" + +constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 +constantToPlaneConfiguration PlanarConfigContig = 1 +constantToPlaneConfiguration PlanarConfigSeparate = 2 + +data TiffCompression + = CompressionNone -- 1 + | CompressionModifiedRLE -- 2 + | CompressionLZW -- 5 + | CompressionJPEG -- 6 + | CompressionPackBit -- 32273 + +data IfdType + = TypeByte + | TypeAscii + | TypeShort + | TypeLong + | TypeRational + | TypeSByte + | TypeUndefined + | TypeSignedShort + | TypeSignedLong + | TypeSignedRational + | TypeFloat + | TypeDouble + deriving Show + +instance BinaryParam Endianness IfdType where + getP endianness = getP endianness >>= conv where + conv :: Word16 -> Get IfdType + conv v = case v of + 1 -> return TypeByte + 2 -> return TypeAscii + 3 -> return TypeShort + 4 -> return TypeLong + 5 -> return TypeRational + 6 -> return TypeSByte + 7 -> return TypeUndefined + 8 -> return TypeSignedShort + 9 -> return TypeSignedLong + 10 -> return TypeSignedRational + 11 -> return TypeFloat + 12 -> return TypeDouble + _ -> fail "Invalid TIF directory type" + + putP endianness = putP endianness . conv where + conv :: IfdType -> Word16 + conv v = case v of + TypeByte -> 1 + TypeAscii -> 2 + TypeShort -> 3 + TypeLong -> 4 + TypeRational -> 5 + TypeSByte -> 6 + TypeUndefined -> 7 + TypeSignedShort -> 8 + TypeSignedLong -> 9 + TypeSignedRational -> 10 + TypeFloat -> 11 + TypeDouble -> 12 + +instance BinaryParam Endianness ExifTag where + getP endianness = tagOfWord16 <$> getP endianness + putP endianness = putP endianness . word16OfTag + +data Predictor + = PredictorNone -- 1 + | PredictorHorizontalDifferencing -- 2 + deriving Eq + +predictorOfConstant :: Word32 -> Get Predictor +predictorOfConstant 1 = pure PredictorNone +predictorOfConstant 2 = pure PredictorHorizontalDifferencing +predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")" + +paddWrite :: B.ByteString -> Put +paddWrite str = putByteString str >> padding where + zero = 0 :: Word8 + padding = when (odd (B.length str)) $ put zero + +instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where + putP (endianness, _, _) = dump + where + dump ExifNone = pure () + dump (ExifLong _) = pure () + dump (ExifShort _) = pure () + dump (ExifIFD _) = pure () + dump (ExifString bstr) = paddWrite bstr + dump (ExifUndefined bstr) = paddWrite bstr + -- wrong if length == 2 + dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts + dump (ExifLongs longs) = V.mapM_ (putP endianness) longs + dump (ExifRational a b) = putP endianness a >> putP endianness b + dump (ExifSignedRational a b) = putP endianness a >> putP endianness b + + getP (endianness, maxi, ifd) = fetcher ifd + where + align ImageFileDirectory { ifdOffset = offset } act = do + readed <- bytesRead + let delta = fromIntegral offset - readed + if offset >= fromIntegral maxi || fromIntegral readed > offset then + pure ExifNone + else do + skip $ fromIntegral delta + act + + getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + getVec count = V.replicateM (fromIntegral count) + + fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd $ do + let byOffset = sortBy (compare `on` ifdOffset) + cleansIfds = fmap (cleanImageFileDirectory endianness) + subIfds <- cleansIfds . byOffset <$> getP endianness + cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + {- + fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd + subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness + cleaned <- fetchExtended endianness subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + -} + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 = + align ifd $ ExifUndefined <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } = + pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd) + [fromIntegral $ ofs .&. 0xFF000000 `unsafeShiftR` (3 * 8) + ,fromIntegral $ ofs .&. 0x00FF0000 `unsafeShiftR` (2 * 8) + ,fromIntegral $ ofs .&. 0x0000FF00 `unsafeShiftR` (1 * 8) + ,fromIntegral $ ofs .&. 0x000000FF + ] + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = + align ifd $ ExifString <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = + pure . ExifShorts $ V.fromListN 2 valList + where high = fromIntegral $ ofs `unsafeShiftR` 16 + low = fromIntegral $ ofs .&. 0xFFFF + valList = case endianness of + EndianLittle -> [low, high] + EndianBig -> [high, low] + fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do + align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do + align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } = + pure . ExifShort . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = + align ifd $ ExifShorts <$> getVec count getE + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } = + pure . ExifLong . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = + align ifd $ ExifLongs <$> getVec count getE + fetcher _ = pure ExifNone + +cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory +cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd + where + aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } + aux _ = ifd +cleanImageFileDirectory _ ifd = ifd + +fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory] +fetchExtended endian maxi = mapM $ \ifd -> do + v <- getP (endian, maxi, ifd) + pure $ ifd { ifdExtended = v } + +-- | All the IFD must be written in order according to the tag +-- value of the IFD. To avoid getting to much restriction in the +-- serialization code, just sort it. +orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] +orderIfdByTag = sortBy comparer where + comparer a b = compare t1 t2 where + t1 = word16OfTag $ ifdIdentifier a + t2 = word16OfTag $ ifdIdentifier b + +-- | Given an official offset and a list of IFD, update the offset information +-- of the IFD with extended data. +setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> (Word32, [ImageFileDirectory]) +setupIfdOffsets initialOffset lst = mapAccumL updater startExtended lst + where ifdElementCount = fromIntegral $ length lst + ifdSize = 12 + ifdCountSize = 2 + nextOffsetSize = 4 + startExtended = initialOffset + + ifdElementCount * ifdSize + + ifdCountSize + nextOffsetSize + + paddedSize blob = fromIntegral $ blobLength + padding where + blobLength = B.length blob + padding = if odd blobLength then 1 else 0 + + updater ix ifd@(ImageFileDirectory { ifdIdentifier = TagExifOffset }) = + (ix, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifUndefined b }) = + (ix + paddedSize b, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) = + (ix + paddedSize b, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v }) + | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) + , ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v }) + | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) + , ifd { ifdOffset = ix }) + updater ix ifd = (ix, ifd) + +instance BinaryParam B.ByteString (TiffHeader, [[ImageFileDirectory]]) where + putP rawData (hdr, ifds) = do + put hdr + putByteString rawData + let endianness = hdrEndianness hdr + (_, offseted) = mapAccumL + (\ix ifd -> setupIfdOffsets ix $ orderIfdByTag ifd) + (hdrOffset hdr) + ifds + forM_ offseted $ \list -> do + putP endianness list + mapM_ (\field -> putP (endianness, (0::Int), field) $ ifdExtended field) list + + getP raw = do + hdr <- get + readed <- bytesRead + skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed + let endian = hdrEndianness hdr + byOffset = sortBy (compare `on` ifdOffset) + cleanIfds = fmap (cleanImageFileDirectory endian) + + ifd <- cleanIfds . byOffset <$> getP endian + cleaned <- fetchExtended endian (B.length raw) ifd + return (hdr, [cleaned]) + +data TiffSampleFormat + = TiffSampleUint + | TiffSampleInt + | TiffSampleDouble + | TiffSampleUnknown + deriving Eq + +unpackSampleFormat :: Word32 -> Get TiffSampleFormat +unpackSampleFormat v = case v of + 1 -> pure TiffSampleUint + 2 -> pure TiffSampleInt + 3 -> pure TiffSampleDouble + 4 -> pure TiffSampleUnknown + vv -> fail $ "Undefined data format (" ++ show vv ++ ")" + +data ImageFileDirectory = ImageFileDirectory + { ifdIdentifier :: !ExifTag -- Word16 + , ifdType :: !IfdType -- Word16 + , ifdCount :: !Word32 + , ifdOffset :: !Word32 + , ifdExtended :: !ExifData + } + deriving Show + +instance BinaryParam Endianness ImageFileDirectory where + getP endianness = + ImageFileDirectory <$> getE <*> getE <*> getE <*> getE + <*> pure ExifNone + where getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + putP endianness ifd = do + let putE :: (BinaryParam Endianness a) => a -> Put + putE = putP endianness + putE $ ifdIdentifier ifd + putE $ ifdType ifd + putE $ ifdCount ifd + putE $ ifdOffset ifd + +instance BinaryParam Endianness [ImageFileDirectory] where + getP endianness = do + count <- getP endianness :: Get Word16 + rez <- replicateM (fromIntegral count) $ getP endianness + _ <- getP endianness :: Get Word32 + pure rez + + + putP endianness lst = do + let count = fromIntegral $ length lst :: Word16 + putP endianness count + mapM_ (putP endianness) lst + putP endianness (0 :: Word32) + +data TiffColorspace + = TiffMonochromeWhite0 -- ^ 0 + | TiffMonochrome -- ^ 1 + | TiffRGB -- ^ 2 + | TiffPaleted -- ^ 3 + | TiffTransparencyMask -- ^ 4 + | TiffCMYK -- ^ 5 + | TiffYCbCr -- ^ 6 + | TiffCIELab -- ^ 8 + + +packPhotometricInterpretation :: TiffColorspace -> Word16 +packPhotometricInterpretation v = case v of + TiffMonochromeWhite0 -> 0 + TiffMonochrome -> 1 + TiffRGB -> 2 + TiffPaleted -> 3 + TiffTransparencyMask -> 4 + TiffCMYK -> 5 + TiffYCbCr -> 6 + TiffCIELab -> 8 + +unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace +unpackPhotometricInterpretation v = case v of + 0 -> pure TiffMonochromeWhite0 + 1 -> pure TiffMonochrome + 2 -> pure TiffRGB + 3 -> pure TiffPaleted + 4 -> pure TiffTransparencyMask + 5 -> pure TiffCMYK + 6 -> pure TiffYCbCr + 8 -> pure TiffCIELab + vv -> fail $ "Unrecognized color space " ++ show vv + +data ExtraSample + = ExtraSampleUnspecified -- ^ 0 + | ExtraSampleAssociatedAlpha -- ^ 1 + | ExtraSampleUnassociatedAlpha -- ^ 2 + +codeOfExtraSample :: ExtraSample -> Word16 +codeOfExtraSample v = case v of + ExtraSampleUnspecified -> 0 + ExtraSampleAssociatedAlpha -> 1 + ExtraSampleUnassociatedAlpha -> 2 + +unPackCompression :: Word32 -> Get TiffCompression +unPackCompression v = case v of + 0 -> pure CompressionNone + 1 -> pure CompressionNone + 2 -> pure CompressionModifiedRLE + 5 -> pure CompressionLZW + 6 -> pure CompressionJPEG + 32773 -> pure CompressionPackBit + vv -> fail $ "Unknown compression scheme " ++ show vv + +packCompression :: TiffCompression -> Word16 +packCompression v = case v of + CompressionNone -> 1 + CompressionModifiedRLE -> 2 + CompressionLZW -> 5 + CompressionJPEG -> 6 + CompressionPackBit -> 32773 +