module Pdf.Toolbox.Document.Encryption
(
Decryptor,
defaultUserPassword,
mkStandardDecryptor,
decryptObject,
DecryptorScope(..),
)
where
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.Lazy.Builder
import Control.Monad
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
import Pdf.Toolbox.Core
data DecryptorScope
= DecryptString
| DecryptStream
type Decryptor = Ref -> DecryptorScope -> IS -> IO IS
decryptObject :: (IS -> IO IS) -> Object a -> IO (Object a)
decryptObject decryptor (OStr str) = OStr `liftM` decryptStr decryptor str
decryptObject decryptor (ODict dict) = ODict `liftM` decryptDict decryptor dict
decryptObject _ o = return o
decryptStr :: (IS -> IO IS) -> Str -> IO Str
decryptStr decryptor (Str str) = do
is <- Streams.fromList [str]
res <- decryptor is >>= Streams.toList
return $ Str $ BS.concat res
decryptDict :: (IS -> IO IS) -> Dict -> IO Dict
decryptDict decryptor (Dict vals) = Dict `liftM` forM vals decr
where
decr (key, val) = do
res <- decryptObject decryptor val
return (key, res)
defaultUserPassword :: ByteString
defaultUserPassword = BS.pack [
0x28, 0xBF, 0x4E, 0x5E, 0x4E, 0x75, 0x8A, 0x41, 0x64, 0x00, 0x4E,
0x56, 0xFF, 0xFA, 0x01, 0x08, 0x2E, 0x2E, 0x00, 0xB6, 0xD0, 0x68,
0x3E, 0x80, 0x2F, 0x0C, 0xA9, 0xFE, 0x64, 0x53, 0x69, 0x7A
]
mkStandardDecryptor :: Monad m
=> Dict
-> Dict
-> ByteString
-> PdfE m (Maybe Decryptor)
mkStandardDecryptor tr enc pass = do
Name filterType <- lookupDict "Filter" enc >>= fromObject
unless (filterType == "Standard") $ throwE $ UnexpectedError $ "Unsupported encryption handler: " ++ show filterType
vVal <- lookupDict "V" enc >>= fromObject >>= intValue
if vVal == 4
then mk4
else mk12 vVal
where
mk12 vVal = do
n <- case vVal of
1 -> return 5
2 -> do
len <- lookupDict "Length" enc >>= fromObject >>= intValue
return $ len `div` 8
_ -> throwE $ UnexpectedError $ "Unsuported encryption handler version: " ++ show vVal
ekey <- mkKey tr enc pass n
ok <- verifyKey tr enc ekey
return $
if not ok
then Nothing
else Just $ \ref _ is -> mkDecryptor V2 ekey n ref is
mk4 = do
Dict cryptoFilters <- lookupDict "CF" enc >>= fromObject
keysMap <- forM cryptoFilters $ \(name, obj) -> do
dict <- fromObject obj
n <- lookupDict "Length" dict >>= fromObject >>= intValue
algName <- lookupDict "CFM" dict >>= toName
alg <-
case algName of
"V2" -> return V2
"AESV2" -> return AESV2
_ -> throwE $ UnexpectedError $ "Unknown crypto method: " ++ show algName
ekey <- mkKey tr enc pass n
return (name, (ekey, n, alg))
(stdCfKey, _, _) <-
case lookup "StdCF" keysMap of
Nothing -> throwE $ UnexpectedError "StdCF is missing"
Just v -> return v
ok <- verifyKey tr enc stdCfKey
if not ok
then return Nothing
else do
strFName <- lookupDict "StrF" enc >>= toName
(strFKey, strFN, strFAlg) <-
case lookup strFName keysMap of
Nothing -> throwE $ UnexpectedError $ "Crypto filter not found: " ++ show strFName
Just v -> return v
stmFName <- lookupDict "StmF" enc >>= toName
(stmFKey, stmFN, stmFAlg) <-
case lookup stmFName keysMap of
Nothing -> throwE $ UnexpectedError $ "Crypto filter not found: " ++ show stmFName
Just v -> return v
return $ Just $ \ref scope is ->
case scope of
DecryptString -> mkDecryptor strFAlg strFKey strFN ref is
DecryptStream -> mkDecryptor stmFAlg stmFKey stmFN ref is
mkKey :: Monad m => Dict -> Dict -> ByteString -> Int -> PdfE m ByteString
mkKey tr enc pass n = do
Str oVal <- lookupDict "O" enc >>= fromObject
pVal <- (BS.pack . BSL.unpack . toLazyByteString . word32LE . fromIntegral)
`liftM` (lookupDict "P" enc >>= fromObject >>= intValue)
Str idVal <- do
Array ids <- lookupDict "ID" tr >>= fromObject
case ids of
[] -> throwE $ UnexpectedError $ "ID array is empty"
(x:_) -> fromObject x
rVal <- lookupDict "R" enc >>= fromObject >>= intValue
encMD <-
case lookupDict' "EncryptMetadata" enc of
Nothing -> return True
Just o -> do
Boolean b <- toBoolean o
return b
let ekey' = BS.take n $ MD5.hash $ BS.concat [pass, oVal, pVal, idVal, pad]
pad =
if rVal < 4 || encMD
then BS.empty
else BS.pack (replicate 4 255)
let ekey = if rVal < 3
then ekey'
else foldl (\bs _ -> BS.take n $ MD5.hash bs) ekey' [1 :: Int .. 50]
return ekey
verifyKey :: Monad m => Dict -> Dict -> ByteString -> PdfE m Bool
verifyKey tr enc ekey = do
Str idVal <- do
Array ids <- lookupDict "ID" tr >>= fromObject
case ids of
[] -> throwE $ UnexpectedError $ "ID array is empty"
(x:_) -> fromObject x
rVal <- lookupDict "R" enc >>= fromObject >>= intValue
Str uVal <- lookupDict "U" enc >>= fromObject
let ok =
case rVal of
2 ->
let uVal' = snd $ RC4.combine (RC4.initCtx ekey) defaultUserPassword
in uVal == uVal'
_ ->
let pass1 = snd $ RC4.combine (RC4.initCtx ekey) $ BS.take 16 $ MD5.hash $ BS.concat [defaultUserPassword, idVal]
uVal' = loop 1 pass1
loop 20 input = input
loop i input = loop (i + 1) $ snd $ RC4.combine (RC4.initCtx $ BS.map (`xor` i) ekey) input
in BS.take 16 uVal == BS.take 16 uVal'
return ok
data Algorithm
= V2
| AESV2
deriving (Show)
mkDecryptor
:: Algorithm
-> ByteString
-> Int
-> Ref
-> IS
-> IO IS
mkDecryptor alg ekey n (Ref index gen) is = do
let key = BS.take (16 `min` n + 5) $ MD5.hash $ BS.concat
[ ekey
, BS.pack $ take 3 $ BSL.unpack $ toLazyByteString
$ int32LE $ fromIntegral index
, BS.pack $ take 2 $ BSL.unpack $ toLazyByteString
$ int32LE $ fromIntegral gen
, salt alg
]
salt V2 = ""
salt AESV2 = "sAlT"
case alg of
V2 -> do
ioRef <- newIORef $ RC4.initCtx key
let readNext = do
chunk <- Streams.read is
case chunk of
Nothing -> return Nothing
Just c -> do
ctx' <- readIORef ioRef
let (ctx'', res) = RC4.combine ctx' c
writeIORef ioRef ctx''
return (Just res)
Streams.makeInputStream readNext
AESV2 -> do
content <- BS.concat <$> Streams.toList is
let initV = BS.take 16 content
aes = AES.initAES key
decrypted = AES.decryptCBC aes initV $ BS.drop 16 content
Streams.fromByteString $ Padding.unpadPKCS5 decrypted