71 lines
2.4 KiB
Haskell
71 lines
2.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module PDF.Object.Navigation (
|
|
(//)
|
|
, getDictionary
|
|
, getField
|
|
, getObject
|
|
, openStream
|
|
, origin
|
|
) where
|
|
|
|
import Codec.Compression.Zlib (decompress)
|
|
import Control.Monad.Reader (MonadReader(..))
|
|
import Control.Monad.Fail (MonadFail(..))
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString.Lazy as Lazy (fromStrict, toStrict)
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map (lookup)
|
|
import PDF.Object (
|
|
Content(..), Dictionary, DirectObject(..), IndirectObjCoordinates(..)
|
|
, Name(..), Object(..), Structure(..)
|
|
)
|
|
import PDF.Output (ObjectId)
|
|
import Prelude hiding (fail)
|
|
import Text.Printf (printf)
|
|
|
|
type PDFContent m = (MonadReader Content m, MonadFail m)
|
|
|
|
expected :: (PDFContent m, Show a) => String -> a -> m b
|
|
expected name = fail . printf "Not a %s: %s" name . show
|
|
|
|
getField :: MonadFail m => String -> Dictionary -> m DirectObject
|
|
getField key aDictionary =
|
|
maybe (fail errorMessage) return (Map.lookup (Name key) aDictionary)
|
|
where
|
|
errorMessage =
|
|
printf "Key %s not found in dictionary %s" key (show aDictionary)
|
|
|
|
castDictionary :: PDFContent m => Object -> m Dictionary
|
|
castDictionary (Direct (Dictionary aDict)) = return aDict
|
|
castDictionary obj = expected "dictionary : " obj
|
|
|
|
getObject :: PDFContent m => ObjectId -> m Object
|
|
getObject objectId = do
|
|
content <- ask
|
|
return (objects content ! objectId)
|
|
|
|
getDictionary :: PDFContent m => DirectObject -> m Dictionary
|
|
getDictionary (Dictionary aDictionary) = return aDictionary
|
|
getDictionary (Reference (IndirectObjCoordinates {objectId})) =
|
|
getObject objectId >>= castDictionary
|
|
getDictionary aDirectObject =
|
|
expected "resource (dictionary or reference)" aDirectObject
|
|
|
|
(//) :: PDFContent m => Dictionary -> [String] -> m DirectObject
|
|
(//) aDict [] = return $ Dictionary aDict
|
|
(//) aDict [key] = getField key aDict
|
|
(//) aDict (key:keys) = getField key aDict >>= getDictionary >>= (// keys)
|
|
|
|
origin :: PDFContent m => m Dictionary
|
|
origin = trailer . docStructure <$> ask
|
|
|
|
openStream :: PDFContent m => Object -> m ByteString
|
|
openStream (Stream {header, streamContent}) = return $
|
|
case Map.lookup (Name "Filter") header of
|
|
Just (NameObject (Name "FlateDecode")) ->
|
|
Lazy.toStrict . decompress . Lazy.fromStrict $ streamContent
|
|
_ -> streamContent
|
|
openStream obj = expected "stream" obj
|