rakhana (empty) → 0.1.0.0
raw patch · 11 files changed
+1544/−0 lines, 11 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, containers, exceptions, lens, mtl, pipes, pipes-safe, scientific, transformers, vector, zlib
Files
- Data/Rakhana.hs +71/−0
- Data/Rakhana/Internal/Parsers.hs +348/−0
- Data/Rakhana/Internal/Types.hs +181/−0
- Data/Rakhana/Nursery.hs +310/−0
- Data/Rakhana/Tape.hs +327/−0
- Data/Rakhana/Util/Drive.hs +75/−0
- Data/Rakhana/XRef.hs +104/−0
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- rakhana.cabal +92/−0
+ Data/Rakhana.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana+ ( Dictionary+ , Drive+ , Header+ , Object+ , NReq+ , NResp+ , Number+ , Playground+ , Reference+ , Stream+ , Tape+ , TReq+ , TResp+ -- Prisms+ , _Array+ , _Boolean+ , _Bytes+ , _Dict+ , _Name+ , _Natural+ , _Number+ , _Real+ , _Ref+ , _Stream+ , dictKey+ , nth+ -- Lenses+ , streamDict+ , streamPos+ -- Nursery+ , nurseryGetInfo+ , nurseryGetHeader+ , nurseryGetPages+ , nurseryLoadStreamData+ , nurseryGetReferences+ , nurseryResolve+ , withNursery+ -- Tape+ , driveBackward+ , driveBottom+ , driveDiscard+ , driveForward+ , driveGet+ , driveGetLazy+ , driveGetSeek+ , driveModifySeek+ , drivePeek+ , driveSeek+ , driveTop+ , fileTape+ , runDrive+ )+ where++--------------------------------------------------------------------------------+import Data.Rakhana.Internal.Types+import Data.Rakhana.Tape+import Data.Rakhana.Nursery
+ Data/Rakhana/Internal/Parsers.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.Internal.Parsers+-- Copyright : (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+--------------------------------------------------------------------------------+module Data.Rakhana.Internal.Parsers where++--------------------------------------------------------------------------------+import Prelude hiding (take)+import Control.Applicative ((<$), (<|>), many)+import Data.ByteString (ByteString)+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 qualified Data.Vector as V++--------------------------------------------------------------------------------+import Data.Attoparsec.ByteString.Char8 hiding (isDigit)+import Data.Scientific (floatingOrInteger)++--------------------------------------------------------------------------------+import Data.Rakhana.Internal.Types++--------------------------------------------------------------------------------+parseHeader :: Parser Header+parseHeader+ = do _ <- string "%PDF-"+ majVer <- decimal+ _ <- char '.'+ minVer <- decimal+ return $ makeHeader majVer minVer++--------------------------------------------------------------------------------+startXRef :: Parser Int+startXRef+ = do res <- many $+ do _ <- manyTill anyChar $ string "startxref"+ skipSpace+ offset <- decimal+ skipSpace+ _ <- string "%%EOF"+ return offset+ case res of+ [] -> fail "Trailer not found"+ 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 "<<"+ dict <- many parseKey+ skipSpace+ _ <- string ">>"+ return $ Dict $ fromList dict++--------------------------------------------------------------------------------+parseKey :: Parser (ByteString, Object)+parseKey+ = do skipSpace+ key <- parseNameString+ obj <- parseObject+ return (key, obj)++--------------------------------------------------------------------------------+parseName :: Parser Object+parseName = fmap Name parseNameString++--------------------------------------------------------------------------------+parseNumber :: Parser Object+parseNumber = regularNumber <|> irregularNumber+ where+ toNumber sc+ = case floatingOrInteger sc of+ Left d -> Number $ Real d+ Right n -> Number $ Natural n++ regularNumber = fmap toNumber scientific+ irregularNumber+ = fmap (Number . Real) $ signed $+ do _ <- char '.'+ s <- takeWhile1 isDigit+ let d = "0." ++ B8.unpack s+ return $ read d++--------------------------------------------------------------------------------+parseNameString :: Parser ByteString+parseNameString+ = do _ <- char '/'+ takeWhile1 isRegularChar+ where+ isRegularChar c = c `notElem` "[]()/<>{}% \n\r"++--------------------------------------------------------------------------------+parseStringBytes :: Parser Object+parseStringBytes+ = do _ <- char '('+ s <- takeStr (0 :: Int) []+ return $ Bytes $ B8.pack s+ where+ takeStr lvl res+ = do c <- anyChar+ case c of+ '(' -> takeStr (lvl+1) (c:res)+ ')' | lvl == 0 -> return $ reverse res+ | otherwise -> takeStr (lvl-1) (c:res)+ '\\'+ -> do c' <- anyChar+ if c' `elem` "()\\"+ then takeStr lvl (c':res)+ else+ case c' of+ 'r' -> takeStr lvl ('\r':res)+ 'n' -> takeStr lvl ('\n':res)+ 'f' -> takeStr lvl ('\f':res)+ 'b' -> takeStr lvl ('\b':res)+ 't' -> takeStr lvl ('\t':res)+ '\r' -> takeStr lvl res+ _ -> do+ c'' <- anyChar+ c''' <- anyChar+ let i' = charToInt c' * 64+ i'' = charToInt c'' * 8+ i''' = charToInt c'''+ h = toEnum $ i' + i'' + i'''+ takeStr lvl (h:res)+ _ -> takeStr lvl (c:res)++--------------------------------------------------------------------------------+parseHexBytes :: Parser Object+parseHexBytes+ = do _ <- char '<'+ s <- many hex+ _ <- char '>'+ return $ Bytes $ B.pack s+ where+ hex = do h <- satisfy isHexDigit+ l <- satisfy isHexDigit+ return $ fromIntegral $ digitToInt h * 16 + digitToInt l++--------------------------------------------------------------------------------+parseBoolean :: Parser Object+parseBoolean = fmap Boolean go+ where+ go = True <$ string "true" <|>+ False <$ string "false"++--------------------------------------------------------------------------------+parseArray :: Parser Object+parseArray+ = do _ <- char '['+ a <- many parseObject+ skipSpace+ _ <- char ']'+ return $ Array $ V.fromList a++--------------------------------------------------------------------------------+parseRef :: Parser Object+parseRef+ = do o <- decimal+ skipSpace+ g <- decimal+ skipSpace+ _ <- char 'R'+ return $ Ref o g++--------------------------------------------------------------------------------+parseObject :: Parser Object+parseObject = skipSpace >> go+ where+ go = parseName <|>+ parseDict <|>+ parseBoolean <|>+ parseArray <|>+ parseRef <|>+ parseHexBytes <|>+ parseStringBytes <|>+ parseNumber++--------------------------------------------------------------------------------+parseStreamHeader :: Parser ()+parseStreamHeader+ = do skipSpace+ _ <- string "stream"+ skipSpace+ return ()++--------------------------------------------------------------------------------+parseIndirectObject :: Parser (Int, Int, Object)+parseIndirectObject+ = do skipSpace+ idx <- decimal+ skipSpace+ gen <- decimal+ skipSpace+ _ <- string "obj"+ skipSpace+ skipComment+ obj <- parseObject+ 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+charToInt c = fromEnum c - 48++--------------------------------------------------------------------------------+pdfEndOfLine :: Parser ()+pdfEndOfLine+ = do _ <- many $ char ' '+ endOfLine <|> () <$ char '\r'++--------------------------------------------------------------------------------+skipComment :: Parser ()+skipComment+ = option () $+ do _ <- char '%'+ skipWhile (not . isSpace)++--------------------------------------------------------------------------------+parseEndOfObject :: Parser ()+parseEndOfObject+ = do skipSpace+ _ <- string "endobj"+ return ()++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------+natural :: Monad m => Object -> m Integer+natural (Number (Natural i)) = return i+natural _ = fail "natural"++--------------------------------------------------------------------------------+optional :: Parser a -> Parser (Maybe a)+optional p = fmap Just p <|> return Nothing
+ Data/Rakhana/Internal/Types.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.Internal.Types+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana.Internal.Types where++--------------------------------------------------------------------------------+import Control.Applicative (pure)+import Data.ByteString (ByteString)+import qualified Data.Map.Strict as M+import qualified Data.Vector as V++--------------------------------------------------------------------------------+import Control.Lens++--------------------------------------------------------------------------------+data Number+ = Natural Integer+ | Real Double+ deriving (Eq, Show)++--------------------------------------------------------------------------------+type Dictionary = M.Map ByteString Object++--------------------------------------------------------------------------------+type Reference = (Int, Int)++--------------------------------------------------------------------------------+data Stream+ = Stream+ { _streamDict :: !Dictionary+ , _streamPos :: !Integer+ }+ deriving (Eq, Show)++--------------------------------------------------------------------------------+data Object+ = Number Number+ | Boolean Bool+ | Name ByteString+ | Dict Dictionary+ | Array (V.Vector Object)+ | Bytes ByteString+ | Ref Int Int+ | AStream Stream+ | Null+ 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++--------------------------------------------------------------------------------+-- Prisms+--------------------------------------------------------------------------------+_Number :: Prism' Object Number+_Number = prism' Number go+ where+ go (Number n) = Just n+ go _ = Nothing++--------------------------------------------------------------------------------+_Natural :: Prism' Number Integer+_Natural = prism' Natural go+ where+ go (Natural n) = Just n+ go _ = Nothing++--------------------------------------------------------------------------------+_Real :: Prism' Number Double+_Real = prism' Real go+ where+ go (Real r) = Just r+ go _ = Nothing++--------------------------------------------------------------------------------+_Boolean :: Prism' Object Bool+_Boolean = prism' Boolean go+ where+ go (Boolean b) = Just b+ go _ = Nothing++--------------------------------------------------------------------------------+_Name :: Prism' Object ByteString+_Name = prism' Name go+ where+ go (Name b) = Just b+ go _ = Nothing++--------------------------------------------------------------------------------+_Dict :: Prism' Object Dictionary+_Dict = prism' Dict go+ where+ go (Dict d) = Just d+ go _ = Nothing++--------------------------------------------------------------------------------+_Array :: Prism' Object (V.Vector Object)+_Array = prism' Array go+ where+ go (Array a) = Just a+ go _ = Nothing++--------------------------------------------------------------------------------+_Bytes :: Prism' Object ByteString+_Bytes = prism' Bytes go+ where+ go (Bytes b) = Just b+ go _ = Nothing++--------------------------------------------------------------------------------+_Ref :: Prism' Object Reference+_Ref = prism' (\(i,g) -> Ref i g) go+ where+ go (Ref i g) = Just (i,g)+ go _ = Nothing++--------------------------------------------------------------------------------+_Stream :: Prism' Object Stream+_Stream = prism' AStream go+ where+ go (AStream s) = Just s+ go _ = Nothing++--------------------------------------------------------------------------------+dictKey :: ByteString -> Traversal' Dictionary Object+dictKey key k d+ = case M.lookup key d of+ Nothing -> pure d+ Just o -> fmap go $ k o+ where+ go o' = M.insert key o' d++--------------------------------------------------------------------------------+nth :: Int -> Traversal' (V.Vector a) a+nth i k ar+ = case ar V.!? i of+ Nothing -> pure ar+ Just a -> fmap go $ k a+ where+ go a' = ar V.// [(i,a')]++--------------------------------------------------------------------------------+-- Lenses+--------------------------------------------------------------------------------+streamDict :: Lens' Stream Dictionary+streamDict = lens _streamDict (\s d -> s { _streamDict = d })++--------------------------------------------------------------------------------+streamPos :: Lens' Stream Integer+streamPos = lens _streamPos (\s p -> s { _streamPos = p })
+ Data/Rakhana/Nursery.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.Nursery+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana.Nursery+ ( Playground+ , NReq+ , NResp+ , nurseryGetInfo+ , nurseryGetHeader+ , nurseryGetPages+ , nurseryLoadStreamData+ , nurseryGetReferences+ , nurseryResolve+ , withNursery+ ) where++--------------------------------------------------------------------------------+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 Data.Rakhana.Internal.Parsers+import Data.Rakhana.Internal.Types+import Data.Rakhana.Tape+import Data.Rakhana.Util.Drive+import Data.Rakhana.XRef++--------------------------------------------------------------------------------+data NurseryException+ = NurseryParsingException String+ | NurseryUnresolvedObject Int Int+ | NurseryRootNotFound+ | NurseryPagesNotFound+ | NurseryInvalidStreamObject+ deriving (Show, Typeable)++--------------------------------------------------------------------------------+type Nursery m a = Proxy TReq TResp NReq NResp m a+type Playground m a = Client' NReq NResp m a+type Root = Dictionary+type Pages = Dictionary++--------------------------------------------------------------------------------+data NReq+ = RqInfo+ | RqHeader+ | RqPages+ | RqResolve Reference+ | RqLoadStreamData Stream+ | RqReferences++--------------------------------------------------------------------------------+data NResp+ = Unit+ | RBinaryLazy BL.ByteString+ | RInfo Dictionary+ | RHeader Header+ | RPages Dictionary+ | RResolve Object+ | RReferences [Reference]++--------------------------------------------------------------------------------+instance Exception NurseryException++--------------------------------------------------------------------------------+data NurseryState+ = NurseryState+ { nurseryHeader :: !Header+ , nurseryXRef :: !XRef+ , nurseryRoot :: !Dictionary+ , nurseryInfo :: !Dictionary+ , nurseryPages :: !Dictionary+ }++--------------------------------------------------------------------------------+bufferSize :: Int+bufferSize = 4096++--------------------------------------------------------------------------------+nursery :: MonadThrow m => Nursery m a+nursery+ = do h <- getHeader+ pos <- getXRefPos+ xref <- getXRef pos+ info <- getInfo xref+ root <- getRoot xref+ pages <- getPages xref root+ let initState = NurseryState+ { nurseryHeader = h+ , nurseryXRef = xref+ , nurseryRoot = root+ , 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++--------------------------------------------------------------------------------+serveInfo :: Monad m => NurseryState -> Nursery m (NResp, NurseryState)+serveInfo s = return (RInfo info, s)+ where+ info = nurseryInfo s++--------------------------------------------------------------------------------+serveHeader :: Monad m => NurseryState -> Nursery m (NResp, NurseryState)+serveHeader s = return (RHeader header, s)+ where+ header = nurseryHeader s++--------------------------------------------------------------------------------+servePages :: Monad m => NurseryState -> Nursery m (NResp, NurseryState)+servePages s = return (RPages pages, s)+ where+ pages = nurseryPages s++--------------------------------------------------------------------------------+serveResolve :: MonadThrow m+ => NurseryState+ -> Reference+ -> Nursery m (NResp, NurseryState)+serveResolve s ref+ = do obj <- resolveObject xref ref+ return (RResolve obj, s)+ where+ xref = nurseryXRef s++--------------------------------------------------------------------------------+serveLoadStream :: MonadThrow m+ => NurseryState+ -> Stream+ -> Nursery m (NResp, NurseryState)+serveLoadStream s st+ = do mLen <- dict ^!? dictKey "Length"+ . act (resolveIfRef xref)+ . _Number+ . _Natural+ case mLen of+ Nothing+ -> throwM NurseryInvalidStreamObject+ Just len+ -> 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)+ where+ dict = st ^. streamDict+ pos = st ^. streamPos+ xref = nurseryXRef s++--------------------------------------------------------------------------------+serveReferences :: Monad m => NurseryState -> Nursery m (NResp, NurseryState)+serveReferences s+ = return (RReferences $ rs, s)+ where+ rs = M.keys $ xrefEntries $ nurseryXRef s++--------------------------------------------------------------------------------+getHeader :: MonadThrow m => Nursery m Header+getHeader = driveParse 8 parseHeader++--------------------------------------------------------------------------------+getInfo :: MonadThrow m => XRef -> Nursery m Dictionary+getInfo xref = perform action trailer+ where+ trailer = xrefTrailer xref++ action = dictKey "Info"+ . _Ref+ . act (resolveObject xref)+ . _Dict++--------------------------------------------------------------------------------+getRoot :: MonadThrow m => XRef -> Nursery m Root+getRoot xref+ = do mR <- trailer ^!? action+ case mR of+ Nothing -> throwM NurseryRootNotFound+ Just r -> return r+ where+ trailer = xrefTrailer xref++ action+ = dictKey "Root"+ . _Ref+ . act (resolveObject xref)+ . _Dict++--------------------------------------------------------------------------------+getPages :: MonadThrow m => XRef -> Root -> Nursery m Pages+getPages xref root+ = do mP <- root ^!? action+ case mP of+ Nothing -> throwM NurseryPagesNotFound+ Just p -> return p+ where+ action+ = dictKey "Pages"+ . _Ref+ . act (resolveObject xref)+ . _Dict++--------------------------------------------------------------------------------+resolveIfRef :: MonadThrow m => XRef -> Object -> Nursery m Object+resolveIfRef xref (Ref i g) = resolveObject xref (i,g)+resolveIfRef _ obj = return obj++--------------------------------------------------------------------------------+resolveObject :: MonadThrow m => XRef -> Reference -> Nursery m Object+resolveObject xref ref@(idx,gen)+ = do driveTop+ driveForward+ loop ref+ where+ entries = xrefEntries xref++ loop cRef+ = case M.lookup cRef entries of+ Nothing+ -> throwM $ NurseryUnresolvedObject idx gen+ Just e+ -> do let offset = tableEntryOffset e+ driveSeek offset+ r <- driveParseObject bufferSize+ case r ^. _3 of+ Ref nidx ngen -> loop (nidx,ngen)+ _ -> return $ r ^. _3++--------------------------------------------------------------------------------+withNursery :: MonadThrow m => Playground m a -> Drive m a+withNursery user = nursery >>~ const user++--------------------------------------------------------------------------------+nurseryLoop :: Monad m+ => (NurseryState -> NReq -> Nursery m (NResp, NurseryState))+ -> NurseryState+ -> NReq+ -> Nursery m r+nurseryLoop k s rq+ = do (r, s') <- k s rq+ rq' <- respond r+ nurseryLoop k s' rq'++--------------------------------------------------------------------------------+-- API+--------------------------------------------------------------------------------+nurseryGetInfo :: Monad m => Playground m Dictionary+nurseryGetInfo+ = do RInfo info <- request RqInfo+ return info++--------------------------------------------------------------------------------+nurseryGetHeader :: Monad m => Playground m Header+nurseryGetHeader+ = do RHeader header <- request RqHeader+ return header++--------------------------------------------------------------------------------+nurseryGetPages :: Monad m => Playground m Dictionary+nurseryGetPages+ = do RPages pages <- request RqPages+ return pages++--------------------------------------------------------------------------------+nurseryResolve :: Monad m => Reference -> Playground m Object+nurseryResolve ref+ = do RResolve obj <- request $ RqResolve ref+ return obj++--------------------------------------------------------------------------------+nurseryLoadStreamData :: Monad m => Stream -> Playground m BL.ByteString+nurseryLoadStreamData s+ = do RBinaryLazy bs <- request $ RqLoadStreamData s+ return bs++--------------------------------------------------------------------------------+nurseryGetReferences :: Monad m => Playground m [Reference]+nurseryGetReferences+ = do RReferences rs <- request $ RqReferences+ return rs
+ Data/Rakhana/Tape.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.Tape+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana.Tape+ ( Drive+ , Direction(..)+ , TReq+ , TResp+ , Tape+ , driveBottom+ , driveBackward+ , driveForward+ , driveGetSeek+ , driveDiscard+ , driveGet+ , driveGetLazy+ , driveModifySeek+ , drivePeek+ , driveSeek+ , driveTop+ , fileTape+ , runDrive+ ) where++--------------------------------------------------------------------------------+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Functor (void)+import System.IO++--------------------------------------------------------------------------------+import Pipes+import Pipes.Core++--------------------------------------------------------------------------------+type Tape m a = Server' TReq TResp m a+type Drive m a = Client' TReq TResp m a++--------------------------------------------------------------------------------+data Direction+ = Forward+ | Backward++--------------------------------------------------------------------------------+data TReq+ = Seek Integer+ | GetSeek+ | Top+ | Bottom+ | Get Int+ | GetLazy Int+ | Direction Direction+ | Peek Int+ | Discard Int++--------------------------------------------------------------------------------+data TResp+ = Unit+ | Binary B.ByteString+ | BinaryLazy BL.ByteString+ | RSeek Integer++--------------------------------------------------------------------------------+data TapeState+ = TapeState+ { tapeStateDirection :: !Direction+ , tapeStatePos :: !Integer+ , tapeStateFilePath :: !FilePath+ , tapeStateHandle :: !Handle+ }++--------------------------------------------------------------------------------+initTapeState :: FilePath -> Handle -> TapeState+initTapeState path h+ = TapeState+ { tapeStateDirection = Forward+ , tapeStatePos = 0+ , tapeStateFilePath = path+ , tapeStateHandle = h+ }++--------------------------------------------------------------------------------+tapeLoop :: Monad m+ => (TapeState -> TReq -> Tape m (TResp, TapeState))+ -> TapeState+ -> TReq+ -> Tape m r+tapeLoop k s rq+ = do (r, s') <- k s rq+ rq' <- respond r+ tapeLoop k s' rq'++--------------------------------------------------------------------------------+newTapeState :: FilePath -> IO TapeState+newTapeState path+ = fmap (initTapeState path) $ openBinaryFile path ReadMode++--------------------------------------------------------------------------------+fileTape :: MonadIO m => FilePath -> Tape m r+fileTape path+ = do s <- liftIO $ newTapeState path+ r <- respond Unit+ tapeLoop dispatch s r+ where+ dispatch s Top = tapeTop s+ dispatch s Bottom = tapeBottom s+ dispatch s (Seek i) = tapeSeek s i+ dispatch s GetSeek = tapeGetSeek s+ dispatch s (Get i) = tapeGet s i+ dispatch s (GetLazy i) = tapeGetLazy s i+ dispatch s (Direction o) = tapeDirection s o+ dispatch s (Peek i) = tapePeek s i+ dispatch s (Discard i) = tapeDiscard s i++--------------------------------------------------------------------------------+tapeTop :: MonadIO m => TapeState -> Tape m (TResp, TapeState)+tapeTop s+ = do liftIO $ hSeek h AbsoluteSeek 0+ return (Unit, s { tapeStatePos = 0 })+ where+ h = tapeStateHandle s++--------------------------------------------------------------------------------+tapeBottom :: MonadIO m => TapeState -> Tape m (TResp, TapeState)+tapeBottom s+ = do liftIO $ hSeek h SeekFromEnd 0+ return (Unit, s { tapeStatePos = 0 })+ where+ h = tapeStateHandle s++--------------------------------------------------------------------------------+tapeSeek :: MonadIO m => TapeState -> Integer -> Tape m (TResp, TapeState)+tapeSeek s i+ = do case d of+ Backward -> liftIO $ hSeek h SeekFromEnd i+ Forward -> liftIO $ hSeek h AbsoluteSeek i+ return (Unit, s { tapeStatePos = i })+ where+ h = tapeStateHandle s+ d = tapeStateDirection s++--------------------------------------------------------------------------------+tapeGetSeek :: MonadIO m => TapeState -> Tape m (TResp, TapeState)+tapeGetSeek s = return (RSeek i, s)+ where+ i = tapeStatePos s++--------------------------------------------------------------------------------+tapeGet :: MonadIO m => TapeState -> Int -> Tape m (TResp, TapeState)+tapeGet s i+ = case o of+ Forward -> getForward+ Backward -> getBackward+ where+ p = tapeStatePos s+ h = tapeStateHandle s+ o = tapeStateDirection s++ getForward+ = liftIO $+ do let p' = p + (fromIntegral i)+ s' = s { tapeStatePos = p' }+ b <- B.hGet h i+ return (Binary b, s')++ getBackward+ = liftIO $+ do let p' = p - (fromIntegral i)+ s' = s { tapeStatePos = p' }+ hSeek h SeekFromEnd $ fromIntegral p'+ b <- B.hGet h i+ return (Binary b, s')++--------------------------------------------------------------------------------+tapeGetLazy :: MonadIO m => TapeState -> Int -> Tape m (TResp, TapeState)+tapeGetLazy s i+ = case o of+ Forward -> getForward+ Backward -> getBackward+ where+ p = tapeStatePos s+ h = tapeStateHandle s+ o = tapeStateDirection s++ getForward+ = liftIO $+ do let p' = p + (fromIntegral i)+ s' = s { tapeStatePos = p' }+ b <- BL.hGet h i+ return (BinaryLazy b, s')++ getBackward+ = liftIO $+ do let p' = p - (fromIntegral i)+ s' = s { tapeStatePos = p' }+ hSeek h SeekFromEnd $ fromIntegral p'+ b <- BL.hGet h i+ return (BinaryLazy b, s')++--------------------------------------------------------------------------------+tapeDirection :: MonadIO m => TapeState -> Direction -> Tape m (TResp, TapeState)+tapeDirection s o+ = return (Unit, s')+ where+ s' = s { tapeStateDirection = o }++--------------------------------------------------------------------------------+tapePeek :: MonadIO m => TapeState -> Int -> Tape m (TResp, TapeState)+tapePeek s i+ = case o of+ Forward -> peekForward+ Backward -> peekBackward+ where+ p = tapeStatePos s+ h = tapeStateHandle s+ o = tapeStateDirection s++ peekForward+ = liftIO $+ do bs <- B.hGet h i+ hSeek h AbsoluteSeek p+ return (Binary bs, s)++ peekBackward+ = liftIO $+ do let p' = p - (fromIntegral i)+ hSeek h SeekFromEnd p'+ b <- B.hGet h i+ return (Binary b,s)++--------------------------------------------------------------------------------+tapeDiscard :: MonadIO m => TapeState -> Int -> Tape m (TResp, TapeState)+tapeDiscard s i+ = case o of+ Forward -> discardForward+ Backward -> discardBackward+ where+ p = tapeStatePos s+ h = tapeStateHandle s+ o = tapeStateDirection s++ discardForward+ = liftIO $+ do let p' = p + (fromIntegral i)+ s' = s { tapeStatePos = p' }+ hSeek h AbsoluteSeek p'+ return (Unit, s')++ discardBackward+ = liftIO $+ do let p' = p - (fromIntegral i)+ s' = s { tapeStatePos = p' }+ hSeek h SeekFromEnd p'+ return (Unit, s')++--------------------------------------------------------------------------------+-- API+--------------------------------------------------------------------------------+driveSeek :: Monad m => Integer -> Drive m ()+driveSeek i = void $ request $ Seek i++--------------------------------------------------------------------------------+driveGetSeek :: Monad m => Drive m Integer+driveGetSeek+ = do RSeek i <- request GetSeek+ return i++--------------------------------------------------------------------------------+driveModifySeek :: Monad m => (Integer -> Integer) -> Drive m ()+driveModifySeek k+ = do i <- driveGetSeek+ driveSeek $ k i++--------------------------------------------------------------------------------+driveTop :: Monad m => Drive m ()+driveTop = void $ request Top++--------------------------------------------------------------------------------+driveBottom :: Monad m => Drive m ()+driveBottom = void $ request Bottom++--------------------------------------------------------------------------------+driveGet :: Monad m => Int -> Drive m B.ByteString+driveGet i+ = do Binary b <- request $ Get i+ return b++--------------------------------------------------------------------------------+driveGetLazy :: Monad m => Int -> Drive m BL.ByteString+driveGetLazy i+ = do BinaryLazy b <- request $ GetLazy i+ return b++--------------------------------------------------------------------------------+driveDirection :: Monad m => Direction -> Drive m ()+driveDirection d = void $ request $ Direction d++--------------------------------------------------------------------------------+driveForward :: Monad m => Drive m ()+driveForward = driveDirection Forward++--------------------------------------------------------------------------------+driveBackward :: Monad m => Drive m ()+driveBackward = driveDirection Backward++--------------------------------------------------------------------------------+drivePeek :: Monad m => Int -> Drive m B.ByteString+drivePeek i+ = do Binary b <- request $ Peek i+ return b++--------------------------------------------------------------------------------+driveDiscard :: Monad m => Int -> Drive m ()+driveDiscard i = void $ request $ Discard i++--------------------------------------------------------------------------------+runDrive :: Monad m => (forall r. Tape m r) -> Drive m a -> m a+runDrive tape drive = runEffect (tape >>~ const drive)
+ Data/Rakhana/Util/Drive.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.Util.Drive+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana.Util.Drive where++--------------------------------------------------------------------------------+import qualified Data.ByteString as B+import Data.Typeable++--------------------------------------------------------------------------------+import Control.Exception+import Control.Lens+import Control.Monad.Catch (MonadThrow(..))+import Data.Attoparsec.ByteString+import Pipes.Safe ()++--------------------------------------------------------------------------------+import Data.Rakhana.Internal.Parsers+import Data.Rakhana.Internal.Types+import Data.Rakhana.Tape++--------------------------------------------------------------------------------+data ParsingException = ParsingException String deriving (Show, Typeable)++--------------------------------------------------------------------------------+instance Exception ParsingException++--------------------------------------------------------------------------------+parseRepeatedly :: Monad m => Int -> Parser a -> Drive m (Either String a)+parseRepeatedly bufferSize parser+ = loop Nothing+ where+ loop mK+ = do bs <- driveGet bufferSize+ case maybe (parse parser bs) ($ bs) mK of+ Fail _ _ e -> return $ Left e+ Partial k -> loop $ Just k+ Done r a -> do let len = fromIntegral $ B.length r+ driveModifySeek (\i -> i - len)+ return $ Right a++--------------------------------------------------------------------------------+driveParse :: MonadThrow m => Int -> Parser a -> Drive m a+driveParse bufSize parser+ = do eR <- parseRepeatedly bufSize parser+ case eR of+ Left e -> throwM $ ParsingException e+ Right a -> return a++--------------------------------------------------------------------------------+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+ where+ couldBeStreamObject (idx, gen) d+ = do eR <- parseRepeatedly 16 parseStreamHeader+ case eR of+ Left _+ -> return $ (idx, gen, Dict d)+ Right _+ -> do p <- driveGetSeek+ return (idx, gen, AStream $ Stream d p)
+ Data/Rakhana/XRef.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Rakhana.XRef+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Rakhana.XRef+ ( getXRef+ , getXRefPos+ ) where++--------------------------------------------------------------------------------+import qualified Data.ByteString.Char8 as B8+import Data.Char (isDigit, isSpace)+import Data.Typeable++--------------------------------------------------------------------------------+import Control.Monad.Catch (Exception, MonadThrow(..))+import Pipes.Safe ()++--------------------------------------------------------------------------------+import Data.Rakhana.Internal.Parsers+import Data.Rakhana.Internal.Types+import Data.Rakhana.Tape+import Data.Rakhana.Util.Drive++--------------------------------------------------------------------------------+data XRefParsingException+ = XRefParsingException String+ deriving (Show, Typeable)++--------------------------------------------------------------------------------+instance Exception XRefParsingException++--------------------------------------------------------------------------------+bufferSize :: Int+bufferSize = 4096++--------------------------------------------------------------------------------+getXRefPos :: MonadThrow m => Drive m Integer+getXRefPos+ = do driveBottom+ driveBackward+ skipEOL+ parseEOF+ skipEOL+ p <- parseXRefPosInteger+ skipEOL+ parseStartXRef+ return p++--------------------------------------------------------------------------------+getXRef :: MonadThrow m => Integer -> Drive m XRef+getXRef pos+ = do driveTop+ driveForward+ driveSeek pos+ eR <- parseRepeatedly bufferSize parseXRef+ either (throwM . XRefParsingException) return eR++--------------------------------------------------------------------------------+skipEOL :: Monad m => Drive m ()+skipEOL+ = do bs <- drivePeek 1+ case B8.uncons bs of+ Just (c, _)+ | isSpace c -> driveDiscard 1 >> skipEOL+ | otherwise -> return ()+ _ -> return ()++--------------------------------------------------------------------------------+parseEOF :: MonadThrow m => Drive m ()+parseEOF+ = do bs <- driveGet 5+ case bs of+ "%%EOF" -> return ()+ _ -> throwM $ XRefParsingException "Expected %%EOF"++--------------------------------------------------------------------------------+parseXRefPosInteger :: MonadThrow m => Drive m Integer+parseXRefPosInteger = go []+ where+ go cs = do bs <- drivePeek 1+ case B8.uncons bs of+ Just (c,_)+ | isDigit c -> driveDiscard 1 >> go (c:cs)+ | otherwise -> return $ read cs+ _ -> return $ read cs++--------------------------------------------------------------------------------+parseStartXRef :: MonadThrow m => Drive m ()+parseStartXRef+ = do bs <- driveGet 9+ case bs of+ "startxref" -> return ()+ _ -> throwM $ XRefParsingException "Expected startxref"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Yorick Laupa++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Yorick Laupa nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+rakhana+=======++Stream based PDF library
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rakhana.cabal view
@@ -0,0 +1,92 @@+-- Initial rakhana.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: rakhana++-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Stream based PDF library++-- A longer description of the package.+description: Stream based PDF library++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Yorick Laupa++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer: yo.eight@gmail.com++homepage: http://github.com/YoEight/rakhana+bug-reports: http://github.com/YoEight/rakhana/issues++-- A copyright notice.+-- copyright:++category: Data++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files: README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.18++source-repository head+ type: git+ location: git://github.com/YoEight/rakhana.git++library+ -- Modules exported by the library.+ exposed-modules: Data.Rakhana++ -- Modules included in this library but not exported.+ other-modules: Data.Rakhana.Internal.Parsers+ Data.Rakhana.Internal.Types+ Data.Rakhana.Nursery+ Data.Rakhana.Tape+ Data.Rakhana.Util.Drive+ Data.Rakhana.XRef++ -- LANGUAGE extensions used by modules in this package.+ other-extensions: DeriveDataTypeable+ OverloadedStrings+ RankNTypes++ -- Other library packages from which modules are imported.+ build-depends: base >=4.7 && <4.8+ , attoparsec == 0.12.*+ , bytestring+ , containers == 0.5.*+ , exceptions == 0.6.*+ , lens == 4.4.*+ , mtl+ , pipes == 4.*+ , pipes-safe > 2 && < 3+ , scientific+ , transformers == 0.4.*+ , vector >= 0.10 && < 0.11+ , zlib >= 0.5 && < 0.6+++ -- Directories containing source files.+ -- hs-source-dirs: .++ -- Base language which the package is written in.+ default-language: Haskell2010