{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
---------------------------------------------------------
-- |
-- Copyright   : (c) 2006-2016, alpheccar.org
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- PDF Images
---------------------------------------------------------

module Graphics.PDF.Image(
   -- * Images
   -- ** Types
     PDFJpeg
   , JpegFile
   , RawImage
   , PDFFilter(..)
   -- ** Functions
   , createPDFJpeg
   , readJpegFile
   , jpegBounds
   , readJpegDataURL
   , createPDFRawImageFromARGB
   , createPDFRawImageFromByteString
 ) where
     
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Draw
import Graphics.PDF.Resources
import Graphics.PDF.Pages
import qualified Data.ByteString.Lazy as B
import Control.Monad
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)

-- | A Jpeg file   
data JpegFile = JpegFile !Int !Int !Int !Int !Builder

data PDFFilter = ASCIIHexDecode
               | ASCII85Decode
               | LZWDecode
               | FlateDecode
               | RunLengthDecode
               | CCITTFaxDecode
               | DCTDecode 
               | NoFilter

m_sof0 :: Int
m_sof0 :: Int
m_sof0 = Int
0xc0 
m_sof1 :: Int 
m_sof1 :: Int
m_sof1 = Int
0xc1 
m_sof2 :: Int 
m_sof2 :: Int
m_sof2 = Int
0xc2  
m_sof3 :: Int 
m_sof3 :: Int
m_sof3 = Int
0xc3  
m_sof5 :: Int 
m_sof5 :: Int
m_sof5 = Int
0xc5 
m_sof6 :: Int  
m_sof6 :: Int
m_sof6 = Int
0xc6 
m_sof7 :: Int  
m_sof7 :: Int
m_sof7 = Int
0xc7  
--m_jpg :: Int 
--m_jpg = 0xc8  
m_sof9 :: Int  
m_sof9 :: Int
m_sof9 = Int
0xc9  
m_sof10 :: Int 
m_sof10 :: Int
m_sof10 = Int
0xca
m_sof11 :: Int 
m_sof11 :: Int
m_sof11 = Int
0xcb
m_sof13 :: Int 
m_sof13 :: Int
m_sof13 = Int
0xcd 
m_sof14 :: Int 
m_sof14 :: Int
m_sof14 = Int
0xce 
m_sof15 :: Int 
m_sof15 :: Int
m_sof15 = Int
0xcf 
--m_dht :: Int 
--m_dht = 0xc4   
--m_dac :: Int 
--m_dac = 0xcc   
m_rst0 :: Int              
m_rst0 :: Int
m_rst0 = Int
0xd0  
m_rst1 :: Int 
m_rst1 :: Int
m_rst1 = Int
0xd1 
m_rst2 :: Int  
m_rst2 :: Int
m_rst2 = Int
0xd2  
m_rst3 :: Int 
m_rst3 :: Int
m_rst3 = Int
0xd3
m_rst4 :: Int   
m_rst4 :: Int
m_rst4 = Int
0xd4 
m_rst5 :: Int  
m_rst5 :: Int
m_rst5 = Int
0xd5
m_rst6 :: Int   
m_rst6 :: Int
m_rst6 = Int
0xd6 
m_rst7 :: Int  
m_rst7 :: Int
m_rst7 = Int
0xd7  
m_soi :: Int 
m_soi :: Int
m_soi = Int
0xd8 
m_eoi :: Int   
m_eoi :: Int
m_eoi = Int
0xd9 
m_sos :: Int   
m_sos :: Int
m_sos = Int
0xda
--m_dqt :: Int    
--m_dqt = 0xdb 
--m_dnl :: Int   
--m_dnl = 0xdc
--m_dri :: Int    
--m_dri = 0xdd
--m_dhp :: Int    
--m_dhp = 0xde
--m_exp :: Int    
--m_exp = 0xdf
--m_app0 :: Int    
--m_app0 = 0xe0  
--m_app1 :: Int 
--m_app1 = 0xe1  
--m_app2 :: Int 
--m_app2 = 0xe2  
--m_app3 :: Int 
--m_app3 = 0xe3  
--m_app4 :: Int 
--m_app4 = 0xe4 
--m_app5 :: Int  
--m_app5 = 0xe5  
--m_app6 :: Int 
--m_app6 = 0xe6  
--m_app7 :: Int 
--m_app7 = 0xe7 
--m_app8 :: Int  
--m_app8 = 0xe8  
--m_app9 :: Int 
--m_app9 = 0xe9  
--m_app10 :: Int 
--m_app10 = 0xea
--m_app11 :: Int 
--m_app11 = 0xeb
--m_app12 :: Int 
--m_app12 = 0xec
--m_app13 :: Int 
--m_app13 = 0xed
--m_app14 :: Int 
--m_app14 = 0xee
--m_app15 :: Int 
--m_app15 = 0xef
--m_jpg0 :: Int 
--m_jpg0 = 0xf0 
--m_jpg13 :: Int 
--m_jpg13 = 0xfd
--m_com :: Int 
--m_com = 0xfe
m_tem :: Int 
m_tem :: Int
m_tem = Int
0x01 
--m_error :: Int 
--m_error = 0x100 
   
