diff --git a/Data/Rakhana.hs b/Data/Rakhana.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Rakhana +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 diff --git a/Data/Rakhana/Internal/Parsers.hs b/Data/Rakhana/Internal/Parsers.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/Internal/Parsers.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Rakhana.Internal.Parsers +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 diff --git a/Data/Rakhana/Internal/Types.hs b/Data/Rakhana/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/Internal/Types.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE RankNTypes #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Rakhana.Internal.Types +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 }) diff --git a/Data/Rakhana/Nursery.hs b/Data/Rakhana/Nursery.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/Nursery.hs @@ -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 +-- 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 diff --git a/Data/Rakhana/Tape.hs b/Data/Rakhana/Tape.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/Tape.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE RankNTypes #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Rakhana.Tape +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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) diff --git a/Data/Rakhana/Util/Drive.hs b/Data/Rakhana/Util/Drive.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/Util/Drive.hs @@ -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 +-- 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) diff --git a/Data/Rakhana/XRef.hs b/Data/Rakhana/XRef.hs new file mode 100644 --- /dev/null +++ b/Data/Rakhana/XRef.hs @@ -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 +-- 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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +rakhana +======= + +Stream based PDF library diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rakhana.cabal b/rakhana.cabal new file mode 100644 --- /dev/null +++ b/rakhana.cabal @@ -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