{-# LANGUAGE OverloadedStrings #-}

-- | Basic support for encrypted PDF files

module Pdf.Core.Encryption
( Decryptor
, DecryptorScope(..)
, defaultUserPassword
, mkStandardDecryptor
, decryptObject
)
where

import Pdf.Core.Object
import Pdf.Core.Object.Util
import Pdf.Core.Util

import qualified Data.Traversable as Traversable
import Data.Bits (xor)
import Data.IORef
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Builder
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap
import Control.Monad
import System.IO.Streams (InputStream)
import qualified System.IO.Streams as Streams
import qualified Crypto.Cipher.RC4 as RC4
import qualified Crypto.Cipher.AES as AES
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Padding as Padding

-- | Encryption handler may specify different encryption keys for strings
-- and streams
data DecryptorScope
  = DecryptString
  | DecryptStream

-- | Decrypt input stream
type Decryptor
  =  Ref
  -> DecryptorScope
  -> InputStream ByteString
  -> IO (InputStream ByteString)

-- | Decrypt object with the decryptor
decryptObject :: Decryptor -> Ref -> Object -> IO Object
decryptObject :: Decryptor -> Ref -> Object -> IO Object
decryptObject Decryptor
decryptor Ref
ref (String ByteString
str)
  = ByteString -> Object
String (ByteString -> Object) -> IO ByteString -> IO Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decryptor -> Ref -> ByteString -> IO ByteString
decryptStr Decryptor
decryptor Ref
ref ByteString
str
decryptObject Decryptor
decryptor Ref
ref (Dict Dict
dict)
  = Dict -> Object
Dict (Dict -> Object) -> IO Dict -> IO Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decryptor -> Ref -> Dict -> IO Dict
decryptDict Decryptor
decryptor Ref
ref Dict
dict
decryptObject Decryptor
decryptor Ref
ref (Array Array
arr)
  = Array -> Object
Array (Array -> Object) -> IO Array -> IO Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decryptor -> Ref -> Array -> IO Array
decryptArray Decryptor
decryptor Ref
ref Array
arr
decryptObject Decryptor
_ Ref
_ Object
o = Object -> IO Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
o

decryptStr :: Decryptor -> Ref -> ByteString -> IO ByteString
decryptStr :: Decryptor -> Ref -> ByteString -> IO ByteString
decryptStr Decryptor
decryptor Ref
ref ByteString
str = do
  InputStream ByteString
is <- [ByteString] -> IO (InputStream ByteString)
forall c. [c] -> IO (InputStream c)
Streams.fromList [ByteString
str]
  [ByteString]
res <- Decryptor
decryptor Ref
ref DecryptorScope
DecryptString InputStream ByteString
is IO (InputStream ByteString)
-> (InputStream ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList
  ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString]
res

decryptDict :: Decryptor -> Ref -> Dict -> IO Dict
decryptDict :: Decryptor -> Ref -> Dict -> IO Dict
decryptDict Decryptor
decryptor Ref
ref Dict
vals = Dict -> (Object -> IO Object) -> IO Dict
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Traversable.forM Dict
vals ((Object -> IO Object) -> IO Dict)
-> (Object -> IO Object) -> IO Dict
forall a b. (a -> b) -> a -> b
$
  Decryptor -> Ref -> Object -> IO Object
decryptObject Decryptor
decryptor Ref
ref

decryptArray :: Decryptor -> Ref -> Array -> IO Array
decryptArray :: Decryptor -> Ref -> Array -> IO Array
decryptArray Decryptor
decryptor Ref
ref Array
vals = Array -> (Object -> IO Object) -> IO Array
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
Vector.forM Array
vals Object -> IO Object
decr
  where
  decr :: Object -> IO Object
decr = Decryptor -> Ref -> Object -> IO Object
decryptObject Decryptor
decryptor Ref
ref

-- | The default user password
defaultUserPassword :: ByteString
defaultUserPassword :: ByteString
defaultUserPassword = [Word8] -> ByteString
BS.pack [
  Word8
0x28, Word8
0xBF, Word8
0x4E, Word8
0x5E, Word8
0x4E, Word8
0x75, Word8
0x8A, Word8
0x41, Word8
0x64, Word8
0x00, Word8
0x4E,
  Word8
0x56, Word8
0xFF, Word8
0xFA, Word8
0x01, Word8
0x08, Word8
0x2E, Word8
0x2E, Word8
0x00, Word8
0xB6, Word8
0xD0, Word8
0x68,
  Word8
0x3E, Word8
0x80, Word8
0x2F, Word8
0x0C, Word8
0xA9, Word8
0xFE, Word8
0x64, Word8
0x53, Word8
0x69, Word8
0x7A
  ]

-- | Standard decryptor, RC4
mkStandardDecryptor :: Dict
                    -- ^ document trailer
                    -> Dict
                    -- ^ encryption dictionary
                    -> ByteString
                    -- ^ user password (32 bytes exactly,
                    -- see 7.6.3.3 Encryption Key Algorithm)
                    -> Either String (Maybe Decryptor)
mkStandardDecryptor :: Dict -> Dict -> ByteString -> Either String (Maybe Decryptor)
mkStandardDecryptor Dict
tr Dict
enc ByteString
pass = do
  Name
filterType <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Filter" Dict
enc of
      Just Object
o -> Object -> Maybe Name
nameValue Object
o Maybe Name -> String -> Either String Name
forall a. Maybe a -> String -> Either String a
`notice` String
"Filter should be a name"
      Maybe Object
_ -> String -> Either String Name
forall a b. a -> Either a b
Left String
"Filter missing"
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
filterType Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"Standard") (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String
"Unsupported encryption handler: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
filterType)

  Int