io :: IO a -> FA a 
io :: forall a. IO a -> FA a
io = ExceptT String IO a -> FA a
forall a. ExceptT String IO a -> FA a
FA (ExceptT String IO a -> FA a)
-> (IO a -> ExceptT String IO a) -> IO a -> FA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ExceptT String IO a
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | File analyzer monad
#if __GLASGOW_HASKELL__ >= 710
newtype FA a = FA { forall a. FA a -> ExceptT String IO a
unFA :: EXC.ExceptT String IO a}
#else
newtype FA a = FA { unFA :: EXC.ErrorT String IO a}
#endif
#ifndef __HADDOCK__
  deriving(Applicative FA
Applicative FA =>
(forall a b. FA a -> (a -> FA b) -> FA b)
-> (forall a b. FA a -> FA b -> FA b)
-> (forall a. a -> FA a)
-> Monad FA
forall a. a -> FA a
forall a b. FA a -> FA b -> FA b
forall a b. FA a -> (a -> FA b) -> FA b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. FA a -> (a -> FA b) -> FA b
>>= :: forall a b. FA a -> (a -> FA b) -> FA b
$c>> :: forall a b. FA a -> FA b -> FA b
>> :: forall a b. FA a -> FA b -> FA b
$creturn :: forall a. a -> FA a
return :: forall a. a -> FA a
Monad,Functor FA
Functor FA =>
(forall a. a -> FA a)
-> (forall a b. FA (a -> b) -> FA a -> FA b)
-> (forall a b c. (a -> b -> c) -> FA a -> FA b -> FA c)
-> (forall a b. FA a -> FA b -> FA b)
-> (forall a b. FA a -> FA b -> FA a)
-> Applicative FA
forall a. a -> FA a
forall a b. FA a -> FA b -> FA a
forall a b. FA a -> FA b -> FA b
forall a b. FA (a -> b) -> FA a -> FA b
forall a b c. (a -> b -> c) -> FA a -> FA b -> FA c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> FA a
pure :: forall a. a -> FA a
$c<*> :: forall a b. FA (a -> b) -> FA a -> FA b
<*> :: forall a b. FA (a -> b) -> FA a -> FA b
$cliftA2 :: forall a b c. (a -> b -> c) -> FA a -> FA b -> FA c
liftA2 :: forall a b c. (a -> b -> c) -> FA a -> FA b -> FA c
$c*> :: forall a b. FA a -> FA b -> FA b
*> :: forall a b. FA a -> FA b -> FA b
$c<* :: forall a b. FA a -> FA b -> FA a
<* :: forall a b. FA a -> FA b -> FA a
Applicative,EXC.MonadError String,(forall a b. (a -> b) -> FA a -> FA b)
-> (forall a b. a -> FA b -> FA a) -> Functor FA
forall a b. a -> FA b -> FA a
forall a b. (a -> b) -> FA a -> FA b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FA a -> FA b
fmap :: forall a b. (a -> b) -> FA a -> FA b
$c<$ :: forall a b. a -> FA b -> FA a
<$ :: forall a b. a -> FA b -> FA a
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 :: forall a. FA a -> IO (Either String a)
runFA = ExceptT String IO a -> IO (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
EXC.runExceptT (ExceptT String IO a -> IO (Either String a))
-> (FA a -> ExceptT String IO a) -> FA a -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FA a -> ExceptT String IO a
forall a. FA a -> ExceptT String IO a
unFA
#else
runFA = EXC.runErrorT . unFA
#endif

readWord16 :: Handle -> FA Int
readWord16 :: Handle -> FA Int
readWord16 Handle
h = IO Int -> FA Int
forall a. IO a -> FA a
io (IO Int -> FA Int) -> IO Int -> FA Int
forall a b. (a -> b) -> a -> b
$ do
    Char
hi <- Handle -> IO Char
hGetChar Handle
h
    Char
lo <- Handle -> IO Char
hGetChar Handle
h
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ ((Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
hi) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Char
lo)

readWord8 :: Handle -> FA Int
readWord8 :: Handle -> FA Int
readWord8 Handle
h = IO Int -> FA Int
forall a. IO a -> FA a
io (IO Int -> FA Int) -> IO Int -> FA Int
forall a b. (a -> b) -> a -> b
$ do
    Char
lo <- Handle -> IO Char
hGetChar Handle
h
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Char
lo
            
--optional :: FA (Maybe a) -> FA (Maybe a)
--optional a = a --`catchError` (\e -> return Nothing)

--jfif :: Handle -> FA (Maybe (Double,Double))
--jfif h = do
--     header <- readWord16 h
--     when (header /= 0x0FFE0) $ throwError (strMsg "No JFIF magic number")
--     readWord16 h
--     mapM_ check "JFIF"
--     readWord16 h
--     unit <- readWord8 h
--     width <- fromIntegral `fmap` readWord16 h
--     height <- fromIntegral `fmap` readWord16 h
--     case unit of
--         1 -> return $ Just (width,height)
--         2 -> return $ Just (width*2.54,height*2.54)
--         _ -> return $ Just (0,0)
--    where
--     check c' = do
--         c <- io $ hGetChar h
--         when (c /= c') $ throwError (strMsg "No JFIF header")
           
parseJpegContent :: Handle -> FA (Int,Int,Int,Int)
parseJpegContent :: Handle -> FA (Int, Int, Int, Int)
parseJpegContent Handle
h = do
    Int
r <- Handle -> FA Int
readWord8 Handle
h
    Bool -> FA () -> FA ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=  Int
0x0FF) (FA () -> FA ()) -> FA () -> FA ()
forall a b. (a -> b) -> a -> b
$ String -> FA ()
forall a. String -> FA a
forall e (m :: * -> *) a. MonadError e m => e -> m a
EXC.throwError String
"No marker found"
    Int
sof <- Handle -> FA Int
readWord8 Handle
h
    case Int
sof of
        Int
a | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_sof5,Int
m_sof6,Int
m_sof7,Int
m_sof9,Int
m_sof10,Int
m_sof11,Int
m_sof13,Int
m_sof14,Int
m_sof15] ->
                String -> FA (Int, Int, Int, Int)
forall a. String -> FA a
forall e (m :: * -> *) a. MonadError e m => e -> m a
EXC.throwError String
"Unuspported compression mode"
          | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_sof0,Int
m_sof1,Int
m_sof2,Int
m_sof3] -> do
              Int
