module Data.Conduit.OpenPGP.Decrypt (
conduitDecrypt
) where
import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import Data.Conduit.Cereal (conduitGet)
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import qualified Data.Conduit.List as CL
import Data.Default (Default, def)
import Data.Maybe (fromJust)
import Data.Serialize (get)
import Codec.Encryption.OpenPGP.S2K (skesk2Key)
import Codec.Encryption.OpenPGP.CFB (decrypt, decryptOpenPGPCfb)
import Codec.Encryption.OpenPGP.Types
data RecursorState = RecursorState {
_depth :: Int
, _lastPKESK :: Maybe PKESK
, _lastSKESK :: Maybe SKESK
} deriving (Eq, Show)
instance Default RecursorState where
def = RecursorState 0 Nothing Nothing
type InputCallback m = String -> m BL.ByteString
conduitDecrypt :: (MonadBaseControl IO m, MonadResource m) => InputCallback IO -> Conduit Pkt m Pkt
conduitDecrypt = conduitDecrypt' 0
conduitDecrypt' :: (MonadBaseControl IO m, MonadResource m) => Int -> InputCallback IO -> Conduit Pkt m Pkt
conduitDecrypt' depth cb = CL.concatMapAccumM push def { _depth = depth }
where
push :: (MonadBaseControl IO m, MonadResource m) => Pkt -> RecursorState -> m (RecursorState, [Pkt])
push i s
| _depth s > 42 = fail "I think we've been quine-attacked"
| otherwise = case i of
(SKESKPkt {}) -> return (s { _lastSKESK = Just (fromPkt i) }, [])
(SymEncDataPkt bs) -> do d <- decryptSEDP (_depth s) cb (fromJust . _lastSKESK $ s) bs
return (s, d)
(SymEncIntegrityProtectedDataPkt _ bs) -> do d <- decryptSEIPDP (_depth s) cb (fromJust . _lastSKESK $ s) bs
return (s, d)
p -> return (s, [p])
decryptSEDP :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, MonadUnsafeIO m) => Int -> InputCallback IO -> SKESK -> B.ByteString -> m [Pkt]
decryptSEDP depth cb skesk bs = do
passphrase <- liftIO $ cb "Input the passphrase I want"
let key = skesk2Key skesk passphrase
decrypted = case decryptOpenPGPCfb (_skeskSymmetricAlgorithm skesk) bs key of
Left e -> error e
Right x -> x
runResourceT $ CB.sourceLbs (BL.fromStrict decrypted) $= conduitGet get $= conduitDecompress $= conduitDecrypt' depth cb $$ CL.consume
decryptSEIPDP :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, MonadUnsafeIO m) => Int -> InputCallback IO -> SKESK -> B.ByteString -> m [Pkt]
decryptSEIPDP depth cb skesk bs = do
passphrase <- liftIO $ cb "Input the passphrase I want"
let key = skesk2Key skesk passphrase
decrypted = case decrypt (_skeskSymmetricAlgorithm skesk) bs key of
Left e -> error e
Right x -> x
runResourceT $ CB.sourceLbs (BL.fromStrict decrypted) $= conduitGet get $= conduitDecompress $= conduitDecrypt' depth cb $$ CL.consume