hOpenPGP 0.9.1 → 0.10

raw patch · 16 files changed

+335/−73 lines, 16 filesdep +crypto-randomdep +errorsdep +tastydep −HUnitdep −test-frameworkdep −test-framework-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: crypto-random, errors, tasty, tasty-hunit, text

Dependencies removed: HUnit, test-framework, test-framework-hunit

API changes (from Hackage documentation)

Files

• Codec/Encryption/OpenPGP/BlockCipher.hs +56/−0
• Codec/Encryption/OpenPGP/CFB.hs +37/−11
• Codec/Encryption/OpenPGP/Internal.hs +6/−0
• Codec/Encryption/OpenPGP/KeyInfo.hs +1/−1
• Codec/Encryption/OpenPGP/KeySelection.hs +35/−0
• Codec/Encryption/OpenPGP/S2K.hs +10/−18
• Codec/Encryption/OpenPGP/SecretKey.hs +83/−0
• Codec/Encryption/OpenPGP/Serialize.hs +27/−17
• Codec/Encryption/OpenPGP/SerializeForSigs.hs +1/−1
• Codec/Encryption/OpenPGP/Signatures.hs +2/−2
• Data/Conduit/OpenPGP/Decrypt.hs +14/−4
• Data/Conduit/OpenPGP/Keyring/Instances.hs +5/−3
• LICENSE +1/−1
• hOpenPGP.cabal +16/−6
• tests/data/pki-password.txt +1/−0
• tests/suite.hs +40/−9

