Better exif parsing, including image resolution.

This introduces a dependency on binary >= 0.6, but we depend
on binary >= 0.5 via zip-archive anyway.

Closes #976.

2 files changed, 212 insertions, 16 deletions

diff --git a/pandoc.cabal b/pandoc.cabal
index a1a4c9b40..94d382c4f 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -232,7 +232,8 @@ Library
                  attoparsec >= 0.10 && < 0.11,
                  yaml >= 0.8.3 && < 0.9,
                  vector >= 0.10 && < 0.11,
-                 hslua >= 0.3 && < 0.4
+                 hslua >= 0.3 && < 0.4,
+                 binary >= 0.6 && < 0.8
   Build-Tools:   alex, happy
   if flag(http-conduit)
      Build-Depends: http-conduit >= 1.9 && < 2.1,
diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs
index e2a8b8283..467205220 100644
--- a/src/Text/Pandoc/ImageSize.hs
+++ b/src/Text/Pandoc/ImageSize.hs
@@ -32,9 +32,14 @@ module Text.Pandoc.ImageSize ( ImageType(..), imageType, imageSize,
                     sizeInPixels, sizeInPoints ) where
 import Data.ByteString (ByteString, unpack)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import Control.Applicative
 import Control.Monad
 import Data.Bits
+import Data.Binary
+import Data.Binary.Get
 import Text.Pandoc.Shared (safeRead)
+import qualified Data.Map as M
 
 -- quick and dirty functions to get image sizes
 -- algorithms borrowed from wwwis.pl
@@ -143,7 +148,7 @@ jpegSize img = do
   guard $ B.length rest >= 14
   case hdr of
        "\xff\xd8\xff\xe0" -> jfifSize rest
-       "\xff\xd8\xff\xe1" -> exifSize rest
+       "\xff\xd8\xff\xe1" -> exifSize $ B.takeWhile (/= '\xff') rest
        _                  -> mzero
 
 jfifSize :: ByteString -> Maybe ImageSize
@@ -177,18 +182,208 @@ findJfifSize bs = do
        Nothing -> fail "Did not find length record"
 
 exifSize :: ByteString -> Maybe ImageSize