_ <- Handle -> FA Int
readWord16 Handle
h
              Int
bits_per_component <- Handle -> FA Int
readWord8 Handle
h
              Int
height <- Handle -> FA Int
readWord16 Handle
h
              Int
width <- Handle -> FA Int
readWord16 Handle
h
              Int
color_space  <- Handle -> FA Int
readWord8 Handle
h
              (Int, Int, Int, Int) -> FA (Int, Int, Int, Int)
forall a. a -> FA a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
bits_per_component,Int
height,Int
width,Int
color_space)                  
          | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_soi,Int
m_tem,Int
m_rst0,Int
m_rst1,Int
m_rst2,Int
m_rst3,Int
m_rst4,Int
m_rst5,Int
m_rst6,Int
m_rst7] -> Handle -> FA (Int, Int, Int, Int)
parseJpegContent Handle
h
          | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m_sos -> let
            loop :: FA (Int, Int, Int, Int)
loop = do
              Int
x <- Handle -> FA Int
readWord8 Handle
h
              if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0xff then FA (Int, Int, Int, Int)
loop else do
                Int
y <- Handle -> FA Int
readWord8 Handle
h
                if Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x00 then FA (Int, Int, Int, Int)
loop else do
                  IO () -> FA ()
forall a. IO a -> FA a
io (IO () -> FA ()) -> IO () -> FA ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
RelativeSeek (-Integer
2)
                  Handle -> FA (Int, Int, Int, Int)
parseJpegContent Handle
h
            in FA (Int, Int, Int, Int)
loop
          | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m_eoi -> String -> FA (Int, Int, Int, Int)
forall a. String -> FA a
forall e (m :: * -> *) a. MonadError e m => e -> m a
EXC.throwError String
"parseJpegContent: hit end of image (EOI) marker before getting JPEG metadata"
          | Bool
otherwise -> do
               Int
l <- Handle -> FA Int
readWord16 Handle
h
               IO () -> FA ()
forall a. IO a -> FA a
io (IO () -> FA ()) -> IO () -> FA ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
RelativeSeek (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2))
               Handle -> FA (Int, Int, Int, Int)
parseJpegContent Handle
h

analyzeJpeg :: Handle -> FA (Int,Int,Int,Int)
analyzeJpeg :: Handle -> FA (Int, Int, Int, Int)
analyzeJpeg Handle
h = do
    -- Get Length
    IO () -> FA ()
forall a. IO a -> FA a
io (IO () -> FA ()) -> IO () -> FA ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
SeekFromEnd Integer
0
    --fileLength <- io $ hTell h
    IO () -> FA ()
forall a. IO a -> FA a
io (IO () -> FA ()) -> IO () -> FA ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
0
    -- Check jpeg
    Int
header <- Handle -> FA Int
readWord16 Handle
h
    Bool -> FA () -> FA ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
header Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0x0FFD8) (FA () -> FA ()) -> FA () -> FA ()
forall a b. (a -> b) -> a -> b
$ String -> FA ()
forall a. String -> FA a
forall e (m :: * -> *) a. MonadError e m => e -> m a
EXC.throwError String
"Not a JPEG File"
   
    -- Extract resolution from jfif
    --res <- optional $ jfif h
    
    IO () -> FA ()
