ImageSize: use JuicyPixels to extract size...

...for png, jpeg, gif, instead of doing our own binary parsing.
See #6936.

1 files changed, 8 insertions, 305 deletions

diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs
index 8517d07c2..665a94690 100644
--- a/src/Text/Pandoc/ImageSize.hs
+++ b/src/Text/Pandoc/ImageSize.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns      #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {- |
@@ -32,14 +32,12 @@ module Text.Pandoc.ImageSize ( ImageType(..)
                              , showInPixel
                              , showFl
                              ) where
-import Data.ByteString (ByteString, unpack)
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
+import Data.Binary.Get
 import Data.Char (isDigit)
 import Control.Monad
-import Data.Bits
-import Data.Binary
-import Data.Binary.Get
 import Text.Pandoc.Shared (safeRead)
 import Data.Default (Default)
 import Numeric (showFFloat)
@@ -47,12 +45,9 @@ import Text.Pandoc.Definition
 import Text.Pandoc.Options
 import qualified Text.Pandoc.UTF8 as UTF8
 import qualified Text.XML.Light as Xml
-import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
-import Control.Monad.Except
 import Control.Applicative
-import Data.Maybe (fromMaybe)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Codec.Picture.Metadata as Metadata
 import Codec.Picture (decodeImageWithMetadata)
@@ -124,9 +119,9 @@ findSvgTag img = "<svg" `B.isInfixOf` img || "<SVG" `B.isInfixOf` img
 imageSize :: WriterOptions -> ByteString -> Either T.Text ImageSize
 imageSize opts img = checkDpi <$>
   case imageType img of
-       Just Png  -> pngSize img
-       Just Gif  -> mbToEither "could not determine GIF size" $ gifSize img
-       Just Jpeg -> jpegSize img
+       Just Png  -> getSize img
+       Just Gif  -> getSize img
+       Just Jpeg -> getSize img
        Just Svg  -> mbToEither "could not determine SVG size" $ svgSize opts img
        Just Eps  -> mbToEither "could not determine EPS size" $ epsSize img
        Just Pdf  -> mbToEither "could not determine PDF size" $ pdfSize img
@@ -141,9 +136,6 @@ imageSize opts img = checkDpi <$>
               , dpiY = if dpiY size == 0 then 72 else dpiY size }
 
 
-defaultSize :: (Integer, Integer)
-defaultSize = (72, 72)
-
 sizeInPixels :: ImageSize -> (Integer, Integer)
 sizeInPixels s = (pxX s, pxY s)
 
@@ -302,8 +294,8 @@ pPdfSize = do
             , dpiY = 72 }
    ) <|> pPdfSize
 
-pngSize :: ByteString -> Either T.Text ImageSize
-pngSize img =
+getSize :: ByteString -> Either T.Text ImageSize
+getSize img =
   case decodeImageWithMetadata img of
     Left e -> Left (T.pack e)
     Right (_, meta) -> do
@@ -319,18 +311,6 @@ pngSize img =
                 , dpiX = fromIntegral dpix
                 , dpiY = fromIntegral dpiy }
 
-gifSize :: ByteString -> Maybe ImageSize
-gifSize img = do
-  let (h, rest) = B.splitAt 6 img
-  guard $ h == "GIF87a" || h == "GIF89a"
-  case map fromIntegral $ unpack $ B.take 4 rest of
-       [w2,w1,h2,h1] -> return ImageSize {
-                          pxX  = shift w1 8 + w2,
-                          pxY  = shift h1 8 + h2,
-                          dpiX = 72,
-                          dpiY = 72
-                          }
-       _             -> Nothing -- "GIF parse error"
 
 svgSize :: WriterOptions -> ByteString -> Maybe ImageSize
 svgSize opts img = do
@@ -378,280 +358,3 @@ emfSize img =
     case parseheader . BL.fromStrict $ img of
       Left _ -> Nothing
       Right (_, _, size) -> Just size
