2020-02-11 08:29:08 +01:00
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2020-02-26 22:13:29 +01:00
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2020-05-28 18:54:15 +02:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2020-02-11 08:29:08 +01:00
|
|
|
module PDF.Object.Navigation (
|
2020-05-28 18:54:15 +02:00
|
|
|
Nav(..)
|
|
|
|
, PPath(..)
|
|
|
|
, ROLayer
|
|
|
|
, RWLayer
|
|
|
|
, StreamContent(..)
|
2020-02-15 13:51:24 +01:00
|
|
|
, (./)
|
2020-02-15 10:22:42 +01:00
|
|
|
, (//)
|
2020-02-15 13:51:24 +01:00
|
|
|
, (>./)
|
|
|
|
, (>//)
|
2020-03-04 18:14:33 +01:00
|
|
|
, castObject
|
2020-05-28 18:54:15 +02:00
|
|
|
, catalog
|
2020-02-11 08:29:08 +01:00
|
|
|
, getDictionary
|
2020-03-08 22:18:47 +01:00
|
|
|
, getKey
|
2020-02-11 17:35:35 +01:00
|
|
|
, objectById
|
2020-05-28 18:54:15 +02:00
|
|
|
, save
|
2020-02-11 08:29:08 +01:00
|
|
|
) where
|
|
|
|
|
2020-02-26 22:13:29 +01:00
|
|
|
import Codec.Compression.Zlib (compress, decompress)
|
2020-05-28 18:54:15 +02:00
|
|
|
import Control.Monad.Except (MonadError(..))
|
2020-02-11 08:29:08 +01:00
|
|
|
import Control.Monad.Reader (MonadReader(..))
|
2020-05-28 18:54:15 +02:00
|
|
|
import Control.Monad.State (MonadState)
|
2020-02-11 08:29:08 +01:00
|
|
|
import Data.ByteString (ByteString)
|
2020-05-28 18:54:15 +02:00
|
|
|
import qualified Data.ByteString as BS (length)
|
2020-02-26 22:13:29 +01:00
|
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString, fromStrict, toStrict)
|
2020-05-28 18:54:15 +02:00
|
|
|
import Data.Id (Id)
|
|
|
|
import qualified Data.Id as Id (at)
|
|
|
|
import qualified Data.Map as Map (adjust, insert, lookup)
|
|
|
|
import PDF.Box (Box(..), at, edit{-, runRO-})
|
2020-02-17 15:29:59 +01:00
|
|
|
import PDF.Layer (Layer(..))
|
2020-02-11 08:29:08 +01:00
|
|
|
import PDF.Object (
|
2020-02-17 15:29:59 +01:00
|
|
|
Dictionary, DirectObject(..), IndirectObjCoordinates(..)
|
2020-05-28 18:54:15 +02:00
|
|
|
, Name(..), Number(..), Object(..), Structure(..)
|
2020-02-11 08:29:08 +01:00
|
|
|
)
|
|
|
|
import Prelude hiding (fail)
|
|
|
|
import Text.Printf (printf)
|
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
newtype PPath = PPath [Component]
|
|
|
|
data DPath = DPath {
|
|
|
|
root :: Id Object
|
|
|
|
, offset :: [Component]
|
|
|
|
} deriving Show
|
|
|
|
|
|
|
|
push :: Component -> DPath -> DPath
|
|
|
|
push component dPath = dPath {offset = (offset dPath) ++ [component]}
|
|
|
|
|
|
|
|
data Nav a = Nav {
|
|
|
|
dPath :: DPath
|
|
|
|
, value :: a
|
|
|
|
} deriving (Functor)
|
|
|
|
|
|
|
|
instance Show a => Show (Nav a) where
|
|
|
|
show (Nav {dPath, value}) = "Nav {dPath = " ++ show dPath ++ ", value = " ++ show value ++ "}"
|
|
|
|
|
|
|
|
type ROLayer m = (MonadReader Layer m, MonadError String m)
|
|
|
|
type RWLayer m = (MonadState Layer m, MonadError String m)
|
2020-02-28 18:14:27 +01:00
|
|
|
type Component = String
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
getDictionary :: ROLayer m => Nav Object -> m (Nav Dictionary)
|
|
|
|
getDictionary (Nav {dPath, value}) =
|
|
|
|
case value of
|
|
|
|
(Direct (Dictionary aDict)) -> return $ Nav {dPath, value = aDict}
|
|
|
|
(Direct (Reference ref)) -> objectById (objectId ref) >>= getDictionary
|
|
|
|
(Stream {header}) -> return $ Nav {dPath, value = header}
|
|
|
|
obj -> expected "dictionary : " obj
|
2020-02-11 17:35:35 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
expected :: (MonadError String m, Show a) => String -> a -> m b
|
|
|
|
expected name = throwError . printf "Not a %s: %s" name . show
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
getKey :: ROLayer m => String -> Nav Object -> m (Nav DirectObject)
|
|
|
|
getKey key navObject = getDictionary navObject >>= f
|
2020-02-11 08:29:08 +01:00
|
|
|
where
|
|
|
|
errorMessage =
|
2020-05-28 18:54:15 +02:00
|
|
|
printf "Key %s not found in object %s" key (show navObject)
|
|
|
|
f (Nav {dPath, value}) =
|
|
|
|
case Map.lookup (Name key) value of
|
|
|
|
Nothing -> throwError errorMessage
|
|
|
|
Just dObj -> return $ Nav {dPath = push key dPath, value = dObj}
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
objectById :: ROLayer m => (Id Object) -> m (Nav Object)
|
2020-02-11 17:35:35 +01:00
|
|
|
objectById objectId = do
|
2020-02-23 22:15:52 +01:00
|
|
|
layer <- ask
|
2020-05-28 18:54:15 +02:00
|
|
|
return $ Nav {
|
|
|
|
dPath = DPath {root = objectId, offset = []}
|
|
|
|
, value = objects layer `Id.at` objectId
|
|
|
|
}
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
castObject :: ROLayer m => Nav DirectObject -> m (Nav Object)
|
|
|
|
castObject (Nav {value = !(Reference (IndirectObjCoordinates {objectId}))}) =
|
2020-03-04 18:14:33 +01:00
|
|
|
objectById objectId
|
2020-05-28 18:54:15 +02:00
|
|
|
castObject (Nav {dPath, value}) = return $ Nav {dPath, value = Direct value}
|
|
|
|
|
|
|
|
(./) :: ROLayer m => m (Nav Object) -> Component -> m (Nav Object)
|
|
|
|
(./) navObject key = (navObject >>= getKey key >>= castObject)
|
2020-02-15 13:51:24 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
(//) :: ROLayer m => m (Nav Object) -> PPath -> m (Nav Object)
|
|
|
|
(//) navObject (PPath []) = navObject
|
|
|
|
(//) navObject (PPath (key:keys)) = navObject ./ key // (PPath keys)
|
2020-02-15 13:51:24 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
(>./) :: ROLayer m => Nav Object -> Component -> m (Nav Object)
|
|
|
|
(>./) navObject = (return navObject ./)
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
(>//) :: ROLayer m => Nav Object -> PPath -> m (Nav Object)
|
|
|
|
(>//) navObject = (return navObject //)
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
catalog :: ROLayer m => m (Nav Object)
|
|
|
|
catalog = do
|
|
|
|
value <- Direct . Dictionary . trailer . docStructure <$> ask
|
|
|
|
return $ Nav {dPath = undefined, value}
|
2020-02-11 08:29:08 +01:00
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
setAt :: [Component] -> DirectObject -> Dictionary -> Dictionary
|
|
|
|
setAt [] _ dict = dict
|
|
|
|
setAt [component] directObject dict =
|
|
|
|
Map.insert (Name component) directObject dict
|
|
|
|
setAt (component:components) directObject dict =
|
|
|
|
Map.adjust setDirObj (Name component) dict
|
|
|
|
where
|
|
|
|
setDirObj (Dictionary subDict) =
|
|
|
|
Dictionary $ setAt components directObject subDict
|
|
|
|
setDirObj x = x
|
|
|
|
|
|
|
|
save :: RWLayer m => Nav Object -> m ()
|
|
|
|
save nav@(Nav {dPath, value = Direct dObj}) =
|
|
|
|
edit .at (root dPath) $ return . setObj
|
|
|
|
where
|
|
|
|
setObj obj@(Stream {header}) =
|
|
|
|
obj {header = setAt (offset dPath) dObj header}
|
|
|
|
setObj (Direct (Dictionary dict)) =
|
|
|
|
Direct . Dictionary $ setAt (offset dPath) dObj dict
|
|
|
|
setObj _ = value nav
|
|
|
|
save (Nav {dPath = DPath {root, offset = []}, value}) = edit $ w root value
|
|
|
|
save _ = throwError "Streams can't be properties of PDF objects"
|
|
|
|
|
|
|
|
data StreamContent = Clear | Raw
|
2020-02-26 22:13:29 +01:00
|
|
|
|
|
|
|
onLazy :: (Lazy.ByteString -> Lazy.ByteString) -> ByteString -> ByteString
|
|
|
|
onLazy f = Lazy.toStrict . f . Lazy.fromStrict
|
|
|
|
|
2020-03-11 10:47:52 +01:00
|
|
|
contains :: String -> DirectObject -> Bool
|
2020-05-28 18:54:15 +02:00
|
|
|
contains needle !(NameObject (Name n)) = needle == n
|
|
|
|
contains needle !(Array directObjects) = oneOf directObjects (contains needle)
|
2020-03-11 10:47:52 +01:00
|
|
|
where
|
|
|
|
oneOf [] _ = False
|
|
|
|
oneOf (x:xs) p = p x || oneOf xs p
|
|
|
|
contains _ _ = False
|
|
|
|
|
2020-05-28 18:54:15 +02:00
|
|
|
instance MonadError String m => Box m StreamContent (Nav Object) ByteString where
|
|
|
|
r sc = r sc . value
|
|
|
|
w sc newStreamContent nav = setValue <$> w sc newStreamContent (value nav)
|
|
|
|
where
|
|
|
|
setValue value = nav {value}
|
|
|
|
|
|
|
|
instance MonadError String m => Box m StreamContent Object ByteString where
|
|
|
|
r Raw (Stream {streamContent}) = return streamContent
|
2020-03-04 18:31:30 +01:00
|
|
|
r Clear (Stream {header, streamContent}) = return $
|
2020-02-26 22:13:29 +01:00
|
|
|
case Map.lookup (Name "Filter") header of
|
2020-03-11 10:47:52 +01:00
|
|
|
Just directObject
|
|
|
|
| contains "FlateDecode" directObject -> onLazy decompress streamContent
|
2020-02-26 22:13:29 +01:00
|
|
|
_ -> streamContent
|
2020-03-04 18:31:30 +01:00
|
|
|
r _ obj = expected "stream" obj
|
2020-02-26 22:13:29 +01:00
|
|
|
|
2020-03-04 18:31:30 +01:00
|
|
|
w Raw streamContent obj@(Stream {}) = return $ obj {streamContent}
|
2020-05-28 18:54:15 +02:00
|
|
|
w Clear newStreamContent (Stream {header}) =
|
|
|
|
let streamContent = getStreamContent (Map.lookup (Name "Filter") header) in
|
|
|
|
return $ Stream {header = fixLength streamContent, streamContent}
|
|
|
|
where
|
|
|
|
getStreamContent (Just directObject)
|
|
|
|
| contains "FlateDecode" directObject = onLazy compress newStreamContent
|
|
|
|
getStreamContent _ = newStreamContent
|
|
|
|
fixLength sc =
|
|
|
|
let newLength = NumberObject . Number . fromIntegral $ BS.length sc in
|
|
|
|
Map.insert (Name "Length") newLength header
|
2020-03-04 18:31:30 +01:00
|
|
|
w _ _ obj = expected "stream" obj
|