forall a. IO a -> FA a
io (IO () -> FA ()) -> IO () -> FA ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
0
    
    (Int
bits_per_component,Int
height,Int
width,Int
color_space) <- Handle -> FA (Int, Int, Int, Int)
parseJpegContent Handle
h
    --io $ print fileLength
    --io $ print res
    --io $ print bits_per_component
    --io $ print height
    --io $ print width
    --io $ print color_space
    --io $ hClose h
    Bool -> FA () -> FA ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
color_space Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
3,Int
4]) (FA () -> FA ()) -> FA () -> FA ()
forall a b. (a -> b) -> a -> b
$ String -> FA ()
forall a. String -> FA a
forall e (m :: * -> *) a. MonadError e m => e -> m a
EXC.throwError String
"Color space not supported"
    (Int, Int, Int, Int) -> FA (Int, Int, Int, Int)
forall a. a -> FA a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
bits_per_component,Int
height,Int
width,Int
color_space)
    
--test = analyzePng "Test/logo.png"
    
withFile :: String -> (Handle -> IO c) -> IO c    
withFile :: forall c. String -> (Handle -> IO c) -> IO c
withFile String
name = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IOMode -> IO Handle
openBinaryFile String
name IOMode
ReadMode) Handle -> IO ()
hClose

-- | Read a JPEG file and return an abstract description of its content or an error
-- The read is not lazy. The whole image will be loaded into memory
readJpegFile :: FilePath
             -> IO (Either String JpegFile)
readJpegFile :: String -> IO (Either String JpegFile)
readJpegFile String
f = (do
     Either String (Int, Int, Int, Int)
r <- IO (Either String (Int, Int, Int, Int))
-> IO (Either String (Int, Int, Int, Int))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Int, Int, Int, Int))
 -> IO (Either String (Int, Int, Int, Int)))
-> IO (Either String (Int, Int, Int, Int))
-> IO (Either String (Int, Int, Int, Int))
forall a b. (a -> b) -> a -> b
$ String
-> (Handle -> IO (Either String (Int, Int, Int, Int)))
-> IO (Either String (Int, Int, Int, Int))
forall c. String -> (Handle -> IO c) -> IO c
withFile String
f ((Handle -> IO (Either String (Int, Int, Int, Int)))
 -> IO (Either String (Int, Int, Int, Int)))
-> (Handle -> IO (Either String (Int, Int, Int, Int)))
-> IO (Either String (Int, Int, Int, Int))
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
             FA (Int, Int, Int, Int) -> IO (Either String (Int, Int, Int, Int))
forall a. FA a -> IO (Either String a)
runFA (Handle -> FA (Int, Int, Int, Int)
analyzeJpeg Handle
h)
     case Either String (Int, Int, Int, Int)
r of
         Right (Int
bits_per_component,Int
height,Int
width,Int
color_space) -> do
                 ByteString
img <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> (Handle -> IO ByteString) -> IO ByteString
forall c. String -> (Handle -> IO c) -> IO c
withFile String
f ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
h' -> do
                     Integer
nb <- Handle -> IO Integer
hFileSize Handle
h'
                     Handle -> Int -> IO ByteString
B.hGet Handle
h' (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nb)
                 Either String JpegFile -> IO (Either String JpegFile)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JpegFile -> Either String JpegFile
forall a b. b -> Either a b
Right (JpegFile -> Either String JpegFile)
-> JpegFile -> Either String JpegFile
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Builder -> JpegFile
JpegFile Int
bits_per_component Int
width Int
height Int
color_space (ByteString -> Builder
fromLazyByteString ByteString
img))
         Left String
s -> Either String JpegFile -> IO (Either String JpegFile)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String JpegFile -> IO (Either String JpegFile))
-> Either String JpegFile -> IO (Either String JpegFile)
forall a b. (a -> b) -> a -> b
$ String -> Either String JpegFile
forall a b. a -> Either a b
Left String
s) IO (Either String JpegFile)
-> (IOException -> IO (Either String JpegFile))
-> IO (Either String JpegFile)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(IOException
err :: IOException) -> Either String JpegFile -> IO (Either String JpegFile)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String JpegFile -> IO (Either String JpegFile))
-> Either String JpegFile -> IO (Either String JpegFile)
forall a b. (a -> b) -> a -> b
$ String -> Either String JpegFile
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show IOException
err)) 

-- | Get the JPEG bounds
jpegBounds :: JpegFile -> (Int,Int)
jpegBounds :: JpegFile -> (Int, Int)
jpegBounds (JpegFile Int
_ Int
w Int
h Int
_ Builder
_) = (Int
w,Int
h)

-- | Use an abstract description of a Jpeg to return a PDFReference that can be used to manipulate the Jpeg in the context
-- of the PDF document
createPDFJpeg :: JpegFile  
              -> PDF (PDFReference PDFJpeg)
