pdf-toolbox-document 0.0.7.1 → 0.1.4
raw patch · 31 files changed
Files
- changelog.md +15/−10
- compat/Prelude.hs +4/−9
- lib/Pdf/Document.hs +39/−0
- lib/Pdf/Document/Catalog.hs +31/−0
- lib/Pdf/Document/Document.hs +61/−0
- lib/Pdf/Document/FontDict.hs +324/−0
- lib/Pdf/Document/Info.hs +98/−0
- lib/Pdf/Document/Internal/Types.hs +50/−0
- lib/Pdf/Document/Internal/Util.hs +58/−0
- lib/Pdf/Document/Page.hs +297/−0
- lib/Pdf/Document/PageNode.hs +95/−0
- lib/Pdf/Document/Pdf.hs +146/−0
- lib/Pdf/Document/Types.hs +9/−0
- lib/Pdf/Toolbox/Document.hs +0/−45
- lib/Pdf/Toolbox/Document/Catalog.hs +0/−24
- lib/Pdf/Toolbox/Document/Document.hs +0/−45
- lib/Pdf/Toolbox/Document/Encryption.hs +0/−233
- lib/Pdf/Toolbox/Document/FontDict.hs +0/−181
- lib/Pdf/Toolbox/Document/Info.hs +0/−23
- lib/Pdf/Toolbox/Document/Internal/Types.hs +0/−49
- lib/Pdf/Toolbox/Document/Internal/Util.hs +0/−24
- lib/Pdf/Toolbox/Document/Monad.hs +0/−38
- lib/Pdf/Toolbox/Document/Page.hs +0/−222
- lib/Pdf/Toolbox/Document/PageNode.hs +0/−77
- lib/Pdf/Toolbox/Document/Pdf.hs +0/−247
- lib/Pdf/Toolbox/Document/Types.hs +0/−25
- pdf-toolbox-document.cabal +39/−23
- test/Test/Internal/Util.hs +23/−0
- test/files/indirect_font_desc_fields.pdf +59/−0
- test/files/nested_xobject.pdf +49/−0
- test/test.hs +94/−0
changelog.md view
@@ -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
compat/Prelude.hs view
@@ -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
+ lib/Pdf/Document.hs view
@@ -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
+ lib/Pdf/Document/Catalog.hs view
@@ -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)
+ lib/Pdf/Document/Document.hs view
@@ -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" [])
+ lib/Pdf/Document/FontDict.hs view
@@ -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
+ lib/Pdf/Document/Info.hs view
@@ -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
+ lib/Pdf/Document/Internal/Types.hs view
@@ -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
+ lib/Pdf/Document/Internal/Util.hs view
@@ -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)
+ lib/Pdf/Document/Page.hs view
@@ -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])
+ lib/Pdf/Document/PageNode.hs view
@@ -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
+ lib/Pdf/Document/Pdf.hs view
@@ -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
+ lib/Pdf/Document/Types.hs view
@@ -0,0 +1,9 @@++-- | Various types++module Pdf.Document.Types+ ( module Pdf.Core.Types+ )+where++import Pdf.Core.Types
− lib/Pdf/Toolbox/Document.hs
@@ -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
− lib/Pdf/Toolbox/Document/Catalog.hs
@@ -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
− lib/Pdf/Toolbox/Document/Document.hs
@@ -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
− lib/Pdf/Toolbox/Document/Encryption.hs
@@ -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
− lib/Pdf/Toolbox/Document/FontDict.hs
@@ -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"
− lib/Pdf/Toolbox/Document/Info.hs
@@ -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
− lib/Pdf/Toolbox/Document/Internal/Types.hs
@@ -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
− lib/Pdf/Toolbox/Document/Internal/Util.hs
@@ -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
− lib/Pdf/Toolbox/Document/Monad.hs
@@ -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
− lib/Pdf/Toolbox/Document/Page.hs
@@ -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])
− lib/Pdf/Toolbox/Document/PageNode.hs
@@ -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
− lib/Pdf/Toolbox/Document/Pdf.hs
@@ -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
− lib/Pdf/Toolbox/Document/Types.hs
@@ -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
pdf-toolbox-document.cabal view
@@ -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
+ test/Test/Internal/Util.hs view
@@ -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‡"
+ test/files/indirect_font_desc_fields.pdf view
@@ -0,0 +1,59 @@+%PDF-1.7++1 0 obj+<</Pages 2 0 R /Type /Catalog>>+endobj++2 0 obj+<</Count 1 /Kids [3 0 R] /Type /Pages>>+endobj++3 0 obj+<</Parent 2 0 R /Resources <</Font <</F1 5 0 R>> /XObject <</X1 8 0 R>>>> /MediaBox [0 0 200 200] /Contents 4 0 R /Type /Page>>+endobj++5 0 obj+<</BaseFont /Helvetica /Subtype /Type1 /FontDescriptor 6 0 R /Type /Font>>+endobj++6 0 obj+<</Flags 7 0 R /Rectangle [0 0 10 10] /ItalicAngle -10 /FontName /Helvetica /Descent 2 /Type /FontDescriptor /Ascent 8>>+endobj++7 0 obj+0+endobj++4 0 obj+<</Length 53>>stream+BT /F1 12 Tf 100 100 TD (Hello World!!!) Tj ET /X1 Do+endstream+endobj++8 0 obj+<</Length 52 /Resources <</Font <</F1 5 0 R>> /XObject <</X1 9 0 R>>>> /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+<</Length 52 /Resources <</Font <</F1 5 0 R>>>> /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+<</Root 1 0 R /Size 6>>+startxref+997+%%EOF
+ test/files/nested_xobject.pdf view
@@ -0,0 +1,49 @@+%PDF-1.7++1 0 obj+<</Pages 2 0 R /Type /Catalog>>+endobj++2 0 obj+<</Count 1 /Kids [3 0 R] /Type /Pages>>+endobj++3 0 obj+<</Resources <</Font <</F1 5 0 R>> /XObject <</X1 6 0 R>>>> /MediaBox [0 0 200 200] /Contents 4 0 R /Parent 2 0 R /Type /Page>>+endobj++5 0 obj+<</Subtype /Type1 /BaseFont /Helvetica /Type /Font>>+endobj++4 0 obj+<</Length 53>>stream+BT /F1 12 Tf 100 100 TD (Hello World!!!) Tj ET /X1 Do+endstream+endobj++6 0 obj+<</Length 52 /Resources <</Font <</F1 5 0 R>> /XObject <</X1 7 0 R>>>> /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+<</Length 52 /Resources <</Font <</F1 5 0 R>>>> /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+<</Root 1 0 R /Size 4>>+startxref+820+%%EOF
+ test/test.hs view
@@ -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