rakhana 0.1.0.0 → 0.1.0.1
raw patch · 8 files changed
+820/−182 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.Rakhana: withNursery :: MonadThrow m => Playground m a -> Drive m a
+ Data.Rakhana: withNursery :: MonadCatch m => Client' NReq NResp m a -> Drive m a
Files
- CHANGELOG.markdown +6/−0
- Data/Rakhana/Internal/Parsers.hs +5/−103
- Data/Rakhana/Internal/Types.hs +6/−18
- Data/Rakhana/Nursery.hs +201/−41
- Data/Rakhana/Tape.hs +5/−2
- Data/Rakhana/Util/Drive.hs +19/−7
- Data/Rakhana/XRef.hs +574/−10
- rakhana.cabal +4/−1
+ CHANGELOG.markdown view
@@ -0,0 +1,6 @@+0.1.0.1+-------+* Added Cross-reference Streams support+* Added Compressed objects support+* Added Object Streams support+* Added PNG UP unprediction support
Data/Rakhana/Internal/Parsers.hs view
@@ -2,14 +2,14 @@ -------------------------------------------------------------------------------- -- | -- Module : Data.Rakhana.Internal.Parsers--- Copyright : (C) 2014 Yorick Laupa+-- Copyright : (C) 2013 Yuras Shumovich, (C) 2014 Yorick Laupa -- License : (see the file LICENSE) -- -- Maintainer : Yorick Laupa <yo.eight@gmail.com> -- Stability : provisional -- Portability : non-portable ----- Base on pdf-toolbox Parser code+-- Based on pdf-toolbox Parser code -------------------------------------------------------------------------------- module Data.Rakhana.Internal.Parsers where @@ -20,7 +20,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Char (digitToInt, isDigit, isHexDigit)-import Data.Map (Map, fromList)+import Data.Map (fromList) import qualified Data.Vector as V --------------------------------------------------------------------------------@@ -54,75 +54,6 @@ xs -> return $ last xs ---------------------------------------------------------------------------------tableXRef :: Parser ()-tableXRef- = do _ <- string "xref"- pdfEndOfLine-----------------------------------------------------------------------------------parseXRef :: Parser XRef-parseXRef- = do skipSpace- tableXRef- h@(s,_) <- parseSubsectionHeader- es <- parseTableEntries s- t <- parseTrailerAfterTable- return $ makeXRef h (fromList es) t-----------------------------------------------------------------------------------parseSubsectionHeader :: Parser (Int, Int)-parseSubsectionHeader- = do start <- decimal- skipSpace- len <- decimal- pdfEndOfLine- return (start, len)-----------------------------------------------------------------------------------parseTrailerAfterTable :: Parser Dictionary-parseTrailerAfterTable- = do skipSpace- _ <- string "trailer"- pdfEndOfLine- skipSpace- Dict d <- parseDict- return d-----------------------------------------------------------------------------------parseTableEntries :: Int -> Parser [(Reference, TableEntry)]-parseTableEntries start- = loop start- where- loop i- = do mT <- optional parseTableEntry- case mT of- Nothing -> return []- Just t- -> let gen = tableEntryGeneration t- off = tableEntryOffset t- ref = (i,gen) in- if (off /= 0)- then fmap ((ref,t):) $ loop (i+1)- else loop (i+1)-----------------------------------------------------------------------------------parseTableEntry :: Parser TableEntry-parseTableEntry- = do skipSpace- offset <- decimal- skipSpace- gen <- decimal- skipSpace- c <- anyChar- case c of- 'n' -> return $ makeTableEntry offset gen False- 'f' -> return $ makeTableEntry offset gen True- _ ->- let msg = "error parsing XRef table entry: unknown char: " ++- [c] in- fail msg---------------------------------------------------------------------------------- parseDict :: Parser Object parseDict = do _ <- string "<<"@@ -258,9 +189,8 @@ parseStreamHeader :: Parser () parseStreamHeader = do skipSpace- _ <- string "stream"- skipSpace- return ()+ _ <- string "stream"+ endOfLine -------------------------------------------------------------------------------- parseIndirectObject :: Parser (Int, Int, Object)@@ -277,40 +207,12 @@ return (idx, gen, obj) ---------------------------------------------------------------------------------makeXRef :: (Int, Int)- -> Map Reference TableEntry- -> Dictionary- -> XRef-makeXRef header entries dict- = XRef- { xrefHeader = header- , xrefEntries = entries- , xrefTrailer = dict- }-----------------------------------------------------------------------------------makeTableEntry :: Integer -> Int -> Bool -> TableEntry-makeTableEntry offset gen free- = TableEntry- { tableEntryOffset = offset- , tableEntryGeneration = gen- , tableEntryFree = free- }---------------------------------------------------------------------------------- makeHeader :: Int -> Int -> Header makeHeader mj mi = Header { headerMaj = mj , headerMin = mi }-----------------------------------------------------------------------------------parseTillStreamData :: Parser ()-parseTillStreamData- = do skipSpace- _ <- string "stream"- pdfEndOfLine -------------------------------------------------------------------------------- charToInt :: Char -> Int
Data/Rakhana/Internal/Types.hs view
@@ -55,30 +55,18 @@ deriving (Eq, Show) ---------------------------------------------------------------------------------data TableEntry- = TableEntry- { tableEntryOffset :: !Integer- , tableEntryGeneration :: !Int- , tableEntryFree :: !Bool- }- deriving Show-----------------------------------------------------------------------------------data XRef- = XRef- { xrefHeader :: !(Int, Int)- , xrefEntries :: !(M.Map Reference TableEntry)- , xrefTrailer :: !Dictionary- }- deriving Show---------------------------------------------------------------------------------- data Header = Header { headerMaj :: !Int , headerMin :: !Int } deriving Show++--------------------------------------------------------------------------------+data Filter+ = FlateDecode+ | Filter_Unsupported ByteString+ deriving Show -------------------------------------------------------------------------------- -- Prisms
Data/Rakhana/Nursery.hs view
@@ -26,16 +26,22 @@ ) where --------------------------------------------------------------------------------+import Prelude hiding (take, takeWhile)+import Control.Applicative import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as M import Data.Typeable hiding (Proxy) ---------------------------------------------------------------------------------import Codec.Compression.Zlib (decompress)-import Control.Lens-import Control.Monad.Catch (Exception, MonadThrow(..))-import Pipes-import Pipes.Core+import Codec.Compression.Zlib (decompress)+import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Attoparsec.ByteString.Char8+import qualified Data.Attoparsec.ByteString.Lazy as PL+import Pipes+import Pipes.Core -------------------------------------------------------------------------------- import Data.Rakhana.Internal.Parsers@@ -47,10 +53,16 @@ -------------------------------------------------------------------------------- data NurseryException = NurseryParsingException String+ | NurseryParsingExceptionInObjStm String | NurseryUnresolvedObject Int Int | NurseryRootNotFound | NurseryPagesNotFound | NurseryInvalidStreamObject+ | NurseryInvalidLinearizedObject+ | NurseryXRefException XRefException+ | NurseryExpectedStreamObject+ | NurseryInvalidObjStm+ | NurseryUnresolvedObjectInObjStm Int deriving (Show, Typeable) --------------------------------------------------------------------------------@@ -79,6 +91,18 @@ | RReferences [Reference] --------------------------------------------------------------------------------+data ObjStm+ = ObjStm+ { objStmCount :: !Integer+ , objStmFirst :: !Integer+ , objStmExtends :: !(Maybe Reference)+ , objStmOffset :: !Integer+ , objStmStream :: !BL.ByteString+ , objStmReg :: !(M.Map Integer Integer)+ }+ deriving Show++-------------------------------------------------------------------------------- instance Exception NurseryException --------------------------------------------------------------------------------@@ -93,15 +117,36 @@ -------------------------------------------------------------------------------- bufferSize :: Int-bufferSize = 4096+bufferSize = 64 ---------------------------------------------------------------------------------nursery :: MonadThrow m => Nursery m a+nursery :: MonadCatch m => Nursery m a nursery- = do h <- getHeader- pos <- getXRefPos- xref <- getXRef pos- info <- getInfo xref+ = do h <- getHeader+ initState <- regularPDFAccess h+ rq <- respond Unit+ nurseryLoop dispatch initState rq+ where+ dispatch s RqInfo = serveInfo s+ dispatch s RqPages = servePages s+ dispatch s (RqResolve ref) = serveResolve s ref+ dispatch s RqHeader = serveHeader s+ dispatch s (RqLoadStreamData t) = serveLoadStream s t+ dispatch s RqReferences = serveReferences s++--------------------------------------------------------------------------------+regularPDFAccess :: MonadThrow m => Header -> Nursery m NurseryState+regularPDFAccess h+ = do pos <- getXRefPos+ xrefE <- getXRef h pos+ case xrefE of+ Left e -> throwM $ NurseryXRefException e+ Right xref -> nurseryState h xref++--------------------------------------------------------------------------------+nurseryState :: MonadThrow m => Header -> XRef -> Nursery m NurseryState+nurseryState h xref+ = do info <- getInfo xref root <- getRoot xref pages <- getPages xref root let initState = NurseryState@@ -111,15 +156,7 @@ , nurseryInfo = info , nurseryPages = pages }- rq <- respond Unit- nurseryLoop dispatch initState rq- where- dispatch s RqInfo = serveInfo s- dispatch s RqPages = servePages s- dispatch s (RqResolve ref) = serveResolve s ref- dispatch s RqHeader = serveHeader s- dispatch s (RqLoadStreamData t) = serveLoadStream s t- dispatch s RqReferences = serveReferences s+ return initState -------------------------------------------------------------------------------- serveInfo :: Monad m => NurseryState -> Nursery m (NResp, NurseryState)@@ -155,7 +192,15 @@ => NurseryState -> Stream -> Nursery m (NResp, NurseryState)-serveLoadStream s st+serveLoadStream s stream+ = do bs <- loadStream xref stream+ return (RBinaryLazy bs, s)+ where+ xref = nurseryXRef s++--------------------------------------------------------------------------------+loadStream :: MonadThrow m => XRef -> Stream -> Nursery m BL.ByteString+loadStream xref stream = do mLen <- dict ^!? dictKey "Length" . act (resolveIfRef xref) . _Number@@ -167,23 +212,21 @@ -> do driveSeek pos bs <- driveGetLazy $ fromIntegral len let filt = dict ^? dictKey "Filter" . _Name- bs' = case filt of- Nothing -> bs- Just x | "FlateDecode" <- x- -> decompress bs- | otherwise -> bs- return (RBinaryLazy bs', s)++ case filt of+ Nothing -> return bs+ Just x | "FlateDecode" <- x -> return $ decompress bs+ | otherwise -> return $ bs where- dict = st ^. streamDict- pos = st ^. streamPos- xref = nurseryXRef s+ dict = stream ^. streamDict+ pos = stream ^. streamPos -------------------------------------------------------------------------------- serveReferences :: Monad m => NurseryState -> Nursery m (NResp, NurseryState) serveReferences s- = return (RReferences $ rs, s)+ = return (RReferences rs, s) where- rs = M.keys $ xrefEntries $ nurseryXRef s+ rs = M.keys $ xrefUTable $ nurseryXRef s -------------------------------------------------------------------------------- getHeader :: MonadThrow m => Nursery m Header@@ -203,6 +246,13 @@ -------------------------------------------------------------------------------- getRoot :: MonadThrow m => XRef -> Nursery m Root getRoot xref+ = maybe (trailerRoot xref) (streamRoot xref) xstreamM+ where+ xstreamM = xrefStream xref++--------------------------------------------------------------------------------+trailerRoot :: MonadThrow m => XRef -> Nursery m Root+trailerRoot xref = do mR <- trailer ^!? action case mR of Nothing -> throwM NurseryRootNotFound@@ -217,6 +267,22 @@ . _Dict --------------------------------------------------------------------------------+streamRoot :: MonadThrow m => XRef -> XRefStream -> Nursery m Root+streamRoot xref xstream+ = do mR <- dict ^!? action+ case mR of+ Nothing -> throwM NurseryRootNotFound+ Just r -> return r+ where+ dict = xrefStreamDict xstream++ action+ = dictKey "Root"+ . _Ref+ . act (resolveObject xref)+ . _Dict++-------------------------------------------------------------------------------- getPages :: MonadThrow m => XRef -> Root -> Nursery m Pages getPages xref root = do mP <- root ^!? action@@ -237,27 +303,121 @@ -------------------------------------------------------------------------------- resolveObject :: MonadThrow m => XRef -> Reference -> Nursery m Object-resolveObject xref ref@(idx,gen)+resolveObject xref ref = do driveTop driveForward loop ref where- entries = xrefEntries xref + entries = xrefUTable xref+ loop cRef = case M.lookup cRef entries of Nothing- -> throwM $ NurseryUnresolvedObject idx gen+ -> resolveCompressedObject xref ref Just e- -> do let offset = tableEntryOffset e+ -> do let offset = uObjOff e driveSeek offset- r <- driveParseObject bufferSize- case r ^. _3 of- Ref nidx ngen -> loop (nidx,ngen)- _ -> return $ r ^. _3+ rE <- driveParseObjectE bufferSize+ case rE of+ Left e' -> throwM $ NurseryParsingException e'+ Right r ->+ case r ^. _3 of+ Ref nidx ngen -> loop (nidx,ngen)+ _ -> return $ r ^. _3 ---------------------------------------------------------------------------------withNursery :: MonadThrow m => Playground m a -> Drive m a+resolveCompressedObject :: MonadThrow m+ => XRef+ -> Reference+ -> Nursery m Object+resolveCompressedObject xref ref@(idx,gen)+ = case M.lookup ref centries of+ Nothing+ -> throwM $ NurseryUnresolvedObject idx gen+ Just cObj+ -> let objsNum = cObjNum cObj+ sRef = (objsNum, 0) in+ do sObj <- resolveObject xref sRef+ let mPos = sObj ^? _Stream+ case mPos of+ Nothing+ -> throwM NurseryExpectedStreamObject+ Just stream+ -> do bs <- loadStream xref stream+ case validateObjStm stream bs of+ Left e+ -> throwM e+ Right o+ -> lookupObjStm ref o+ where+ centries = xrefCTable xref++--------------------------------------------------------------------------------+validateObjStm :: Stream -> BL.ByteString -> Either NurseryException ObjStm+validateObjStm stream bs+ = maybe (Left NurseryInvalidObjStm) Right action+ where+ action+ = do typ <- dict ^? dictKey "Type" . _Name+ when (typ /= "ObjStm") Nothing+ n <- dict ^? dictKey "N" . _Number . _Natural+ first <- dict ^? dictKey "First" . _Number . _Natural+ reg <- registery $ fromIntegral n+ let extends = dict ^? dictKey "Extends" . _Ref++ info = ObjStm+ { objStmCount = n+ , objStmFirst = first+ , objStmExtends = extends+ , objStmOffset = pos+ , objStmStream = bs+ , objStmReg = reg+ }++ return info++ registery n+ = case PL.parse (parseRegistery n) bs of+ PL.Done _ r -> Just r+ _ -> Nothing++ parseRegistery n+ = execStateT (replicateM_ n step) M.empty++ step = do lift skipSpace+ num <- lift decimal+ _ <- lift space+ off <- lift decimal++ modify' (M.insert num off)++ dict = stream ^. streamDict+ pos = stream ^. streamPos++--------------------------------------------------------------------------------+lookupObjStm :: MonadThrow m => Reference -> ObjStm -> Nursery m Object+lookupObjStm (idx,_) stm+ = case M.lookup (fromIntegral idx) reg of+ Nothing -> throwM $ NurseryUnresolvedObjectInObjStm idx+ Just off+ -> do let skipN = fromIntegral (first+off)+ stream' = BL.drop skipN stream++ case PL.parse parser stream' of+ PL.Fail _ _ e+ -> throwM $ NurseryParsingExceptionInObjStm e+ PL.Done _ obj+ -> return obj+ where+ parser = parseDict <|> parseArray++ reg = objStmReg stm+ stream = objStmStream stm+ first = objStmFirst stm++--------------------------------------------------------------------------------+withNursery :: MonadCatch m => Client' NReq NResp m a -> Drive m a withNursery user = nursery >>~ const user --------------------------------------------------------------------------------
Data/Rakhana/Tape.hs view
@@ -167,8 +167,11 @@ getForward = liftIO $- do let p' = p + (fromIntegral i)- s' = s { tapeStatePos = p' }+ do siz <- hFileSize h+ let p' = p + (fromIntegral i)+ delta = p' - siz+ p'' = if delta > 0 then p' - delta else p'+ s' = s { tapeStatePos = p'' } b <- B.hGet h i return (Binary b, s')
Data/Rakhana/Util/Drive.hs view
@@ -59,17 +59,29 @@ -------------------------------------------------------------------------------- driveParseObject :: MonadThrow m => Int -> Drive m (Int, Int, Object)-driveParseObject bufSize- = do r <- driveParse bufSize parseIndirectObject- case r ^. _3 of- Dict d -> couldBeStreamObject (r ^. _1, r ^. _2) d- _ -> return r+driveParseObject i+ = do rE <- driveParseObjectE i+ either (throwM . ParsingException) return rE++--------------------------------------------------------------------------------+driveParseObjectE :: Monad m+ => Int+ -> Drive m (Either String (Int, Int, Object))+driveParseObjectE bufSize+ = do rE <- parseRepeatedly bufSize parseIndirectObject+ case rE of+ Left e -> return $ Left e+ Right r+ | Dict d <- r ^. _3+ -> couldBeStreamObject (r ^. _1, r ^. _2) d+ | otherwise+ -> return $ Right r where couldBeStreamObject (idx, gen) d = do eR <- parseRepeatedly 16 parseStreamHeader case eR of Left _- -> return $ (idx, gen, Dict d)+ -> return $ Right $ (idx, gen, Dict d) Right _ -> do p <- driveGetSeek- return (idx, gen, AStream $ Stream d p)+ return $ Right $ (idx, gen, AStream $ Stream d p)
Data/Rakhana/XRef.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Rakhana.XRef@@ -13,18 +15,39 @@ -- -------------------------------------------------------------------------------- module Data.Rakhana.XRef- ( getXRef+ ( XRef(..)+ , XRefException(..)+ , CObj(..)+ , FObj(..)+ , UObj(..)+ , XRefStream(..)+ , getXRef , getXRefPos ) where ---------------------------------------------------------------------------------import qualified Data.ByteString.Char8 as B8-import Data.Char (isDigit, isSpace)+import Prelude hiding (take)+import Data.Bits (shiftL)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import Data.Foldable (traverse_)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Data.Word import Data.Typeable ---------------------------------------------------------------------------------import Control.Monad.Catch (Exception, MonadThrow(..))-import Pipes.Safe ()+import Codec.Compression.Zlib+import Codec.Compression.Zlib.Internal+import Control.Lens+import Control.Monad.Catch (Exception, MonadThrow(..))+import Control.Monad.State.Strict+import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString.Lazy as PL+import Data.Attoparsec.ByteString.Char8+import Pipes.Safe () -------------------------------------------------------------------------------- import Data.Rakhana.Internal.Parsers@@ -33,14 +56,139 @@ import Data.Rakhana.Util.Drive ---------------------------------------------------------------------------------data XRefParsingException+data Entry+ = FreeObject Integer Int+ | UsedObject Integer Int+ | CompressedObject Integer Int+ deriving Show++--------------------------------------------------------------------------------+data XRef+ = XRef+ { xrefFirstNumber :: !Int+ , xrefObjectCount :: !Int+ , xrefUTable :: !UTable+ , xrefFTable :: !FTable+ , xrefCTable :: !CTable+ , xrefTrailer :: !Dictionary+ , xrefStream :: !(Maybe XRefStream)+ }+ deriving Show++--------------------------------------------------------------------------------+data Predictor+ = Png_Up+ | Predictor_Unsupported Integer+ deriving Show++--------------------------------------------------------------------------------+data DecodeParms+ = DecodeParms+ { decodeParmsColumns :: !Integer+ , decodeParmsPredictor :: !Predictor+ }+ deriving Show++--------------------------------------------------------------------------------+data XRefStream+ = XRefStream+ { xrefStreamLength :: !Int+ , xrefStreamSize :: !Integer+ , xrefStreamFirstNumber :: !Integer+ , xrefStreamEntryCount :: !Integer+ , xrefStreamPrev :: !(Maybe Integer)+ , xrefStreamW :: !(Integer, Integer, Integer)+ , xrefStreamEntryWidth :: !Integer+ , xrefStreamDecodeParms :: !(Maybe DecodeParms)+ , xrefStreamFilter :: !(Maybe Filter)+ , xrefStreamPos :: !Integer+ , xrefStreamDict :: !Dictionary+ }+ deriving Show++--------------------------------------------------------------------------------+data UObj+ = UObj+ { uObjOff :: !Integer+ , uObjGen :: !Int+ }+ deriving Show++--------------------------------------------------------------------------------+data CObj+ = CObj+ { cObjNum :: !Int+ , cObjIdx :: !Integer+ }+ deriving Show++--------------------------------------------------------------------------------+data FObj+ = FObj+ { fObjNxtNum :: !Int+ , fObjGen :: !Int+ }+ deriving Show++--------------------------------------------------------------------------------+type FTable = M.Map (Int,Int) FObj+type UTable = M.Map (Int,Int) UObj+type CTable = M.Map (Int,Int) CObj++--------------------------------------------------------------------------------+data ObjType+ = Free+ | Used+ | Compressed+ deriving Show++--------------------------------------------------------------------------------+data XRefException = XRefParsingException String+ | InvalidXRefStream+ | UnsupportedFilter B.ByteString+ | UnsupportedPredictor Integer+ | ZLibException String String deriving (Show, Typeable) ---------------------------------------------------------------------------------instance Exception XRefParsingException+instance Exception XRefException --------------------------------------------------------------------------------+data ExtractState+ = ExtractState+ { _extractType :: !ObjType+ , _extractOffset :: !Integer+ , _extractGen :: !Int+ }++--------------------------------------------------------------------------------+data UnpredictState+ = UnpredictState+ { _unpredictPrev :: ![Word8]+ , _unpredictId :: !Int+ , _unpredictUTable :: !UTable+ , _unpredictFTable :: !FTable+ , _unpredictCTable :: !CTable+ }++--------------------------------------------------------------------------------+data NopredictState+ = NopredictState+ { _nopredictId :: !Int+ , _nopredictUTable :: !UTable+ , _nopredictFTable :: !FTable+ , _nopredictCTable :: !CTable+ }++--------------------------------------------------------------------------------+-- Lenses+--------------------------------------------------------------------------------+makeLenses ''ExtractState+makeLenses ''UnpredictState+makeLenses ''NopredictState++-------------------------------------------------------------------------------- bufferSize :: Int bufferSize = 4096 @@ -58,15 +206,345 @@ return p ---------------------------------------------------------------------------------getXRef :: MonadThrow m => Integer -> Drive m XRef-getXRef pos+getXRef :: Monad m => Header -> Integer -> Drive m (Either XRefException XRef)+getXRef h pos+ = do rE <- crossRef pos+ case rE of+ Left e+ | headerMaj h == 1 && headerMin h < 5+ -> return $ Left e+ | otherwise+ -> crossRefStream pos+ _ -> return rE++--------------------------------------------------------------------------------+crossRef :: Monad m => Integer -> Drive m (Either XRefException XRef)+crossRef pos = do driveTop driveForward driveSeek pos eR <- parseRepeatedly bufferSize parseXRef- either (throwM . XRefParsingException) return eR+ return $ either (Left . XRefParsingException) Right eR --------------------------------------------------------------------------------+crossRefStream :: Monad m => Integer -> Drive m (Either XRefException XRef)+crossRefStream offset = loop (offset, Nothing)+ where+ loop (off, newerRefM)+ = do xrefE <- crossRefStreamStep off+ case xrefE of+ Left e -> return $ Left e+ Right xref+ -> let prevM = xrefStream xref >>= xrefStreamPrev+ upd nRef+ = let nUTable+ = M.union (xrefUTable nRef)+ (xrefUTable xref)+ nCTable+ = M.union (xrefCTable nRef)+ (xrefCTable xref) in++ nRef { xrefUTable = nUTable+ , xrefCTable = nCTable+ } in+ case prevM of+ Nothing ->+ let updRef = maybe xref upd newerRefM in+ return $ Right updRef+ Just prev+ -> do xrefE' <- loop (prev, Just xref)+ case xrefE' of+ Left e'+ -> return $ Left e'+ Right xref'+ -> let updRef = maybe xref' upd+ newerRefM+ in return $ Right updRef++--------------------------------------------------------------------------------+crossRefStreamStep :: Monad m => Integer -> Drive m (Either XRefException XRef)+crossRefStreamStep offset+ = do streamE <- parseXRefStream offset+ let xstreamE = streamE >>= validateXRefStream+ case xstreamE of+ Left e -> return $ Left e+ Right xstream+ -> do let len = xrefStreamLength xstream+ filt = xrefStreamFilter xstream+ pos = xrefStreamPos xstream+ driveSeek pos+ bs <- driveGetLazy len+ let dbsE = decodeBS filt bs+ dparms = xrefStreamDecodeParms xstream+ mPred = fmap decodeParmsPredictor dparms+ res =+ case mPred of+ Nothing -> dbsE >>= noPredict xstream+ Just prd -> dbsE >>= unpredict prd xstream+ return res++--------------------------------------------------------------------------------+parseXRefStream :: Monad m => Integer -> Drive m (Either XRefException Stream)+parseXRefStream offset+ = do driveTop+ driveForward+ driveSeek offset+ rE <- driveParseObjectE 128+ case rE of+ Left e -> return $ Left $ XRefParsingException e+ Right r ->+ let xstream = r ^. _3+ expt = XRefParsingException "Expected a XRef Stream" in+ return $ maybe (Left $ expt) Right (xstream ^? _Stream)++--------------------------------------------------------------------------------+getFilter :: Dictionary -> Maybe Filter+getFilter dict+ = dict ^? dictKey "Filter" . _Name . to toFilt+ where+ toFilt "FlateDecode" = FlateDecode+ toFilt x = Filter_Unsupported x++--------------------------------------------------------------------------------+decodeParms :: Dictionary -> Maybe DecodeParms+decodeParms dict+ = do parms <- dict ^? dictKey "DecodeParms" . _Dict+ col <- parms ^? dictKey "Columns" . _Number . _Natural+ prd <- parms ^? dictKey "Predictor" . _Number . _Natural . to toPred+ return DecodeParms+ { decodeParmsColumns = col+ , decodeParmsPredictor = prd+ }+ where+ toPred 12 = Png_Up+ toPred x = Predictor_Unsupported x++--------------------------------------------------------------------------------+decompressErrorStr :: DecompressError -> String+decompressErrorStr TruncatedInput = "TruncatedInput"+decompressErrorStr DictionaryRequired = "DictionaryRequired"+decompressErrorStr DataError = "DataError"++--------------------------------------------------------------------------------+zlibDecompress :: L.ByteString -> Either XRefException L.ByteString+zlibDecompress bs+ = foldDecompressStream go (Right L.Empty)+ (\code msg -> Left $ ZLibException (decompressErrorStr code) msg) $+ decompressWithErrors zlibFormat defaultDecompressParams bs+ where+ go b aE = fmap (\b' -> L.Chunk b b') aE++--------------------------------------------------------------------------------+decodeBS :: Maybe Filter -> L.ByteString -> Either XRefException L.ByteString+decodeBS (Just filt) bs+ = case filt of+ FlateDecode -> zlibDecompress bs+ Filter_Unsupported x -> Left $ UnsupportedFilter x+decodeBS _ bs+ = Right bs++--------------------------------------------------------------------------------+unpredict :: Predictor+ -> XRefStream+ -> L.ByteString+ -> Either XRefException XRef+unpredict p xstream input+ = case p of+ Png_Up -> unpredictPngUp xstream input+ Predictor_Unsupported x -> Left $ UnsupportedPredictor x++--------------------------------------------------------------------------------+noPredict :: XRefStream -> L.ByteString -> Either XRefException XRef+noPredict xstream input+ = case PL.parse parser input of+ PL.Fail _ _ e -> Left $ XRefParsingException e+ PL.Done _ bs -> Right bs+ where+ width = fromIntegral $ xrefStreamEntryWidth xstream+ firstNumber = fromIntegral $ xrefStreamFirstNumber xstream+ ecount = fromIntegral $ xrefStreamEntryCount xstream+ start = NopredictState+ { _nopredictId = firstNumber - 1+ , _nopredictUTable = M.empty+ , _nopredictFTable = M.empty+ , _nopredictCTable = M.empty+ }++ parser = evalStateT aState start+++ aState = do replicateM_ ecount action+ utable <- use nopredictUTable+ ftable <- use nopredictFTable+ ctable <- use nopredictCTable++ return XRef+ { xrefFirstNumber = firstNumber+ , xrefObjectCount = ecount+ , xrefUTable = utable+ , xrefFTable = ftable+ , xrefCTable = ctable+ , xrefTrailer = M.empty+ , xrefStream = Just xstream+ }++ action+ = do oid <- nopredictId <+= 1+ row <- lift step++ let (typ, off, gen) = extractTableEntry xstream row+ ref = (oid,gen)+ cref = (oid, 0)+ fobj = FObj (fromIntegral off) gen+ uobj = UObj off gen+ cobj = CObj (fromIntegral off) (fromIntegral gen)++ case typ of+ Free -> nopredictFTable.at ref ?= fobj+ Used -> nopredictUTable.at ref ?= uobj+ Compressed -> nopredictCTable.at cref ?= cobj++ step = do bs <- take width+ let row = B.unpack bs+ return row++--------------------------------------------------------------------------------+unpredictPngUp :: XRefStream -> L.ByteString -> Either XRefException XRef+unpredictPngUp xstream input+ = case PL.parse parser input of+ PL.Fail _ _ e -> Left $ XRefParsingException e+ PL.Done _ bs -> Right bs+ where+ width = fromIntegral $ xrefStreamEntryWidth xstream+ firstNumber = fromIntegral $ xrefStreamFirstNumber xstream+ ecount = fromIntegral $ xrefStreamEntryCount xstream+ start = UnpredictState+ { _unpredictPrev = replicate width 0+ , _unpredictId = firstNumber - 1+ , _unpredictUTable = M.empty+ , _unpredictFTable = M.empty+ , _unpredictCTable = M.empty+ }++ parser = evalStateT aState start++ aState = do replicateM_ ecount action+ utable <- use unpredictUTable+ ftable <- use unpredictFTable+ ctable <- use unpredictCTable++ return XRef+ { xrefFirstNumber = firstNumber+ , xrefObjectCount = ecount+ , xrefUTable = utable+ , xrefFTable = ftable+ , xrefCTable = ctable+ , xrefTrailer = M.empty+ , xrefStream = Just xstream+ }+ action+ = do prev <- use unpredictPrev+ newPrev <- lift $ step prev+ oid <- unpredictId <+= 1++ unpredictPrev .= newPrev++ let (typ, off, gen) = extractTableEntry xstream newPrev+ ref = (oid, gen)+ cref = (oid, 0)+ fobj = FObj (fromIntegral off) gen+ uobj = UObj off gen+ cobj = CObj (fromIntegral off) (fromIntegral gen)++ case typ of+ Free -> unpredictFTable.at ref ?= fobj+ Used -> unpredictUTable.at ref ?= uobj+ Compressed -> unpredictCTable.at cref ?= cobj++ step prev+ = do _ <- anyWord8+ bs <- take width+ let newPrev = zipWith (+) (B.unpack bs) prev+ return newPrev++--------------------------------------------------------------------------------+extractTableEntry :: XRefStream -> [Word8] -> (ObjType, Integer, Int)+extractTableEntry xstream arr+ = mkEntry $ execState (traverse_ action $ zip [1..width] arr) start+ where+ start = ExtractState Free 0 0++ mkEntry s+ = let off = s ^. extractOffset+ gen = s ^. extractGen+ typ = s ^. extractType in+ (typ, off, gen)++ action (i,w)+ | i == 1+ = case w of+ 0x00 -> extractType .= Free+ 0x01 -> extractType .= Used+ 0x02 -> extractType .= Compressed+ _ -> error $ "Invalid entry type " ++ show w+ | i <= oLen+1+ = extractOffset += (fromIntegral w) `shiftL` (8*(oLen-i+1))+ | i <= oLen+gLen+1+ = extractGen += (fromIntegral w) `shiftL` (8*(gLen-i+1))+ | otherwise+ = return ()++ (_,c2,c3) = xrefStreamW xstream+ oLen = fromIntegral c2+ gLen = fromIntegral c3+ width = fromIntegral $ xrefStreamEntryWidth xstream++--------------------------------------------------------------------------------+validateXRefStream :: Stream -> Either XRefException XRefStream+validateXRefStream s+ = maybe (Left InvalidXRefStream) Right action+ where+ action+ = do typ <- dict ^? dictKey "Type" . _Name+ when (typ /= "XRef") Nothing+ size <- dict ^? dictKey "Size" . _Number . _Natural+ len <- dict ^? dictKey "Length" . _Number . _Natural+ w@(c1,c2,c3) <- getW+ let xstream = XRefStream+ { xrefStreamLength = fromIntegral len+ , xrefStreamSize = size+ , xrefStreamFirstNumber = fromMaybe 0 firstNumber+ , xrefStreamEntryCount = fromMaybe size entryCount+ , xrefStreamPrev = getPrev+ , xrefStreamW = w+ , xrefStreamDecodeParms = decodeParms dict+ , xrefStreamFilter = getFilter dict+ , xrefStreamEntryWidth = c1 + c2 + c3+ , xrefStreamPos = s ^. streamPos+ , xrefStreamDict = dict+ }+ return xstream+++ dict = s ^. streamDict++ firstNumber+ = do ar <- dict ^? dictKey "Index" . _Array+ ar ^? nth 0 . _Number . _Natural++ entryCount+ = do ar <- dict ^? dictKey "Index" . _Array+ ar ^? nth 1 . _Number . _Natural++ getPrev = dict ^? dictKey "Prev" . _Number . _Natural++ getW = do ar <- dict ^? dictKey "W" . _Array+ one <- ar ^? nth 0 . _Number . _Natural+ two <- ar ^? nth 1 . _Number . _Natural+ three <- ar ^? nth 2 . _Number . _Natural+ return (one, two, three)++-------------------------------------------------------------------------------- skipEOL :: Monad m => Drive m () skipEOL = do bs <- drivePeek 1@@ -102,3 +580,89 @@ case bs of "startxref" -> return () _ -> throwM $ XRefParsingException "Expected startxref"++--------------------------------------------------------------------------------+-- Parsers+--------------------------------------------------------------------------------+tableXRef :: Parser ()+tableXRef+ = do _ <- string "xref"+ pdfEndOfLine++--------------------------------------------------------------------------------+parseXRef :: Parser XRef+parseXRef+ = do skipSpace+ tableXRef+ (fnum, ecount) <- parseSubsectionHeader+ (ftable, utable) <- parseTableEntries fnum+ trailer <- parseTrailerAfterTable+ return XRef+ { xrefFirstNumber = fnum+ , xrefObjectCount = ecount+ , xrefUTable = utable+ , xrefFTable = ftable+ , xrefCTable = M.empty+ , xrefTrailer = trailer+ , xrefStream = Nothing+ }++--------------------------------------------------------------------------------+parseSubsectionHeader :: Parser (Int, Int)+parseSubsectionHeader+ = do start <- decimal+ skipSpace+ ecount <- decimal+ pdfEndOfLine+ return (start, ecount)++--------------------------------------------------------------------------------+parseTrailerAfterTable :: Parser Dictionary+parseTrailerAfterTable+ = do skipSpace+ _ <- string "trailer"+ pdfEndOfLine+ skipSpace+ Dict d <- parseDict+ return d++--------------------------------------------------------------------------------+parseTableEntries :: Int -> Parser (FTable, UTable)+parseTableEntries firstNumber+ = loop start+ where+ loop (i, ftable, utable)+ = do mT <- optional parseTableEntry+ case mT of+ Nothing -> return (ftable, utable)+ Just (off, gen, used)+ | used+ -> let key = (i, gen)+ obj = UObj off gen+ utable' = M.insert key obj utable in+ loop (i+1, ftable, utable')+ | otherwise+ -> let key = (i, gen)+ obj = FObj (fromIntegral off) gen+ ftable' = M.insert key obj ftable in+ loop (i+1, ftable', utable)++ start :: (Int, FTable, UTable)+ start = (firstNumber, M.empty, M.empty)++--------------------------------------------------------------------------------+parseTableEntry :: Parser (Integer, Int, Bool)+parseTableEntry+ = do skipSpace+ offset <- decimal+ skipSpace+ gen <- decimal+ skipSpace+ c <- anyChar+ case c of+ 'n' -> return (offset, gen, True)+ 'f' -> return (offset, gen, False)+ _ ->+ let msg = "error parsing XRef table entry: unknown char: " +++ [c] in+ fail msg
rakhana.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.1.0.1 -- A short (one-line) description of the package. synopsis: Stream based PDF library@@ -44,6 +44,7 @@ -- Extra files to be distributed with the package, such as examples or a -- README. extra-source-files: README.md+ CHANGELOG.markdown -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.18@@ -66,8 +67,10 @@ -- LANGUAGE extensions used by modules in this package. other-extensions: DeriveDataTypeable+ FlexibleContexts OverloadedStrings RankNTypes+ TemplateHaskell -- Other library packages from which modules are imported. build-depends: base >=4.7 && <4.8