createPDFJpeg :: JpegFile -> PDF (PDFReference PDFJpeg)
createPDFJpeg (JpegFile Int
bits_per_component Int
width Int
height Int
color_space Builder
img) = do
        PDFReference Int
s <- Draw ()
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
forall a.
Draw a
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
createContent Draw ()
a' Maybe (PDFReference PDFPage)
forall a. Maybe a
Nothing  
        Int -> PDFFloat -> PDFFloat -> PDF ()
recordBound Int
s (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)
        PDFReference PDFJpeg -> PDF (PDFReference PDFJpeg)
forall a. a -> PDF a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> PDFReference PDFJpeg
forall s. Int -> PDFReference s
PDFReference Int
s) 
    where
       color :: a -> [(PDFName, AnyPdfObject)]
color a
c = case a
c of
           a
1 -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"ColorSpace" (String -> PDFName
PDFName String
"DeviceGray")]
           a
3 -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"ColorSpace" (String -> PDFName
PDFName String
"DeviceRGB")]
           a
4 -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"ColorSpace" (String -> PDFName
PDFName String
"DeviceCMYK")
                ,String -> [PDFInteger] -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Decode" ((Int -> PDFInteger) -> [Int] -> [PDFInteger]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PDFInteger
PDFInteger ([Int] -> [PDFInteger]) -> [Int] -> [PDFInteger]
forall a b. (a -> b) -> a -> b
$ [Int
1,Int
0,Int
1,Int
0,Int
1,Int
0,Int
1,Int
0])
                ]
           a
_ -> String -> [(PDFName, AnyPdfObject)]
forall a. HasCallStack => String -> a
error String
"Jpeg color space not supported"
       a' :: Draw ()
a' = 
                 do (DrawState -> DrawState) -> Draw ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modifyStrict ((DrawState -> DrawState) -> Draw ())
-> (DrawState -> DrawState) -> Draw ()
forall a b. (a -> b) -> a -> b
$ \DrawState
s -> DrawState
s  {otherRsrcs = dictFromList $
                                                   [ entry "Type" (PDFName $ "XObject")
                                                   , entry "Subtype" (PDFName $ "Image")
                                                   , entry "Width" (PDFInteger $ width)
                                                   , entry "Height" (PDFInteger $ height)
                                                   , entry "BitsPerComponent" (PDFInteger $ bits_per_component)
                                                   , entry "Interpolate" True
                                                   , entry "Filter" (PDFName $ "DCTDecode")
                                                   ] ++ color color_space
                                             }
                    Builder -> Draw ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Builder
img        
        
createPDFRawImageFromByteString :: Int -- ^ Width
                                -> Int -- ^ Height
                                -> Bool -- ^ Interpolation
                                -> PDFFilter -- ^ Decompression filter to be sued by the PDF reader to render the picture
                                -> B.ByteString -- ^ RGB pixels
                                -> PDF (PDFReference RawImage)  
createPDFRawImageFromByteString :: Int
-> Int
-> Bool
-> PDFFilter
-> ByteString
-> PDF (PDFReference RawImage)
createPDFRawImageFromByteString Int
width Int
height Bool
interpolate PDFFilter
pdfFilter ByteString
stream =  do
        PDFReference Int
s <- Draw ()
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
forall a.
Draw a
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
createContent Draw ()
a' Maybe (PDFReference PDFPage)
forall a. Maybe a
Nothing  
        Int -> PDFFloat -> PDFFloat -> PDF ()
recordBound Int
s (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)
        PDFReference RawImage -> PDF (PDFReference RawImage)
forall a. a -> PDF a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> PDFReference RawImage
forall s. Int -> PDFReference s
PDFReference Int
s) 
    where     
        getFilter :: [(PDFName, AnyPdfObject)]
getFilter = case PDFFilter
pdfFilter of 
                    PDFFilter
NoFilter -> []
                    PDFFilter
ASCIIHexDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"ASCIIHexDecode")]
                    PDFFilter
ASCII85Decode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"ASCII85Decode")]
                    PDFFilter
LZWDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"LZWDecode")]
                    PDFFilter
FlateDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"FlateDecode")]
                    PDFFilter
RunLengthDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"RunLengthDecode")]
                    PDFFilter
CCITTFaxDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"CCITTFaxDecode")]
                    PDFFilter
DCTDecode -> [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Filter" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"DCTDecode")]

        a' :: Draw ()
a' =  do 
                (DrawState -> DrawState) -> Draw ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modifyStrict ((DrawState -> DrawState) -> Draw ())
-> (DrawState -> DrawState) -> Draw ()
forall a b. (a -> b) -> a -> b
$ \DrawState
s -> DrawState
s  {otherRsrcs = dictFromList $
                                                   [ entry "Type" (PDFName $ "XObject")
                                                   , entry "Subtype" (PDFName $ "Image")
                                                   , entry "Width" (PDFInteger $ width)
                                                   , entry "Height" (PDFInteger $ height)
                                                   , entry "BitsPerComponent" (PDFInteger $ 8)
                                                   , entry "ColorSpace" (PDFName "DeviceRGB")
                                                   , entry "Interpolate" interpolate
                                                   ] ++ getFilter
                                             }
                Builder -> Draw ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> Draw ())
