diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -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 diff --git a/Data/Rakhana/Internal/Parsers.hs b/Data/Rakhana/Internal/Parsers.hs --- a/Data/Rakhana/Internal/Parsers.hs +++ b/Data/Rakhana/Internal/Parsers.hs @@ -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 -- 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 diff --git a/Data/Rakhana/Internal/Types.hs b/Data/Rakhana/Internal/Types.hs --- a/Data/Rakhana/Internal/Types.hs +++ b/Data/Rakhana/Internal/Types.hs @@ -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 diff --git a/Data/Rakhana/Nursery.hs b/Data/Rakhana/Nursery.hs --- a/Data/Rakhana/Nursery.hs +++ b/Data/Rakhana/Nursery.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/Data/Rakhana/Tape.hs b/Data/Rakhana/Tape.hs --- a/Data/Rakhana/Tape.hs +++ b/Data/Rakhana/Tape.hs @@ -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') diff --git a/Data/Rakhana/Util/Drive.hs b/Data/Rakhana/Util/Drive.hs --- a/Data/Rakhana/Util/Drive.hs +++ b/Data/Rakhana/Util/Drive.hs @@ -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) diff --git a/Data/Rakhana/XRef.hs b/Data/Rakhana/XRef.hs --- a/Data/Rakhana/XRef.hs +++ b/Data/Rakhana/XRef.hs @@ -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 diff --git a/rakhana.cabal b/rakhana.cabal --- a/rakhana.cabal +++ b/rakhana.cabal @@ -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