@@ -0,0 +1,56 @@+-- BlockCipher.hs: OpenPGP (RFC4880) block cipher stuff+-- Copyright © 2013  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++{-# LANGUAGE ExistentialQuantification #-}++module Codec.Encryption.OpenPGP.BlockCipher (+    BCipher(..)+  , bcBlockSize+  , saBlockSize+  , keySize+) where++import Codec.Encryption.OpenPGP.Types++import Crypto.Cipher.Types (BlockCipher(..))+import qualified Crypto.Cipher as CC+import qualified Crypto.Nettle.Ciphers as CNC++data BCipher = forall a. (BlockCipher a) => BCipher a++bcBlockSize :: BCipher -> Int+bcBlockSize (BCipher bc) = blockSize bc++saBlockSize :: SymmetricAlgorithm -> Int+saBlockSize = bcBlockSize . saToBCipher++saToBCipher :: SymmetricAlgorithm -> BCipher+saToBCipher Plaintext = error "this shouldn't have happened" -- FIXME: orphan instance?+saToBCipher IDEA = error "IDEA not yet implemented" -- FIXME: IDEA+saToBCipher ReservedSAFER = error "SAFER not implemented" -- FIXME: or not?+saToBCipher ReservedDES = error "DES not implemented" -- FIXME: or not?+saToBCipher (OtherSA _) = error "Unknown, unimplemented symmetric algorithm"+saToBCipher CAST5 = BCipher (undefined :: CNC.CAST128)+saToBCipher Twofish = BCipher (undefined :: CNC.TWOFISH)+saToBCipher TripleDES = BCipher (undefined :: CC.DES_EDE3)+saToBCipher Blowfish = BCipher (undefined :: CC.Blowfish128)+saToBCipher AES128 = BCipher (undefined :: CC.AES128)+saToBCipher AES192 = BCipher (undefined :: CC.AES192)+saToBCipher AES256 = BCipher (undefined :: CC.AES256)++-- in octets; FIXME: co-opt Cipher's cipherKeySize or not?+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

@@ -3,51 +3,63 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE ExistentialQuantification #-}- module Codec.Encryption.OpenPGP.CFB (    decrypt+ , decryptNoNonce  , decryptOpenPGPCfb+ , encryptNoNonce ) where +import Codec.Encryption.OpenPGP.BlockCipher (BCipher(..), bcBlockSize) import Codec.Encryption.OpenPGP.Types+import Control.Applicative ((<$>), (<*>))+import Control.Error.Util (note) 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+    let nonce = decrypt1 ciphertext bc+    cleartext <- decrypt2 ciphertext bc+    if nonceCheck bc nonce then return cleartext else fail "Session key quickcheck failed"     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)+        decrypt2 :: B.ByteString -> BCipher -> Either String B.ByteString+        decrypt2 ct (BCipher cipher) = note "unexpected CFB-resync failure" (CC.makeIV (B.take (blockSize cipher) (B.drop 2 ct))) >>= \i -> return (cdecrypt sa cipher i (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+    let (nonce, cleartext) = B.splitAt (bcBlockSize bc + 2) (decrypt' ciphertext bc)+    if nonceCheck bc nonce then return cleartext else fail "Session key quickcheck failed"     where         decrypt' :: B.ByteString -> BCipher -> B.ByteString         decrypt' ct (BCipher cipher) = cdecrypt sa cipher nullIV ct -bsize :: BCipher -> Int-bsize (BCipher bc) = blockSize bc+decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString+decryptNoNonce Plaintext _ ciphertext _ = return ciphertext+decryptNoNonce sa iv ciphertext keydata = do+    bc <- mkBCipher sa keydata+    decrypt' ciphertext bc+    where+        decrypt' :: B.ByteString -> BCipher -> Either String B.ByteString+        decrypt' ct (BCipher cipher) = note "Bad IV" (CC.makeIV iv) >>= \i -> return (cdecrypt sa cipher i ct)  cdecrypt :: BlockCipher cipher => SymmetricAlgorithm -> cipher -> CC.IV cipher -> B.ByteString -> B.ByteString cdecrypt sa     | sa `elem` [CAST5, Twofish] = paddedCfbDecrypt     | otherwise = cfbDecrypt +nonceCheck :: BCipher -> B.ByteString -> Bool+nonceCheck bc = (==) <$> B.take 2 . B.drop (bcBlockSize bc - 2) <*> B.drop (bcBlockSize bc)+ 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@@ -73,3 +85,17 @@         ekey = case makeKey keydata of           Left _ -> error "bad cipher parameters"           Right key -> key++encryptNoNonce :: SymmetricAlgorithm -> S2K -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString+encryptNoNonce Plaintext _ _ payload keydata = return payload+encryptNoNonce sa s2k iv payload keydata = do+    bc <- mkBCipher sa keydata+    encrypt' payload bc+    where+        encrypt' :: B.ByteString -> BCipher -> Either String B.ByteString+        encrypt' ct (BCipher cipher) = note "Bad IV" (CC.makeIV iv) >>= \i -> return (cencrypt sa cipher i ct)++cencrypt :: BlockCipher cipher => SymmetricAlgorithm -> cipher -> CC.IV cipher -> B.ByteString -> B.ByteString+cencrypt sa+    | sa `elem` [CAST5, Twofish] = error "padding for nettle-encryption not implemented yet"+    | otherwise = cfbEncrypt

@@ -12,6 +12,7 @@  , issuer  , emptyPSC  , pubkeyToMPIs+ , multiplicativeInverse ) where  import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160)@@ -77,3 +78,8 @@   where pkParams f = MPI . f . DSA.public_params $ k  pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k++multiplicativeInverse :: Integral a => a -> a -> a+multiplicativeInverse _ 1 = 1+multiplicativeInverse q p = (n * q + 1) `div` p+    where n = p - multiplicativeInverse p (q `mod` p)

@@ -20,7 +20,7 @@  keySize (RSAPubKey x) = RSA.public_size x * 8 keySize (DSAPubKey x) = bitcount . DSA.params_p . DSA.public_params $ x-keySize (ElGamalPubKey x) = bitcount $ x !! 0+keySize (ElGamalPubKey x) = bitcount $ head x  bitcount = (*8) . length . unfoldr (\x -> if x == 0 then Nothing else Just (True, x `shiftR` 8)) 

