JPEG EXIF loading

src/Codec/Picture/Jpg.hs

@@ -28,6 +28,7 @@ import Control.Monad.Trans( lift )
 import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS )
 
 import Data.Bits( (.|.), unsafeShiftL )
+import Data.Monoid( (<>) )
 import Data.Int( Int16, Int32 )
 import Data.Word(Word8, Word32)
 import Data.Binary( Binary(..), encode )
@@ -46,6 +47,8 @@ import Codec.Picture.InternalHelper
 import Codec.Picture.BitWriter
 import Codec.Picture.Types
 import Codec.Picture.Metadata( Metadatas )
+import Codec.Picture.Tiff.Types
+import Codec.Picture.Tiff.Metadata
 import Codec.Picture.Jpg.Types
 import Codec.Picture.Jpg.Common
 import Codec.Picture.Jpg.Progressive
@@ -241,6 +244,7 @@ data JpgDecoderState = JpgDecoderState
     , currentFrame          :: Maybe JpgFrameHeader
     , app14Marker           :: !(Maybe JpgAdobeApp14)
     , app0JFifMarker        :: !(Maybe JpgJFIFApp0)
+    , app1ExifMarker        :: !(Maybe [ImageFileDirectory])
     , componentIndexMapping :: ![(Word8, Int)]
     , isProgressive         :: !Bool
     , maximumHorizontalResolution :: !Int
@@ -268,6 +272,7 @@ emptyDecoderState = JpgDecoderState
     , componentIndexMapping = []
     , app14Marker = Nothing
     , app0JFifMarker = Nothing
+    , app1ExifMarker = Nothing
     , isProgressive        = False
     , maximumHorizontalResolution = 0
     , maximumVerticalResolution   = 0
@@ -279,6 +284,8 @@ emptyDecoderState = JpgDecoderState
 jpgMachineStep :: JpgFrame -> JpgScripter s ()
 jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s ->
     s { app14Marker = Just app14 }
+jpgMachineStep (JpgExif exif) = modify $ \s ->
+    s { app1ExifMarker = Just exif }
 jpgMachineStep (JpgJFIF app0) = modify $ \s ->
     s { app0JFifMarker = Just app0 }
 jpgMachineStep (JpgAppFrame _ _) = pure ()
@@ -548,7 +555,9 @@ decodeJpegWithMetadata file = case runGetStrict get file of
   Right img -> case imgKind of
      Just BaseLineDCT ->
        let (st, arr) = decodeBaseline
-           meta = foldMap extractMetadatas $ app0JFifMarker st
+           jfifMeta = foldMap extractMetadatas $ app0JFifMarker st
+           exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st
+           meta = jfifMeta <> exifMeta
        in
        (, meta) <$>
            dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr

src/Codec/Picture/Jpg/Types.hs

@@ -64,6 +64,7 @@ import Data.Binary.Put( Put
 
 import Codec.Picture.InternalHelper
 import Codec.Picture.Jpg.DefaultTable
+import Codec.Picture.Tiff.Types
 
 {-import Debug.Trace-}
 import Text.Printf
@@ -104,6 +105,7 @@ data JpgFrame =
       JpgAppFrame        !Word8 B.ByteString
     | JpgAdobeAPP14      !JpgAdobeApp14
     | JpgJFIF            !JpgJFIFApp0
+    | JpgExif            ![ImageFileDirectory]
     | JpgExtension       !Word8 B.ByteString
     | JpgQuantTable      ![JpgQuantTableSpec]
     | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanPackedTree)]
@@ -428,6 +430,9 @@ putFrame :: JpgFrame -> Put
 putFrame (JpgAdobeAPP14 _adobe) = return ()
 putFrame (JpgJFIF jfif) =
     put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif
+putFrame (JpgExif _exif) =
+    return () -- TODO
+    {-put (JpgAppSegment 0) >> put exif-}
 putFrame (JpgAppFrame appCode str) =
     put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
 putFrame (JpgExtension appCode str) =
@@ -480,6 +485,17 @@ parseJF__  str lst = go where
     Left _err -> lst
     Right jfif -> JpgJFIF jfif : lst
 
+parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame]
+parseExif str lst 
+  | exifHeader `B.isPrefixOf` str = go
+  | otherwise = lst
+  where
+    exifHeader = BC.pack "Exif\0\0"
+    tiff = B.drop (B.length exifHeader) str
+    go = case runGetStrict (getP tiff) tiff of
+      Left _err -> lst
+      Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst
+
 parseFrames :: Get [JpgFrame]
 parseFrames = do
     kind <- get
@@ -495,6 +511,8 @@ parseFrames = do
         JpgEndOfImage -> return []
         JpgAppSegment 0 ->
             parseJF__ <$> takeCurrentFrame <*> parseNextFrame
+        JpgAppSegment 1 ->
+            parseExif <$> takeCurrentFrame <*> parseNextFrame
         JpgAppSegment 14 ->
             parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame
         JpgAppSegment c ->

src/Codec/Picture/Tiff.hs

@@ -43,11 +43,9 @@ import Control.Monad.Writer.Strict( execWriter, tell, Writer )
 import Data.Int( Int8 )
 import Data.Word( Word8, Word16, Word32 )
 import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
-import Data.Binary( Binary( .. ) )
-import Data.Binary.Get( Get, bytesRead, skip)
-import Data.Binary.Put( runPut, putByteString )
+import Data.Binary.Get( Get )
+import Data.Binary.Put( runPut )
 
-import Data.List( sortBy, mapAccumL )
 import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Storable.Mutable as M
@@ -91,19 +89,6 @@ unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v
 unLong _ (ExtendedDataLong v) = pure v
 unLong errMessage _ = fail errMessage
 
