JuicyPixels 3.2.8.3 → 3.2.9
raw patch · 10 files changed
+1256/−1039 lines, 10 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Codec.Picture.Metadata: extractExifMetas :: Metadatas -> [(ExifTag, ExifData)]
+ Codec.Picture.Metadata.Exif: TagFlash :: ExifTag
+ Codec.Picture.Metadata.Exif: TagLightSource :: ExifTag
+ Codec.Picture.Metadata.Exif: isInIFD0 :: ExifTag -> Bool
Files
- JuicyPixels.cabal +2/−2
- README.md +2/−2
- changelog +8/−1
- src/Codec/Picture/Jpg.hs +4/−0
- src/Codec/Picture/Jpg/Types.hs +28/−4
- src/Codec/Picture/Metadata.hs +270/−259
- src/Codec/Picture/Metadata/Exif.hs +218/−205
- src/Codec/Picture/Tiff.hs +4/−3
- src/Codec/Picture/Tiff/Metadata.hs +237/−98
- src/Codec/Picture/Tiff/Types.hs +483/−465
JuicyPixels.cabal view
@@ -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: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -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)
README.md view
@@ -1,7 +1,6 @@  -[](https://travis-ci.org/Twinside/Juicy.Pixels) [](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.
changelog view
@@ -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
src/Codec/Picture/Jpg.hs view
@@ -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
src/Codec/Picture/Jpg/Types.hs view
@@ -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
src/Codec/Picture/Metadata.hs view
@@ -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 + ] +
src/Codec/Picture/Metadata/Exif.hs view
@@ -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` ()
src/Codec/Picture/Tiff.hs view
@@ -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
src/Codec/Picture/Tiff/Metadata.hs view
@@ -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 +
src/Codec/Picture/Tiff/Types.hs view
@@ -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 +