diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs index 1f1bba7..a4ede07 100644 --- a/src/Codec/Picture/Jpg.hs +++ b/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 diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs index 9cd25bf..f553938 100644 --- a/src/Codec/Picture/Jpg/Types.hs +++ b/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 -> diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs index 023d4ea..ce4799b 100644 --- a/src/Codec/Picture/Tiff.hs +++ b/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 diff --git a/src/Codec/Picture/Tiff/Types.hs b/src/Codec/Picture/Tiff/Types.hs index 3687e49..3eaf0f2 100644 --- a/src/Codec/Picture/Tiff/Types.hs +++ b/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