diff --git a/Codec/Encryption/OpenPGP/CFB.hs b/Codec/Encryption/OpenPGP/CFB.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/CFB.hs @@ -0,0 +1,75 @@ +-- CFB.hs: OpenPGP (RFC4880) CFB mode +-- Copyright © 2013 Daniel Kahn Gillmor and Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE ExistentialQuantification #-} + +module Codec.Encryption.OpenPGP.CFB ( + decrypt + , decryptOpenPGPCfb +) where + +import Codec.Encryption.OpenPGP.Types +import Crypto.Cipher.Types (makeKey, nullIV, BlockCipher(..), Cipher(..)) +import qualified Crypto.Cipher as CC +import qualified Crypto.Nettle.Ciphers as CNC +import qualified Data.ByteString as B +import Data.Maybe (fromJust) +import Data.SecureMem (ToSecureMem) + +data BCipher = forall a. (BlockCipher a) => BCipher a + +decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString +decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext +decryptOpenPGPCfb sa ciphertext keydata = do + bc <- mkBCipher sa keydata + return $ B.drop (bsize bc + 2) (decrypt1 ciphertext bc `B.append` decrypt2 ciphertext bc) -- FIXME: verify the code + where + decrypt1 :: B.ByteString -> BCipher -> B.ByteString + decrypt1 ct (BCipher cipher) = cdecrypt sa cipher nullIV (B.take (blockSize cipher + 2) ct) + decrypt2 :: B.ByteString -> BCipher -> B.ByteString + decrypt2 ct (BCipher cipher) = cdecrypt sa cipher (fromJust (CC.makeIV (B.take (blockSize cipher) (B.drop 2 ct)))) (B.drop (blockSize cipher + 2) ct) + +decrypt :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString +decrypt Plaintext ciphertext _ = return ciphertext +decrypt sa ciphertext keydata = do + bc <- mkBCipher sa keydata + return $ B.drop (bsize bc + 2) (decrypt' ciphertext bc) -- FIXME: verify the code + where + decrypt' :: B.ByteString -> BCipher -> B.ByteString + decrypt' ct (BCipher cipher) = cdecrypt sa cipher nullIV ct + +bsize :: BCipher -> Int +bsize (BCipher bc) = blockSize bc + +cdecrypt :: BlockCipher cipher => SymmetricAlgorithm -> cipher -> CC.IV cipher -> B.ByteString -> B.ByteString +cdecrypt sa + | sa `elem` [CAST5, Twofish] = paddedCfbDecrypt + | otherwise = cfbDecrypt + +paddedCfbDecrypt :: BlockCipher cipher => cipher -> CC.IV cipher -> B.ByteString -> B.ByteString +paddedCfbDecrypt cipher iv ciphertext = B.take (B.length ciphertext) (cfbDecrypt cipher iv padded) + where + padded = ciphertext `B.append` B.pack (replicate (blockSize cipher - (B.length ciphertext `mod` blockSize cipher)) 0) + +mkBCipher :: ToSecureMem b => SymmetricAlgorithm -> b -> Either String BCipher +mkBCipher Plaintext = const (fail "this shouldn't have happened") -- FIXME: orphan instance? +mkBCipher IDEA = const (fail "IDEA not yet implemented") -- FIXME: IDEA +mkBCipher ReservedSAFER = const (fail "SAFER not implemented") -- FIXME: or not? +mkBCipher ReservedDES = const (fail "DES not implemented") -- FIXME: or not? +mkBCipher (OtherSA _) = const (fail "Unknown, unimplemented symmetric algorithm") +mkBCipher CAST5 = return . BCipher . (ciph :: ToSecureMem b => b -> CNC.CAST128) +mkBCipher Twofish = return . BCipher . (ciph :: ToSecureMem b => b -> CNC.TWOFISH) +mkBCipher TripleDES = return . BCipher . (ciph :: ToSecureMem b => b -> CC.DES_EDE3) +mkBCipher Blowfish = return . BCipher . (ciph :: ToSecureMem b => b -> CC.Blowfish128) +mkBCipher AES128 = return . BCipher . (ciph :: ToSecureMem b => b -> CC.AES128) +mkBCipher AES192 = return . BCipher . (ciph :: ToSecureMem b => b -> CC.AES192) +mkBCipher AES256 = return . BCipher . (ciph :: ToSecureMem b => b -> CC.AES256) + +ciph :: (CC.BlockCipher cipher, ToSecureMem b) => b -> cipher -- FIXME: return an Either String cipher ? +ciph keydata = cipherInit ekey + where + ekey = case makeKey keydata of + Left _ -> error "bad cipher parameters" + Right key -> key diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -5,17 +5,44 @@ module Codec.Encryption.OpenPGP.S2K ( string2Key + ,skesk2Key ) where import Codec.Encryption.OpenPGP.Types +import Control.Monad.Loops (untilM_) +import Control.Monad.Trans.State.Lazy (execState, get, put) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -string2Key :: Integral a => S2K -> a -> BL.ByteString -> B.ByteString -string2Key (Simple SHA1) ksz bs - | 20 < ksz = error "FIXME" - | otherwise = B.take (fromIntegral ksz) . SHA1.hashlazy $ bs +string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString +string2Key (Simple SHA1) ksz bs = B.take (fromIntegral ksz) $ hashpp SHA1.hashlazy ksz bs string2Key (Salted SHA1 salt) ksz bs = string2Key (Simple SHA1) ksz (BL.append (BL.fromChunks [salt]) bs) string2Key (IteratedSalted SHA1 salt cnt) ksz bs = string2Key (Simple SHA1) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromChunks [salt]) bs) -string2Key _ _ _ = error "FIXME" +string2Key _ _ _ = error "FIXME: unimplemented S2K hash" + +-- in bytes +keySize :: SymmetricAlgorithm -> Int +keySize Plaintext = 0 +keySize IDEA = 16 -- according to https://en.wikipedia.org/wiki/International_Data_Encryption_Algorithm +keySize TripleDES = 24 -- RFC 4880 says 168 bits (derived from 192 bits) but we don't know who does the derivation +keySize CAST5 = 16 +keySize Blowfish = 16 +keySize ReservedSAFER = undefined +keySize ReservedDES = undefined +keySize AES128 = 16 +keySize AES192 = 24 +keySize AES256 = 32 +keySize Twofish = 32 +keySize (OtherSA _) = undefined + +skesk2Key :: SKESK -> BL.ByteString -> B.ByteString +skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass +skesk2Key _ _ = error "FIXME" + +hashpp :: (BL.ByteString -> B.ByteString) -> Int -> BL.ByteString -> B.ByteString +hashpp hf keysize pp = snd (execState (hashround `untilM_` bigEnough) (0, B.empty)) + where + hashround = get >>= \(ctr, bs) -> put (ctr + 1, bs `B.append` hf (nulpad ctr `BL.append` pp)) + nulpad = BL.pack . flip replicate 0 + bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize) diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -23,6 +23,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word8, Word32) +import Data.Maybe (fromMaybe) import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs) import Codec.Encryption.OpenPGP.Types @@ -526,10 +527,8 @@ symalgo <- getWord8 s2k <- getS2K remainder <- remaining - mpib <- getBytes remainder - case runGet (many getMPI) mpib of - Left _ -> return $ SKESKPkt pv (toFVal symalgo) s2k [] - Right mpis -> return $ SKESKPkt pv (toFVal symalgo) s2k mpis + esk <- getByteString remainder + return $ SKESKPkt pv (toFVal symalgo) s2k (if B.null esk then Nothing else Just esk) | t == 4 = do pv <- getWord8 sigtype <- getWord8 @@ -649,10 +648,10 @@ let bs = runPut $ put sp putPacketLength . fromIntegral . B.length $ bs putByteString bs -putPkt (SKESKPkt pv symalgo s2k mpis) = do +putPkt (SKESKPkt pv symalgo s2k mesk) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k - let bsk = runPut $ mapM_ put mpis + let bsk = fromMaybe B.empty mesk putPacketLength . fromIntegral $ 2 + (B.length bs2k) + (B.length bsk) putWord8 pv -- should be 4 putWord8 $ fromIntegral . fromFVal $ symalgo diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -566,7 +566,7 @@ -- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI] | SignaturePkt SignaturePayload - | SKESKPkt PacketVersion SymmetricAlgorithm S2K [MPI] + | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe B.ByteString) | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag | SecretKeyPkt PKPayload SKAddendum | PublicKeyPkt PKPayload @@ -591,7 +591,7 @@ , _pkeskMPIs :: [MPI] } deriving (Data, Eq, Show, Typeable) instance Packet PKESK where - data PacketType PKESK = PKESKType + data PacketType PKESK = PKESKType deriving (Show, Eq) packetType _ = PKESKType packetCode _ = 1 toPkt (PKESK a b c d) = PKESKPkt a b c d @@ -601,7 +601,7 @@ { _signaturePayload :: SignaturePayload } deriving (Data, Eq, Show, Typeable) instance Packet Signature where - data PacketType Signature = SignatureType + data PacketType Signature = SignatureType deriving (Show, Eq) packetType _ = SignatureType packetCode _ = 2 toPkt (Signature a ) = SignaturePkt a @@ -611,10 +611,10 @@ { _skeskPacketVersion :: PacketVersion , _skeskSymmetricAlgorithm :: SymmetricAlgorithm , _skeskS2K :: S2K - , _skeskMPIs :: [MPI] + , _skeskESK :: Maybe B.ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SKESK where - data PacketType SKESK = SKESKType + data PacketType SKESK = SKESKType deriving (Show, Eq) packetType _ = SKESKType packetCode _ = 3 toPkt (SKESK a b c d) = SKESKPkt a b c d @@ -629,7 +629,7 @@ , _onePassSignatureNestedFlag :: NestedFlag } deriving (Data, Eq, Show, Typeable) instance Packet OnePassSignature where - data PacketType OnePassSignature = OnePassSignatureType + data PacketType OnePassSignature = OnePassSignatureType deriving (Show, Eq) packetType _ = OnePassSignatureType packetCode _ = 4 toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f @@ -640,7 +640,7 @@ , _secretKeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) instance Packet SecretKey where - data PacketType SecretKey = SecretKeyType + data PacketType SecretKey = SecretKeyType deriving (Show, Eq) packetType _ = SecretKeyType packetCode _ = 5 toPkt (SecretKey a b) = SecretKeyPkt a b @@ -650,7 +650,7 @@ { _publicKeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable) instance Packet PublicKey where - data PacketType PublicKey = PublicKeyType + data PacketType PublicKey = PublicKeyType deriving (Show, Eq) packetType _ = PublicKeyType packetCode _ = 6 toPkt (PublicKey a) = PublicKeyPkt a @@ -661,7 +661,7 @@ , _secretSubkeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) instance Packet SecretSubkey where - data PacketType SecretSubkey = SecretSubkeyType + data PacketType SecretSubkey = SecretSubkeyType deriving (Show, Eq) packetType _ = SecretSubkeyType packetCode _ = 7 toPkt (SecretSubkey a b) = SecretSubkeyPkt a b @@ -672,7 +672,7 @@ , _compressedDataPayload :: CompressedDataPayload } deriving (Data, Eq, Show, Typeable) instance Packet CompressedData where - data PacketType CompressedData = CompressedDataType + data PacketType CompressedData = CompressedDataType deriving (Show, Eq) packetType _ = CompressedDataType packetCode _ = 8 toPkt (CompressedData a b) = CompressedDataPkt a b @@ -682,7 +682,7 @@ { _symEncDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SymEncData where - data PacketType SymEncData = SymEncDataType + data PacketType SymEncData = SymEncDataType deriving (Show, Eq) packetType _ = SymEncDataType packetCode _ = 9 toPkt (SymEncData a) = SymEncDataPkt a @@ -692,7 +692,7 @@ { _markerPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet Marker where - data PacketType Marker = MarkerType + data PacketType Marker = MarkerType deriving (Show, Eq) packetType _ = MarkerType packetCode _ = 10 toPkt (Marker a) = MarkerPkt a @@ -705,7 +705,7 @@ , _literalDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet LiteralData where - data PacketType LiteralData = LiteralDataType + data PacketType LiteralData = LiteralDataType deriving (Show, Eq) packetType _ = LiteralDataType packetCode _ = 11 toPkt (LiteralData a b c d) = LiteralDataPkt a b c d @@ -715,7 +715,7 @@ { _trustPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet Trust where - data PacketType Trust = TrustType + data PacketType Trust = TrustType deriving (Show, Eq) packetType _ = TrustType packetCode _ = 12 toPkt (Trust a) = TrustPkt a @@ -725,7 +725,7 @@ { _userIdPayload :: String } deriving (Data, Eq, Show, Typeable) instance Packet UserId where - data PacketType UserId = UserIdType + data PacketType UserId = UserIdType deriving (Show, Eq) packetType _ = UserIdType packetCode _ = 13 toPkt (UserId a) = UserIdPkt a @@ -735,7 +735,7 @@ { _publicSubkeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable) instance Packet PublicSubkey where - data PacketType PublicSubkey = PublicSubkeyType + data PacketType PublicSubkey = PublicSubkeyType deriving (Show, Eq) packetType _ = PublicSubkeyType packetCode _ = 14 toPkt (PublicSubkey a) = PublicSubkeyPkt a @@ -745,7 +745,7 @@ { _userAttributeSubPackets :: [UserAttrSubPacket] } deriving (Data, Eq, Show, Typeable) instance Packet UserAttribute where - data PacketType UserAttribute = UserAttributeType + data PacketType UserAttribute = UserAttributeType deriving (Show, Eq) packetType _ = UserAttributeType packetCode _ = 17 toPkt (UserAttribute a) = UserAttributePkt a @@ -756,7 +756,7 @@ , _symEncIntegrityProtectedDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SymEncIntegrityProtectedData where - data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType + data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType deriving (Show, Eq) packetType _ = SymEncIntegrityProtectedDataType packetCode _ = 18 toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b @@ -766,7 +766,7 @@ { _modificationDetectionCodePayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet ModificationDetectionCode where - data PacketType ModificationDetectionCode = ModificationDetectionCodeType + data PacketType ModificationDetectionCode = ModificationDetectionCodeType deriving (Show, Eq) packetType _ = ModificationDetectionCodeType packetCode _ = 19 toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a @@ -777,7 +777,7 @@ , _otherPacketPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet OtherPacket where - data PacketType OtherPacket = OtherPacketType + data PacketType OtherPacket = OtherPacketType deriving (Show, Eq) packetType _ = OtherPacketType packetCode _ = undefined -- FIXME toPkt (OtherPacket a b) = OtherPacketPkt a b diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -0,0 +1,72 @@ +-- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption +-- Copyright © 2013 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE FlexibleContexts #-} + +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 } -- FIXME: this depth stuff is convoluted + 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 -- FIXME: this shouldn't pass the whole SKESK + 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 -- FIXME: this shouldn't pass the whole SKESK + 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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.8 +Version: 0.9 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -122,8 +122,10 @@ , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.S2K + , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.Signatures , Data.Conduit.OpenPGP.Compression + , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Verify @@ -139,13 +141,20 @@ , conduit >= 0.5 && < 1.1 , containers , crypto-pubkey >= 0.1.4 + , cryptocipher + , crypto-cipher-types , cryptohash + , data-default , ixset >= 1.0 , lens >= 3.0 + , monad-loops , mtl + , nettle , openpgp-asciiarmor >= 0.1 + , securemem , split , time >= 1.1 + , transformers , zlib default-language: Haskell2010 @@ -163,11 +172,19 @@ , conduit , containers , crypto-pubkey >= 0.1.4 + , cryptocipher + , crypto-cipher-types , cryptohash + , data-default , ixset >= 1.0 , lens >= 3.0 + , monad-loops + , mtl + , nettle + , securemem , split , time >= 1.1 + , transformers , zlib , HUnit , test-framework @@ -179,3 +196,8 @@ source-repository head type: git location: git://git.debian.org/users/clint/hOpenPGP.git + +source-repository this + type: git + location: git://git.debian.org/users/clint/hOpenPGP.git + tag: v0.9 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -16,10 +16,13 @@ import Codec.Encryption.OpenPGP.Types import Data.Conduit.Cereal (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) +import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt) import Data.Conduit.OpenPGP.Keyring (conduitToTKs, conduitToTKsDropping, sinkKeyringMap) import Data.Conduit.OpenPGP.Verify (conduitVerify) +import Codec.Encryption.OpenPGP.Serialize () import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import Data.IxSet ((@=), getOne) import Data.Maybe (isJust) import Data.Serialize (get, put) @@ -87,6 +90,28 @@ let verification' = map (fmap (fingerprint . _verificationSigner)) verification assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' +-- This needs a lot of work +testSymmetricEncryption :: FilePath -> FilePath -> B.ByteString -> Assertion +testSymmetricEncryption encfile passfile cleartext = do + passphrase <- BL.readFile $ "tests/data/" ++ passfile + -- get parse tree + pt <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ encfile) DC.$= conduitGet get DC.$$ CL.consume + -- assert parse tree has exactly two packets: skesk, encdata + assertEqual "wrong number of packets" 2 (length pt) + let skesk = fromPkt.head $ pt + d = fromPkt.last $ pt + -- FIXME: these assertions don't currently do anything properly, + -- because haskell notices the _-prefixed accessor invocations below + -- and the type system chokes before we hit them: + assertEqual "first packet should be SKESK" SKESKType (packetType skesk) + assertEqual "second packet should be encrypted data" SymEncIntegrityProtectedDataType (packetType d) + decrypted <- DC.runResourceT $ CL.sourceList pt DC.$= conduitDecrypt (fakeCallback passphrase) DC.$$ CL.consume + let payload = _literalDataPayload . fromPkt . head $ decrypted + assertEqual ("cleartext for " ++ encfile) cleartext payload + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + tests :: [Test] tests = [ testGroup "Serialization group" [ @@ -221,6 +246,28 @@ , testCase "conduitCompress (BZip2)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress BZip2) 1) , testCase "conduitToTKs" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKs) 4) , testCase "conduitToTKsDropping" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKsDropping) 4) + ], + testGroup "Encrypted data" [ + testCase "Symmetric Encryption simple S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish.gpg" "symmetric-password.txt" "test\n") ] ]