{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.PDF.Image(
PDFJpeg
, JpegFile
, RawImage
, PDFFilter(..)
, createPDFJpeg
, readJpegFile
, jpegBounds
, readJpegDataURL
, createPDFRawImageFromARGB
, createPDFRawImageFromByteString
) where
import Graphics.PDF.LowLevel.Types
import qualified Data.Map.Strict as M
import Graphics.PDF.Draw
import Graphics.PDF.Resources
import Graphics.PDF.Pages
import qualified Data.ByteString.Lazy as B
import Control.Monad.Writer
#if __GLASGOW_HASKELL__ >= 608
import System.IO hiding(withFile)
#else
import System.IO
#endif
import Data.Char(ord)
import Data.Bits
#if __GLASGOW_HASKELL__ >= 710
import qualified Control.Monad.Except as EXC
#else
import qualified Control.Monad.Error as EXC
#endif
import Graphics.PDF.Coordinates
import Data.Binary.Builder(Builder,fromLazyByteString,fromByteString)
import Control.Exception as E
import qualified Data.Vector.Unboxed as U
import Data.Word
import qualified Data.ByteString.Char8 as C8 (ByteString, pack, index, length)
import Data.ByteString.Base64(decode)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Error.Util (note)
data JpegFile = JpegFile !Int !Int !Int !Int !Builder
data PDFFilter = ASCIIHexDecode
| ASCII85Decode
| LZWDecode
| FlateDecode
| RunLengthDecode
| CCITTFaxDecode
| DCTDecode
| NoFilter
m_sof0 :: Int
m_sof0 = 0xc0
m_sof1 :: Int
m_sof1 = 0xc1
m_sof2 :: Int
m_sof2 = 0xc2
m_sof3 :: Int
m_sof3 = 0xc3
m_sof5 :: Int
m_sof5 = 0xc5
m_sof6 :: Int
m_sof6 = 0xc6
m_sof7 :: Int
m_sof7 = 0xc7
m_sof9 :: Int
m_sof9 = 0xc9
m_sof10 :: Int
m_sof10 = 0xca
m_sof11 :: Int
m_sof11 = 0xcb
m_sof13 :: Int
m_sof13 = 0xcd
m_sof14 :: Int
m_sof14 = 0xce
m_sof15 :: Int
m_sof15 = 0xcf
m_rst0 :: Int
m_rst0 = 0xd0
m_rst1 :: Int
m_rst1 = 0xd1
m_rst2 :: Int
m_rst2 = 0xd2
m_rst3 :: Int
m_rst3 = 0xd3
m_rst4 :: Int
m_rst4 = 0xd4
m_rst5 :: Int
m_rst5 = 0xd5
m_rst6 :: Int
m_rst6 = 0xd6
m_rst7 :: Int
m_rst7 = 0xd7
m_soi :: Int
m_soi = 0xd8
m_eoi :: Int
m_eoi = 0xd9
m_sos :: Int
m_sos = 0xda
m_tem :: Int
m_tem = 0x01
io :: IO a -> FA a
io = FA . liftIO
#if __GLASGOW_HASKELL__ >= 710
newtype FA a = FA { unFA :: EXC.ExceptT String IO a}
#else
newtype FA a = FA { unFA :: EXC.ErrorT String IO a}
#endif
#ifndef __HADDOCK__
deriving(Monad,Applicative,EXC.MonadError String,Functor)
#else
instance Monad FA
instance MonadError String FA
instance MonadIO FA
instance Functor FA
#endif
runFA :: FA a -> IO (Either String a)
#if __GLASGOW_HASKELL__ >= 710
runFA = EXC.runExceptT . unFA
#else
runFA = EXC.runErrorT . unFA
#endif
readWord16 :: Handle -> FA Int
readWord16 h = io $ do
hi <- hGetChar h
lo <- hGetChar h
return $ ((fromEnum hi) `shiftL` 8) .|. (fromEnum . ord $ lo)
readWord8 :: Handle -> FA Int
readWord8 h = io $ do
lo <- hGetChar h
return $ fromEnum . ord $ lo
parseJpegContent :: Handle -> FA (Int,Int,Int,Int)
parseJpegContent h = do
r <- readWord8 h
when (r /= 0x0FF) $ EXC.throwError "No marker found"
sof <- readWord8 h
case sof of
a | a `elem` [m_sof5,m_sof6,m_sof7,m_sof9,m_sof10,m_sof11,m_sof13,m_sof14,m_sof15] ->
EXC.throwError "Unuspported compression mode"
| a `elem` [m_sof0,m_sof1,m_sof2,m_sof3] -> do
_ <- readWord16 h
bits_per_component <- readWord8 h
height <- readWord16 h
width <- readWord16 h
color_space <- readWord8 h
return (bits_per_component,height,width,color_space)
| a `elem` [m_soi,m_tem,m_rst0,m_rst1,m_rst2,m_rst3,m_rst4,m_rst5,m_rst6,m_rst7] -> parseJpegContent h
| a == m_sos -> let
loop = do
x <- readWord8 h
if x /= 0xff then loop else do
y <- readWord8 h
if y == 0x00 then loop else do
io $ hSeek h RelativeSeek (-2)
parseJpegContent h
in loop
| a == m_eoi -> EXC.throwError "parseJpegContent: hit end of image (EOI) marker before getting JPEG metadata"
| otherwise -> do
l <- readWord16 h
io $ hSeek h RelativeSeek (fromIntegral (l-2))
parseJpegContent h
analyzeJpeg :: Handle -> FA (Int,Int,Int,Int)
analyzeJpeg h = do
io $ hSeek h SeekFromEnd 0
io $ hSeek h AbsoluteSeek 0
header <- readWord16 h
when (header /= 0x0FFD8) $ EXC.throwError "Not a JPEG File"
io $ hSeek h AbsoluteSeek 0
(bits_per_component,height,width,color_space) <- parseJpegContent h
unless (color_space `elem` [1,3,4]) $ EXC.throwError "Color space not supported"
return (bits_per_component,height,width,color_space)
withFile :: String -> (Handle -> IO c) -> IO c
withFile name = bracket (openBinaryFile name ReadMode) hClose
readJpegFile :: FilePath
-> IO (Either String JpegFile)
readJpegFile f = (do
r <- liftIO $ withFile f $ \h -> do
runFA (analyzeJpeg h)
case r of
Right (bits_per_component,height,width,color_space) -> do
img <- liftIO $ withFile f $ \h' -> do
nb <- hFileSize h'
B.hGet h' (fromIntegral nb)
return (Right $ JpegFile bits_per_component width height color_space (fromLazyByteString img))
Left s -> return $ Left s) `E.catch` (\(err :: IOException) -> return $ Left (show err))
jpegBounds :: JpegFile -> (Int,Int)
jpegBounds (JpegFile _ w h _ _) = (w,h)
createPDFJpeg :: JpegFile
-> PDF (PDFReference PDFJpeg)
createPDFJpeg (JpegFile bits_per_component width height color_space img) = do
PDFReference s <- createContent a' Nothing
recordBound s (fromIntegral width) (fromIntegral height)
return (PDFReference s)
where
color c = case c of
1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]
3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]
4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")
,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])
]
_ -> error "Jpeg color space not supported"
a' =
do modifyStrict $ \s -> s {otherRsrcs = PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")
, (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")
, (PDFName "Width",AnyPdfObject . PDFInteger $ width)
, (PDFName "Height",AnyPdfObject . PDFInteger $ height)
, (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)
, (PDFName "Interpolate", AnyPdfObject True)
, (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")
] ++ color color_space
}
tell img
createPDFRawImageFromByteString :: Int
-> Int
-> Bool
-> PDFFilter
-> B.ByteString
-> PDF (PDFReference RawImage)
createPDFRawImageFromByteString width height interpolate pdfFilter stream = do
PDFReference s <- createContent a' Nothing
recordBound s (fromIntegral width) (fromIntegral height)
return (PDFReference s)
where
getFilter = case pdfFilter of
NoFilter -> []
ASCIIHexDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "ASCIIHexDecode")]
ASCII85Decode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "ASCII85Decode")]
LZWDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "LZWDecode")]
FlateDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "FlateDecode")]
RunLengthDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "RunLengthDecode")]
CCITTFaxDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "CCITTFaxDecode")]
DCTDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")]
a' = do
modifyStrict $ \s -> s {otherRsrcs = PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")
, (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")
, (PDFName "Width",AnyPdfObject . PDFInteger $ width)
, (PDFName "Height",AnyPdfObject . PDFInteger $ height)
, (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ 8)
, (PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")
, (PDFName "Interpolate", AnyPdfObject interpolate)
] ++ getFilter
}
tell . fromLazyByteString $ stream
createPDFRawImageFromARGB :: Int
-> Int
-> Bool
-> U.Vector Word32
-> PDF (PDFReference RawImage)
createPDFRawImageFromARGB width height interpolate stream = do
PDFReference s <- createContent a' Nothing
recordBound s (fromIntegral width) (fromIntegral height)
return (PDFReference s)
where
addPixel (a:t) =
let xa = fromIntegral $ (a `shiftR` 16) .&. 0x0FF
xb = fromIntegral $ (a `shiftR` 8) .&. 0x0FF
xc = fromIntegral $ (a `shiftR` 0) .&. 0x0FF
in
xa:xb:xc:addPixel t
addPixel [] = []
a' = do
modifyStrict $ \s -> s {otherRsrcs = PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")
, (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")
, (PDFName "Width",AnyPdfObject . PDFInteger $ width)
, (PDFName "Height",AnyPdfObject . PDFInteger $ height)
, (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ 8)
, (PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")
, (PDFName "Interpolate", AnyPdfObject interpolate)
]
}
tell . fromLazyByteString . B.pack . addPixel . U.toList $ stream
sIndex :: C8.ByteString -> Int -> Maybe Char
sIndex bs idx =
if (idx < 0) || (idx > C8.length bs)
then Nothing
else Just $ bs `C8.index` idx
sReadWord8 :: C8.ByteString -> Int -> Maybe Int
sReadWord8 bs idx = (fromEnum . ord) <$> (bs `sIndex` idx)
sReadWord16 :: C8.ByteString -> Int -> Maybe Int
sReadWord16 bs idx = do
hi <- sReadWord8 bs idx
lo <- sReadWord8 bs (idx + 1)
return $ (hi `shiftL` 8) .|. lo
parseJpegDetailData :: C8.ByteString -> Int -> Maybe (Int,Int,Int,Int)
parseJpegDetailData bs offset = do
bpc <- sReadWord8 bs (offset + 4)
hgt <- sReadWord16 bs (offset + 5)
wdt <- sReadWord16 bs (offset + 7)
cls <- sReadWord8 bs (offset + 9)
return (bpc, hgt, wdt, cls)
(?|) :: Maybe b -> a -> Either a b
(?|) = flip note
parseJpegContentData :: C8.ByteString -> Int -> Either String (Int,Int,Int,Int)
parseJpegContentData bs offset = do
r <- sReadWord8 bs offset ?| "Corrupt JPEG data URL - no marker found"
guard (r == 0x0FF) ?| "Corrupt JPEG data URL - no marker found"
sof <- (sReadWord8 bs (offset + 1)) ?| "Corrupt JPEG data URL - no start of file offset found"
case sof of
a | a `elem` [m_sof5,m_sof6,m_sof7,m_sof9,m_sof10,m_sof11,m_sof13,m_sof14,m_sof15] -> Left "Unsupported compression mode"
| a `elem` [m_sof0,m_sof1,m_sof3] -> (parseJpegDetailData bs offset) ?| "Corrupt JPEG data URL - insufficient data in URL"
| a `elem` [m_soi,m_eoi,m_tem,m_rst0,m_rst1,m_rst2,m_rst3,m_rst4,m_rst5,m_rst6,m_rst7] -> parseJpegContentData bs (offset + 2)
| otherwise -> do
l <- (sReadWord16 bs (offset + 2)) ?| "Corrupt JPEG data URL - insufficient data in URL"
parseJpegContentData bs (offset + l + 2)
checkColorSpace :: (Int,Int,Int,Int) -> Either String (Int,Int,Int,Int)
checkColorSpace hdrData@(_,_,_,color_space) = do
guard (color_space `elem` [1,3,4]) ?| ("Color space [" ++ show color_space ++ "] not supported")
return hdrData
analyzeJpegData :: C8.ByteString -> Either String (Int,Int,Int,Int)
analyzeJpegData bs = do
header <- sReadWord16 bs 0 ?| "Not a JPEG data URL - no marker found"
guard (header == 0x0FFD8) ?| "Not a JPEG data URL - invalid JPEG marker"
hdrData <- parseJpegContentData bs 0
checkColorSpace hdrData
readJpegData :: String -> Either String JpegFile
readJpegData dataString = do
bs <- decode $ C8.pack dataString
(bits_per_component,height,width,color_space) <- analyzeJpegData bs
return $ JpegFile bits_per_component width height color_space (fromByteString bs)
readJpegDataURL :: String -> Either String JpegFile
readJpegDataURL dataurl = do
guard (take 23 dataurl == "data:image/jpeg;base64,") ?| "Data URL does not start with a valid JPEG header"
readJpegData $ drop 23 dataurl
data PDFJpeg
instance PDFXObject PDFJpeg where
drawXObject a = withNewContext $ do
(width,height) <- bounds a
applyMatrix (scale width height)
privateDrawXObject a
instance PdfObject PDFJpeg where
toPDF _ = noPdfObject
instance PdfLengthInfo PDFJpeg where
instance PdfResourceObject (PDFReference PDFJpeg) where
toRsrc = AnyPdfObject
data RawImage
instance PDFXObject RawImage where
drawXObject a = withNewContext $ do
(width,height) <- bounds a
applyMatrix (scale width height)
privateDrawXObject a
instance PdfObject RawImage where
toPDF _ = noPdfObject
instance PdfLengthInfo RawImage where
instance PdfResourceObject (PDFReference RawImage) where
toRsrc = AnyPdfObject