{-# LANGUAGE  OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}

-- | Stream related tools

module Pdf.Core.Stream
(
  StreamFilter,
  knownFilters,
  readStream,
  rawStreamContent,
  decodedStreamContent,
  decodeStream
)
where

import Pdf.Core.Exception
import Pdf.Core.Object
import Pdf.Core.Parsers.Object
import Pdf.Core.Stream.Filter.Type
import Pdf.Core.Stream.Filter.FlateDecode
import Pdf.Core.IO.Buffer (Buffer)
import qualified Pdf.Core.IO.Buffer as Buffer

import Data.Int
import Data.Maybe
import Data.ByteString (ByteString)
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap
import Control.Monad
import Control.Exception hiding (throw)
import System.IO.Streams (InputStream)
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.Attoparsec as Streams

-- | Read 'Stream' from stream
--
-- We need to pass current position here to calculate stream data offset
readStream :: InputStream ByteString -> Int64 -> IO Stream
readStream :: InputStream ByteString -> Int64 -> IO Stream
readStream InputStream ByteString
is Int64
off = do
  (InputStream ByteString
is', IO Int64
counter) <- InputStream ByteString -> IO (InputStream ByteString, IO Int64)
Streams.countInput InputStream ByteString
is
  (Ref
_, Object
obj) <- Parser (Ref, Object) -> InputStream ByteString -> IO (Ref, Object)
forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream Parser (Ref, Object)
parseIndirectObject InputStream ByteString
is'
    IO (Ref, Object)
-> (ParseException -> IO (Ref, Object)) -> IO (Ref, Object)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(Streams.ParseException String
msg) -> Corrupted -> IO (Ref, Object)
forall e a. Exception e => e -> IO a
throwIO (String -> [String] -> Corrupted
Corrupted String
msg [])
  case Object
obj of
    Stream (S Dict
dict Int64
_) -> do
      Int64
off' <- IO Int64
counter
      Stream -> IO Stream
forall (m :: * -> *) a. Monad m => a -> m a
return (Dict -> Int64 -> Stream
S Dict
dict (Int64
off Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
off'))
    Object
_ -> ParseException -> IO Stream
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO Stream) -> ParseException -> IO Stream
forall a b. (a -> b) -> a -> b
$ String -> ParseException
Streams.ParseException (String
"stream expected, but got: "
                                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
obj)

-- | All stream filters implemented by the toolbox
--
-- Right now it contains only FlateDecode filter
knownFilters :: [StreamFilter]
knownFilters :: [StreamFilter]
knownFilters = [Maybe StreamFilter] -> [StreamFilter]
forall a. [Maybe a] -> [a]
catMaybes [Maybe StreamFilter
flateDecode]

-- | Raw stream content.
-- Filters are not applyed
--
-- The 'InputStream' returned is valid only until the next 'bufferSeek'
--
-- Note: \"Length\" could be an indirect object, but we don't want
-- to read indirect objects here. So we require length to be provided
rawStreamContent :: Buffer
                 -> Int           -- ^ stream length
                 -> Int64         -- ^ stream offset
                                  -- The payload is offset of stream data
                 -> IO (InputStream ByteString)
rawStreamContent :: Buffer -> Int -> Int64 -> IO (InputStream ByteString)
rawStreamContent Buffer
buf Int
len Int64
off = do
  Buffer -> Int64 -> IO ()
Buffer.seek Buffer
buf Int64
off
  Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (Buffer -> InputStream ByteString
Buffer.toInputStream Buffer
buf)

-- | Decode stream content
--
-- It should be already decrypted
--
-- The 'InputStream' is valid only until the next 'bufferSeek'
decodeStream :: [StreamFilter]
             -> Stream -> InputStream ByteString
             -> IO (InputStream ByteString)
decodeStream :: [StreamFilter]
-> Stream -> InputStream ByteString -> IO (InputStream ByteString)
decodeStream [StreamFilter]
filters (S Dict
dict Int64
_) InputStream ByteString
istream =
  Dict -> IO [(Name, Maybe Dict)]
buildFilterList Dict
dict IO [(Name, Maybe Dict)]
-> ([(Name, Maybe Dict)] -> IO (InputStream ByteString))
-> IO (InputStream ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InputStream ByteString
 -> (Name, Maybe Dict) -> IO (InputStream ByteString))
-> InputStream ByteString
-> [(Name, Maybe Dict)]
-> IO (InputStream ByteString)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM InputStream ByteString
-> (Name, Maybe Dict) -> IO (InputStream ByteString)
decode InputStream ByteString
istream
  where
  decode :: InputStream ByteString
-> (Name, Maybe Dict) -> IO (InputStream ByteString)
decode InputStream ByteString
is (Name
name, Maybe Dict
params) = do
    StreamFilter
f <- Name -> IO StreamFilter
findFilter Name
name
    StreamFilter
-> Maybe Dict
-> InputStream ByteString
-> IO (InputStream ByteString)
filterDecode StreamFilter
f Maybe Dict
params InputStream ByteString
is
  findFilter :: Name -> IO StreamFilter
findFilter Name
name =
    case (StreamFilter -> Bool) -> [StreamFilter] -> [StreamFilter]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) (Name -> Bool) -> (StreamFilter -> Name) -> StreamFilter -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamFilter -> Name
filterName) [StreamFilter]
filters of
      [] -> Corrupted -> IO StreamFilter
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO StreamFilter) -> Corrupted -> IO StreamFilter
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted String
"Filter not found" []
      (StreamFilter
f : [StreamFilter]
_) -> StreamFilter -> IO StreamFilter
forall (m :: * -> *) a. Monad m => a -> m a
return StreamFilter
f