@@ -0,0 +1,35 @@+-- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys+-- Copyright © 2014  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++{-# LANGUAGE OverloadedStrings #-}++module Codec.Encryption.OpenPGP.KeySelection (+   parseEightOctetKeyId+ , parseFingerprint+) where++import qualified Data.ByteString as B+import Codec.Encryption.OpenPGP.Internal (integerToBEBS)+import Codec.Encryption.OpenPGP.Types+import Control.Applicative (optional, (<$>), (*>))+import Control.Monad ((<=<))+import Data.Attoparsec.Text (asciiCI, count, hexadecimal, inClass, parseOnly, Parser, satisfy)+import Data.Text (Text, toUpper)+import qualified Data.Text as T++parseEightOctetKeyId :: Text -> Either String EightOctetKeyId+parseEightOctetKeyId = fmap EightOctetKeyId . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper++parseFingerprint :: Text -> Either String TwentyOctetFingerprint+parseFingerprint = fmap TwentyOctetFingerprint . (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/=' ')++hexPrefix :: Parser (Maybe Text)+hexPrefix = optional (asciiCI "0x")++hexen :: Int -> Parser Text+hexen n = T.pack <$> count n (satisfy (inClass "A-F0-9"))++hexes :: Parser B.ByteString+hexes = integerToBEBS <$> hexadecimal

@@ -8,33 +8,25 @@   ,skesk2Key ) where +import Codec.Encryption.OpenPGP.BlockCipher (keySize) 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 Crypto.Hash.SHA512 as SHA512 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL  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: unimplemented S2K hash"+string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp (hf ha) ksz bs+string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromChunks [salt]) bs)+string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict salt) bs)+string2Key _ _ _ = error "FIXME: unimplemented S2K type" --- 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+hf :: HashAlgorithm -> BL.ByteString -> B.ByteString+hf SHA1 = SHA1.hashlazy+hf SHA512 = SHA512.hashlazy+hf _ = error "FIXME: unimplemented S2K hash"  skesk2Key :: SKESK -> BL.ByteString -> B.ByteString skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass

@@ -0,0 +1,83 @@+-- SecretKey.hs: OpenPGP (RFC4880) secret key decryption+-- Copyright © 2013  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.SecretKey (+   decryptPrivateKey+ , encryptPrivateKey+ , encryptPrivateKeyIO+ , reencryptSecretKeyIO+) where++import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.BlockCipher (saBlockSize, keySize)+import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)+import Codec.Encryption.OpenPGP.Serialize (getSecretKey)+import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)+import Control.Monad ((>=>))+import qualified Crypto.Hash.SHA1 as SHA1+import Crypto.Random (createEntropyPool, cprgCreate, cprgGenerateWithEntropy, SystemRNG)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Serialize (runGet, runPut, put)+import Data.Serialize.Get (getBytes, remaining, getWord16be)+import qualified Crypto.PubKey.RSA as R++decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum+decryptPrivateKey (pkp, ska@(SUS16bit {})) pp = either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp)+decryptPrivateKey (pkp, ska@(SUSSHA1 {})) pp = either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp)+decryptPrivateKey (_, SUSym {}) _ = error "SUSym key decryption not implemented"+decryptPrivateKey (_, ska@(SUUnencrypted {})) _ = ska++decryptSKA :: (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum+decryptSKA (pkp, SUS16bit sa s2k iv payload) pp = do+    let key = skesk2Key (SKESK 4 sa s2k Nothing) pp+    p <- decryptNoNonce sa iv payload key+    (s, cksum) <- runGet (getSecretKey pkp >>= \sk -> getWord16be >>= \csum -> return (sk, csum)) p  -- FIXME: check the 16bit hash+    let checksum = cksum+    return $ SUUnencrypted s checksum  -- FIXME: is this the correct checksum?+decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do+    let key = skesk2Key (SKESK 4 sa s2k Nothing) pp+    p <- decryptNoNonce sa iv payload key+    (s, cksum) <- runGet (getSecretKey pkp >>= \sk -> remaining >>= (getBytes >=> \csum -> return (sk, csum))) p  -- FIXME: check the SHA1 hash+    let checksum = sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p+    return $ SUUnencrypted s checksum  -- FIXME: is this the correct checksum?+decryptSKA _ _ = fail "Unexpected codepath"++-- |generates pseudo-random salt and IV+encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum+encryptPrivateKeyIO ska pp = saltiv >>= \(s,i) -> return (encryptPrivateKey s i ska pp)+    where+        saltiv = do+                    ep <- createEntropyPool+                    let gen = cprgCreate ep :: SystemRNG+		        bb = fst (cprgGenerateWithEntropy (8 + saBlockSize AES256) gen)+		    return $ B.splitAt 8 bb++-- |8-octet salt, IV must be length of cipher blocksize+encryptPrivateKey :: B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum+encryptPrivateKey _ _ ska@(SUS16bit {}) _ = ska+encryptPrivateKey _ _ ska@(SUSSHA1 {}) _ = ska+encryptPrivateKey _ _ ska@(SUSym {}) _ = ska+encryptPrivateKey salt iv (SUUnencrypted skey _) pp = SUSSHA1 AES256 s2k iv (encryptSKey skey s2k iv pp)+    where+       s2k = IteratedSalted SHA512 salt 12058624++encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString+encryptSKey (RSAPrivateKey (R.PrivateKey _ d p q _ _ _)) s2k iv pp = either error id (encryptNoNonce AES256 s2k iv payload key)+    where+        key = string2Key s2k (keySize AES256) pp+        algospecific = runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)+	cksum = SHA1.hash algospecific+	payload = algospecific `B.append` cksum+	u = inverse q p+encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal++inverse :: Integral a => a -> a -> a+inverse _ 1 = 1+inverse q p = (n * q + 1) `div` p+    where n = p - inverse p (q `mod` p)++reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey+reencryptSecretKeyIO sk pp = encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n -> return sk { _secretKeySKAddendum = n }