v <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"V" Dict
enc of
      Just Object
n -> Object -> Maybe Int
intValue Object
n Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"V should be an integer"
      Maybe Object
_ -> String -> Either String Int
forall a b. a -> Either a b
Left String
"V is missing"

  if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
    then Either String (Maybe Decryptor)
mk4
    else Int -> Either String (Maybe Decryptor)
forall a p.
(Eq a, Num a, Show a) =>
a
-> Either
     String
     (Maybe
        (Ref
         -> p -> InputStream ByteString -> IO (InputStream ByteString)))
mk12 Int
v

  where
  mk12 :: a
-> Either
     String
     (Maybe
        (Ref
         -> p -> InputStream ByteString -> IO (InputStream ByteString)))
mk12 a
v = do
    Int
n <-
      case a
v of
        a
1 -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
5
        a
2 -> do
          case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Length" Dict
enc of
            Just Object
o -> (Int -> Int) -> Either String Int -> Either String Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) (Object -> Maybe Int
intValue Object
o
                        Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"Length should be an integer")
            Maybe Object
Nothing -> String -> Either String Int
forall a b. a -> Either a b
Left String
"Length is missing"
        a
_ -> String -> Either String Int
forall a b. a -> Either a b
Left (String
"Unsuported encryption handler version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v)

    ByteString
ekey <- Dict -> Dict -> ByteString -> Int -> Either String ByteString
mkKey Dict
tr Dict
enc ByteString
pass Int
n
    Bool
ok <- Dict -> Dict -> ByteString -> Either String Bool
verifyKey Dict
tr Dict
enc ByteString
ekey
    Maybe
  (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
-> Either
     String
     (Maybe
        (Ref
         -> p -> InputStream ByteString -> IO (InputStream ByteString)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
   (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
 -> Either
      String
      (Maybe
         (Ref
          -> p -> InputStream ByteString -> IO (InputStream ByteString))))
-> Maybe
     (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
-> Either
     String
     (Maybe
        (Ref
         -> p -> InputStream ByteString -> IO (InputStream ByteString)))
forall a b. (a -> b) -> a -> b
$
      if Bool -> Bool
not Bool
ok
        then Maybe
  (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
forall a. Maybe a
Nothing
        else (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
-> Maybe
     (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
forall a. a -> Maybe a
Just ((Ref
  -> p -> InputStream ByteString -> IO (InputStream ByteString))
 -> Maybe
      (Ref
       -> p -> InputStream ByteString -> IO (InputStream ByteString)))
-> (Ref
    -> p -> InputStream ByteString -> IO (InputStream ByteString))
-> Maybe
     (Ref -> p -> InputStream ByteString -> IO (InputStream ByteString))
forall a b. (a -> b) -> a -> b
$ \Ref
ref p
_ InputStream ByteString
is -> Algorithm
-> ByteString
-> Int
-> Ref
-> InputStream ByteString
-> IO (InputStream ByteString)
mkDecryptor Algorithm
V2 ByteString
ekey Int
n Ref
ref InputStream ByteString
is

  mk4 :: Either String (Maybe Decryptor)
mk4 = do
    Dict
cryptoFilters <-
      case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"CF" Dict
enc of
        Maybe Object
Nothing -> String -> Either String Dict
forall a b. a -> Either a b
Left String
"CF is missing in crypt handler V4"
        Just Object
o -> Object -> Maybe Dict
dictValue Object
o Maybe Dict -> String -> Either String Dict
forall a. Maybe a -> String -> Either String a
`notice` String
"CF should be a dictionary"
    HashMap Name (ByteString, Int, Algorithm)
keysMap <- Dict
-> (Object -> Either String (ByteString, Int, Algorithm))
-> Either String (HashMap Name (ByteString, Int, Algorithm))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Traversable.forM Dict
cryptoFilters ((Object -> Either String (ByteString, Int, Algorithm))
 -> Either String (HashMap Name (ByteString, Int, Algorithm)))
-> (Object -> Either String (ByteString, Int, Algorithm))
-> Either String (HashMap Name (ByteString, Int, Algorithm))
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Dict
dict <- Object -> Maybe Dict
dictValue Object
obj Maybe Dict -> String -> Either String Dict
forall a. Maybe a -> String -> Either String a
`notice` String
"Crypto filter should be a dictionary"
      Int
n <-
        case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Length" Dict
dict of
          Maybe Object
Nothing -> String -> Either String Int
forall a b. a -> Either a b
Left String
"Crypto filter without Length"
          Just Object
o -> Object -> Maybe Int
intValue Object
o Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"Crypto filter length should be int"
      Name
algName <-
        case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"CFM" Dict
dict of
          Maybe Object
Nothing -> String -> Either String Name
forall a b. a -> Either a b
Left String
"CFM is missing"
          Just Object
o -> Object -> Maybe Name
nameValue Object
o Maybe Name -> String -> Either String Name
forall a. Maybe a -> String -> Either String a
`notice` String
"CFM should be a name"
      Algorithm
alg <-
        case Name
algName of
          Name
"V2" -> Algorithm -> Either String Algorithm
forall (m :: * -> *) a. Monad m => a -> m a
return Algorithm
V2
          Name
"AESV2" -> Algorithm -> Either String Algorithm
forall (m :: * -> *) a. Monad m => a -> m a
return Algorithm
AESV2
          Name
_ -> String -> Either String Algorithm
forall a b. a -> Either a b
Left (String -> Either String Algorithm)
-> String -> Either String Algorithm
forall a b. (a -> b) -> a -> b
$ String
"Unknown crypto method: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
algName
      ByteString
ekey <- Dict -> Dict -> ByteString -> Int -> Either String ByteString
mkKey Dict
tr Dict
enc ByteString
pass Int
n
      (ByteString, Int, Algorithm)
-> Either String (ByteString, Int, Algorithm)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
ekey, Int
n, Algorithm
alg)

    (ByteString
stdCfKey, Int
_, Algorithm
_) <- Name
-> HashMap Name (ByteString, Int, Algorithm)
-> Maybe (ByteString, Int, Algorithm)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"StdCF" HashMap Name (ByteString, Int, Algorithm)
keysMap
      Maybe (ByteString, Int, Algorithm)
-> String -> Either String (ByteString, Int, Algorithm)
forall a. Maybe a -> String -> Either String a
`notice` String
"StdCF is missing"
    Bool
ok <- Dict -> Dict -> ByteString -> Either String Bool
verifyKey Dict
tr Dict
enc ByteString
stdCfKey
    if Bool -> Bool
not Bool
ok
      then Maybe Decryptor -> Either String (Maybe Decryptor)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Decryptor
forall a. Maybe a
Nothing

      else do
        Name
strFName <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"StrF" Dict
enc Maybe Object -> (Object -> Maybe Name) -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Name
nameValue)
          Maybe Name -> String -> Either String Name
forall a. Maybe a -> String -> Either String a
`notice` String
"StrF is missing"
        (ByteString
strFKey, Int
strFN, Algorithm
strFAlg) <- Name
-> HashMap Name (ByteString, Int, Algorithm)
-> Maybe (ByteString, Int, Algorithm)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
strFName HashMap Name (ByteString, Int, Algorithm)
keysMap
          Maybe (ByteString, Int, Algorithm)
-> String -> Either String (ByteString, Int, Algorithm)
forall a. Maybe a -> String -> Either String a
`notice` (String
"Crypto filter not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
strFName)

        Name
stmFName <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"StmF" Dict
enc Maybe Object -> (Object -> Maybe Name) -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Name
nameValue)
          Maybe Name -> String -> Either String Name
forall a. Maybe a -> String -> Either String a
`notice` String
"StmF is missing"
        (ByteString
stmFKey, Int
stmFN, Algorithm
stmFAlg) <- Name
-> HashMap Name (ByteString, Int, Algorithm)
-> Maybe (ByteString, Int, Algorithm)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
stmFName HashMap Name (ByteString, Int, Algorithm)
keysMap
          Maybe (ByteString, Int, Algorithm)
-> String -> Either String (ByteString, Int, Algorithm)
forall a. Maybe a -> String -> Either String a
`notice` (String
"Crypto filter not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
stmFName)

        Maybe Decryptor -> Either String (Maybe Decryptor)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Decryptor -> Either String (Maybe Decryptor))
-> Maybe Decryptor -> Either String (Maybe Decryptor)
forall a b. (a -> b) -> a -> b
$ Decryptor -> Maybe Decryptor
forall a. a -> Maybe a
Just (Decryptor -> Maybe Decryptor) -> Decryptor -> Maybe Decryptor
forall a b. (a -> b) -> a -> b
$ \Ref
ref DecryptorScope
scope InputStream ByteString
is ->
          case DecryptorScope
scope of
            DecryptorScope
DecryptString -> Algorithm
-> ByteString
-> Int
-> Ref
-> InputStream ByteString
-> IO (InputStream ByteString)
mkDecryptor Algorithm
strFAlg ByteString
strFKey Int
strFN Ref
ref InputStream ByteString
is
            DecryptorScope
DecryptStream -> Algorithm
-> ByteString
-> Int
-> Ref
-> InputStream ByteString
-> IO (InputStream ByteString)
mkDecryptor Algorithm
stmFAlg ByteString
stmFKey Int
stmFN Ref
ref InputStream ByteString
is

mkKey :: Dict -> Dict -> ByteString -> Int -> Either String ByteString
mkKey :: Dict -> Dict -> ByteString -> Int -> Either String ByteString
mkKey Dict
tr Dict
enc ByteString
pass Int
n = do
  ByteString
oVal <- do
    Object
o <- Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"O" Dict
enc Maybe Object -> String -> Either String Object
forall a. Maybe a -> String -> Either String a
`notice` String
"O is missing"
    Object -> Maybe ByteString
stringValue Object
o Maybe ByteString -> String -> Either String ByteString
forall a. Maybe a -> String -> Either String a
`notice` String
"o should be a string"

  ByteString
pVal <- do
    Object
o <- Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"P" Dict
enc Maybe Object -> String -> Either String Object
forall a. Maybe a -> String -> Either String a
`notice` String
"P is missing"
    Int
i <- Object -> Maybe Int
intValue Object
o Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"P should be an integer"
    ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (Int -> ByteString) -> Int -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> (Int -> [Word8]) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack (ByteString -> [Word8]) -> (Int -> ByteString) -> Int -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
          (Builder -> ByteString) -> (Int -> Builder) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
word32LE (Word32 -> Builder) -> (Int -> Word32) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String ByteString)
-> Int -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Int
i

  ByteString
idVal <- do
    Array
ids <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"ID" Dict
tr Maybe Object -> (Object -> Maybe Array) -> Maybe Array
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Array
arrayValue)
        Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"ID should be an array"
    case (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
ids) of
      [] -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"ID array is empty"
      (Object
x:[Object]
_) -> Object -> Maybe ByteString
stringValue Object
x
                  Maybe ByteString -> String -> Either String ByteString
forall a. Maybe a -> String -> Either String a
`notice` String
"The first element if ID should be a string"

  Int
rVal <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"R" Dict
enc Maybe Object -> (Object -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Int
intValue)
      Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"R should be an integer"

  Bool
encMD <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"EncryptMetadata" Dict
enc of
      Maybe Object
Nothing -> Bool -> Either String Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Just Object
o -> Object -> Maybe Bool
boolValue Object
o Maybe Bool -> String -> Either String Bool
forall a. Maybe a -> String -> Either String a
`notice` String
"EncryptMetadata should be a bool"

  let ekey' :: ByteString
ekey' = Int -> ByteString -> ByteString
BS.take Int
n (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString
pass, ByteString
oVal, ByteString
pVal, ByteString
idVal, ByteString
pad]
      pad :: ByteString
pad =
        if Int
rVal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
|| Bool
encMD
          then ByteString
BS.empty
          else [Word8] -> ByteString
BS.pack (Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
4 Word8
255)
      ekey :: ByteString
ekey =
        if Int
rVal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
           then ByteString
ekey'
           else (ByteString -> Int -> ByteString)
-> ByteString -> [Int] -> ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ByteString
bs Int
_ -> Int -> ByteString -> ByteString
BS.take Int
n (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash ByteString
bs)
                      ByteString
ekey'
                      [Int
1 :: Int .. Int
50]

  ByteString -> Either String ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
ekey

verifyKey :: Dict -> Dict -> ByteString -> Either String Bool
verifyKey :: Dict -> Dict -> ByteString -> Either String Bool
verifyKey Dict
tr Dict
enc ByteString
ekey = do
  Int
rVal <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"R" Dict
enc Maybe Object -> (Object -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Int
intValue)
      Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"R should be an integer"

  ByteString
idVal <- do
    Array
ids <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"ID" Dict
tr Maybe Object -> (Object -> Maybe Array) -> Maybe Array
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Array
arrayValue)
        Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"ID should be an array"
    case (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
ids) of
      [] -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"ID array is empty"
      (Object
x:[Object]
_) -> Object -> Maybe ByteString
stringValue Object
x
                  Maybe ByteString -> String -> Either String ByteString
forall a. Maybe a -> String -> Either String a
`notice` String
"The first element if ID should be a string"

  ByteString
uVal <- (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"U" Dict
enc Maybe Object -> (Object -> Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe ByteString
stringValue)
      Maybe ByteString -> String -> Either String ByteString
forall a. Maybe a -> String -> Either String a
`notice` String
"U should be a string"

  Bool -> Either String Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either String Bool) -> Bool -> Either String Bool
forall a b. (a -> b) -> a -> b
$
    case Int
rVal of
      Int
2 ->
        let uVal' :: ByteString
uVal' = (Ctx, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((Ctx, ByteString) -> ByteString)
-> (Ctx, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString -> (Ctx, ByteString)
RC4.combine (ByteString -> Ctx
RC4.initCtx ByteString
ekey)
                                      ByteString
defaultUserPassword
        in ByteString
uVal ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
uVal'
      Int
_ ->
        let pass1 :: ByteString
pass1 = (Ctx, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((Ctx, ByteString) -> ByteString)
-> (Ctx, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString -> (Ctx, ByteString)
RC4.combine (ByteString -> Ctx
RC4.initCtx ByteString
ekey)
                        (ByteString -> (Ctx, ByteString))
-> ByteString -> (Ctx, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
16 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash
                        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString
defaultUserPassword, ByteString
idVal]
            uVal' :: ByteString
uVal' = Word8 -> ByteString -> ByteString
loop Word8
1 ByteString
pass1
            loop :: Word8 -> ByteString -> ByteString
loop Word8
20 ByteString
input = ByteString
input
            loop Word8
i ByteString
input = Word8 -> ByteString -> ByteString
loop (Word8
i Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Ctx, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((Ctx, ByteString) -> ByteString)
-> (Ctx, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString -> (Ctx, ByteString)
RC4.combine (ByteString -> Ctx
RC4.initCtx
                                        (ByteString -> Ctx) -> ByteString -> Ctx
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8) -> ByteString -> ByteString
BS.map (Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
`xor` Word8
i) ByteString
ekey) ByteString
input
        in Int -> ByteString -> ByteString
BS.take Int
16 ByteString
uVal ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteString -> ByteString
BS.take Int
16 ByteString
uVal'

data Algorithm
  = V2
  | AESV2
  deriving (Int -> Algorithm -> String -> String
[Algorithm] -> String -> String
Algorithm -> String
(Int -> Algorithm -> String -> String)
-> (Algorithm -> String)
-> ([Algorithm] -> String -> String)
-> Show Algorithm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Algorithm] -> String -> String
$cshowList :: [Algorithm] -> String -> String
show :: Algorithm -> String
$cshow :: Algorithm -> String
showsPrec :: Int -> Algorithm -> String -> String
$cshowsPrec :: Int -> Algorithm -> String -> String
Show)

mkDecryptor
  :: Algorithm
  -> ByteString
  -> Int
  -> Ref
  -> InputStream ByteString
  -> IO (InputStream ByteString)
mkDecryptor :: Algorithm
-> ByteString
-> Int
-> Ref
-> InputStream ByteString
-> IO (InputStream ByteString)
mkDecryptor Algorithm
alg ByteString
ekey Int
n (R Int
index Int
gen) InputStream ByteString
is = do
  let key :: ByteString
key = Int -> ByteString -> ByteString
BS.take (Int
16 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat
        [ ByteString
ekey
        , [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
3 ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BSL.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString
                  (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int32 -> Builder
int32LE (Int32 -> Builder) -> Int32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index
        , [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
2 ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BSL.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString
                  (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int32 -> Builder
int32LE (Int32 -> Builder) -> Int32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
gen
        , Algorithm -> ByteString
forall p. IsString p => Algorithm -> p
salt Algorithm
alg
        ]
      salt :: Algorithm -> p
salt Algorithm
V2 = p
""
      salt Algorithm
AESV2 = p
"sAlT"

  case Algorithm
alg of
    Algorithm
V2 -> do
      IORef Ctx
ioRef <- Ctx -> IO (IORef Ctx)
forall a. a -> IO (IORef a)
newIORef (Ctx -> IO (IORef Ctx)) -> Ctx -> IO (IORef Ctx)
forall a b. (a -> b) -> a -> b
$ ByteString -> Ctx
RC4.initCtx ByteString
key
      let readNext :: IO (Maybe ByteString)
readNext = do
            Maybe ByteString
chunk <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
            case Maybe ByteString
chunk of
              Maybe ByteString
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
              Just ByteString
c -> do
                Ctx
ctx' <- IORef Ctx -> IO Ctx
forall a. IORef a -> IO a
readIORef IORef Ctx
ioRef
                let (Ctx
ctx'', ByteString
res) = Ctx -> ByteString -> (Ctx, ByteString)
RC4.combine Ctx
ctx' ByteString
c
                IORef Ctx -> Ctx -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Ctx
ioRef Ctx
ctx''
                Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
res)
      IO (Maybe ByteString) -> IO (InputStream ByteString)
forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream IO (Maybe ByteString)
readNext

    Algorithm
AESV2 -> do
      ByteString
content <- [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
is
      let initV :: ByteString
initV = Int -> ByteString -> ByteString
BS.take Int
16 ByteString
content
          aes :: AES
aes = ByteString -> AES
forall b. Byteable b => b -> AES
AES.initAES ByteString
key
          decrypted :: ByteString
decrypted = AES -> ByteString -> ByteString -> ByteString
forall iv. Byteable iv => AES -> iv -> ByteString -> ByteString
AES.decryptCBC AES
aes ByteString
initV (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
16 ByteString
content
      ByteString -> IO (InputStream ByteString)
Streams.fromByteString (ByteString -> IO (InputStream ByteString))
-> ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Padding.unpadPKCS5 ByteString
decrypted