-exifSize rest = do
-  let bs' = B.takeWhile (/='\xff') $ B.drop 8 rest  -- exif data
-  let (_,bs'') = B.breakSubstring "\xa0\x02" bs' -- width
-  let rawWidth = B.take 2 $ B.drop 10 bs''
-  let (_,bs''') = B.breakSubstring "\xa0\x03" bs' -- height
-  let rawHeight = B.take 2 $ B.drop 10 bs'''
-  let tonum bs =  case map fromIntegral $ unpack bs of
-                       [x,y]  -> Just $ shift x 8 + y
-                       _      -> Nothing
-  case (tonum rawWidth, tonum rawHeight) of
-       (Just w, Just h) ->
-                 return $ ImageSize { pxX = w, pxY = h, dpiX = 72, dpiY = 72 }
-       _      -> fail "Could not determine exif image size"
-  -- some day, figure out how to parse dpi from exif
+exifSize = -- runGet ((Just <$> exifHeader) `mplus` return Nothing) .
+  runGet (Just <$> exifHeader) .
+           BL.fromChunks . (:[])
 
+exifHeader :: Get ImageSize
+exifHeader = do
+  _app1DataSize <- getWord16be
+  exifHdr <- getWord32be
+  unless (exifHdr == 0x45786966) $ fail "Did not find exif header"
+  zeros <- getWord16be
+  unless (zeros == 0) $ fail "Expected zeros after exif header"
+  -- beginning of tiff header -- we read whole thing to use
+  -- in getting data from offsets:
+  tiffHeader <- lookAhead getRemainingLazyByteString
+  byteAlign <- getWord16be
+  let bigEndian = byteAlign == 0x4d4d
+  let (getWord16, getWord32, getWord64) =
+        if bigEndian
+           then (getWord16be, getWord32be, getWord64be)
+           else (getWord16le, getWord32le, getWord64le)
+  let getRational = do
+        num <- getWord32
+        den <- getWord32
+        return $ fromIntegral num / fromIntegral den
+  tagmark <- getWord16
+  unless (tagmark == 0x002a) $ fail "Failed alignment sanity check"
+  ifdOffset <- getWord32
+  skip (fromIntegral ifdOffset - 8) -- skip to IDF
+  numentries <- getWord16
+  let ifdEntry = do
+       tag <- getWord16 >>= \t ->
+                maybe (fail $ "Unknown tag type " ++ show t) return
+                (M.lookup t tagTypeTable)
+       dataFormat <- getWord16
+       numComponents <- getWord32
+       (fmt, bytesPerComponent) <-
+             case dataFormat of
+                  1  -> return (UnsignedByte . runGet getWord8, 1)
+                  2  -> return (AsciiString, 1)
+                  3  -> return (UnsignedShort . runGet getWord16, 2)
+                  4  -> return (UnsignedLong . runGet getWord32, 4)
+                  5  -> return (UnsignedRational . runGet getRational, 8)
+                  6  -> return (SignedByte . runGet getWord8, 1)
+                  7  -> return (Undefined . runGet getWord8, 1)
+                  8  -> return (SignedShort . runGet getWord16, 2)
+                  9  -> return (SignedLong . runGet getWord32, 4)
+                  10 -> return (SignedRational . runGet getRational, 8)
+                  11 -> return (SingleFloat . runGet getWord32 {- TODO -}, 4)
+                  12 -> return (DoubleFloat . runGet getWord64 {- TODO -}, 8)
+                  _  -> fail $ "Unknown data format " ++ show dataFormat
+       let totalBytes = fromIntegral $ numComponents * bytesPerComponent
+       payload <- if totalBytes <= 4 -- data is right here
+                     then (fmt . BL.fromChunks . (:[])) <$>
+                          (getByteString totalBytes <*
+                          skip (4 - totalBytes))
+                     else do  -- get data from offset
+                          offs <- getWord32
+                          return $ fmt $ BL.take (fromIntegral totalBytes) $
+                                   BL.drop (fromIntegral offs) tiffHeader
+       return (tag, payload)
+  entries <- sequence $ replicate (fromIntegral numentries) ifdEntry
+  subentries <- case lookup ExifOffset entries of
+                      Just (UnsignedLong offset) -> do
+                        pos <- bytesRead
+                        skip (fromIntegral offset - (fromIntegral pos - 8))
+                        numsubentries <- getWord16
+                        sequence $
+                           replicate (fromIntegral numsubentries) ifdEntry
+                      _ -> return []
+  let allentries = entries ++ subentries
+  (width, height) <- case (lookup ExifImageWidth allentries,
+                           lookup ExifImageHeight allentries) of
+                          (Just (UnsignedLong w), Just (UnsignedLong h)) ->
+                            return (fromIntegral w, fromIntegral h)
+                          _ -> fail "Could not determine image width, height"
+  let resfactor = case lookup ResolutionUnit allentries of
+                        Just (UnsignedShort 1) -> (100 / 254)
+                        _ -> 1
+  let xres = maybe 72 (\(UnsignedRational x) -> floor $ x * resfactor)
+             $ lookup XResolution allentries
+  let yres = maybe 72 (\(UnsignedRational x) -> floor $ x * resfactor)
+             $ lookup YResolution allentries
+  return $ ImageSize{
+                    pxX  = width
+                  , pxY  = height
+                  , dpiX = xres
+                  , dpiY = yres }
+
+data DataFormat = UnsignedByte Word8
+                | AsciiString BL.ByteString
+                | UnsignedShort Word16
+                | UnsignedLong Word32
+                | UnsignedRational Rational
+                | SignedByte Word8
+                | Undefined Word8
+                | SignedShort Word16
+                | SignedLong Word32
+                | SignedRational Rational
+                | SingleFloat Word32
+                | DoubleFloat Word64
+                deriving (Show)
+
+data TagType = ImageDescription
+             | Make
+             | Model
+             | Orientation
+             | XResolution
+             | YResolution
+             | ResolutionUnit
+             | Software
+             | DateTime
+             | WhitePoint
+             | PrimaryChromaticities
+             | YCbCrCoefficients
+             | YCbCrPositioning
+             | ReferenceBlackWhite
+             | Copyright
+             | ExifOffset
+             | ExposureTime
+             | FNumber
+             | ExposureProgram
+             | ISOSpeedRatings
+             | ExifVersion
+             | DateTimeOriginal
+             | DateTimeDigitized
+             | ComponentConfiguration
+             | CompressedBitsPerPixel
+             | ShutterSpeedValue
+             | ApertureValue
+             | BrightnessValue
+             | ExposureBiasValue
+             | MaxApertureValue
+             | SubjectDistance
+             | MeteringMode
+             | LightSource
+             | Flash
+             | FocalLength
+             | MakerNote
+             | UserComment
+             | FlashPixVersion
+             | ColorSpace
+             | ExifImageWidth
+             | ExifImageHeight
+             | RelatedSoundFile
+             | ExifInteroperabilityOffset
+             | FocalPlaneXResolution
+             | FocalPlaneYResolution
+             | FocalPlaneResolutionUnit
+             | SensingMethod
+             | FileSource
+             | SceneType
+             deriving (Show, Eq, Ord)
+
+tagTypeTable :: M.Map Word16 TagType
+tagTypeTable = M.fromList
+  [ (0x010e, ImageDescription)
+  , (0x010f, Make)
+  , (0x0110, Model)
+  , (0x0112, Orientation)
+  , (0x011a, XResolution)
+  , (0x011b, YResolution)
+  , (0x0128, ResolutionUnit)
+  , (0x0131, Software)
+  , (0x0132, DateTime)
+  , (0x013e, WhitePoint)
+  , (0x013f, PrimaryChromaticities)
+  , (0x0211, YCbCrCoefficients)
+  , (0x0213, YCbCrPositioning)
+  , (0x0214, ReferenceBlackWhite)
+  , (0x8298, Copyright)
+  , (0x8769, ExifOffset)
+  , (0x829a, ExposureTime)
+  , (0x829d, FNumber)
+  , (0x8822, ExposureProgram)
+  , (0x8827, ISOSpeedRatings)
+  , (0x9000, ExifVersion)
+  , (0x9003, DateTimeOriginal)
+  , (0x9004, DateTimeDigitized)
+  , (0x9101, ComponentConfiguration)
+  , (0x9102, CompressedBitsPerPixel)
+  , (0x9201, ShutterSpeedValue)
+  , (0x9202, ApertureValue)
+  , (0x9203, BrightnessValue)
+  , (0x9204, ExposureBiasValue)
+  , (0x9205, MaxApertureValue)
+  , (0x9206, SubjectDistance)
+  , (0x9207, MeteringMode)
+  , (0x9208, LightSource)
+  , (0x9209, Flash)
+  , (0x920a, FocalLength)
+  , (0x927c, MakerNote)
+  , (0x9286, UserComment)
+  , (0xa000, FlashPixVersion)
+  , (0xa001, ColorSpace)
+  , (0xa002, ExifImageWidth)
+  , (0xa003, ExifImageHeight)
+  , (0xa004, RelatedSoundFile)
+  , (0xa005, ExifInteroperabilityOffset)
+  , (0xa20e, FocalPlaneXResolution)
+  , (0xa20f, FocalPlaneYResolution)
+  , (0xa210, FocalPlaneResolutionUnit)
+  , (0xa217, SensingMethod)
+  , (0xa300, FileSource)
+  , (0xa301, SceneType)
+  ]