@@ -5,11 +5,12 @@  module Codec.Encryption.OpenPGP.Serialize (    putSKAddendum+ , getSecretKey ) where  import Control.Applicative ((<$>),(<*>)) import Control.Lens ((^.))-import Control.Monad (guard, mplus, replicateM)+import Control.Monad (guard, liftM, mplus, replicateM, replicateM_) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)@@ -25,7 +26,7 @@ import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) -import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs)+import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs, multiplicativeInverse) import Codec.Encryption.OpenPGP.Types  instance Serialize SigSubPacket where@@ -36,19 +37,19 @@ --     put = putNotationFlagSet  instance Serialize CompressionAlgorithm where-    get = getWord8 >>= return . toFVal+    get = liftM toFVal getWord8     put = putWord8 . fromFVal  instance Serialize PubKeyAlgorithm where-    get = getWord8 >>= return . toFVal+    get = liftM toFVal getWord8     put = putWord8 . fromFVal  instance Serialize HashAlgorithm where-    get = getWord8 >>= return . toFVal+    get = liftM toFVal getWord8     put = putWord8 . fromFVal  instance Serialize SymmetricAlgorithm where-    get = getWord8 >>= return . toFVal+    get = liftM toFVal getWord8     put = putWord8 . fromFVal  instance Serialize MPI where@@ -56,7 +57,7 @@     put = putMPI  instance Serialize SigType where-    get = getWord8 >>= return . toFVal+    get = liftM toFVal getWord8     put = putWord8 . fromFVal  instance Serialize UserAttrSubPacket where@@ -391,14 +392,14 @@ getSigSubPacketType :: Get (Bool, Word8) getSigSubPacketType = do                          x <- getWord8-                         if x .&. 0x80 == 0x80 then return (True, x .&. 0x7f) else return (False, x)+                         return (if x .&. 128 == 128 then (True, x .&. 127) else (False, x))  putSigSubPacketType :: Bool -> Word8 -> Put putSigSubPacketType False sst = putWord8 sst putSigSubPacketType True sst = putWord8 (sst .|. 0x80)  bsToFFSet :: FutureFlag a => ByteString -> Set a-bsToFFSet bs = Set.fromAscList .  concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. (shiftR 128 x) == (shiftR 128 x) then [toFFlag (acc + x)] else []) [0..7])) 0 (B.unpack bs)+bsToFFSet bs = Set.fromAscList .  concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. shiftR 128 x == shiftR 128 x then [toFFlag (acc + x)] else []) [0..7])) 0 (B.unpack bs)  ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString ffSetToFixedLengthBS len ffs = B.take (fromIntegral len) (B.append (ffSetToBS ffs) (B.pack (replicate 5 0)))@@ -407,7 +408,7 @@ ffSetToBS = B.pack . ffSetToBS'     where         ffSetToBS' :: FutureFlag a => Set a -> [Word8]-        ffSetToBS' ks = map (foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) (map (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks) [0..(fromFFlag $ Set.findMax ks) `div` 8])+        ffSetToBS' ks = map ((foldl (.|.) 0 .  map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) . (\ x -> Set.filter (\ y -> fromFFlag y `div` 8 == x) ks)) [0 .. fromFFlag (Set.findMax ks) `div` 8]  fromS2K :: S2K -> ByteString fromS2K (Simple hashalgo) = B.pack [0, fromIntegral . fromFVal $ hashalgo]@@ -415,7 +416,7 @@     | B.length salt == 8 = B.pack [1, fromIntegral . fromFVal $ hashalgo] `B.append` salt     | otherwise = error "Confusing salt size" fromS2K (IteratedSalted hashalgo salt count)-    | B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` (encodeIterationCount count)+    | B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` encodeIterationCount count     | otherwise = error "Confusing salt size" fromS2K (OtherS2K _ bs) = bs @@ -571,7 +572,7 @@                           flen <- getWord8                           fn <- getByteString (fromIntegral flen)                           ts <- getWord32be-                          ldata <- getByteString (len - (6 + (fromIntegral flen)))+                          ldata <- getByteString (len - (6 + fromIntegral flen))                           return $ LiteralDataPkt (toFVal dt) fn ts ldata             | t == 12 = do                           tdata <- getByteString len@@ -612,7 +613,7 @@                               iformat <- getWord8                               nuls <- getBytes 12 -- should be NULs                               bs <- getByteString (l - 17)-                              if hver /= 1 || nuls /= (B.pack (replicate 12 0)) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs+                              if hver /= 1 || nuls /= B.pack (replicate 12 0) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs                 | otherwise = do                                  bs <- getByteString (l - 1)                                  return $ OtherUASub t bs@@ -628,7 +629,7 @@             putWord16le 16             putWord8 1             putWord8 (fromFVal iformat)-            mapM_ putWord8 $ replicate 12 0+            replicateM_ 12 $ putWord8 0             putByteString idata         putUserAttrSubPacket' (OtherUASub t bs) = do             putWord8 t@@ -638,7 +639,7 @@ putPkt (PKESKPkt pv eokeyid pkalgo mpis) = do     putWord8 (0xc0 .|. 1)     let bsk = runPut $ mapM_ put mpis-    putPacketLength . fromIntegral $ 10 + (B.length bsk)+    putPacketLength . fromIntegral $ 10 + B.length bsk     putWord8 pv -- must be 3     putByteString (unEOKI eokeyid) -- must be 8 octets     putWord8 $ fromIntegral . fromFVal $ pkalgo@@ -652,7 +653,7 @@     putWord8 (0xc0 .|. 3)     let bs2k = fromS2K s2k     let bsk = fromMaybe B.empty mesk-    putPacketLength . fromIntegral $ 2 + (B.length bs2k) + (B.length bsk)+    putPacketLength . fromIntegral $ 2 + B.length bs2k + B.length bsk     putWord8 pv -- should be 4     putWord8 $ fromIntegral . fromFVal $ symalgo     putByteString bs2k@@ -729,7 +730,7 @@     putByteString bs putPkt (SymEncIntegrityProtectedDataPkt pv b) = do     putWord8 (0xc0 .|. 18)-    putPacketLength . fromIntegral $ (B.length b) + 1+    putPacketLength . fromIntegral $ B.length b + 1     putWord8 pv -- should be 1     putByteString b putPkt (ModificationDetectionCodePkt hash) = do@@ -786,6 +787,11 @@         do MPI x <- get            return $ ElGamalPrivateKey [x] +putSKey :: SKey -> Put+putSKey (RSAPrivateKey (R.PrivateKey _ d p q _ _ _)) = put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)+    where+        u = multiplicativeInverse q p+ putMPI :: MPI -> Put putMPI (MPI i) = do let bs = integerToBEBS i                     putWord16be . countBits $ bs@@ -849,6 +855,10 @@     put s2k     putByteString iv     putByteString encryptedblock+putSKAddendum (SUUnencrypted sk checksum) = do+    putWord8 0+    putSKey sk+    putWord16be checksum putSKAddendum _ = fail "Type not supported"  symEncBlockSize :: SymmetricAlgorithm -> Int