buildFilterList :: Dict -> IO [(Name, Maybe Dict)]
buildFilterList :: Dict -> IO [(Name, Maybe Dict)]
buildFilterList Dict
dict = do
  let f :: Object
f = Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
fromMaybe Object
Null (Maybe Object -> Object) -> Maybe Object -> Object
forall a b. (a -> b) -> a -> b
$ Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Filter" Dict
dict
      p :: Object
p = Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
fromMaybe Object
Null (Maybe Object -> Object) -> Maybe Object -> Object
forall a b. (a -> b) -> a -> b
$ Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"DecodeParms" Dict
dict
  case (Object
f, Object
p) of
    (Object
Null, Object
_) -> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    (Name Name
fd, Object
Null) -> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fd, Maybe Dict
forall a. Maybe a
Nothing)]
    (Name Name
fd, Dict Dict
pd) -> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fd, Dict -> Maybe Dict
forall a. a -> Maybe a
Just Dict
pd)]
    (Name Name
fd, Array Array
arr)
      | [Dict Dict
pd] <- Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
arr
      -> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fd, Dict -> Maybe Dict
forall a. a -> Maybe a
Just Dict
pd)]
    (Array Array
fa, Object
Null) -> do
      [Name]
fa' <- [Object] -> (Object -> IO Name) -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
fa) ((Object -> IO Name) -> IO [Name])
-> (Object -> IO Name) -> IO [Name]
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Object
o of
          Name Name
n -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
          Object
_ -> Corrupted -> IO Name
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO Name) -> Corrupted -> IO Name
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted (String
"Filter should be a Name") []
      [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)])
-> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Maybe Dict] -> [(Name, Maybe Dict)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fa' (Maybe Dict -> [Maybe Dict]
forall a. a -> [a]
repeat Maybe Dict
forall a. Maybe a
Nothing)
    (Array Array
fa, Array Array
pa) | Array -> Int
forall a. Vector a -> Int
Vector.length Array
fa Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Array -> Int
forall a. Vector a -> Int
Vector.length Array
pa -> do
      [Name]
fa' <- [Object] -> (Object -> IO Name) -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
fa) ((Object -> IO Name) -> IO [Name])
-> (Object -> IO Name) -> IO [Name]
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Object
o of
          Name Name
n -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
          Object
_ -> Corrupted -> IO Name
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO Name) -> Corrupted -> IO Name
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted (String
"Filter should be a Name") []
      [Dict]
pa' <- [Object] -> (Object -> IO Dict) -> IO [Dict]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
pa) ((Object -> IO Dict) -> IO [Dict])
-> (Object -> IO Dict) -> IO [Dict]
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Object
o of
          Dict Dict
d -> Dict -> IO Dict
forall (m :: * -> *) a. Monad m => a -> m a
return Dict
d
          Object
_ -> Corrupted -> IO Dict
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO Dict) -> Corrupted -> IO Dict
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted (String
"DecodeParams should be a dictionary") []
      [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)])
-> [(Name, Maybe Dict)] -> IO [(Name, Maybe Dict)]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Maybe Dict] -> [(Name, Maybe Dict)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fa' ((Dict -> Maybe Dict) -> [Dict] -> [Maybe Dict]
forall a b. (a -> b) -> [a] -> [b]
map Dict -> Maybe Dict
forall a. a -> Maybe a
Just [Dict]
pa')
    (Object, Object)
_ -> Corrupted -> IO [(Name, Maybe Dict)]
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO [(Name, Maybe Dict)])
-> Corrupted -> IO [(Name, Maybe Dict)]
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted (String
"Can't handle Filter and DecodeParams: ("
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") []

-- | Decoded stream content
--
-- The 'InputStream' is valid only until the next 'bufferSeek'
--
-- Note: \"Length\" could be an indirect object, that is why
-- we cann't read it ourself
decodedStreamContent :: Buffer
                     -> [StreamFilter]
                     -> (InputStream ByteString -> IO (InputStream ByteString))
                     -- ^ decryptor
                     -> Int
                     -- ^ stream length
                     -> Stream
                     -- ^ stream with offset
                     -> IO (InputStream ByteString)
decodedStreamContent :: Buffer
-> [StreamFilter]
-> (InputStream ByteString -> IO (InputStream ByteString))
-> Int
-> Stream
-> IO (InputStream ByteString)
decodedStreamContent Buffer
buf [StreamFilter]
filters InputStream ByteString -> IO (InputStream ByteString)
decryptor Int
len s :: Stream
s@(S Dict
_ Int64
off) =
  Buffer -> Int -> Int64 -> IO (InputStream ByteString)
rawStreamContent Buffer
buf Int
len Int64
off IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream ByteString))
-> IO (InputStream ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  InputStream ByteString -> IO (InputStream ByteString)
decryptor IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream ByteString))
-> IO (InputStream ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  [StreamFilter]
-> Stream -> InputStream ByteString -> IO (InputStream ByteString)
decodeStream [StreamFilter]
filters Stream
s