-
-
-jpegSize :: ByteString -> Either T.Text ImageSize
-jpegSize img =
-  let (hdr, rest) = B.splitAt 4 img
-  in if B.length rest < 14
-        then Left "unable to determine JPEG size"
-        else case hdr of
-               "\xff\xd8\xff\xe0" -> jfifSize rest
-               "\xff\xd8\xff\xe1" -> exifSize rest
-               _                  -> Left "unable to determine JPEG size"
-
-jfifSize :: ByteString -> Either T.Text ImageSize
-jfifSize rest =
-  case map fromIntegral $ unpack $ B.take 5 $ B.drop 9 rest of
-    [dpiDensity,dpix1,dpix2,dpiy1,dpiy2] ->
-      let factor = case dpiDensity of
-                        1 -> id
-                        2 -> \x -> x * 254 `div` 10
-                        _ -> const 72
-          dpix = factor (shift dpix1 8 + dpix2)
-          dpiy = factor (shift dpiy1 8 + dpiy2)
-      in case findJfifSize rest of
-         Left msg    -> Left msg
-         Right (w,h) -> Right ImageSize { pxX = w
-                                        , pxY = h
-                                        , dpiX = dpix
-                                        , dpiY = dpiy }
-    _ -> Left "unable to determine JFIF size"
-
-findJfifSize :: ByteString -> Either T.Text (Integer,Integer)
-findJfifSize bs =
-  let bs' = B.dropWhile (=='\xff') $ B.dropWhile (/='\xff') bs
-  in case B.uncons bs' of
-       Just (c,bs'') | c >= '\xc0' && c <= '\xc3' ->
-         case map fromIntegral $ unpack $ B.take 4 $ B.drop 3 bs'' of
-              [h1,h2,w1,w2] -> Right (shift w1 8 + w2, shift h1 8 + h2)
-              _             -> Left "JFIF parse error"
-       Just (_,bs'') ->
-         case map fromIntegral $ unpack $ B.take 2 bs'' of
-              [c1,c2] ->
-                let len = shift c1 8 + c2
-                -- skip variables
-                in  findJfifSize $ B.drop len bs''
-              _       -> Left "JFIF parse error"
-       Nothing -> Left "Did not find JFIF length record"
-
-runGet' :: Get (Either T.Text a) -> BL.ByteString -> Either T.Text a
-runGet' p bl =
-#if MIN_VERSION_binary(0,7,0)
-  case runGetOrFail p bl of
-       Left (_,_,msg) -> Left $ T.pack msg
-       Right (_,_,x)  -> x
-#else
-  runGet p bl
-#endif
-
-exifSize :: ByteString -> Either T.Text ImageSize
-exifSize bs = runGet' header bl
-  where bl = BL.fromChunks [bs]
-        header = runExceptT $ exifHeader bl
--- NOTE:  It would be nicer to do
--- runGet ((Just <$> exifHeader) <|> return Nothing)
--- which would prevent pandoc from raising an error when an exif header can't
--- be parsed.  But we only get an Alternative instance for Get in binary 0.6,
--- and binary 0.5 ships with ghc 7.6.
-
-exifHeader :: BL.ByteString -> ExceptT T.Text Get ImageSize
-exifHeader hdr = do
-  _app1DataSize <- lift getWord16be
-  exifHdr <- lift getWord32be
-  unless (exifHdr == 0x45786966) $ throwError "Did not find exif header"
-  zeros <- lift getWord16be
-  unless (zeros == 0) $ throwError "Expected zeros after exif header"
-  -- beginning of tiff header -- we read whole thing to use
-  -- in getting data from offsets:
-  let tiffHeader = BL.drop 8 hdr
-  byteAlign <- lift 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 <- lift getWord16
-  unless (tagmark == 0x002a) $ throwError "Failed alignment sanity check"
-  ifdOffset <- lift getWord32
-  lift $ skip (fromIntegral ifdOffset - 8) -- skip to IDF
-  numentries <- lift  getWord16
-  let ifdEntry :: ExceptT T.Text Get (TagType, DataFormat)
-      ifdEntry = do
-       tag <- fromMaybe UnknownTagType . flip M.lookup tagTypeTable
-                <$> lift getWord16
-       dataFormat <- lift getWord16
-       numComponents <- lift getWord32
-       (fmt, bytesPerComponent) <-
-             case dataFormat of
-                  1  -> return (UnsignedByte <$> getWord8, 1)
-                  2  -> return (AsciiString <$>
-                                getLazyByteString
-                                (fromIntegral numComponents), 1)
-                  3  -> return (UnsignedShort <$> getWord16, 2)
-                  4  -> return (UnsignedLong <$> getWord32, 4)
-                  5  -> return (UnsignedRational <$> getRational, 8)
-                  6  -> return (SignedByte <$> getWord8, 1)
-                  7  -> return (Undefined <$> getLazyByteString
-                                (fromIntegral numComponents), 1)
-                  8  -> return (SignedShort <$> getWord16, 2)
-                  9  -> return (SignedLong <$> getWord32, 4)
-                  10 -> return (SignedRational <$> getRational, 8)
-                  11 -> return (SingleFloat <$> getWord32 {- TODO -}, 4)
-                  12 -> return (DoubleFloat <$> getWord64 {- TODO -}, 8)
-                  _  -> throwError $ "Unknown data format " <> T.pack (show dataFormat)
-       let totalBytes = fromIntegral $ numComponents * bytesPerComponent
-       payload <- if totalBytes <= 4 -- data is right here
-                     then lift $ fmt <* skip (4 - totalBytes)
-                     else do  -- get data from offset
-                          offs <- lift getWord32
-                          let bytesAtOffset =
-                                 BL.take (fromIntegral totalBytes)
-                                 $ BL.drop (fromIntegral offs) tiffHeader
-                          case runGet' (Right <$> fmt) bytesAtOffset of
-                               Left msg -> throwError msg
-                               Right x  -> return x
-       return (tag, payload)
-  entries <- replicateM (fromIntegral numentries) ifdEntry
-  subentries <- case lookup ExifOffset entries of
-                      Just (UnsignedLong offset') -> do
-                        pos <- lift bytesRead
-                        lift $ skip (fromIntegral offset' - (fromIntegral pos - 8))
-                        numsubentries <- lift getWord16
-                        replicateM (fromIntegral numsubentries) ifdEntry
-                      _ -> return []
-  let allentries = entries ++ subentries
-  (wdth, hght) <- case (lookup ExifImageWidth allentries,
-                        lookup ExifImageHeight allentries) of
-                       (Just (UnsignedLong w), Just (UnsignedLong h)) ->
-                         return (fromIntegral w, fromIntegral h)
-                       _ -> return defaultSize
-                            -- we return a default width and height when
-                            -- the exif header doesn't contain these
-  let resfactor = case lookup ResolutionUnit allentries of
-                        Just (UnsignedShort 1) -> 100 / 254
-                        _ -> 1
-  let xres = case lookup XResolution allentries of
-                  Just (UnsignedRational x) -> floor (x * resfactor)
-                  _ -> 72
-  let yres = case lookup YResolution allentries of
-                  Just (UnsignedRational y) -> floor (y * resfactor)
-                  _ -> 72
-  return ImageSize{
-                    pxX  = wdth
-                  , pxY  = hght
-                  , dpiX = xres
-                  , dpiY = yres }
-
-data DataFormat = UnsignedByte Word8
-                | AsciiString BL.ByteString
-                | UnsignedShort Word16
-                | UnsignedLong Word32
-                | UnsignedRational Rational
-                | SignedByte Word8
-                | Undefined BL.ByteString
-                | 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
-             | UnknownTagType
-             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)
-  ]