@@ -101,7 +101,7 @@     putByteString bs  payloadForSig :: SigType -> PktStreamContext -> ByteString-payloadForSig BinarySig state = (fromPkt (lastLD state))^.literalDataPayload+payloadForSig BinarySig state = fromPkt (lastLD state)^.literalDataPayload payloadForSig CanonicalTextSig state = payloadForSig BinarySig state payloadForSig StandaloneSig _ = B.empty payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)

@@ -116,9 +116,9 @@         verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis ha pkey bs) pub         verify'' _ _ _ _ _ = Left "unimplemented key type" 	verify''' f pub = if f then Right pub else Left "verification failed"-	dsaVerify mpis ha pkey bs = DSA.verify (dsaTruncate pkey . hashFunction (hashDescr ha)) pkey (dsaMPIsToSig mpis) bs+	dsaVerify mpis ha pkey = DSA.verify (dsaTruncate pkey . hashFunction (hashDescr ha)) pkey (dsaMPIsToSig mpis) 	rsaVerify mpis ha pkey bs = P15.verify (hashDescr ha) pkey bs (rsaMPItoSig mpis)-        dsaMPIsToSig mpis = (DSA.Signature (unMPI (mpis !! 0)) (unMPI (mpis !! 1)))+        dsaMPIsToSig mpis = DSA.Signature (unMPI (head mpis)) (unMPI (mpis !! 1))         rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis))         hashalgo :: Pkt -> HashAlgorithm         hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha

@@ -9,7 +9,10 @@    conduitDecrypt ) where +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..))+import qualified Control.Monad.Trans.State.Lazy as S+import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Conduit@@ -18,7 +21,7 @@ import Data.Conduit.OpenPGP.Compression (conduitDecompress) import qualified Data.Conduit.List as CL import Data.Default (Default, def)-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, isNothing) import Data.Serialize (get)  import Codec.Encryption.OpenPGP.S2K (skesk2Key)@@ -29,10 +32,11 @@      _depth    :: Int   , _lastPKESK :: Maybe PKESK   , _lastSKESK :: Maybe SKESK+  , _lastLDP   :: Maybe LiteralData } deriving (Eq, Show)  instance Default RecursorState where-    def = RecursorState 0 Nothing Nothing+    def = RecursorState 0 Nothing Nothing Nothing  type InputCallback m = String -> m BL.ByteString @@ -48,10 +52,16 @@ 	    | 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)+                                                return (processLDPs s d, d)                        (SymEncIntegrityProtectedDataPkt _ bs) -> do d <- decryptSEIPDP (_depth s) cb (fromJust . _lastSKESK $ s) bs-                                                                    return (s, d)+                                                                    return (processLDPs s d, d)+                       m@(ModificationDetectionCodePkt mdc) -> do when (isNothing (_lastLDP s)) $ fail "MDC with no referent"+                                                                  when (fmap (SHA1.hash . _literalDataPayload) (_lastLDP s) /= Just mdc) $ fail "MDC indicates tampering"+                                                                  return (s, [m])                        p -> return (s, [p])+        processLDPs s ds = S.execState (mapM_ ldpCheck ds) s+        ldpCheck l@(LiteralDataPkt {}) = S.get >>= \o -> S.put o { _lastLDP = Just . fromPkt $ l }+        ldpCheck _ = return ()  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

@@ -1,5 +1,5 @@ -- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys--- Copyright © 2012-2013  Clint Adams+-- Copyright © 2012-2014  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -11,7 +11,7 @@ import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types -import Control.Lens ((^..))+import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate)  instance Indexable TK where@@ -19,10 +19,12 @@                 [ ixGen (Proxy :: Proxy PKPayload)                 , ixFun getEOKIs                 , ixFun getTOFs+                , ixFun getUIDs                 ]  getEOKIs :: TK -> [EightOctetKeyId] getEOKIs tk = map eightOctetKeyID (tk ^.. biplate :: [PKPayload]) getTOFs :: TK -> [TwentyOctetFingerprint] getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload])-+getUIDs :: TK -> [String]+getUIDs tk = (tk^.tkUIDs)^..folded._1

@@ -1,4 +1,4 @@-Copyright © 2012-2013 Clint Adams <clint@debian.org>+Copyright © 2012-2014 Clint Adams <clint@debian.org>  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the

@@ -1,5 +1,5 @@ Name:                hOpenPGP-Version:             0.9.1+Version:             0.10 Synopsis:            native Haskell implementation of OpenPGP (RFC4880) Description:         native Haskell implementation of OpenPGP (RFC4880) Homepage:            http://floss.scru.org/hOpenPGP/@@ -7,7 +7,7 @@ License-file:        LICENSE Author:              Clint Adams Maintainer:          Clint Adams <clint@debian.org>-Copyright:           2012-2013  Clint Adams+Copyright:           2012-2014  Clint Adams Category:            Codec, Data Build-type:          Simple Extra-source-files: tests/suite.hs@@ -111,6 +111,7 @@   , tests/data/6F87040E-cr.pubkey   , tests/data/v3.key   , tests/data/primary-binding.gpg+  , tests/data/pki-password.txt   , tests/data/symmetric-password.txt   , tests/data/encryption-sym-aes256-s2k0.gpg   , tests/data/encryption-sym-aes128-s2k0.gpg@@ -142,8 +143,10 @@                      , Codec.Encryption.OpenPGP.Compression                      , Codec.Encryption.OpenPGP.Fingerprint                      , Codec.Encryption.OpenPGP.KeyInfo+                     , Codec.Encryption.OpenPGP.KeySelection                      , Codec.Encryption.OpenPGP.S2K                      , Codec.Encryption.OpenPGP.CFB+                     , Codec.Encryption.OpenPGP.SecretKey                      , Codec.Encryption.OpenPGP.Signatures                      , Data.Conduit.OpenPGP.Compression                      , Data.Conduit.OpenPGP.Decrypt@@ -152,6 +155,7 @@                      , Data.Conduit.OpenPGP.Verify   Other-Modules: Codec.Encryption.OpenPGP.Internal                , Codec.Encryption.OpenPGP.SerializeForSigs+               , Codec.Encryption.OpenPGP.BlockCipher   Build-depends: attoparsec                , base                  > 4       && < 5                , base64-bytestring@@ -163,9 +167,11 @@                , containers                , crypto-cipher-types                , crypto-pubkey         >= 0.1.4+               , crypto-random                , cryptocipher                , cryptohash                , data-default+               , errors                , ixset                 >= 1.0                , lens                  >= 3.0                , monad-loops@@ -174,6 +180,7 @@                , openpgp-asciiarmor                 >= 0.1                , securemem                , split+               , text                , time                               >= 1.1                , transformers                , zlib@@ -186,6 +193,7 @@   Ghc-options: -Wall   Build-depends: hOpenPGP                , base                  > 4       && < 5+               , attoparsec                , bytestring                , bzlib                , cereal@@ -194,9 +202,11 @@                , containers                , crypto-cipher-types                , crypto-pubkey         >= 0.1.4+               , crypto-random                , cryptocipher                , cryptohash                , data-default+               , errors                , ixset                 >= 1.0                , lens                  >= 3.0                , monad-loops@@ -204,12 +214,12 @@                , nettle                , securemem                , split+               , text                , time                               >= 1.1                , transformers                , zlib-               , HUnit-               , test-framework-               , test-framework-hunit+               , tasty+               , tasty-hunit                , resourcet              > 0.4 && < 0.5   default-language: Haskell2010 @@ -220,4 +230,4 @@ source-repository this   type:     git   location: git://git.debian.org/users/clint/hOpenPGP.git-  tag:      v0.9.1+  tag:      v0.10

@@ -0,0 +1,1 @@+test

@@ -1,24 +1,26 @@ {-# LANGUAGE OverloadedStrings #-}  -- suite.hs: hOpenPGP test suite--- Copyright © 2012-2013  Clint Adams+-- Copyright © 2012-2014  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.HUnit--import Test.HUnit (Assertion, assertFailure, assertEqual)+import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.HUnit (testCase, Assertion, assertFailure, assertEqual)  import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)+import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)+import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) import Codec.Encryption.OpenPGP.Types+import Crypto.PubKey.RSA (PrivateKey(private_pub)) 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 Data.Text (Text) import Codec.Encryption.OpenPGP.Serialize ()  import qualified Data.ByteString as B@@ -112,8 +114,29 @@           fakeCallback :: BL.ByteString -> String -> IO BL.ByteString           fakeCallback = const . return -tests :: [Test]-tests = [+testSecretKeyDecryption :: FilePath -> FilePath -> Assertion+testSecretKeyDecryption keyfile passfile = do+  passphrase <- BL.readFile $ "tests/data/" ++ passfile+  kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$$ CL.consume+  let SecretKey pkp ska = fromPkt . head $ kr+      SUUnencrypted (RSAPrivateKey dpk) _ = decryptPrivateKey (pkp, ska) passphrase  -- FIXME: better API for multiple keytypes+      RSAPubKey pk = _pubkey pkp+  assertEqual "private key matches public key" pk (private_pub dpk)++-- FIXME: this should be reworked either with tasty-golden or some other form of sanity+testSecretKeyEncryption :: FilePath -> FilePath -> Assertion+testSecretKeyEncryption keyfile passfile = do+  passphrase <- BL.readFile $ "tests/data/" ++ passfile+  kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$$ CL.consume+  gkr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC.$= conduitGet get DC.$$ CL.consume+  let SecretKey pkp ska = fromPkt . head $ kr+      newska = encryptPrivateKey "\226~\197\a\202#\"G" "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t" ska passphrase+      newtruck = toPkt (SecretKey pkp newska):tail kr+  assertEqual "encrypted private key matches golden file" gkr newtruck+++tests :: TestTree+tests = testGroup "unit tests" [   testGroup "Serialization group" [      testCase "000001-006.public_key" (testSerialization "000001-006.public_key")    , testCase "000002-013.user_id" (testSerialization "000002-013.user_id")@@ -268,14 +291,22 @@    , 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")+   ],+  testGroup "Encrypted secret keys" [+     testCase "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "simple.seckey" "pki-password.txt")+   , testCase "SUS16bit CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt")+   , testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt")+   ],+  testGroup "Encrypting secret keys" [+     testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt")    ]  ]  cgp :: DC.Conduit B.ByteString (DC.ResourceT IO) Pkt cgp = conduitGet (get :: Get Pkt) -fp :: String -> TwentyOctetFingerprint-fp = read+fp :: Text -> TwentyOctetFingerprint+fp = either error id . parseFingerprint  main :: IO () main = defaultMain tests