-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 -> [ImageFileDirectory] -> Get [ImageFileDirectory]
-fetchExtended endian = mapM $ \ifd -> do
-  v <- getP (endian, ifd)
-  pure $ ifd { ifdExtended = v }
-
 findIFD :: String -> TiffTag -> [ImageFileDirectory]
         -> Get ImageFileDirectory
 findIFD errorMessage tag lst =
@@ -578,83 +563,40 @@ ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory
                     EndianLittle -> (V.head v, ExtendedDataNone)
                     EndianBig -> (V.head v `unsafeShiftL` 16, ExtendedDataNone)
 
--- | 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 = ExtendedDataAscii b }) =
-            (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } )
-        updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v })
-            | V.length v > 1 = ( ix + fromIntegral (V.length v * 4)
-                               , ifd { ifdOffset = ix } )
-        updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort v })
-            | V.length v > 2 = ( ix + fromIntegral (V.length v * 2)
-                             , ifd { ifdOffset = ix })
-        updater ix ifd = (ix, ifd)
-
 instance BinaryParam B.ByteString TiffInfo where
-  putP rawData nfo = do
-    put $ tiffHeader nfo
-
-    let ifdStartOffset = hdrOffset $ tiffHeader nfo
-        endianness = hdrEndianness $ tiffHeader nfo
-
-        ifdShort = ifdSingleShort endianness
-        ifdShorts = ifdMultiShort endianness
-        list = setupIfdOffsets ifdStartOffset . orderIfdByTag . execWriter $ do
-            ifdSingleLong TagImageWidth $ tiffWidth nfo
-            ifdSingleLong TagImageLength $ tiffHeight nfo
-            ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo
-            ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo
-            ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo
-            ifdShort TagPhotometricInterpretation
-                                        . packPhotometricInterpretation
-                                        $ tiffColorspace nfo
-            ifdShort TagPlanarConfiguration
-                    . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo
-            ifdShort TagCompression . packCompression
-                                          $ tiffCompression nfo
-            ifdMultiLong TagStripOffsets $ tiffOffsets nfo
-
-            ifdMultiLong TagStripByteCounts $ tiffStripSize nfo
-
-            maybe (return ())
-                  (ifdShort TagExtraSample . codeOfExtraSample)
-                $ tiffExtraSample nfo
-
-            let subSampling = tiffYCbCrSubsampling nfo
-            unless (V.null subSampling) $
-                 ifdShorts TagYCbCrSubsampling subSampling
-
-    putByteString rawData
-    putP endianness list
-    mapM_ (\ifd -> putP (endianness, ifd) $ ifdExtended ifd) list
-
-  getP _ = do
-    hdr <- get
-    readed <- bytesRead
-    skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed
-    let endian = hdrEndianness hdr
-
-    ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian
-    cleaned <- fetchExtended endian ifd
+  putP rawData nfo = putP rawData (tiffHeader nfo, list) where
+    endianness = hdrEndianness $ tiffHeader nfo
+
+    ifdShort = ifdSingleShort endianness
+    ifdShorts = ifdMultiShort endianness
+
+    list = execWriter $ do
+      ifdSingleLong TagImageWidth $ tiffWidth nfo
+      ifdSingleLong TagImageLength $ tiffHeight nfo
+      ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo
+      ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo
+      ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo
+      ifdShort TagPhotometricInterpretation
+                                  . packPhotometricInterpretation
+                                  $ tiffColorspace nfo
+      ifdShort TagPlanarConfiguration
+              . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo
+      ifdShort TagCompression . packCompression
+                                    $ tiffCompression nfo
+      ifdMultiLong TagStripOffsets $ tiffOffsets nfo
+
+      ifdMultiLong TagStripByteCounts $ tiffStripSize nfo
+
+      maybe (return ())
+            (ifdShort TagExtraSample . codeOfExtraSample)
+          $ tiffExtraSample nfo
+
+      let subSampling = tiffYCbCrSubsampling nfo
+      unless (V.null subSampling) $
+           ifdShorts TagYCbCrSubsampling subSampling
+
+  getP rawData = do
+    (hdr, cleaned) <- getP rawData
 
     let dataFind str tag = findIFDData str tag cleaned
         dataDefault def tag = findIFDDefaultData def tag cleaned

src/Codec/Picture/Tiff/Types.hs

@@ -48,7 +48,7 @@ import Data.Binary.Put( Put
                       , putWord32le, putWord32be
                       , putByteString
                       )
-
+import Data.List( sortBy, mapAccumL )
 import qualified Data.Vector as V
 import qualified Data.ByteString as B
 import Data.Word( Word16, Word32 )
@@ -391,6 +391,69 @@ instance BinaryParam (Endianness, ImageFileDirectory) ExtendedDirectoryData wher
           align ifd >> (ExtendedDataLong <$> getVec count getE)
       fetcher _ = pure ExtendedDataNone
 
+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 -> [ImageFileDirectory] -> Get [ImageFileDirectory]
+fetchExtended endian = mapM $ \ifd -> do
+  v <- getP (endian, 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 = ExtendedDataAscii b }) =
+            (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v })
+            | V.length v > 1 = ( ix + fromIntegral (V.length v * 4)
+                               , ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort 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, ifd) $ ifdExtended ifd) list
+
+  getP _ = do
+    hdr <- get
+    readed <- bytesRead
+    skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed
+    let endian = hdrEndianness hdr
+
+    ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian
+    cleaned <- fetchExtended endian ifd
+    return (hdr, cleaned)
+
 data TiffSampleFormat
   = TiffSampleUint
   | TiffSampleInt