-> (ByteString -> Builder) -> ByteString -> Draw ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
fromLazyByteString (ByteString -> Draw ()) -> ByteString -> Draw ()
forall a b. (a -> b) -> a -> b
$ ByteString
stream

createPDFRawImageFromARGB :: Int -- ^ Width
                          -> Int -- ^ Height
                          -> Bool -- ^ Interpolation
                          -> U.Vector Word32 -- ^ ARGB pixels (A component not used y the PDF document)
                          -> PDF (PDFReference RawImage)  
createPDFRawImageFromARGB :: Int -> Int -> Bool -> Vector Word32 -> PDF (PDFReference RawImage)
createPDFRawImageFromARGB Int
width Int
height Bool
interpolate Vector Word32
stream =  do
        PDFReference Int
s <- Draw ()
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
forall a.
Draw a
-> Maybe (PDFReference PDFPage) -> PDF (PDFReference PDFStream)
createContent Draw ()
a' Maybe (PDFReference PDFPage)
forall a. Maybe a
Nothing  
        Int -> PDFFloat -> PDFFloat -> PDF ()
recordBound Int
s (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> PDFFloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)
        PDFReference RawImage -> PDF (PDFReference RawImage)
forall a. a -> PDF a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> PDFReference RawImage
forall s. Int -> PDFReference s
PDFReference Int
s) 
    where
        addPixel :: [a] -> [a]
addPixel (a
a:[a]
t) =  
           let xa :: a
xa = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0FF
               xb :: a
xb = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0FF
               xc :: a
xc = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
0) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0FF
           in
           a
xaa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
xba -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
xca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a]
addPixel [a]
t
        addPixel [] = []
                        
        a' :: Draw ()
a' =  do 
                (DrawState -> DrawState) -> Draw ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modifyStrict ((DrawState -> DrawState) -> Draw ())
-> (DrawState -> DrawState) -> Draw ()
forall a b. (a -> b) -> a -> b
$ \DrawState
s -> DrawState
s  {otherRsrcs = dictFromList $
                                                   [ entry "Type" (PDFName $ "XObject")
                                                   , entry "Subtype" (PDFName $ "Image")
                                                   , entry "Width" (PDFInteger $  width)
                                                   , entry "Height" (PDFInteger $  height)
                                                   , entry "BitsPerComponent" (PDFInteger $ 8)
                                                   , entry "ColorSpace" (PDFName "DeviceRGB")
                                                   , entry "Interpolate" interpolate
                                                   ]
                                             }
                Builder -> Draw ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> Draw ())
-> (Vector Word32 -> Builder) -> Vector Word32 -> Draw ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
fromLazyByteString (ByteString -> Builder)
-> (Vector Word32 -> ByteString) -> Vector Word32 -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (Vector Word32 -> [Word8]) -> Vector Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word32] -> [Word8]
forall {a} {a}. (Integral a, Bits a, Num a) => [a] -> [a]
addPixel ([Word32] -> [Word8])
-> (Vector Word32 -> [Word32]) -> Vector Word32 -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word32 -> [Word32]
forall a. Unbox a => Vector a -> [a]
U.toList (Vector Word32 -> Draw ()) -> Vector Word32 -> Draw ()
forall a b. (a -> b) -> a -> b
$ Vector Word32
stream  

-- Read Jpeg from ByteString
sIndex :: C8.ByteString -> Int -> Maybe Char
sIndex :: ByteString -> Int -> Maybe Char
sIndex ByteString
bs Int
idx = 
  if (Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) Bool -> Bool -> Bool
|| (Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
C8.length ByteString
bs)
  then Maybe Char
forall a. Maybe a
Nothing
  else Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char) -> Char -> Maybe Char
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> Int -> Char
`C8.index` Int
idx

sReadWord8 :: C8.ByteString -> Int -> Maybe Int
sReadWord8 :: ByteString -> Int -> Maybe Int
sReadWord8 ByteString
bs Int
idx = (Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (Char -> Int) -> Maybe Char -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString
bs ByteString -> Int -> Maybe Char
`sIndex` Int
idx)

sReadWord16 :: C8.ByteString -> Int -> Maybe Int
sReadWord16 :: ByteString -> Int -> Maybe Int
sReadWord16 ByteString
bs Int
idx = do
  Int
hi <- ByteString -> Int -> Maybe Int
sReadWord8 ByteString
bs Int
idx
  Int
