diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,22 +1,27 @@ -0.0.7.1 +0.1.4 -* fix compilation on ghc 7.4, 7.6 and 7.8 -* fix xobject handling in text extraction +* support ghc-9.10 -0.0.7.0 +0.1.3.1 -* support xobjects in text extraction +* add missing file in test suite -0.0.6.0 +0.1.3 -* switch to errors-2.0 +* support ghc from 8.6 to 9.6 and drop older versions +* fix handling of indirect objects in Font Descriptor (#76) -0.0.5.1 +0.1.2 -* support ghc-7.10.1 +* add missing file in test suite (#71) +* reexport Info from Pdf.Document.Info (#73) -0.0.5.0 +0.1.1 +* rework API +* support ghc from 8.0 to 8.10 and drop older versions +* lots of improvements to text extraction +* interpret unknown xref stream entry type as reference to null object * support crypto handler version 4 (V2 and AESV2) 0.0.4.0 diff --git a/compat/Prelude.hs b/compat/Prelude.hs --- a/compat/Prelude.hs +++ b/compat/Prelude.hs @@ -5,21 +5,16 @@ ( module P, -#if MIN_VERSION_base(4,8,0) +#if MIN_VERSION_base(4,11,0) #else - (<$>), - Monoid(..), - Applicative(..), + Semigroup(..), #endif - ) where import "base" Prelude as P -#if MIN_VERSION_base(4,8,0) +#if MIN_VERSION_base(4,11,0) #else -import Data.Functor ((<$>)) -import Data.Monoid(Monoid(..)) -import Control.Applicative (Applicative(..)) +import Data.Semigroup(Semigroup(..)) #endif diff --git a/lib/Pdf/Document.hs b/lib/Pdf/Document.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document.hs @@ -0,0 +1,39 @@ + +-- | Mid level utils for processing PDF file +-- +-- Basic example how to get number of pages in document +-- +-- @ +-- import Pdf.Document +-- +-- withPdfFile \"input.pdf\" $ \\pdf -> +-- doc <- 'document' pdf +-- catalog <- 'documentCatalog' doc +-- rootNode <- 'catalogPageNode' catalog +-- count <- 'pageNodeNKids' rootNode +-- print count +-- page <- 'loadPageByNum' rootNode 1 +-- text <- 'pageExtractText' page +-- print text +-- @ + +module Pdf.Document +( module Pdf.Document.Types +, module Pdf.Document.Pdf +, module Pdf.Document.Document +, module Pdf.Document.Catalog +, module Pdf.Document.PageNode +, module Pdf.Document.Page +, module Pdf.Document.Info +, module Pdf.Document.FontDict +) +where + +import Pdf.Document.Types +import Pdf.Document.Pdf +import Pdf.Document.Document +import Pdf.Document.Info +import Pdf.Document.Catalog +import Pdf.Document.PageNode +import Pdf.Document.Page +import Pdf.Document.FontDict diff --git a/lib/Pdf/Document/Catalog.hs b/lib/Pdf/Document/Catalog.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Catalog.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Document datalog + +module Pdf.Document.Catalog +( + Catalog, + catalogPageNode +) +where + +import Pdf.Core.Object.Util +import Pdf.Core.Exception +import Pdf.Core.Util + +import Pdf.Document.Pdf +import Pdf.Document.Internal.Types +import Pdf.Document.Internal.Util + +import qualified Data.HashMap.Strict as HashMap + +-- | Get root node of page tree +catalogPageNode :: Catalog -> IO PageNode +catalogPageNode (Catalog pdf _ dict) = do + ref <- sure $ + (HashMap.lookup "Pages" dict >>= refValue) + `notice` "Pages should be an indirect reference" + obj <- lookupObject pdf ref >>= deref pdf + node <- sure $ dictValue obj `notice` "Pages should be a dictionary" + ensureType "Pages" node + return (PageNode pdf ref node) diff --git a/lib/Pdf/Document/Document.hs b/lib/Pdf/Document/Document.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Document.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | PDF document + +module Pdf.Document.Document +( + Document, + documentCatalog, + documentInfo, + documentEncryption +) +where + +import Pdf.Core.Object +import Pdf.Core.Object.Util +import Pdf.Core.Exception +import Pdf.Core.Util + +import Pdf.Document.Pdf +import Pdf.Document.Internal.Types + +import qualified Data.HashMap.Strict as HashMap +import Control.Exception hiding (throw) + +dict :: Document -> Dict +dict (Document _ d) = d + +pdf :: Document -> Pdf +pdf (Document p _) = p + +-- | Get the document catalog +documentCatalog :: Document -> IO Catalog +documentCatalog doc = do + ref <- sure $ (HashMap.lookup "Root" (dict doc) >>= refValue) + `notice` "trailer: Root should be an indirect reference" + obj <- lookupObject (pdf doc) ref + d <- sure $ dictValue obj `notice` "catalog should be a dictionary" + return (Catalog (pdf doc) ref d) + +-- | Infornation dictionary for the document +documentInfo :: Document -> IO (Maybe Info) +documentInfo doc = do + case HashMap.lookup "Info" (dict doc) of + Nothing -> return Nothing + Just (Ref ref) -> do + obj <- lookupObject (pdf doc) ref + d <- sure $ dictValue obj `notice` "info should be a dictionary" + return (Just (Info (pdf doc) ref d)) + _ -> throwIO $ Corrupted "document Info should be an indirect reference" [] + +-- | Document encryption dictionary +documentEncryption :: Document -> IO (Maybe Dict) +documentEncryption doc = do + case HashMap.lookup "Encrypt" (dict doc) of + Nothing -> return Nothing + Just o -> do + o' <- deref (pdf doc) o + case o' of + Dict d -> return (Just d) + Null -> return Nothing + _ -> throwIO (Corrupted "document Encrypt should be a dictionary" []) diff --git a/lib/Pdf/Document/FontDict.hs b/lib/Pdf/Document/FontDict.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/FontDict.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Font dictionary + +module Pdf.Document.FontDict +( + FontDict, + FontSubtype(..), + fontDictSubtype, + fontDictLoadInfo, +) +where + +import Pdf.Core.Object +import Pdf.Core.Object.Util +import Pdf.Core.Exception +import Pdf.Core.Util +import Pdf.Core.Types +import qualified Pdf.Core.Name as Name +import Pdf.Content + +import Pdf.Document.Pdf +import Pdf.Document.Internal.Types + +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import Control.Monad +import Control.Exception hiding (throw) +import qualified System.IO.Streams as Streams +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (ignore) +import qualified Data.Text as Text + +-- | Font subtypes +data FontSubtype + = FontType0 + | FontType1 + | FontMMType1 + | FontType3 + | FontTrueType + deriving (Show, Eq) + +-- | Get font subtype +fontDictSubtype :: FontDict -> IO FontSubtype +fontDictSubtype (FontDict pdf dict) = do + obj <- sure (HashMap.lookup "Subtype" dict + `notice` "Subtype should exist") + >>= deref pdf + str <- sure $ nameValue obj `notice` "Subtype should be a name" + case str of + "Type0" -> return FontType0 + "Type1" -> return FontType1 + "MMType1" -> return FontMMType1 + "Type3" -> return FontType3 + "TrueType" -> return FontTrueType + _ -> throwIO $ Unexpected ("Unexpected font subtype: " ++ show str) [] + +-- | Load font info for the font +fontDictLoadInfo :: FontDict -> IO FontInfo +fontDictLoadInfo fd@(FontDict pdf fontDict) = do + subtype <- fontDictSubtype fd + case subtype of + FontType0 -> FontInfoComposite <$> loadFontInfoComposite pdf fontDict + FontType3 -> do + fi <- loadFontInfoSimple pdf fontDict + obj <- sure (HashMap.lookup "FontMatrix" fontDict + `notice` "FontMatrix should exist") + >>= deref pdf + arr <- sure $ arrayValue obj + `notice` "FontMatrix should be an array" + fontMatrix <- + case mapM realValue (Vector.toList arr) of + Just [a, b, c, d, e, f] -> do + return $ Transform a b c d e f + Nothing -> throwIO $ Corrupted "FontMatrics should contain numbers" [] + _ -> throwIO $ Corrupted "FontMatrix: wrong number of elements" [] + return $ FontInfoSimple fi { + fiSimpleFontMatrix = fontMatrix + } + _ -> FontInfoSimple <$> loadFontInfoSimple pdf fontDict + +loadFontInfoComposite :: Pdf -> Dict -> IO FIComposite +loadFontInfoComposite pdf fontDict = do + toUnicode <- loadUnicodeCMap pdf fontDict + + descFont <- do + descFontObj <- sure (HashMap.lookup "DescendantFonts" fontDict + `notice` "DescendantFonts should exist") + >>= deref pdf + descFontArr <- sure $ arrayValue descFontObj + `notice` "DescendantFonts should be an array" + case Vector.toList descFontArr of + [o] -> do + o' <- deref pdf o + sure $ dictValue o' + `notice` "DescendantFonts element should be a dictionary" + _ -> throwIO $ Corrupted + "Unexpected value of DescendantFonts key in font dictionary" [] + + defaultWidth <- + case HashMap.lookup "DW" descFont of + Nothing -> return 1000 + Just o -> do + o' <- deref pdf o + sure $ realValue o' `notice` "DW should be real" + + widths <- + case HashMap.lookup "W" descFont of + Nothing -> return mempty + Just o -> do + o' <- deref pdf o + arr <- sure (arrayValue o' `notice` "W should be an array") + >>= Vector.mapM (deref pdf) + sure $ makeCIDFontWidths arr + + fontDescriptor <- loadFontDescriptor pdf descFont + + return $ FIComposite { + fiCompositeUnicodeCMap = toUnicode, + fiCompositeWidths = widths, + fiCompositeDefaultWidth = defaultWidth, + fiCompositeFontDescriptor = fontDescriptor + } + +loadFontInfoSimple :: Pdf -> Dict -> IO FISimple +loadFontInfoSimple pdf fontDict = do + toUnicode <- loadUnicodeCMap pdf fontDict + + encoding <- + case HashMap.lookup "Encoding" fontDict of + Just (Name "WinAnsiEncoding") -> return $ Just SimpleFontEncoding + { simpleFontBaseEncoding = FontBaseEncodingWinAnsi + , simpleFontDifferences = [] + } + Just (Name "MacRomanEncoding") -> return $ Just SimpleFontEncoding + { simpleFontBaseEncoding = FontBaseEncodingMacRoman + , simpleFontDifferences = [] + } + Just o -> do + o' <- deref pdf o + encDict <- sure (dictValue o' + `notice` "Encoding should be a dictionary") + case HashMap.lookup "BaseEncoding" encDict of + Just (Name "WinAnsiEncoding") -> do + diffs <- loadEncodingDifferences pdf encDict + return $ Just SimpleFontEncoding + { simpleFontBaseEncoding = FontBaseEncodingWinAnsi + , simpleFontDifferences = diffs + } + Just (Name "MacRomanEncoding") -> do + diffs <- loadEncodingDifferences pdf encDict + return $ Just SimpleFontEncoding + { simpleFontBaseEncoding = FontBaseEncodingMacRoman + , simpleFontDifferences = diffs + } + Nothing -> do + diffs <- loadEncodingDifferences pdf encDict + return $ Just SimpleFontEncoding + -- XXX: should be StandardEncoding? + { simpleFontBaseEncoding = FontBaseEncodingWinAnsi + , simpleFontDifferences = diffs + } + _ -> return Nothing + _ -> return Nothing + + widths <- + case HashMap.lookup "Widths" fontDict of + Nothing -> return Nothing + Just v -> do + v' <- deref pdf v + array <- sure $ arrayValue v' + `notice` "Widths should be an array" + widths <- forM (Vector.toList array) $ \o -> + sure (realValue o `notice` "Widths elements should be real") + firstChar <- sure $ (HashMap.lookup "FirstChar" fontDict >>= intValue) + `notice` "FirstChar should be an integer" + lastChar <- sure $ (HashMap.lookup "LastChar" fontDict >>= intValue) + `notice` "LastChar should be an integer" + return $ Just (firstChar, lastChar, widths) + + fontDescriptor <- loadFontDescriptor pdf fontDict + + return $ FISimple + { fiSimpleUnicodeCMap = toUnicode + , fiSimpleEncoding = encoding + , fiSimpleWidths = widths + , fiSimpleFontMatrix = scale 0.001 0.001 + , fiSimpleFontDescriptor = fontDescriptor + } + +loadEncodingDifferences :: Pdf -> Dict -> IO [(Word8, ByteString)] +loadEncodingDifferences pdf dict = do + case HashMap.lookup "Differences" dict of + Nothing -> return [] + Just v -> do + v' <- deref pdf v + arr <- sure $ arrayValue v' + `notice` "Differences should be an array" + case Vector.toList arr of + [] -> return [] + (o : rest) -> do + n' <- fromIntegral <$> (sure $ intValue o + `notice` "Differences: the first element should be integer") + go [] n' rest + where + go res _ [] = return res + go res n (o:rest) = + case o of + (Number _) -> do + n' <- fromIntegral <$> (sure $ intValue o + `notice` "Differences: elements should be integers") + go res n' rest + (Name name) -> go (((n, Name.toByteString name)) : res) (n + 1) rest + _ -> throwIO $ Corrupted + ("Differences array: unexpected object: " ++ show o) [] + +loadUnicodeCMap :: Pdf -> Dict -> IO (Maybe UnicodeCMap) +loadUnicodeCMap pdf fontDict = + case HashMap.lookup "ToUnicode" fontDict of + Nothing -> return Nothing + Just o -> do + ref <- sure $ refValue o + `notice` "ToUnicode should be a reference" + toUnicode <- lookupObject pdf ref + case toUnicode of + Stream s -> do + is <- streamContent pdf ref s + content <- mconcat <$> Streams.toList is + case parseUnicodeCMap content of + Left e -> throwIO $ Corrupted ("can't parse cmap: " ++ show e) [] + Right cmap -> return $ Just cmap + _ -> throwIO $ Corrupted "ToUnicode: not a stream" [] + + +loadFontDescriptor :: Pdf -> Dict -> IO (Maybe FontDescriptor) +loadFontDescriptor pdf fontDict = do + case HashMap.lookup "FontDescriptor" fontDict of + Nothing -> return Nothing + Just o -> do + ref <- sure $ refValue o + `notice` "FontDescriptor should be a reference" + fd <- (sure . (`notice` "FontDescriptor: not a dictionary") . dictValue) =<< + lookupObject pdf ref + + fontName <- required "FontName" nameValue' fd + fontFamily <- optional "FontFamily" stringValue fd + fontStretch <- optional "FontStretch" nameValue' fd + fontWeight <- optional "FontWeight" intValue fd + flags <- required "Flags" int64Value fd + fontBBox <- optional "FontBBox" + (join . fmap (either (const Nothing) Just . rectangleFromArray) . arrayValue) fd + italicAngle <- required "ItalicAngle" realValue fd + ascent <- optional "Ascent" realValue fd + descent <- optional "Descent" realValue fd + leading <- optional "Leading" realValue fd + capHeight <- optional "CapHeight" realValue fd + xHeight <- optional "XHeight" realValue fd + stemV <- optional "StemV" realValue fd + stemH <- optional "StemH" realValue fd + avgWidth <- optional "AvgWidth" realValue fd + maxWidth <- optional "MaxWidth" realValue fd + missingWidth <- optional "MissingWidth" realValue fd + charSet <- optional "CharSet" stringValue fd + + return $ Just $ FontDescriptor + { fdFontName = fontName + , fdFontFamily = fontFamily + , fdFontStretch = fontStretch + , fdFontWeight = fontWeight + , fdFlags = flags + , fdFontBBox = fontBBox + , fdItalicAngle = italicAngle + , fdDescent = descent + , fdAscent = ascent + , fdLeading = leading + , fdCapHeight = capHeight + , fdXHeight = xHeight + , fdStemV = stemV + , fdStemH = stemH + , fdAvgWidth = avgWidth + , fdMaxWidth = maxWidth + , fdMissingWidth = missingWidth + , fdCharSet = charSet + } + where + required = requiredInDict pdf "FontDescriptor" + optional = optionalInDict pdf "FontDescriptor" + nameValue' = fmap Name.toByteString . nameValue + +-- | Parse a value from a required field of a dictionary. This will +-- raise an exception if a) the field is not present or b) the field +-- value has a false type. +requiredInDict :: Pdf -- ^ in case the field is a reference + -> String -- ^ a context for a failure notice + -> Name -- ^ name of dictionary field + -> (Object -> Maybe a) -- ^ function for type-casting the object + -> Dict -- ^ the dictionary + -> IO a +requiredInDict pdf context key typeFun dict = do + case HashMap.lookup key dict of + Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " should exist") [] + Just oIn -> do + o <- deref pdf oIn + case typeFun o of + Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " type failure") [] + Just v -> return v + where + msg = Text.unpack $ decodeUtf8With ignore $ Name.toByteString key + +-- | Parse a value from an optional field of a dictionary. This will +-- raise an exception if the field value has a false type. +optionalInDict :: Pdf -> String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a) +optionalInDict pdf context key typeFun dict = + case HashMap.lookup key dict of + Nothing -> return Nothing + Just oIn -> do + o <- deref pdf oIn + case typeFun o of + Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " type failure") [] + Just v -> return $ Just v + where + msg = Text.unpack $ decodeUtf8With ignore $ Name.toByteString key diff --git a/lib/Pdf/Document/Info.hs b/lib/Pdf/Document/Info.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Info.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Document info dictionary + +module Pdf.Document.Info +( + Info, + infoTitle, + infoAuthor, + infoSubject, + infoKeywords, + infoCreator, + infoProducer, +) +where + +import Pdf.Core.Exception +import Pdf.Core.Util +import Pdf.Core.Object.Util + +import Pdf.Document.Pdf +import Pdf.Document.Internal.Types +import Pdf.Document.Internal.Util + +import Data.Text (Text) +import qualified Data.HashMap.Strict as HashMap + +-- | Document title +infoTitle :: Info -> IO (Maybe Text) +infoTitle (Info pdf _ dict) = + case HashMap.lookup "Title" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Title should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str + +-- | The name of the person who created the document +infoAuthor :: Info -> IO (Maybe Text) +infoAuthor (Info pdf _ dict) = + case HashMap.lookup "Author" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Author should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str + +-- | The subject of the document +infoSubject :: Info -> IO (Maybe Text) +infoSubject (Info pdf _ dict) = + case HashMap.lookup "Subject" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Subject should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str + +-- | Keywords associated with the document +infoKeywords :: Info -> IO (Maybe Text) +infoKeywords (Info pdf _ dict) = + case HashMap.lookup "Keywords" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Keywords should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str + +-- | The name of the application that created the original document +infoCreator :: Info -> IO (Maybe Text) +infoCreator (Info pdf _ dict) = + case HashMap.lookup "Creator" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Creator should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str + +-- | The name of the application that converted the document to PDF format +infoProducer :: Info -> IO (Maybe Text) +infoProducer (Info pdf _ dict) = + case HashMap.lookup "Producer" dict of + Nothing -> return Nothing + Just o -> do + o' <- deref pdf o + mstr <- sure $ fmap Just (stringValue o') `notice` "Producer should be a string" + case mstr of + Nothing -> return Nothing + Just str -> Just <$> decodeTextStringThrow str diff --git a/lib/Pdf/Document/Internal/Types.hs b/lib/Pdf/Document/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Internal/Types.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal type declarations + +module Pdf.Document.Internal.Types +( + Pdf(..), + Document(..), + Catalog(..), + Info(..), + PageNode(..), + Page(..), + PageTree(..), + FontDict(..), +) +where + +import Pdf.Core + +import Data.HashMap.Strict as HashMap +import Data.IORef + +type ObjectCache = (Bool, HashMap Ref Object) + +data Pdf = Pdf File (IORef ObjectCache) + +-- | PDF document +-- +-- It is a trailer under the hood +data Document = Document Pdf Dict + +-- | Document catalog +data Catalog = Catalog Pdf Ref Dict + +-- | Information dictionary +data Info = Info Pdf Ref Dict + +-- | Page tree node, contains pages or other nodes +data PageNode = PageNode Pdf Ref Dict + +-- | Pdf document page +data Page = Page Pdf Ref Dict + +-- | Page tree +data PageTree = + PageTreeNode PageNode | + PageTreeLeaf Page + +-- | Font dictionary +data FontDict = FontDict Pdf Dict diff --git a/lib/Pdf/Document/Internal/Util.hs b/lib/Pdf/Document/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Internal/Util.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Utilities for internal use + +module Pdf.Document.Internal.Util +( + ensureType, + dictionaryType, + decodeTextString, + decodeTextStringThrow +) +where + +import Pdf.Core +import Pdf.Core.Exception +import qualified Pdf.Content.Encoding.PdfDoc as PdfDoc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HashMap +import Control.Monad +import Control.Exception hiding (throw) + +-- | Check that the dictionary has the specified \"Type\" filed +ensureType :: Name -> Dict -> IO () +ensureType name dict = do + n <- sure $ dictionaryType dict + unless (n == name) $ + throwIO $ Corrupted ("Expected type: " ++ show name ++ + ", but found: " ++ show n) [] + +-- | Get dictionary type, name at key \"Type\" +dictionaryType :: Dict -> Either String Name +dictionaryType dict = + case HashMap.lookup "Type" dict of + Just (Name n) -> Right n + Just _ -> Left "Type should be a name" + _ -> Left "Type is missing" + +decodeTextStringThrow :: ByteString -> IO Text +decodeTextStringThrow bs = case decodeTextString bs of + Left err -> throwIO $ Corrupted err [] + Right txt -> return txt + +decodeTextString :: ByteString -> Either String Text +decodeTextString bs + | "\254\255" `ByteString.isPrefixOf` bs + = Right (Text.decodeUtf16BEWith Text.ignore (ByteString.drop 2 bs)) + | otherwise + = do + chars <- forM (ByteString.unpack bs) $ \c -> + maybe (Left "Unknow symbol") Right (Map.lookup c PdfDoc.encoding) + return (Text.concat chars) diff --git a/lib/Pdf/Document/Page.hs b/lib/Pdf/Document/Page.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Page.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | PDF document page + +module Pdf.Document.Page +( + Page, + pageParentNode, + pageContents, + pageMediaBox, + pageFontDicts, + pageExtractText, + pageExtractGlyphs, + glyphsToText +) +where + +import Pdf.Core.Object +import Pdf.Core.Object.Util +import Pdf.Core.Exception +import Pdf.Core.Util +import Pdf.Content + +import Pdf.Document.Pdf +import Pdf.Document.Types +import Pdf.Document.PageNode +import Pdf.Document.FontDict +import Pdf.Document.Internal.Types +import Pdf.Document.Internal.Util + +import Data.Maybe +import qualified Data.List as List +import qualified Data.Traversable as Traversable +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy.Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception hiding (throw) +import System.IO.Streams (InputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams + +-- | Page's parent node +pageParentNode :: Page -> IO PageNode +pageParentNode (Page pdf _ dict) = do + ref <- sure $ (HashMap.lookup "Parent" dict >>= refValue) + `notice` "Parent should be a reference" + node <- loadPageNode pdf ref + case node of + PageTreeNode n -> return n + PageTreeLeaf _ -> throwIO $ Corrupted + "page parent should be a note, but leaf found" [] + +-- | List of references to page's content streams +pageContents :: Page -> IO [Ref] +pageContents (Page pdf pageRef dict) = + message ("contents for page: " ++ show pageRef) $ do + case HashMap.lookup "Contents" dict of + Nothing -> return [] + Just (Ref ref) -> do + -- it could be reference to the only content stream, + -- or to an array of content streams + o <- lookupObject pdf ref >>= deref pdf + case o of + Stream _ -> return [ref] + Array objs -> forM (Vector.toList objs) $ \obj -> + sure $ refValue obj `notice` "Content should be a reference" + _ -> throwIO $ Corrupted + ("Unexpected value in page content ref: " ++ show o) [] + Just (Array objs) -> forM (Vector.toList objs) $ \obj -> + sure $ refValue obj `notice` "Content should be a reference" + _ -> throwIO $ Corrupted "Unexpected value in page contents" [] + +-- | Media box, inheritable +pageMediaBox :: Page -> IO (Rectangle Double) +pageMediaBox page = mediaBoxRec (PageTreeLeaf page) + +mediaBoxRec :: PageTree -> IO (Rectangle Double) +mediaBoxRec tree = do + let (pdf, dict) = + case tree of + PageTreeNode (PageNode p _ d) -> (p, d) + PageTreeLeaf (Page p _ d) -> (p, d) + case HashMap.lookup "MediaBox" dict of + Just box -> do + box' <- deref pdf box + arr <- sure $ arrayValue box' + `notice` "MediaBox should be an array" + sure $ rectangleFromArray arr + Nothing -> do + parent <- + case tree of + PageTreeNode node -> do + parent <- pageNodeParent node + case parent of + Nothing -> throwIO $ Corrupted "Media box not found" [] + Just p -> return (PageTreeNode p) + PageTreeLeaf page -> PageTreeNode <$> pageParentNode page + mediaBoxRec parent + +-- | Font dictionaries for the page +pageFontDicts :: Page -> IO [(Name, FontDict)] +pageFontDicts (Page pdf _ dict) = + case HashMap.lookup "Resources" dict of + Nothing -> return [] + Just res -> do + res' <- deref pdf res + resDict <- sure $ dictValue res' + `notice` "Resources should be a dictionary" + case HashMap.lookup "Font" resDict of + Nothing -> return [] + Just fonts -> do + fonts' <- deref pdf fonts + fontsDict <- sure $ dictValue fonts' + `notice` "Font should be a dictionary" + forM (HashMap.toList fontsDict) $ \(name, font) -> do + font' <- deref pdf font + fontDict <- sure $ dictValue font' + `notice` "Each font should be a dictionary" + ensureType "Font" fontDict + return (name, FontDict pdf fontDict) + +data XObject = XObject + { xobjectContent :: Lazy.ByteString + , xobjectGlyphDecoder :: GlyphDecoder + , xobjectChildren :: Map Name XObject + } + +instance Show XObject where + show xobj = show (xobjectContent xobj, xobjectChildren xobj) + +pageXObjects :: Page -> IO (Map Name XObject) +pageXObjects (Page pdf _ dict) = dictXObjects pdf dict + +dictXObjects :: Pdf -> Dict -> IO (Map Name XObject) +dictXObjects pdf dict = + case HashMap.lookup "Resources" dict of + Nothing -> return Map.empty + Just res -> do + resDict <- do + v <- deref pdf res + sure $ dictValue v + `notice` "Resources should be a dict" + + case HashMap.lookup "XObject" resDict of + Nothing -> return Map.empty + Just xo -> do + xosDict <- do + v <- deref pdf xo + sure $ dictValue v + `notice` "XObject should be a dict" + result <- forM (HashMap.toList xosDict) $ \(name, o) -> do + ref <- sure $ refValue o + `notice` "Not a ref" + s@(S xoDict _) <- do + v <- lookupObject pdf ref + sure $ streamValue v + `notice` "Not a stream" + + case HashMap.lookup "Subtype" xoDict of + Just (Name "Form") -> do + is <- streamContent pdf ref s + cont <- Lazy.ByteString.fromChunks <$> Streams.toList is + + fontDicts <- Map.fromList <$> + pageFontDicts (Page pdf ref xoDict) + + glyphDecoders <- Traversable.forM fontDicts $ \fontDict -> + fontInfoDecodeGlyphs <$> fontDictLoadInfo fontDict + let glyphDecoder fontName = \str -> + case Map.lookup fontName glyphDecoders of + Nothing -> [] + Just decode -> decode str + + children <- dictXObjects pdf xoDict + + let xobj = XObject + { xobjectContent = cont + , xobjectGlyphDecoder = glyphDecoder + , xobjectChildren = children + } + return (name, Just xobj) + + _ -> return (name, Nothing) + + return $ Map.fromList $ flip mapMaybe result $ \(n, mo) -> do + o <- mo + return (n, o) + +-- | Extract text from the page +-- +-- It tries to add spaces between chars if they don't present +-- as actual characters in content stream. +pageExtractText :: Page -> IO Text +pageExtractText page = glyphsToText <$> pageExtractGlyphs page + +pageExtractGlyphs :: Page -> IO [Span] +pageExtractGlyphs page = do + fontDicts <- Map.fromList <$> pageFontDicts page + glyphDecoders <- Traversable.forM fontDicts $ \fontDict -> + fontInfoDecodeGlyphs <$> fontDictLoadInfo fontDict + let glyphDecoder fontName = \str -> + case Map.lookup fontName glyphDecoders of + Nothing -> [] + Just decode -> decode str + + xobjects <- pageXObjects page + + is <- do + contents <- pageContents page + let Page pdf _ _ = page + is <- combinedContent pdf contents + Streams.parserToInputStream parseContent is + + -- use content stream processor to extract text + let loop xobjs s p = do + next <- readNextOperator s + case next of + Just (Op_Do, [Name name]) -> processDo xobjs name p >>= loop xobjs s + Just op -> + case processOp op p of + Left err -> throwIO (Unexpected err []) + Right p' -> loop xobjs s p' + Nothing -> return p + + processDo xobjs name p = do + case Map.lookup name xobjs of + Nothing -> return p + Just xobj -> do + s <- do + s <- Streams.fromLazyByteString (xobjectContent xobj) + Streams.parserToInputStream parseContent s + + let gdec' = prGlyphDecoder p + p' <- loop (xobjectChildren xobj) s + (p {prGlyphDecoder = xobjectGlyphDecoder xobj}) + return (p' {prGlyphDecoder = gdec'}) + + p <- loop xobjects is $ mkProcessor { + prGlyphDecoder = glyphDecoder + } + return (List.reverse (prSpans p)) + +combinedContent :: Pdf -> [Ref] -> IO (InputStream ByteString) +combinedContent pdf refs = do + allStreams <- forM refs $ \ref -> do + o <- lookupObject pdf ref + case o of + Stream s -> return (ref, s) + _ -> throwIO (Corrupted "Page content is not a stream" []) + + Streams.fromGenerator $ forM_ allStreams $ \(ref, stream) -> do + is <- liftIO $ streamContent pdf ref stream + yield is + where + yield is = do + chunk <- liftIO $ Streams.read is + case chunk of + Nothing -> return () + Just c -> do + Streams.yield c + yield is + +-- | Convert glyphs to text, trying to add spaces and newlines +-- +-- It takes list of spans. Each span is a list of glyphs that are outputed in one shot. +-- So we don't need to add space inside span, only between them. +glyphsToText :: [Span] -> Text +glyphsToText + = Lazy.Text.toStrict + . Text.Builder.toLazyText + . snd + . foldl step ((Vector 0 0, False), mempty) + . List.map spGlyphs + where + step acc [] = acc + step ((Vector lx2 ly2, wasSpace), res) sp@(x : _) = + let Vector x1 y1 = glyphTopLeft x + Vector x2 _ = glyphBottomRight (last sp) + Vector _ y2 = glyphTopLeft (last sp) + space = + if abs (ly2 - y1) < 1.8 + then if wasSpace || abs (lx2 - x1) < 1.8 + then mempty + else Text.Builder.singleton ' ' + else Text.Builder.singleton '\n' + txt = Text.Builder.fromLazyText $ Lazy.Text.fromChunks $ mapMaybe glyphText sp + endWithSpace = glyphText (last sp) == Just " " + in ((Vector x2 y2, endWithSpace), mconcat [res, space, txt]) diff --git a/lib/Pdf/Document/PageNode.hs b/lib/Pdf/Document/PageNode.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/PageNode.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Page tree node + +module Pdf.Document.PageNode +( + PageNode, + PageTree(..), + pageNodeNKids, + pageNodeParent, + pageNodeKids, + loadPageNode, + pageNodePageByNum, +) +where + +import Pdf.Core +import Pdf.Core.Exception +import Pdf.Core.Util +import Pdf.Core.Object.Util + +import Pdf.Document.Pdf +import Pdf.Document.Internal.Types +import Pdf.Document.Internal.Util + +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import Control.Monad +import Control.Exception hiding (throw) + +-- | Total number of child leaf nodes, including deep children +pageNodeNKids :: PageNode -> IO Int +pageNodeNKids (PageNode _ _ dict) = sure $ + (HashMap.lookup "Count" dict >>= intValue) + `notice` "Count should be an integer" + +-- | Parent page node +pageNodeParent :: PageNode -> IO (Maybe PageNode) +pageNodeParent (PageNode pdf _ dict) = + case HashMap.lookup "Parent" dict of + Nothing -> return Nothing + Just o@(Ref ref) -> do + obj <- deref pdf o + node <- sure $ dictValue obj `notice` "Parent should be a dictionary" + ensureType "Pages" node + return $ Just (PageNode pdf ref node) + _ -> throwIO (Corrupted "Parent should be an indirect ref" []) + +-- | Referencies to all kids +pageNodeKids :: PageNode -> IO [Ref] +pageNodeKids (PageNode pdf _ dict) = do + obj <- sure (HashMap.lookup "Kids" dict + `notice` "Page node should have Kids") + >>= deref pdf + kids <- sure $ arrayValue obj + `notice` "Kids should be an array" + forM (Vector.toList kids) $ \k -> sure $ + refValue k `notice` "each kid should be a reference" + +-- | Load page tree node by reference +loadPageNode :: Pdf -> Ref -> IO PageTree +loadPageNode pdf ref = do + obj <- lookupObject pdf ref >>= deref pdf + node <- sure $ dictValue obj `notice` "page should be a dictionary" + nodeType <- sure $ dictionaryType node + case nodeType of + "Pages" -> return $ PageTreeNode (PageNode pdf ref node) + "Page" -> return $ PageTreeLeaf (Page pdf ref node) + _ -> throwIO $ Corrupted ("Unexpected page tree node type: " + ++ show nodeType) [] + +-- | Find page by it's number +-- +-- Note: it is not efficient for PDF files with a lot of pages, +-- because it performs traversal through the page tree each time. +-- Use 'pageNodeNKids', 'pageNodeKids' and 'loadPageNode' for +-- efficient traversal. +pageNodePageByNum :: PageNode -> Int -> IO Page +pageNodePageByNum node@(PageNode pdf nodeRef _) num = + message ("page #" ++ show num ++ " for node: " ++ show nodeRef) $ do + pageNodeKids node >>= loop num + where + loop _ [] = throwIO $ Corrupted "Page not found" [] + loop i (x:xs) = do + kid <- loadPageNode pdf x + case kid of + PageTreeNode n -> do + nkids <- pageNodeNKids n + if i < nkids + then pageNodePageByNum n i + else loop (i - nkids) xs + PageTreeLeaf page -> + if i == 0 + then return page + else loop (i - 1) xs diff --git a/lib/Pdf/Document/Pdf.hs b/lib/Pdf/Document/Pdf.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Pdf.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Pdf.Document.Pdf +( + Pdf, + withPdfFile, + fromFile, + fromHandle, + fromBytes, + document, + lookupObject, + streamContent, + rawStreamContent, + deref, + isEncrypted, + setUserPassword, + defaultUserPassword, + EncryptedError (..), + enableCache, + disableCache, +) +where + +import Pdf.Core.Object +import Pdf.Core.Stream (knownFilters) +import Pdf.Core.File (File) +import qualified Pdf.Core.File as File +import Pdf.Core.Encryption (defaultUserPassword) + +import Pdf.Document.Internal.Types + +import Data.Typeable +import Data.IORef +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.HashMap.Strict as HashMap +import Control.Monad +import Control.Exception hiding (throw) +import System.IO (Handle) +import System.IO.Streams (InputStream) + +withPdfFile :: FilePath -> (Pdf -> IO a) -> IO a +withPdfFile path action = File.withPdfFile path $ \f -> do + pdf <- fromFile f + action pdf + +-- | Make Pdf with interface to pdf file +fromFile :: File -> IO Pdf +fromFile f = Pdf f + <$> newIORef (False, HashMap.empty) + +-- | Make Pdf with seekable handle +fromHandle :: Handle -> IO Pdf +fromHandle h = do + File.fromHandle knownFilters h >>= fromFile + +-- | Make Pdf from a ByteString +fromBytes :: ByteString -> IO Pdf +fromBytes h = do + File.fromBytes knownFilters h >>= fromFile + +file :: Pdf -> File +file (Pdf f _) = f + +-- | Get PDF document +document :: Pdf -> IO Document +document pdf = do + status <- File.encryptionStatus (file pdf) + case status of + File.Encrypted -> throwIO $ + EncryptedError "File is encrypted, use 'setUserPassword'" + File.Decrypted -> return () + File.Plain -> return () + + Document pdf <$> File.lastTrailer (file pdf) + +-- | Find object by it's reference +lookupObject :: Pdf -> Ref -> IO Object +lookupObject pdf ref = do + let Pdf _ cacheRef = pdf + (useCache, cache) <- readIORef cacheRef + case HashMap.lookup ref cache of + Just obj -> return obj + Nothing -> do + obj <- File.findObject (file pdf) ref + when useCache $ + writeIORef cacheRef (useCache, HashMap.insert ref obj cache) + return obj + +-- | Cache object for future lookups +enableCache :: Pdf -> IO () +enableCache (Pdf _ cacheRef) = do + (_, cache) <- readIORef cacheRef + writeIORef cacheRef (True, cache) + +-- | Don't cache object for future lookups +disableCache :: Pdf -> IO () +disableCache (Pdf _ cacheRef) = do + (_, cache) <- readIORef cacheRef + writeIORef cacheRef (False, cache) + +-- | Get stream content, decoded and decrypted +-- +-- Note: length of the content may differ from the raw one +streamContent :: Pdf + -> Ref + -> Stream + -> IO (InputStream ByteString) +streamContent pdf ref s = + File.streamContent (file pdf) ref s + +-- | Get stream content without decoding it +rawStreamContent + :: Pdf + -> Ref + -> Stream + -> IO (InputStream ByteString) +rawStreamContent pdf ref s = + File.rawStreamContent (file pdf) ref s + +-- | Whether the PDF document it encrypted +isEncrypted :: Pdf -> IO Bool +isEncrypted pdf = do + status <- File.encryptionStatus (file pdf) + return $ case status of + File.Encrypted -> True + File.Decrypted -> True + File.Plain -> False + +-- | Set the password to be user for decryption +-- +-- Returns False when the password is wrong +setUserPassword :: Pdf -> ByteString -> IO Bool +setUserPassword pdf password = + File.setUserPassword (file pdf) password + +deref :: Pdf -> Object -> IO Object +deref pdf (Ref r) = lookupObject pdf r +deref _ o = return o + +-- | File is enctypted +data EncryptedError = EncryptedError Text + deriving (Show, Typeable) + +instance Exception EncryptedError diff --git a/lib/Pdf/Document/Types.hs b/lib/Pdf/Document/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Pdf/Document/Types.hs @@ -0,0 +1,9 @@ + +-- | Various types + +module Pdf.Document.Types + ( module Pdf.Core.Types + ) +where + +import Pdf.Core.Types diff --git a/lib/Pdf/Toolbox/Document.hs b/lib/Pdf/Toolbox/Document.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document.hs +++ /dev/null @@ -1,45 +0,0 @@ - --- | Mid level utils for processing PDF file --- --- Basic example how to get number of pages in document --- --- @ --- withBinaryFile \"input.pdf\" ReadMode $ \handle -> --- 'runPdfWithHandle' handle 'knownFilters' $ do --- pdf <- 'document' --- catalog <- 'documentCatalog' pdf --- rootNode <- 'catalogPageNode' catalog --- cout <- 'pageNodeNKids' rootNode --- liftIO $ print count --- @ - -module Pdf.Toolbox.Document -( - module Pdf.Toolbox.Document.Types, - module Pdf.Toolbox.Document.Monad, - module Pdf.Toolbox.Document.Pdf, - module Pdf.Toolbox.Document.Document, - module Pdf.Toolbox.Document.Catalog, - module Pdf.Toolbox.Document.PageNode, - module Pdf.Toolbox.Document.Page, - module Pdf.Toolbox.Document.Info, - module Pdf.Toolbox.Document.FontDict, - module Pdf.Toolbox.Core.Error, - module Pdf.Toolbox.Core.Object.Types, - module Pdf.Toolbox.Core.Object.Util -) -where - -import Pdf.Toolbox.Core.Error -import Pdf.Toolbox.Core.Object.Types -import Pdf.Toolbox.Core.Object.Util - -import Pdf.Toolbox.Document.Types -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Pdf -import Pdf.Toolbox.Document.Document -import Pdf.Toolbox.Document.Info -import Pdf.Toolbox.Document.Catalog -import Pdf.Toolbox.Document.PageNode -import Pdf.Toolbox.Document.Page -import Pdf.Toolbox.Document.FontDict diff --git a/lib/Pdf/Toolbox/Document/Catalog.hs b/lib/Pdf/Toolbox/Document/Catalog.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Catalog.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Document datalog - -module Pdf.Toolbox.Document.Catalog -( - Catalog, - catalogPageNode -) -where - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Internal.Types -import Pdf.Toolbox.Document.Internal.Util - --- | Get root node of page tree -catalogPageNode :: MonadPdf m => Catalog -> PdfE m PageNode -catalogPageNode (Catalog _ dict) = do - ref <- lookupDict "Pages" dict >>= fromObject - node <- lookupObject ref >>= fromObject - ensureType "Pages" node - return $ PageNode ref node diff --git a/lib/Pdf/Toolbox/Document/Document.hs b/lib/Pdf/Toolbox/Document/Document.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Document.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | PDF document - -module Pdf.Toolbox.Document.Document -( - Document, - documentCatalog, - documentEncryption, - documentInfo -) -where - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Internal.Types -import Pdf.Toolbox.Document.Internal.Util - --- | Get the document catalog -documentCatalog :: MonadPdf m => Document -> PdfE m Catalog -documentCatalog (Document _ dict) = do - ref <- lookupDict "Root" dict >>= fromObject - cat <- lookupObject ref >>= fromObject - ensureType "Catalog" cat - return $ Catalog ref cat - --- | Document encryption dictionary -documentEncryption :: MonadPdf m => Document -> PdfE m (Maybe Dict) -documentEncryption (Document _ dict) = do - case lookupDict' "Encrypt" dict of - Nothing -> return Nothing - Just o -> do - o' <- deref o >>= fromObject - return $ Just o' - --- | Infornation dictionary for the document -documentInfo :: MonadPdf m => Document -> PdfE m (Maybe Info) -documentInfo (Document _ dict) = - case lookupDict' "Info" dict of - Nothing -> return Nothing - Just r -> do - ref <- fromObject r - info <- lookupObject ref >>= fromObject - return $ Just $ Info ref info diff --git a/lib/Pdf/Toolbox/Document/Encryption.hs b/lib/Pdf/Toolbox/Document/Encryption.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Encryption.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Basic support for encrypted PDF documents - -module Pdf.Toolbox.Document.Encryption -( - Decryptor, - defaultUserPassword, - mkStandardDecryptor, - decryptObject, - DecryptorScope(..), -) -where - -import Data.Bits (xor) -import Data.IORef -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.ByteString.Lazy.Builder -import Control.Monad -import qualified System.IO.Streams as Streams -import qualified Crypto.Cipher.RC4 as RC4 -import qualified Crypto.Cipher.AES as AES -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Padding as Padding - -import Pdf.Toolbox.Core - --- | Encryption handler may specify different encryption keys for strings --- and streams -data DecryptorScope - = DecryptString - | DecryptStream - --- | Decrypt input stream -type Decryptor = Ref -> DecryptorScope -> IS -> IO IS - --- | Decrypt object with the decryptor -decryptObject :: (IS -> IO IS) -> Object a -> IO (Object a) -decryptObject decryptor (OStr str) = OStr `liftM` decryptStr decryptor str -decryptObject decryptor (ODict dict) = ODict `liftM` decryptDict decryptor dict -decryptObject _ o = return o - -decryptStr :: (IS -> IO IS) -> Str -> IO Str -decryptStr decryptor (Str str) = do - is <- Streams.fromList [str] - res <- decryptor is >>= Streams.toList - return $ Str $ BS.concat res - -decryptDict :: (IS -> IO IS) -> Dict -> IO Dict -decryptDict decryptor (Dict vals) = Dict `liftM` forM vals decr - where - decr (key, val) = do - res <- decryptObject decryptor val - return (key, res) - --- | The default user password -defaultUserPassword :: ByteString -defaultUserPassword = BS.pack [ - 0x28, 0xBF, 0x4E, 0x5E, 0x4E, 0x75, 0x8A, 0x41, 0x64, 0x00, 0x4E, - 0x56, 0xFF, 0xFA, 0x01, 0x08, 0x2E, 0x2E, 0x00, 0xB6, 0xD0, 0x68, - 0x3E, 0x80, 0x2F, 0x0C, 0xA9, 0xFE, 0x64, 0x53, 0x69, 0x7A - ] - --- | Standard decryptor. RC4 -mkStandardDecryptor :: Monad m - => Dict -- ^ document trailer - -> Dict -- ^ encryption dictionary - -> ByteString -- ^ user password (32 bytes exactly, see 7.6.3.3 Encryption Key Algorithm) - -> PdfE m (Maybe Decryptor) -mkStandardDecryptor tr enc pass = do - Name filterType <- lookupDict "Filter" enc >>= fromObject - unless (filterType == "Standard") $ throwE $ UnexpectedError $ "Unsupported encryption handler: " ++ show filterType - vVal <- lookupDict "V" enc >>= fromObject >>= intValue - - if vVal == 4 - then mk4 - else mk12 vVal - - where - mk12 vVal = do - n <- case vVal of - 1 -> return 5 - 2 -> do - len <- lookupDict "Length" enc >>= fromObject >>= intValue - return $ len `div` 8 - _ -> throwE $ UnexpectedError $ "Unsuported encryption handler version: " ++ show vVal - - ekey <- mkKey tr enc pass n - ok <- verifyKey tr enc ekey - return $ - if not ok - then Nothing - else Just $ \ref _ is -> mkDecryptor V2 ekey n ref is - - mk4 = do - Dict cryptoFilters <- lookupDict "CF" enc >>= fromObject - - keysMap <- forM cryptoFilters $ \(name, obj) -> do - dict <- fromObject obj - n <- lookupDict "Length" dict >>= fromObject >>= intValue - algName <- lookupDict "CFM" dict >>= toName - alg <- - case algName of - "V2" -> return V2 - "AESV2" -> return AESV2 - _ -> throwE $ UnexpectedError $ "Unknown crypto method: " ++ show algName - ekey <- mkKey tr enc pass n - return (name, (ekey, n, alg)) - - (stdCfKey, _, _) <- - case lookup "StdCF" keysMap of - Nothing -> throwE $ UnexpectedError "StdCF is missing" - Just v -> return v - ok <- verifyKey tr enc stdCfKey - if not ok - then return Nothing - - else do - strFName <- lookupDict "StrF" enc >>= toName - (strFKey, strFN, strFAlg) <- - case lookup strFName keysMap of - Nothing -> throwE $ UnexpectedError $ "Crypto filter not found: " ++ show strFName - Just v -> return v - - stmFName <- lookupDict "StmF" enc >>= toName - (stmFKey, stmFN, stmFAlg) <- - case lookup stmFName keysMap of - Nothing -> throwE $ UnexpectedError $ "Crypto filter not found: " ++ show stmFName - Just v -> return v - - return $ Just $ \ref scope is -> - case scope of - DecryptString -> mkDecryptor strFAlg strFKey strFN ref is - DecryptStream -> mkDecryptor stmFAlg stmFKey stmFN ref is - -mkKey :: Monad m => Dict -> Dict -> ByteString -> Int -> PdfE m ByteString -mkKey tr enc pass n = do - Str oVal <- lookupDict "O" enc >>= fromObject - pVal <- (BS.pack . BSL.unpack . toLazyByteString . word32LE . fromIntegral) - `liftM` (lookupDict "P" enc >>= fromObject >>= intValue) - Str idVal <- do - Array ids <- lookupDict "ID" tr >>= fromObject - case ids of - [] -> throwE $ UnexpectedError $ "ID array is empty" - (x:_) -> fromObject x - rVal <- lookupDict "R" enc >>= fromObject >>= intValue - - encMD <- - case lookupDict' "EncryptMetadata" enc of - Nothing -> return True - Just o -> do - Boolean b <- toBoolean o - return b - - let ekey' = BS.take n $ MD5.hash $ BS.concat [pass, oVal, pVal, idVal, pad] - pad = - if rVal < 4 || encMD - then BS.empty - else BS.pack (replicate 4 255) - - let ekey = if rVal < 3 - then ekey' - else foldl (\bs _ -> BS.take n $ MD5.hash bs) ekey' [1 :: Int .. 50] - return ekey - -verifyKey :: Monad m => Dict -> Dict -> ByteString -> PdfE m Bool -verifyKey tr enc ekey = do - Str idVal <- do - Array ids <- lookupDict "ID" tr >>= fromObject - case ids of - [] -> throwE $ UnexpectedError $ "ID array is empty" - (x:_) -> fromObject x - rVal <- lookupDict "R" enc >>= fromObject >>= intValue - Str uVal <- lookupDict "U" enc >>= fromObject - let ok = - case rVal of - 2 -> - let uVal' = snd $ RC4.combine (RC4.initCtx ekey) defaultUserPassword - in uVal == uVal' - _ -> - let pass1 = snd $ RC4.combine (RC4.initCtx ekey) $ BS.take 16 $ MD5.hash $ BS.concat [defaultUserPassword, idVal] - uVal' = loop 1 pass1 - loop 20 input = input - loop i input = loop (i + 1) $ snd $ RC4.combine (RC4.initCtx $ BS.map (`xor` i) ekey) input - in BS.take 16 uVal == BS.take 16 uVal' - return ok - -data Algorithm - = V2 - | AESV2 - deriving (Show) - -mkDecryptor - :: Algorithm - -> ByteString - -> Int - -> Ref - -> IS - -> IO IS -mkDecryptor alg ekey n (Ref index gen) is = do - let key = BS.take (16 `min` n + 5) $ MD5.hash $ BS.concat - [ ekey - , BS.pack $ take 3 $ BSL.unpack $ toLazyByteString - $ int32LE $ fromIntegral index - , BS.pack $ take 2 $ BSL.unpack $ toLazyByteString - $ int32LE $ fromIntegral gen - , salt alg - ] - salt V2 = "" - salt AESV2 = "sAlT" - - case alg of - V2 -> do - ioRef <- newIORef $ RC4.initCtx key - let readNext = do - chunk <- Streams.read is - case chunk of - Nothing -> return Nothing - Just c -> do - ctx' <- readIORef ioRef - let (ctx'', res) = RC4.combine ctx' c - writeIORef ioRef ctx'' - return (Just res) - Streams.makeInputStream readNext - - AESV2 -> do - content <- BS.concat <$> Streams.toList is - let initV = BS.take 16 content - aes = AES.initAES key - decrypted = AES.decryptCBC aes initV $ BS.drop 16 content - Streams.fromByteString $ Padding.unpadPKCS5 decrypted diff --git a/lib/Pdf/Toolbox/Document/FontDict.hs b/lib/Pdf/Toolbox/Document/FontDict.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/FontDict.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Font dictionary - -module Pdf.Toolbox.Document.FontDict -( - FontDict, - FontSubtype(..), - fontDictSubtype, - fontDictLoadInfo -) -where - -import Data.Word -import Data.ByteString (ByteString) -import Control.Monad -import qualified System.IO.Streams as Streams - -import Pdf.Toolbox.Core -import Pdf.Toolbox.Content - -import Pdf.Toolbox.Document.Internal.Types -import Pdf.Toolbox.Document.Monad - --- | Font subtypes -data FontSubtype - = FontType0 - | FontType1 - | FontMMType1 - | FontType3 - | FontTrueType - deriving (Show, Eq) - --- | Get font subtype -fontDictSubtype :: Monad m => FontDict -> PdfE m FontSubtype -fontDictSubtype (FontDict dict) = do - Name str <- lookupDict "Subtype" dict >>= fromObject - case str of - "Type0" -> return FontType0 - "Type1" -> return FontType1 - "MMType1" -> return FontMMType1 - "Type3" -> return FontType3 - "TrueType" -> return FontTrueType - _ -> throwE $ UnexpectedError $ "Unexpected font subtype: " ++ show str - --- | Load font info for the font -fontDictLoadInfo :: (MonadPdf m, MonadIO m) => FontDict -> PdfE m FontInfo -fontDictLoadInfo fd@(FontDict fontDict) = do - subtype <- fontDictSubtype fd - case subtype of - FontType0 -> FontInfoComposite `liftM` loadFontInfoComposite fontDict - FontType3 -> do - fi <- loadFontInfoSimple fontDict - Array arr <- lookupDict "FontMatrix" fontDict >>= deref >>= fromObject - fontMatrix <- - case arr of - [a, b, c, d, e, f] -> do - a' <- fromObject a >>= realValue - b' <- fromObject b >>= realValue - c' <- fromObject c >>= realValue - d' <- fromObject d >>= realValue - e' <- fromObject e >>= realValue - f' <- fromObject f >>= realValue - return $ Transform a' b' c' d' e' f' - _ -> throwE $ UnexpectedError "FontMatrix: wrong number of elements" - return $ FontInfoSimple fi { - fiSimpleFontMatrix = fontMatrix - } - _ -> FontInfoSimple `liftM` loadFontInfoSimple fontDict - -loadFontInfoComposite :: (MonadPdf m, MonadIO m) => Dict -> PdfE m FIComposite -loadFontInfoComposite fontDict = do - toUnicode <- loadUnicodeCMap fontDict - descFont <- do - descFontArr <- lookupDict "DescendantFonts" fontDict >>= deref >>= fromObject - case descFontArr of - Array [o] -> deref o >>= fromObject - _ -> throwE $ UnexpectedError "Unexpected value of DescendantFonts key in font dictionary" - defaultWidth <- - case lookupDict' "DW" descFont of - Nothing -> return 1000 - Just o -> deref o >>= fromObject >>= realValue - widths <- - case lookupDict' "W" descFont of - Nothing -> return mempty - Just o -> deref o >>= fromObject >>= makeCIDFontWidths - return $ FIComposite { - fiCompositeUnicodeCMap = toUnicode, - fiCompositeWidths = widths, - fiCompositeDefaultWidth = defaultWidth - } - -loadFontInfoSimple :: (MonadPdf m, MonadIO m) => Dict -> PdfE m FISimple -loadFontInfoSimple fontDict = do - toUnicode <- loadUnicodeCMap fontDict - encoding <- - case lookupDict' "Encoding" fontDict of - Just (OName "WinAnsiEncoding") -> return $ Just SimpleFontEncoding { - simpleFontBaseEncoding = FontBaseEncodingWinAnsi, - simpleFontDifferences = [] - } - Just (OName "MacRomanEncoding") -> return $ Just SimpleFontEncoding { - simpleFontBaseEncoding = FontBaseEncodingMacRoman, - simpleFontDifferences = [] - } - Just o -> do - encDict <- deref o >>= fromObject - case lookupDict' "BaseEncoding" encDict of - Just (OName "WinAnsiEncoding") -> do - diffs <- loadEncodingDifferences encDict - return $ Just SimpleFontEncoding { - simpleFontBaseEncoding = FontBaseEncodingWinAnsi, - simpleFontDifferences = diffs - } - Just (OName "MacRomanEncoding") -> do - diffs <- loadEncodingDifferences encDict - return $ Just SimpleFontEncoding { - simpleFontBaseEncoding = FontBaseEncodingMacRoman, - simpleFontDifferences = diffs - } - Nothing -> do - diffs <- loadEncodingDifferences encDict - return $ Just SimpleFontEncoding { - simpleFontBaseEncoding = FontBaseEncodingWinAnsi, -- XXX: should be StandardEncoding? - simpleFontDifferences = diffs - } - _ -> return Nothing - _ -> return Nothing - widths <- - case lookupDict' "Widths" fontDict of - Nothing -> return Nothing - Just v -> do - Array array <- deref v >>= fromObject - widths <- mapM (fromObject >=> realValue) array - firstChar <- lookupDict "FirstChar" fontDict >>= fromObject >>= intValue - lastChar <- lookupDict "LastChar" fontDict >>= fromObject >>= intValue - return $ Just (firstChar, lastChar, widths) - return $ FISimple { - fiSimpleUnicodeCMap = toUnicode, - fiSimpleEncoding = encoding, - fiSimpleWidths = widths, - fiSimpleFontMatrix = scale 0.001 0.001 - } - -loadEncodingDifferences :: MonadPdf m => Dict -> PdfE m [(Word8, ByteString)] -loadEncodingDifferences dict = do - case lookupDict' "Differences" dict of - Nothing -> return [] - Just o -> do - Array arr <- deref o >>= fromObject - case arr of - [] -> return [] - (ONumber n : rest) -> do - n' <- fromIntegral `liftM` intValue n - go [] n' rest - _ -> throwE $ UnexpectedError "Differences array: the first object should be a number" - where - go res _ [] = return res - go res n (o:rest) = - case o of - (ONumber n') -> do - n'' <- fromIntegral `liftM` intValue n' - go res n'' rest - (OName (Name bs)) -> go (((n, bs)) : res) (n + 1) rest - _ -> throwE $ UnexpectedError $ "Differences array: unexpected object: " ++ show o - -loadUnicodeCMap :: (MonadPdf m, MonadIO m) => Dict -> PdfE m (Maybe UnicodeCMap) -loadUnicodeCMap fontDict = - case lookupDict' "ToUnicode" fontDict of - Nothing -> return Nothing - Just o -> do - ref <- fromObject o - toUnicode <- lookupObject ref - case toUnicode of - OStream s -> do - Stream _ is <- streamContent ref s - content <- mconcat `liftM` liftIO (Streams.toList is) - case parseUnicodeCMap content of - Left e -> throwE $ UnexpectedError $ "can't parse cmap: " ++ show e - Right cmap -> return $ Just cmap - _ -> throwE $ UnexpectedError "ToUnicode: not a stream" diff --git a/lib/Pdf/Toolbox/Document/Info.hs b/lib/Pdf/Toolbox/Document/Info.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Info.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Document info dictionary - -module Pdf.Toolbox.Document.Info -( - infoTitle -) -where - -import Control.Monad - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Internal.Types - --- | Document title -infoTitle :: MonadPdf m => Info -> PdfE m (Maybe Str) -infoTitle (Info _ dict) = - case lookupDict' "Title" dict of - Nothing -> return Nothing - Just o -> liftM Just $ deref o >>= fromObject diff --git a/lib/Pdf/Toolbox/Document/Internal/Types.hs b/lib/Pdf/Toolbox/Document/Internal/Types.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Internal/Types.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} - --- | Internal type declarations - -module Pdf.Toolbox.Document.Internal.Types -( - Document(..), - Catalog(..), - PageTree(..), - PageNode(..), - Page(..), - Info(..), - FontDict(..) -) -where - -import Pdf.Toolbox.Core - --- | PDF document --- --- It is a trailer under the hood -data Document = Document XRef Dict - deriving Show - --- | Document catalog -data Catalog = Catalog Ref Dict - deriving Show - --- | Page tree -data PageTree = - PageTreeNode PageNode | - PageTreeLeaf Page - deriving Show - --- | Page tree node, contains pages or other nodes -data PageNode = PageNode Ref Dict - deriving Show - --- | Pdf document page -data Page = Page Ref Dict - deriving Show - --- | Information dictionary -data Info = Info Ref Dict - deriving Show - --- | Font dictionary -data FontDict = FontDict Dict - deriving Show diff --git a/lib/Pdf/Toolbox/Document/Internal/Util.hs b/lib/Pdf/Toolbox/Document/Internal/Util.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Internal/Util.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Utilities for internal use - -module Pdf.Toolbox.Document.Internal.Util -( - ensureType, - dictionaryType -) -where - -import Control.Monad - -import Pdf.Toolbox.Core - --- | Check that the dictionary has the specified \"Type\" filed -ensureType :: Monad m => Name -> Dict -> PdfE m () -ensureType name dict = do - n <- dictionaryType dict - unless (n == name) $ throwE $ UnexpectedError $ "Expected type: " ++ show name ++ ", but found: " ++ show n - --- | Get dictionary type, name at key \"Type\" -dictionaryType :: Monad m => Dict -> PdfE m Name -dictionaryType dict = lookupDict "Type" dict >>= fromObject diff --git a/lib/Pdf/Toolbox/Document/Monad.hs b/lib/Pdf/Toolbox/Document/Monad.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Monad.hs +++ /dev/null @@ -1,38 +0,0 @@ - --- | Interface to the underlying PDF file - -module Pdf.Toolbox.Document.Monad -( - MonadPdf(..), - deref -) -where - -import Data.Int - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Encryption - --- | Interface to the underlying PDF file -class Monad m => MonadPdf m where - -- | find object by it's reference - lookupObject :: Ref -> PdfE m (Object Int64) - -- | decoded stream content - -- - -- Note: the 'IS' returned is valid only until the next 'lookupObject' - -- or any other operation, that requares seek - streamContent :: Ref -> Stream Int64 -> PdfE m (Stream IS) - -- | Current decryptor - getDecryptor :: PdfE m (Maybe Decryptor) - -- | Get random access input stream for direct access to the PDF file - getRIS :: PdfE m RIS - -- | Get all stream filters - getStreamFilters :: PdfE m [StreamFilter] - --- | Recursively load indirect object -deref :: (MonadPdf m, Show a) => Object a -> PdfE m (Object ()) -deref (ORef ref) = do - o <- lookupObject ref - deref o -deref o = return $ mapObject (const ()) o diff --git a/lib/Pdf/Toolbox/Document/Page.hs b/lib/Pdf/Toolbox/Document/Page.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Page.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | PDF document page - -module Pdf.Toolbox.Document.Page -( - Page, - pageParentNode, - pageContents, - pageMediaBox, - pageFontDicts, - pageExtractText, - XObject(..), - pageXObjects -) -where - -import Data.Int -import qualified Data.Traversable as Traversable -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy as Lazy.ByteString -import Data.Text (Text) -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as TextB -import qualified Data.Map as Map -import Control.Monad -import qualified System.IO.Streams as Streams -import qualified System.IO.Streams.Attoparsec as Streams - -import Pdf.Toolbox.Core -import Pdf.Toolbox.Content - -import Pdf.Toolbox.Document.Types -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.PageNode -import Pdf.Toolbox.Document.FontDict -import Pdf.Toolbox.Document.Encryption -import Pdf.Toolbox.Document.Internal.Types -import Pdf.Toolbox.Document.Internal.Util - --- | Page's parent node -pageParentNode :: MonadPdf m => Page -> PdfE m PageNode -pageParentNode (Page _ dict) = do - ref <- lookupDict "Parent" dict >>= fromObject - node <- loadPageNode ref - case node of - PageTreeNode n -> return n - PageTreeLeaf _ -> throwE $ UnexpectedError "page parent should be a note, but leaf should" - --- | List of references to page's content streams -pageContents :: MonadPdf m => Page -> PdfE m [Ref] -pageContents page@(Page _ dict) = annotateError ("contents for page: " ++ show page) $ do - case lookupDict' "Contents" dict of - Nothing -> return [] - Just (ORef ref) -> do - -- it could be reference to the only content stream, - -- or to an array of content streams - o <- lookupObject ref - case o of - OStream _ -> return [ref] - OArray (Array objs) -> mapM fromObject objs - _ -> throwE $ UnexpectedError $ "Unexpected value in page content ref: " ++ show o - Just (OArray (Array objs)) -> mapM fromObject objs - _ -> throwE $ UnexpectedError "Unexpected value in page contents" - --- | Media box, inheritable -pageMediaBox :: MonadPdf m => Page -> PdfE m (Rectangle Double) -pageMediaBox page = mediaBox (PageTreeLeaf page) - -mediaBox :: MonadPdf m => PageTree -> PdfE m (Rectangle Double) -mediaBox tree = do - let dict = case tree of - PageTreeNode (PageNode _ d) -> d - PageTreeLeaf (Page _ d) -> d - case lookupDict' "MediaBox" dict of - Just box -> fromObject box >>= rectangleFromArray - Nothing -> do - parent <- case tree of - PageTreeNode node -> do - parent <- pageNodeParent node - case parent of - Nothing -> throwE $ UnexpectedError $ "Media box not found" - Just p -> return $ PageTreeNode p - PageTreeLeaf page -> PageTreeNode `liftM` pageParentNode page - mediaBox parent - --- | Font dictionaries for the page -pageFontDicts :: MonadPdf m => Page -> PdfE m [(Name, FontDict)] -pageFontDicts (Page _ dict) = - case lookupDict' "Resources" dict of - Nothing -> return [] - Just res -> do - resDict <- deref res >>= fromObject - case lookupDict' "Font" resDict of - Nothing -> return [] - Just fonts -> do - Dict fontsDict <- deref fonts >>= fromObject - forM fontsDict $ \(name, font) -> do - fontDict <- deref font >>= fromObject - ensureType "Font" fontDict - return (name, FontDict fontDict) - -data XObject = XObject Lazy.ByteString GlyphDecoder - -pageXObjects :: (MonadPdf m, MonadIO m) => Page -> PdfE m [(Name, XObject)] -pageXObjects (Page _ dict) = - case lookupDict' "Resources" dict of - Nothing -> return [] - Just res -> do - resDict <- deref res >>= fromObject - case lookupDict' "XObject" resDict of - Nothing -> return [] - Just xo' -> do - Dict xosDict <- deref xo' >>= fromObject - liftM catMaybes $ forM xosDict $ \(name, o) -> do - ref <- fromObject o - xo <- lookupObject ref >>= toStream - - let Stream xoDict _ = xo - case lookupDict' "Subtype" xoDict of - Just (OName "Form") -> do - xobject <- mkXObject xo ref - return $ Just (name, xobject) - _ -> return Nothing - -mkXObject :: (MonadPdf m, MonadIO m) => Stream Int64 -> Ref -> PdfE m XObject -mkXObject s ref = do - Stream dict is <- streamContent ref s - cont <- liftIO $ Lazy.ByteString.fromChunks <$> Streams.toList is - - fontDicts <- Map.fromList `liftM` pageFontDicts (Page undefined dict) - - glyphDecoders <- Traversable.forM fontDicts $ \fontDict -> - fontInfoDecodeGlyphs `liftM` fontDictLoadInfo fontDict - let glyphDecoder fontName = \str -> - case Map.lookup fontName glyphDecoders of - Nothing -> [] - Just decode -> decode str - - return (XObject cont glyphDecoder) - --- | Extract text from the page --- --- It tries to add spaces between chars if they don't present --- as actual characters in content stream. -pageExtractText :: (MonadPdf m, MonadIO m) => Page -> PdfE m Text -pageExtractText page = do - -- load fonts and create glyph decoder - fontDicts <- Map.fromList `liftM` pageFontDicts page - glyphDecoders <- Traversable.forM fontDicts $ \fontDict -> - fontInfoDecodeGlyphs `liftM` fontDictLoadInfo fontDict - let glyphDecoder fontName = \str -> - case Map.lookup fontName glyphDecoders of - Nothing -> [] - Just decode -> decode str - - xobjects <- Map.fromList `liftM` pageXObjects page - - -- prepare content streams - contents <- pageContents page - streams <- forM contents $ \ref -> do - s@(Stream dict _) <- lookupObject ref >>= toStream - len <- lookupDict "Length" dict >>= deref >>= fromObject >>= intValue - return (s, ref, len) - - -- parse content streams - maybe_decr <- getDecryptor - let decr = - case maybe_decr of - Nothing -> \_ is -> return is - Just decryptor -> \ref is -> decryptor ref DecryptStream is - - ris <- getRIS - filters <- getStreamFilters - is <- parseContentStream ris filters decr streams - - -- use content stream processor to extract text - let loop s p = do - next <- readNextOperator s - case next of - Just (Op_Do, [OName xoName]) -> processDo xoName p >>= loop s - Just op -> processOp op p >>= loop s - Nothing -> return p - - processDo name p = do - case Map.lookup name xobjects of - Nothing -> return p - Just (XObject cont gdec) -> do - xois <- liftIO $ do - cont_is <- Streams.fromLazyByteString cont - Streams.parserToInputStream parseContent cont_is - let gdec' = prGlyphDecoder p - p' <- loop xois (p {prGlyphDecoder = gdec}) - return (p' {prGlyphDecoder = gdec'}) - - p <- loop is $ mkProcessor { - prGlyphDecoder = glyphDecoder - } - - return $ glyphsToText (prGlyphs p) - --- | Convert glyphs to text, trying to add spaces and newlines --- --- It takes list of spans. Each span is a list of glyphs that are outputed in one shot. --- So we don't need to add space inside span, only between them. -glyphsToText :: [[Glyph]] -> Text -glyphsToText = TextL.toStrict . TextB.toLazyText . snd . foldl step ((Vector 0 0, False), mempty) - where - step acc [] = acc - step ((Vector lx2 ly2, wasSpace), res) sp = - let Vector x1 y1 = glyphTopLeft (head sp) - Vector x2 _ = glyphBottomRight (last sp) - Vector _ y2 = glyphTopLeft (last sp) - space = - if abs (ly2 - y1) < 1.8 - then if wasSpace || abs (lx2 - x1) < 1.8 - then mempty - else TextB.singleton ' ' - else TextB.singleton '\n' - txt = TextB.fromLazyText $ TextL.fromChunks $ mapMaybe glyphText sp - endWithSpace = glyphText (last sp) == Just " " - in ((Vector x2 y2, endWithSpace), mconcat [res, space, txt]) diff --git a/lib/Pdf/Toolbox/Document/PageNode.hs b/lib/Pdf/Toolbox/Document/PageNode.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/PageNode.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Page tree node - -module Pdf.Toolbox.Document.PageNode -( - PageNode, - PageTree(..), - pageNodeNKids, - pageNodeParent, - pageNodeKids, - loadPageNode, - pageNodePageByNum -) -where - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Internal.Types -import Pdf.Toolbox.Document.Internal.Util - --- | Total number of child leaf nodes, including deep children -pageNodeNKids :: MonadPdf m => PageNode -> PdfE m Int -pageNodeNKids (PageNode _ dict) = - lookupDict "Count" dict >>= fromObject >>= intValue - --- | Parent page node -pageNodeParent :: MonadPdf m => PageNode -> PdfE m (Maybe PageNode) -pageNodeParent (PageNode _ dict) = - case lookupDict' "Parent" dict of - Nothing -> return Nothing - Just o -> do - ref <- fromObject o - node <- lookupObject ref >>= fromObject - ensureType "Pages" node - return $ Just $ PageNode ref node - --- | Referencies to all kids -pageNodeKids :: MonadPdf m => PageNode -> PdfE m [Ref] -pageNodeKids (PageNode _ dict) = do - Array kids <- lookupDict "Kids" dict >>= fromObject - mapM fromObject kids - --- | Load page tree node by reference -loadPageNode :: MonadPdf m => Ref -> PdfE m PageTree -loadPageNode ref = do - node <- lookupObject ref >>= fromObject - nodeType <- dictionaryType node - case nodeType of - "Pages" -> return $ PageTreeNode $ PageNode ref node - "Page" -> return $ PageTreeLeaf $ Page ref node - _ -> throwE $ UnexpectedError $ "Unexpected page tree node type: " ++ show nodeType - --- | Find page by it's number --- --- Note: it is not efficient for PDF files with a lot of pages, --- because it performs traversal through the page tree each time. --- Use 'pageNodeNKids', 'pageNodeKids' and 'loadPageNode' for --- efficient traversal. -pageNodePageByNum :: MonadPdf m => PageNode -> Int -> PdfE m Page -pageNodePageByNum node num = annotateError ("page #" ++ show num ++ " for node: " ++ show node) $ do - pageNodeKids node >>= loop num - where - loop _ [] = throwE $ UnexpectedError "Page not found" - loop i (x:xs) = do - kid <- loadPageNode x - case kid of - PageTreeNode n -> do - nkids <- pageNodeNKids n - if i < nkids - then pageNodePageByNum n i - else loop (i - nkids) xs - PageTreeLeaf page -> - if i == 0 - then return page - else loop (i - 1) xs diff --git a/lib/Pdf/Toolbox/Document/Pdf.hs b/lib/Pdf/Toolbox/Document/Pdf.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Pdf.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | Basic implementation of pdf monad - -module Pdf.Toolbox.Document.Pdf -( - Pdf, - Pdf', - runPdf, - runPdfWithHandle, - document, - flushObjectCache, - withoutObjectCache, - knownFilters, - isEncrypted, - setUserPassword, - defaultUserPassword, - decrypt, - MonadIO(..) -) -where - -import Data.Int -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Map (Map) -import qualified Data.Map as Map -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import System.IO -import qualified System.IO.Streams as Streams - -import Pdf.Toolbox.Core - -import Pdf.Toolbox.Document.Monad -import Pdf.Toolbox.Document.Encryption -import Pdf.Toolbox.Document.Internal.Types - -data PdfState = PdfState { - stRIS :: RIS, - stFilters :: [StreamFilter], - stLastXRef :: Maybe XRef, - stAddToObjectCache :: Bool, - stObjectCache :: Map Ref (Object Int64), - stXRefStreamCache :: Map Int64 [ByteString], - stDecryptor :: Maybe Decryptor - } - --- | Basic implementation of pdf monad -newtype Pdf' m a = Pdf' (StateT PdfState m a) - deriving (Monad, Functor, Applicative, MonadIO, MonadTrans) - --- | Convenient type alias -type Pdf m = PdfE (Pdf' m) - -instance MonadIO m => MonadPdf (Pdf' m) where - lookupObject ref = annotateError ("lookupObject: " ++ show ref) $ do - cached <- getFromCache ref - case cached of - Just o -> return o - Nothing -> do - xref <- getLastXRef - entry <- lookupEntryRec ref xref - o <- readObjectForEntry ref entry - addObjectToCache ref o - return o - streamContent ref s = do - decryptor <- do - dec <- getDecryptor - case dec of - Nothing -> return return - Just d -> return $ d ref DecryptStream - takeStreamContent decryptor s - getDecryptor = lift $ Pdf' $ gets stDecryptor - getRIS = lift $ Pdf' $ gets stRIS - getStreamFilters = lift $ Pdf' $ gets stFilters - -readObjectForEntry :: MonadIO m => Ref -> XRefEntry -> Pdf m (Object Int64) -readObjectForEntry ref (XRefTableEntry entry) - | teIsFree entry = return ONull - | otherwise = do - ris <- getRIS - readObjectAtOffset ris (teOffset entry) (teGen entry) >>= decrypt ref -readObjectForEntry ref (XRefStreamEntry entry) = - case entry of - StreamEntryFree _ _ -> return ONull - StreamEntryUsed off gen -> do - ris <- getRIS - readObjectAtOffset ris off gen >>= decrypt ref - StreamEntryCompressed index num -> do - objStream <- lookupObject (Ref index 0) >>= toStream - Stream dict is <- streamContent (Ref index 0) objStream - first <- lookupDict "First" dict >>= fromObject >>= intValue - mapObject (error "readObjectForEntry: impossible") `liftM` - readCompressedObject is (fromIntegral first) num - -getXRefStream :: MonadIO m => Stream Int64 -> Pdf m (Stream IS) -getXRefStream s@(Stream dict off) = do - cache <- lift $ Pdf' $ gets stXRefStreamCache - content <- - case Map.lookup off cache of - Just content -> return content - Nothing -> do - Stream _ is <- takeStreamContent return s - content <- liftIO $ Streams.toList is - lift $ Pdf' $ modify $ \st -> st {stXRefStreamCache = Map.insert off content $ stXRefStreamCache st} - return content - is <- liftIO $ Streams.fromList content - return $ Stream dict is - -lookupEntryRec :: MonadIO m => Ref -> XRef -> Pdf m XRefEntry -lookupEntryRec ref = annotateError ("Can't find xref entry for ref: " ++ show ref) . loop - where - loop xref = do - res <- lookupXRefEntry ref xref - case res of - Just e -> return e - Nothing -> do - ris <- getRIS - prev <- prevXRef ris xref - case prev of - Just xref' -> loop xref' - Nothing -> throwE $ UnexpectedError "There are no more xrefs" - -lookupXRefEntry :: MonadIO m => Ref -> XRef -> Pdf m (Maybe XRefEntry) -lookupXRefEntry ref (XRefTable off) = do - ris <- getRIS - seek ris off - _ <- inputStream ris >>= isTable - fmap XRefTableEntry `liftM` lookupTableEntry ris ref -lookupXRefEntry ref (XRefStream _ s) = do - decoded <- getXRefStream s - fmap XRefStreamEntry `liftM` lookupStreamEntry decoded ref - -takeStreamContent :: MonadIO m => (IS -> IO IS) -> Stream Int64 -> Pdf m (Stream IS) -takeStreamContent decryptor s@(Stream dict _) = annotateError ("reading stream content: " ++ show s) $ do - len <- do - obj <- lookupDict "Length" dict - case obj of - ONumber _ -> fromObject obj >>= intValue - ORef ref -> lookupObject ref >>= fromObject >>= intValue - _ -> throwE $ UnexpectedError $ "Unexpected length object in stream: " ++ show obj - ris <- getRIS - filters <- lift $ Pdf' $ gets stFilters - decodedStreamContent ris filters decryptor len s - -getLastXRef :: MonadIO m => Pdf m XRef -getLastXRef = do - cached <- lift $ Pdf' $ gets stLastXRef - case cached of - Just xref -> return xref - Nothing -> do - xref <- getRIS >>= lastXRef - lift $ Pdf' $ modify $ \st -> st {stLastXRef = Just xref} - return xref - -getFromCache :: Monad m => Ref -> Pdf m (Maybe (Object Int64)) -getFromCache ref = do - cache <- lift $ Pdf' $ gets stObjectCache - return $ Map.lookup ref cache - -addObjectToCache :: Monad m => Ref -> Object Int64 -> Pdf m () -addObjectToCache ref o = do - add <- lift $ Pdf' $ gets stAddToObjectCache - when add $ - lift $ Pdf' $ modify $ \st -> - st {stObjectCache = Map.insert ref o $ stObjectCache st} - --- | Perform action without adding objects to cache. --- Note: the existent cache is not flushed, and is used --- within the action -withoutObjectCache :: Monad m => Pdf m () -> Pdf m () -withoutObjectCache action = do - old <- lift $ Pdf' $ do - val <- gets stAddToObjectCache - modify $ \st -> st {stAddToObjectCache = False} - return val - action - lift $ Pdf' $ modify $ \st -> st {stAddToObjectCache = old} - --- | Remove all objects from cache -flushObjectCache :: Monad m => Pdf m () -flushObjectCache = lift $ Pdf' $ modify $ \st -> st {stObjectCache = Map.empty} - --- | Execute PDF action with 'RIS' -runPdf :: MonadIO m => RIS -> [StreamFilter] -> Pdf m a -> m (Either PdfError a) -runPdf ris filters action = runPdf' ris filters $ runExceptT action - --- | Execute PDF action with 'Handle' -runPdfWithHandle :: MonadIO m => Handle -> [StreamFilter] -> Pdf m a -> m (Either PdfError a) -runPdfWithHandle handle filters action = do - ris <- liftIO $ fromHandle handle - runPdf ris filters action - -runPdf' :: MonadIO m => RIS -> [StreamFilter] -> Pdf' m a -> m a -runPdf' ris filters (Pdf' action) = evalStateT action $ PdfState { - stRIS = ris, - stFilters = filters, - stLastXRef = Nothing, - stObjectCache = Map.empty, - stXRefStreamCache = Map.empty, - stDecryptor = Nothing, - stAddToObjectCache = True - } - --- | Get PDF document -document :: MonadIO m => Pdf m Document -document = do - ris <- getRIS - xref <- lastXRef ris - tr <- trailer ris xref - return $ Document xref tr - --- | Whether the PDF document it encrypted -isEncrypted :: MonadIO m => Pdf m Bool -isEncrypted = annotateError "isEncrypted" $ do - ris <- getRIS - tr <- lastXRef ris >>= trailer ris - case lookupDict' "Encrypt" tr of - Nothing -> return False - Just _ -> return True - --- | Set the password to be user for decryption --- --- Returns False when the password is wrong -setUserPassword :: MonadIO m => ByteString -> Pdf m Bool -setUserPassword pass = annotateError "setUserPassword" $ do - ris <- getRIS - tr <- lastXRef ris >>= trailer ris - enc <- case lookupDict' "Encrypt" tr of - Nothing -> throwE $ UnexpectedError "The document is not encrypted" - Just enc -> deref enc >>= fromObject - decryptor <- mkStandardDecryptor tr enc $ BS.take 32 $ pass `mappend` defaultUserPassword - lift $ Pdf' $ modify $ \s -> s {stDecryptor = decryptor} - case decryptor of - Nothing -> return False - _ -> return True - --- | Decrypt PDF object using user password is set -decrypt :: MonadIO m => Ref -> Object a -> Pdf m (Object a) -decrypt ref o = do - decryptor <- getDecryptor - case decryptor of - Nothing -> return o - Just decr -> liftIO $ decryptObject (decr ref DecryptString) o diff --git a/lib/Pdf/Toolbox/Document/Types.hs b/lib/Pdf/Toolbox/Document/Types.hs deleted file mode 100644 --- a/lib/Pdf/Toolbox/Document/Types.hs +++ /dev/null @@ -1,25 +0,0 @@ - --- | Various types - -module Pdf.Toolbox.Document.Types -( - Rectangle(..), - rectangleFromArray -) -where - -import Pdf.Toolbox.Core - --- | Rectangle -data Rectangle a = Rectangle a a a a - deriving Show - --- | Create rectangle form an array of 4 numbers -rectangleFromArray :: Monad m => Array -> PdfE m (Rectangle Double) -rectangleFromArray (Array [a', b', c', d']) = do - a <- fromObject a' >>= realValue - b <- fromObject b' >>= realValue - c <- fromObject c' >>= realValue - d <- fromObject d' >>= realValue - return $ Rectangle a b c d -rectangleFromArray array = throwE $ UnexpectedError $ "rectangleFromArray: " ++ show array diff --git a/pdf-toolbox-document.cabal b/pdf-toolbox-document.cabal --- a/pdf-toolbox-document.cabal +++ b/pdf-toolbox-document.cabal @@ -1,5 +1,5 @@ name: pdf-toolbox-document -version: 0.0.7.1 +version: 0.1.4 synopsis: A collection of tools for processing PDF files. license: BSD3 license-file: LICENSE @@ -8,9 +8,11 @@ copyright: Copyright (c) Yuras Shumovich 2012-2016 category: PDF build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 homepage: https://github.com/Yuras/pdf-toolbox extra-source-files: changelog.md + test/files/nested_xobject.pdf + test/files/indirect_font_desc_fields.pdf description: Mid level tools for processing PDF files. . @@ -23,29 +25,43 @@ library hs-source-dirs: lib compat - exposed-modules: Pdf.Toolbox.Document - Pdf.Toolbox.Document.Types - Pdf.Toolbox.Document.Monad - Pdf.Toolbox.Document.Pdf - Pdf.Toolbox.Document.Document - Pdf.Toolbox.Document.Info - Pdf.Toolbox.Document.Catalog - Pdf.Toolbox.Document.PageNode - Pdf.Toolbox.Document.Page - Pdf.Toolbox.Document.FontDict - Pdf.Toolbox.Document.Encryption - Pdf.Toolbox.Document.Internal.Types - Pdf.Toolbox.Document.Internal.Util + exposed-modules: Pdf.Document + Pdf.Document.Types + Pdf.Document.Pdf + Pdf.Document.Document + Pdf.Document.Info + Pdf.Document.Catalog + Pdf.Document.PageNode + Pdf.Document.Page + Pdf.Document.FontDict + Pdf.Document.Internal.Types + Pdf.Document.Internal.Util other-modules: Prelude - build-depends: base >= 4.5 && < 5, - transformers, + build-depends: base >= 4.9 && < 5, containers, text, bytestring, + vector, + unordered-containers, io-streams, - cipher-rc4, - cipher-aes, - cryptohash, - crypto-api, - pdf-toolbox-core ==0.0.4.*, - pdf-toolbox-content ==0.0.5.* + pdf-toolbox-core ==0.1.*, + pdf-toolbox-content ==0.1.* + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + other-modules: Test.Internal.Util + build-depends: base, + directory, + unordered-containers, + io-streams, + hspec, + pdf-toolbox-core, + pdf-toolbox-document + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + default-language: Haskell2010 diff --git a/test/Test/Internal/Util.hs b/test/Test/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Internal/Util.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Internal.Util +( spec +) +where + +import Pdf.Document.Internal.Util + +import Test.Hspec + +spec :: Spec +spec = describe "Internal.Util" $ do + describe "decodeTextString" $ do + context "when string starts with BOM" $ do + it "decodes it as UTF16BE" $ do + decodeTextString "\254\255\NULH\NULe\NULl\NULl\NULo\EOT^" + `shouldBe` Right "Helloў" + + context "when string doesn't start with BOM" $ do + it "decodes it as PDFDocEncoding string" $ do + decodeTextString "Hello\130" + `shouldBe` Right "Hello‡" diff --git a/test/files/indirect_font_desc_fields.pdf b/test/files/indirect_font_desc_fields.pdf new file mode 100644 --- /dev/null +++ b/test/files/indirect_font_desc_fields.pdf @@ -0,0 +1,59 @@ +%PDF-1.7 + +1 0 obj +<> +endobj + +2 0 obj +<> +endobj + +3 0 obj +<> /XObject <>>> /MediaBox [0 0 200 200] /Contents 4 0 R /Type /Page>> +endobj + +5 0 obj +<> +endobj + +6 0 obj +<> +endobj + +7 0 obj +0 +endobj + +4 0 obj +<>stream +BT /F1 12 Tf 100 100 TD (Hello World!!!) Tj ET /X1 Do +endstream +endobj + +8 0 obj +<> /XObject <>>> /BBox [0 0 200 200] /Subtype /Form /Type /XObject>>stream +BT /F1 12 Tf 10 10 TD (XObject is here) Tj ET /X1 Do +endstream +endobj + +9 0 obj +<>>> /BBox [0 0 200 200] /Subtype /Form /Type /XObject>>stream +BT /F1 12 Tf 50 50 TD (nested XObject is here) Tj ET +endstream +endobj +xref +1 9 +0000000009 00000 n +0000000057 00000 n +0000000113 00000 n +0000000503 00000 n +0000000257 00000 n +0000000348 00000 n +0000000485 00000 n +0000000604 00000 n +0000000812 00000 n +trailer +<> +startxref +997 +%%EOF diff --git a/test/files/nested_xobject.pdf b/test/files/nested_xobject.pdf new file mode 100644 --- /dev/null +++ b/test/files/nested_xobject.pdf @@ -0,0 +1,49 @@ +%PDF-1.7 + +1 0 obj +<> +endobj + +2 0 obj +<> +endobj + +3 0 obj +<> /XObject <>>> /MediaBox [0 0 200 200] /Contents 4 0 R /Parent 2 0 R /Type /Page>> +endobj + +5 0 obj +<> +endobj + +4 0 obj +<>stream +BT /F1 12 Tf 100 100 TD (Hello World!!!) Tj ET /X1 Do +endstream +endobj + +6 0 obj +<> /XObject <>>> /Subtype /Form /Type /XObject /BBox [0 0 200 200]>>stream +BT /F1 12 Tf 10 10 TD (XObject is here) Tj ET /X1 Do +endstream +endobj + +7 0 obj +<>>> /Subtype /Form /Type /XObject /BBox [0 0 200 200]>>stream +BT /F1 12 Tf 50 50 TD (nested XObject is here) Tj ET +endstream +endobj +xref +1 7 +0000000009 00000 n +0000000057 00000 n +0000000113 00000 n +0000000326 00000 n +0000000257 00000 n +0000000427 00000 n +0000000635 00000 n +trailer +<> +startxref +820 +%%EOF diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main +( + main +) +where + +import Pdf.Core.Object +import Pdf.Core.Writer +import Pdf.Document + +import qualified Test.Internal.Util as Internal.Util + +import qualified Data.HashMap.Strict as HashMap +import Control.Exception (bracket, finally) +import Control.Monad +import System.IO +import qualified System.IO.Streams as Streams +import System.Directory (getTemporaryDirectory, removeFile) +import System.Timeout + +import Test.Hspec + +main :: IO () +main = hspec $ do + Internal.Util.spec + + describe "simple.pdf" $ do + it "should have title" $ + withSimpleFile $ \h -> do + pdf <- fromHandle h + doc <- document pdf + maybe_info <- documentInfo doc + title <- + case maybe_info of + Nothing -> return Nothing + Just info -> infoTitle info + title `shouldBe` Just "simple PDF file" + + describe "nested_xobject" $ do + it "should have correct text" $ do + withPdfFile "test/files/nested_xobject.pdf" $ \pdf -> do + doc <- document pdf + catalog <- documentCatalog doc + root <- catalogPageNode catalog + page <- pageNodePageByNum root 0 + -- here timeout breaks infinite loop in case of a bug + txt <- timeout 5000000 $ pageExtractText page + txt `shouldBe` Just + "\nHello World!!!\nXObject is here\nnested XObject is here" + + describe "FontDescription with indirect fields" $ do + it "should have correct text" $ do + withPdfFile "test/files/indirect_font_desc_fields.pdf" $ \pdf -> do + doc <- document pdf + catalog <- documentCatalog doc + root <- catalogPageNode catalog + page <- pageNodePageByNum root 0 + -- here timeout breaks infinite loop in case of a bug + txt <- timeout 5000000 $ pageExtractText page + txt `shouldBe` Just + "\nHello World!!!\nXObject is here\nnested XObject is here" + +-- | Generate simple PDF file for tests +withSimpleFile :: (Handle -> IO ()) -> IO () +withSimpleFile action = do + dir <- getTemporaryDirectory + bracket + (openBinaryTempFile dir "simple.pdf") + (\(path, h) -> hClose h `finally` removeFile path) + $ \(_, h) -> do + out <- Streams.handleToOutputStream h + + writer <- makeWriter out + writeHeader writer + deleteObject writer (R 0 1) 65535 + forM_ objects $ \(ref, obj) -> + writeObject writer ref obj + writeXRefTable writer 0 tr + + action h + where + tr = HashMap.fromList + [ ("Size", Number $ fromIntegral $ length objects + 1) + , ("Info", Ref infoRef) + ] + info = HashMap.fromList + [ ("Title", String "simple PDF file") + ] + objects = + [ (infoRef, Dict info) + ] + infoRef = R 1 0