rakhana 0.2.0.1 → 0.2.0.2
raw patch · 6 files changed
+240/−207 lines, 6 filesdep −pipes-safePVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies removed: pipes-safe
API changes (from Hackage documentation)
+ Data.Rakhana: NurseryWrongObject :: Reference -> Reference -> NurseryException
Files
- CHANGELOG.markdown +5/−0
- Data/Rakhana/Internal/Parsers.hs +6/−1
- Data/Rakhana/Nursery.hs +34/−26
- Data/Rakhana/Util/Drive.hs +2/−9
- Data/Rakhana/XRef.hs +192/−169
- rakhana.cabal +1/−2
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+0.2.0.2+-------+* Bug fix: Fix PDF literal parser+* Strengthen object resolution+ 0.2.0.1 ------- * Bug fix: Discard incoherent XRef table entries with offset equal to 0
Data/Rakhana/Internal/Parsers.hs view
@@ -75,6 +75,10 @@ parseName = fmap Name parseNameString --------------------------------------------------------------------------------+parseNull :: Parser Object+parseNull = Null <$ string "null"++-------------------------------------------------------------------------------- parseNumber :: Parser Object parseNumber = regularNumber <|> irregularNumber where@@ -183,7 +187,8 @@ parseRef <|> parseHexBytes <|> parseStringBytes <|>- parseNumber+ parseNumber <|>+ parseNull -------------------------------------------------------------------------------- parseStreamHeader :: Parser ()
Data/Rakhana/Nursery.hs view
@@ -41,6 +41,7 @@ import Control.Monad.Error.Class import Control.Monad.Reader import Control.Monad.State.Strict+import Control.Monad.Trans.Except import Data.Attoparsec.ByteString.Char8 import qualified Data.Attoparsec.ByteString.Lazy as PL import Pipes@@ -66,6 +67,7 @@ | NurseryExpectedStreamObject | NurseryInvalidObjStm | NurseryUnresolvedObjectInObjStm Int+ | NurseryWrongObject Reference Reference deriving (Show, Typeable) --------------------------------------------------------------------------------@@ -139,15 +141,8 @@ => Header -> Nursery m NurseryState regularPDFAccess h- = do posE <- getXRefPos- case posE of- Left e- -> throwError $ NurseryXRefException e- Right pos- -> do xrefE <- getXRef h pos- case xrefE of- Left e -> throwError $ NurseryXRefException e- Right xref -> nurseryState h xref+ = do pos <- hoist liftError getXRefPos+ nurseryState h =<< hoist liftError (getXRef h pos) -------------------------------------------------------------------------------- nurseryState :: MonadError NurseryException m@@ -343,16 +338,20 @@ Just e -> do let offset = uObjOff e driveSeek offset- rE <- driveParseObject bufferSize- case rE of- Left e'- -> throwError $- NurseryParsingException (Just cRef) e'- Right r- -> case r ^. _3 of- Ref nidx ngen -> loop (nidx,ngen)- _ -> return $ r ^. _3+ r <- parsing cRef + let pRef = (r ^. _1, r ^. _2)+ when (cRef /= pRef) $+ throwError $ NurseryWrongObject cRef pRef++ case r ^. _3 of+ Ref nidx ngen -> loop (nidx,ngen)+ _ -> return $ r ^. _3++ parsing cRef+ = driveParseObject bufferSize >>=+ either (throwError . NurseryParsingException (Just cRef)) return+ -------------------------------------------------------------------------------- resolveCompressedObject :: MonadError NurseryException m => XRef@@ -372,18 +371,18 @@ -> throwError NurseryExpectedStreamObject Just stream -> do bs <- loadStream xref stream- case validateObjStm stream bs of- Left e- -> throwError e- Right o- -> lookupObjStm ref o+ o <- validateObjStm stream bs+ lookupObjStm ref o where centries = xrefCTable xref ---------------------------------------------------------------------------------validateObjStm :: Stream -> BL.ByteString -> Either NurseryException ObjStm+validateObjStm :: MonadError NurseryException m+ => Stream+ -> BL.ByteString+ -> m ObjStm validateObjStm stream bs- = maybe (Left NurseryInvalidObjStm) Right action+ = maybe (throwError NurseryInvalidObjStm) return action where action = do typ <- dict ^? dictKey "Type" . _Name@@ -429,7 +428,8 @@ -> Nursery m Object lookupObjStm (idx,_) stm = case M.lookup (fromIntegral idx) reg of- Nothing -> throwError $ NurseryUnresolvedObjectInObjStm idx+ Nothing+ -> throwError $ NurseryUnresolvedObjectInObjStm idx Just off -> do let skipN = fromIntegral (first+off) stream' = BL.drop skipN stream@@ -462,6 +462,14 @@ = do (r, s') <- k s rq rq' <- respond r nurseryLoop k s' rq'++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------+liftError :: MonadError NurseryException m => ExceptT XRefException m a -> m a+liftError action+ = runExceptT action >>=+ either (throwError . NurseryXRefException) return -------------------------------------------------------------------------------- -- API
Data/Rakhana/Util/Drive.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Rakhana.Util.Drive@@ -15,13 +14,10 @@ -------------------------------------------------------------------------------- import qualified Data.ByteString as B-import Data.Typeable ---------------------------------------------------------------------------------import Control.Exception import Control.Lens import Data.Attoparsec.ByteString-import Pipes.Safe () -------------------------------------------------------------------------------- import Data.Rakhana.Internal.Parsers@@ -29,10 +25,7 @@ import Data.Rakhana.Tape ---------------------------------------------------------------------------------data ParsingException = ParsingException String deriving (Show, Typeable)-----------------------------------------------------------------------------------instance Exception ParsingException+data ParsingException = ParsingException String deriving Show -------------------------------------------------------------------------------- driveParse :: Monad m => Int -> Parser a -> Drive m (Either String a)
Data/Rakhana/XRef.hs view
@@ -40,11 +40,11 @@ import Codec.Compression.Zlib import Codec.Compression.Zlib.Internal import Control.Lens+import Control.Monad.Error.Class 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@@ -167,134 +167,144 @@ } ---------------------------------------------------------------------------------data NopredictState- = NopredictState- { _nopredictId :: !Int- , _nopredictUTable :: !UTable- , _nopredictFTable :: !FTable- , _nopredictCTable :: !CTable+data NoUnpredictState+ = NoUnpredictState+ { _noUnpredictId :: !Int+ , _noUnpredictUTable :: !UTable+ , _noUnpredictFTable :: !FTable+ , _noUnpredictCTable :: !CTable } --------------------------------------------------------------------------------+data EntriesParse+ = EntriesParse+ { _entriesParseId :: !Int+ , _entriesParseFTable :: !FTable+ , _entriesParseUTable :: !UTable+ }++-------------------------------------------------------------------------------- -- Lenses -------------------------------------------------------------------------------- makeLenses ''ExtractState makeLenses ''UnpredictState-makeLenses ''NopredictState+makeLenses ''NoUnpredictState+makeLenses ''EntriesParse -------------------------------------------------------------------------------- bufferSize :: Int bufferSize = 4096 ---------------------------------------------------------------------------------getXRefPos :: Monad m => Drive m (Either XRefException Integer)+getXRefPos :: MonadError XRefException m => Drive m Integer getXRefPos = do driveBottom driveBackward skipEOL- mE <- parseEOF- case mE of- Just e- -> return $ Left e- Nothing- -> do skipEOL- p <- parseXRefPosInteger- skipEOL- mR <- parseStartXRef- return $ maybe (Right p) Left mR+ parseEOF+ skipEOL+ p <- parseXRefPosInteger+ skipEOL+ parseStartXRef+ return p ---------------------------------------------------------------------------------getXRef :: Monad m => Header -> Integer -> Drive m (Either XRefException XRef)+getXRef :: MonadError XRefException m => Header -> Integer -> Drive m 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 <- driveParse bufferSize parseXRef- return $ either (Left . XRefParsingException) Right eR + catchError (normalXRef pos) $ \e ->+ if headerMaj h == 1 && headerMin h < 5+ then throwError e+ else streamXRef pos+ ---------------------------------------------------------------------------------crossRefStream :: Monad m => Integer -> Drive m (Either XRefException XRef)-crossRefStream offset = loop (offset, Nothing)+normalXRef :: MonadError XRefException m => Integer -> Drive m XRef+normalXRef pos+ = do driveSeek pos+ xref <- parsing+ let dict = xrefTrailer xref+ mPrev = dict ^? dictKey "Prev" . _Number . _Natural++ case mPrev of+ Nothing+ -> return xref+ Just prev+ -> do xrefPrev <- normalXRef prev+ let nUTable+ = M.union (xrefUTable xref)+ (xrefUTable xrefPrev)++ newXRef+ = xref { xrefUTable = nUTable }++ return newXRef where+ parsing+ = driveParse bufferSize parseXRef >>=+ either (throwError . XRefParsingException) return++--------------------------------------------------------------------------------+streamXRef :: MonadError XRefException m => Integer -> Drive m XRef+streamXRef 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+ = do xref <- streamXRefStep off+ let prevXRefPos = xrefStream xref >>= xrefStreamPrev+ updateXRef 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+ nRef { xrefUTable = nUTable+ , xrefCTable = nCTable+ } + case prevXRefPos of+ Nothing+ -> return $ maybe xref updateXRef newerRefM+ Just prev+ -> loop (prev, Just xref) >>= \xref' ->+ return $ maybe xref' updateXRef newerRefM+ ---------------------------------------------------------------------------------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+streamXRefStep :: MonadError XRefException m => Integer -> Drive m XRef+streamXRefStep offset+ = do stream <- parseXRefStream offset+ xstream <- validateXRefStream stream+ let len = xrefStreamLength xstream+ filt = xrefStreamFilter xstream+ pos = xrefStreamPos xstream+ dparms = xrefStreamDecodeParms xstream+ mPred = fmap decodeParmsPredictor dparms + driveSeek pos+ bs <- driveGetLazy len+ dbs <- decodeByteString filt bs++ case mPred of+ Nothing -> noUnpredict xstream dbs+ Just prd -> unpredict prd xstream dbs+ ---------------------------------------------------------------------------------parseXRefStream :: Monad m => Integer -> Drive m (Either XRefException Stream)+parseXRefStream :: MonadError XRefException m => Integer -> Drive m Stream parseXRefStream offset- = do driveTop- driveForward- driveSeek offset- rE <- driveParseObject 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)+ = do driveSeek offset+ (_,_,obj) <- parsing + maybe+ (throwError $ XRefParsingException "Expected a XRef Stream")+ return+ (obj ^? _Stream)+ where+ parsing+ = driveParseObject 128 >>=+ either (throwError . XRefParsingException) return+ -------------------------------------------------------------------------------- getFilter :: Dictionary -> Maybe Filter getFilter dict@@ -324,57 +334,62 @@ decompressErrorStr DataError = "DataError" ---------------------------------------------------------------------------------zlibDecompress :: L.ByteString -> Either XRefException L.ByteString+zlibDecompress :: MonadError XRefException m => L.ByteString -> m 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+ = foldDecompressStream (liftM . L.Chunk) (return L.Empty)+ (\code -> throwError . ZLibException (decompressErrorStr code))+ (decompressWithErrors zlibFormat defaultDecompressParams bs) ---------------------------------------------------------------------------------decodeBS :: Maybe Filter -> L.ByteString -> Either XRefException L.ByteString-decodeBS (Just filt) bs+decodeByteString :: MonadError XRefException m+ => Maybe Filter+ -> L.ByteString+ -> m L.ByteString+decodeByteString (Just filt) bs = case filt of FlateDecode -> zlibDecompress bs- Filter_Unsupported x -> Left $ UnsupportedFilter x-decodeBS _ bs- = Right bs+ Filter_Unsupported x -> throwError $ UnsupportedFilter x+decodeByteString _ bs+ = return bs ---------------------------------------------------------------------------------unpredict :: Predictor+unpredict :: MonadError XRefException m+ => Predictor -> XRefStream -> L.ByteString- -> Either XRefException XRef+ -> m XRef unpredict p xstream input = case p of Png_Up -> unpredictPngUp xstream input- Predictor_Unsupported x -> Left $ UnsupportedPredictor x+ Predictor_Unsupported x -> throwError $ UnsupportedPredictor x ---------------------------------------------------------------------------------noPredict :: XRefStream -> L.ByteString -> Either XRefException XRef-noPredict xstream input+noUnpredict :: MonadError XRefException m+ => XRefStream+ -> L.ByteString+ -> m XRef+noUnpredict xstream input = case PL.parse parser input of- PL.Fail _ _ e -> Left $ XRefParsingException e- PL.Done _ bs -> Right bs+ PL.Fail _ _ e -> throwError $ XRefParsingException e+ PL.Done _ bs -> return 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+ start = NoUnpredictState+ { _noUnpredictId = firstNumber - 1+ , _noUnpredictUTable = M.empty+ , _noUnpredictFTable = M.empty+ , _noUnpredictCTable = M.empty } parser = evalStateT aState start aState = do replicateM_ ecount action- utable <- use nopredictUTable- ftable <- use nopredictFTable- ctable <- use nopredictCTable+ utable <- use noUnpredictUTable+ ftable <- use noUnpredictFTable+ ctable <- use noUnpredictCTable return XRef { xrefFirstNumber = firstNumber@@ -387,35 +402,39 @@ } action- = do oid <- nopredictId <+= 1+ = do oid <- noUnpredictId <+= 1 row <- lift step+ (typ, off, gen) <- either fail return+ (extractTableEntry xstream row) - let (typ, off, gen) = extractTableEntry xstream row- ref = (oid,gen)+ let 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+ Free -> noUnpredictFTable.at ref ?= fobj+ Used -> noUnpredictUTable.at ref ?= uobj+ Compressed -> noUnpredictCTable.at cref ?= cobj step = do bs <- take width let row = B.unpack bs return row ---------------------------------------------------------------------------------unpredictPngUp :: XRefStream -> L.ByteString -> Either XRefException XRef+unpredictPngUp :: MonadError XRefException m+ => XRefStream+ -> L.ByteString+ -> m XRef unpredictPngUp xstream input = case PL.parse parser input of- PL.Fail _ _ e -> Left $ XRefParsingException e- PL.Done _ bs -> Right bs+ PL.Fail _ _ e -> throwError $ XRefParsingException e+ PL.Done _ bs -> return bs where width = fromIntegral $ xrefStreamEntryWidth xstream firstNumber = fromIntegral $ xrefStreamFirstNumber xstream- ecount = fromIntegral $ xrefStreamEntryCount xstream+ ecount = fromIntegral $ xrefStreamEntryCount xstream start = UnpredictState { _unpredictPrev = replicate width 0 , _unpredictId = firstNumber - 1@@ -446,9 +465,10 @@ oid <- unpredictId <+= 1 unpredictPrev .= newPrev+ (typ, off, gen) <- either fail return+ (extractTableEntry xstream newPrev) - let (typ, off, gen) = extractTableEntry xstream newPrev- ref = (oid, gen)+ let ref = (oid, gen) cref = (oid, 0) fobj = FObj (fromIntegral off) gen uobj = UObj off gen@@ -466,10 +486,14 @@ return newPrev ---------------------------------------------------------------------------------extractTableEntry :: XRefStream -> [Word8] -> (ObjType, Integer, Int)+extractTableEntry :: XRefStream+ -> [Word8]+ -> Either String (ObjType, Integer, Int) extractTableEntry xstream arr- = mkEntry $ execState (traverse_ action $ zip [1..width] arr) start+ = fmap mkEntry $ execStateT action start where+ action = traverse_ step $ zip [1..width] arr+ start = ExtractState Free 0 0 mkEntry s@@ -478,13 +502,13 @@ typ = s ^. extractType in (typ, off, gen) - action (i,w)+ step (i,w) | i == 1 = case w of 0x00 -> extractType .= Free 0x01 -> extractType .= Used 0x02 -> extractType .= Compressed- _ -> error $ "Invalid entry type " ++ show w+ _ -> lift $ Left $ "Invalid entry type " ++ show w | i <= oLen+1 = extractOffset += (fromIntegral w) `shiftL` (8*(oLen-i+1)) | i <= oLen+gLen+1@@ -498,9 +522,9 @@ width = fromIntegral $ xrefStreamEntryWidth xstream ---------------------------------------------------------------------------------validateXRefStream :: Stream -> Either XRefException XRefStream+validateXRefStream :: MonadError XRefException m => Stream -> m XRefStream validateXRefStream s- = maybe (Left InvalidXRefStream) Right action+ = maybe (throwError InvalidXRefStream) return action where action = do typ <- dict ^? dictKey "Type" . _Name@@ -553,12 +577,12 @@ _ -> return () ---------------------------------------------------------------------------------parseEOF :: Monad m => Drive m (Maybe XRefException)+parseEOF :: MonadError XRefException m => Drive m () parseEOF = do bs <- driveGet 5 case bs of- "%%EOF" -> return Nothing- _ -> return $ Just $ XRefParsingException "Expected %%EOF"+ "%%EOF" -> return ()+ _ -> throwError $ XRefParsingException "Expected %%EOF" -------------------------------------------------------------------------------- parseXRefPosInteger :: Monad m => Drive m Integer@@ -572,12 +596,12 @@ _ -> return $ read cs ---------------------------------------------------------------------------------parseStartXRef :: Monad m => Drive m (Maybe XRefException)+parseStartXRef :: MonadError XRefException m => Drive m () parseStartXRef = do bs <- driveGet 9 case bs of- "startxref" -> return Nothing- _ -> return $ Just $+ "startxref" -> return ()+ _ -> throwError $ XRefParsingException "Expected startxref" --------------------------------------------------------------------------------@@ -594,7 +618,7 @@ = do skipSpace tableXRef (fnum, ecount) <- parseSubsectionHeader- (ftable, utable) <- parseTableEntries fnum+ (ftable, utable) <- parseTableEntries fnum ecount trailer <- parseTrailerAfterTable return XRef { xrefFirstNumber = fnum@@ -626,30 +650,29 @@ return d ---------------------------------------------------------------------------------parseTableEntries :: Int -> Parser (FTable, UTable)-parseTableEntries firstNumber- = loop start+parseTableEntries :: Int -> Int -> Parser (FTable, UTable)+parseTableEntries firstNumber n+ = parser where- loop (i, ftable, utable)- = do mT <- optional parseTableEntry- case mT of- Nothing -> return (ftable, utable)- Just (off, gen, used)- | off == 0- -> loop(i+1, ftable, utable)- | 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)+ parser = fmap end $ execStateT action start+ action = replicateM_ n step - start :: (Int, FTable, UTable)- start = (firstNumber, M.empty, M.empty)+ step = do (off, gen, used) <- lift parseTableEntry+ eid <- entriesParseId <+= 1+ let key = (eid, gen)+ when (off /= 0) $+ if used+ then entriesParseUTable.at key ?= UObj off gen+ else let nxt = fromIntegral off in+ entriesParseFTable.at key ?= FObj nxt gen++ start = EntriesParse+ { _entriesParseId = firstNumber - 1+ , _entriesParseFTable = M.empty+ , _entriesParseUTable = M.empty+ }++ end s = (s ^. entriesParseFTable, s ^. entriesParseUTable) -------------------------------------------------------------------------------- parseTableEntry :: Parser (Integer, Int, Bool)
rakhana.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.1+version: 0.2.0.2 -- A short (one-line) description of the package. synopsis: Stream based PDF library@@ -79,7 +79,6 @@ , lens == 4.4.* , mtl , pipes == 4.*- , pipes-safe > 2 && < 3 , scientific , transformers == 0.4.* , vector >= 0.10 && < 0.11