lo <- ByteString -> Int -> Maybe Int
sReadWord8 ByteString
bs (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Int
hi Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
lo

parseJpegDetailData :: C8.ByteString -> Int -> Maybe (Int,Int,Int,Int)
parseJpegDetailData :: ByteString -> Int -> Maybe (Int, Int, Int, Int)
parseJpegDetailData ByteString
bs Int
offset = do
  Int
bpc <- ByteString -> Int -> Maybe Int
sReadWord8  ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
  Int
hgt <- ByteString -> Int -> Maybe Int
sReadWord16 ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)
  Int
wdt <- ByteString -> Int -> Maybe Int
sReadWord16 ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
  Int
cls <- ByteString -> Int -> Maybe Int
sReadWord8  ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
9)
  (Int, Int, Int, Int) -> Maybe (Int, Int, Int, Int)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
bpc, Int
hgt, Int
wdt, Int
cls)

(?|) :: Maybe b -> a -> Either a b
?| :: forall b a. Maybe b -> a -> Either a b
(?|) = (a -> Maybe b -> Either a b) -> Maybe b -> a -> Either a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Maybe b -> Either a b
forall a b. a -> Maybe b -> Either a b
note

parseJpegContentData :: C8.ByteString -> Int -> Either String (Int,Int,Int,Int)
parseJpegContentData :: ByteString -> Int -> Either String (Int, Int, Int, Int)
parseJpegContentData ByteString
bs Int
offset = do
  Int
r <- ByteString -> Int -> Maybe Int
sReadWord8 ByteString
bs Int
offset Maybe Int -> String -> Either String Int
forall b a. Maybe b -> a -> Either a b
?| String
"Corrupt JPEG data URL - no marker found"
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x0FF) Maybe () -> String -> Either String ()
forall b a. Maybe b -> a -> Either a b
?| String
"Corrupt JPEG data URL - no marker found"
  Int
sof <- (ByteString -> Int -> Maybe Int
sReadWord8 ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Maybe Int -> String -> Either String Int
forall b a. Maybe b -> a -> Either a b
?| String
"Corrupt JPEG data URL - no start of file offset found"
  case Int
sof of
    Int
a | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_sof5,Int
m_sof6,Int
m_sof7,Int
m_sof9,Int
m_sof10,Int
m_sof11,Int
m_sof13,Int
m_sof14,Int
m_sof15] -> String -> Either String (Int, Int, Int, Int)
forall a b. a -> Either a b
Left String
"Unsupported compression mode"
      | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_sof0,Int
m_sof1,Int
m_sof3] -> (ByteString -> Int -> Maybe (Int, Int, Int, Int)
parseJpegDetailData ByteString
bs Int
offset) Maybe (Int, Int, Int, Int)
-> String -> Either String (Int, Int, Int, Int)
forall b a. Maybe b -> a -> Either a b
?| String
"Corrupt JPEG data URL - insufficient data in URL"
      | Int
a Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
m_soi,Int
m_eoi,Int
m_tem,Int
m_rst0,Int
m_rst1,Int
m_rst2,Int
m_rst3,Int
m_rst4,Int
m_rst5,Int
m_rst6,Int
m_rst7] -> ByteString -> Int -> Either String (Int, Int, Int, Int)
parseJpegContentData ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      | Bool
otherwise -> do 
          Int
l <- (ByteString -> Int -> Maybe Int
sReadWord16 ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) Maybe Int -> String -> Either String Int
forall b a. Maybe b -> a -> Either a b
?| String
"Corrupt JPEG data URL - insufficient data in URL"
          ByteString -> Int -> Either String (Int, Int, Int, Int)
parseJpegContentData ByteString
bs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

checkColorSpace :: (Int,Int,Int,Int) -> Either String (Int,Int,Int,Int)
checkColorSpace :: (Int, Int, Int, Int) -> Either String (Int, Int, Int, Int)
checkColorSpace hdrData :: (Int, Int, Int, Int)
hdrData@(Int
_,Int
_,Int
_,Int
color_space) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
color_space Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
3,Int
4]) Maybe () -> String -> Either String ()
forall b a. Maybe b -> a -> Either a b
?| (String
"Color space [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
color_space String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] not supported")
  (Int, Int, Int, Int) -> Either String (Int, Int, Int, Int)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int, Int, Int)
hdrData

analyzeJpegData :: C8.ByteString -> Either String (Int,Int,Int,Int)
analyzeJpegData :: ByteString -> Either String (Int, Int, Int, Int)
analyzeJpegData ByteString
bs = do
  Int
header <- ByteString -> Int -> Maybe Int
sReadWord16 ByteString
bs Int
0 Maybe Int -> String -> Either String Int
forall b a. Maybe b -> a -> Either a b
?| String
"Not a JPEG data URL - no marker found"
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
header Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x0FFD8) Maybe () -> String -> Either String ()
forall b a. Maybe b -> a -> Either a b
?| String
"Not a JPEG data URL - invalid JPEG marker" 
  (Int, Int, Int, Int)
hdrData <- ByteString -> Int -> Either String (Int, Int, Int, Int)
parseJpegContentData ByteString
bs Int
0
  (Int, Int, Int, Int) -> Either String (Int, Int, Int, Int)
checkColorSpace (Int, Int, Int, Int)
hdrData

readJpegData :: String -> Either String JpegFile
readJpegData :: String -> Either String JpegFile
readJpegData String
dataString = do
  ByteString
bs <- ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack String
dataString
  (Int
bits_per_component,Int
height,Int
width,Int
color_space) <- ByteString -> Either String (Int, Int, Int, Int)
analyzeJpegData ByteString
bs
  JpegFile -> Either String JpegFile
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (JpegFile -> Either String JpegFile)
-> JpegFile -> Either String JpegFile
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Builder -> JpegFile
JpegFile Int
bits_per_component Int
width Int
height Int
color_space (ByteString -> Builder
fromByteString ByteString
bs) 

-- | Reads a data URL string, and returns a JpegFile.
-- The incoming string must be a correctly formatted data URL for a JPEG.
-- You can convert jpeg files to data URLs at the following web site:
-- http://dataurl.net/#dataurlmaker
readJpegDataURL :: String -> Either String JpegFile
readJpegDataURL :: String -> Either String JpegFile
readJpegDataURL String
dataurl = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
23 String
dataurl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"data:image/jpeg;base64,") Maybe () -> String -> Either String ()
forall b a. Maybe b -> a -> Either a b
?| String
"Data URL does not start with a valid JPEG header"
  String -> Either String JpegFile
readJpegData (String -> Either String JpegFile)
-> String -> Either String JpegFile
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
23 String
dataurl   


     
-- | A Jpeg PDF object
data PDFJpeg
instance PDFXObject PDFJpeg where
    drawXObject :: PDFReference PDFJpeg -> Draw ()
drawXObject PDFReference PDFJpeg
a = Draw () -> Draw ()
forall a. Draw a -> Draw a
withNewContext (Draw () -> Draw ()) -> Draw () -> Draw ()
forall a b. (a -> b) -> a -> b
$ do
            (PDFFloat
width,PDFFloat
height) <- PDFReference PDFJpeg -> Draw (PDFFloat, PDFFloat)
forall a.
PDFXObject a =>
PDFReference a -> Draw (PDFFloat, PDFFloat)
forall (m :: * -> *) a.
(PDFGlobals m, PDFXObject a) =>
PDFReference a -> m (PDFFloat, PDFFloat)
bounds PDFReference PDFJpeg
a
            Matrix -> Draw ()
applyMatrix (PDFFloat -> PDFFloat -> Matrix
scale PDFFloat
width PDFFloat
height)
            PDFReference PDFJpeg -> Draw ()
forall a. PDFXObject a => PDFReference a -> Draw ()
privateDrawXObject PDFReference PDFJpeg
a
        
instance PdfObject PDFJpeg where
  toPDF :: PDFJpeg -> Builder
toPDF PDFJpeg
_ = Builder
forall s. Monoid s => s
noPdfObject

instance PdfLengthInfo PDFJpeg where

instance PdfResourceObject (PDFReference PDFJpeg) where
  toRsrc :: PDFReference PDFJpeg -> AnyPdfObject
toRsrc = PDFReference PDFJpeg -> AnyPdfObject
forall a. (PdfObject a, PdfLengthInfo a) => a -> AnyPdfObject
AnyPdfObject

-- | A raw image
data RawImage

instance PDFXObject RawImage where
    drawXObject :: PDFReference RawImage -> Draw ()
drawXObject PDFReference RawImage
a = Draw () -> Draw ()
forall a. Draw a -> Draw a
withNewContext (Draw () -> Draw ()) -> Draw () -> Draw ()
forall a b. (a -> b) -> a -> b
$ do
            (PDFFloat
width,PDFFloat
height) <- PDFReference RawImage -> Draw (PDFFloat, PDFFloat)
forall a.
PDFXObject a =>
PDFReference a -> Draw (PDFFloat, PDFFloat)
forall (m :: * -> *) a.
(PDFGlobals m, PDFXObject a) =>
PDFReference a -> m (PDFFloat, PDFFloat)
bounds PDFReference RawImage
a
            Matrix -> Draw ()
applyMatrix (PDFFloat -> PDFFloat -> Matrix
scale PDFFloat
width PDFFloat
height)
            PDFReference RawImage -> Draw ()
forall a. PDFXObject a => PDFReference a -> Draw ()
privateDrawXObject PDFReference RawImage
a
        
instance PdfObject RawImage where
  toPDF :: RawImage -> Builder
toPDF RawImage
_ = Builder
forall s. Monoid s => s
noPdfObject

instance PdfLengthInfo RawImage where

instance PdfResourceObject (PDFReference RawImage) where
  toRsrc :: PDFReference RawImage -> AnyPdfObject
toRsrc = PDFReference RawImage -> AnyPdfObject
forall a. (PdfObject a, PdfLengthInfo a) => a -> AnyPdfObject
AnyPdfObject