diff --git a/Data/OpenPGP/CryptoAPI.hs b/Data/OpenPGP/CryptoAPI.hs --- a/Data/OpenPGP/CryptoAPI.hs +++ b/Data/OpenPGP/CryptoAPI.hs @@ -10,7 +10,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), runStateT) import Data.Binary (encode, decode, get, Word16) -import Crypto.Classes hiding (cfb,unCfb,hash,sign,verify,encode) +import Crypto.Classes hiding (cfb,unCfb,sign,verify,encode) import Data.Tagged (untag, asTaggedTypeOf, Tagged(..)) import Crypto.Modes (cfb, unCfb, zeroIV) import Crypto.Types (IV) @@ -39,41 +39,23 @@ -- | A decryption routine, Bool=True to do resynchronization type Decrypt = (Bool -> LZ.ByteString -> (LZ.ByteString, LZ.ByteString)) --- Start differently-formatted section --- | This should be in Crypto.Classes and is based on buildKeyIO -buildKeyGen :: (BlockCipher k, CryptoRandomGen g) => g -> Either GenError (k, g) -buildKeyGen = runStateT (go (0::Int)) - where - go 1000 = lift $ Left $ GenErrorOther - "Tried 1000 times to generate a key from the system entropy.\ - \ No keys were returned! Perhaps the system entropy is broken\ - \ or perhaps the BlockCipher instance being used has a non-flat\ - \ keyspace." - go i = do - let bs = keyLength - kd <- StateT $ genBytes ((7 + untag bs) `div` 8) - case buildKey kd of - Nothing -> go (i+1) - Just k -> return $ k `asTaggedTypeOf` bs --- End differently-formatted section - find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet find_key = OpenPGP.find_key fingerprint -hash :: OpenPGP.HashAlgorithm -> LZ.ByteString -> (BS.ByteString, String) -hash OpenPGP.MD5 = hash_ (undefined :: MD5) -hash OpenPGP.SHA1 = hash_ (undefined :: SHA1) -hash OpenPGP.RIPEMD160 = hash_ (undefined :: RIPEMD160) -hash OpenPGP.SHA256 = hash_ (undefined :: SHA256) -hash OpenPGP.SHA384 = hash_ (undefined :: SHA384) -hash OpenPGP.SHA512 = hash_ (undefined :: SHA512) -hash OpenPGP.SHA224 = hash_ (undefined :: SHA224) -hash _ = error "Unsupported HashAlgorithm in hash" +pgpHash :: OpenPGP.HashAlgorithm -> LZ.ByteString -> (BS.ByteString, String) +pgpHash OpenPGP.MD5 = formatHash . (hash :: LZ.ByteString -> MD5) +pgpHash OpenPGP.SHA1 = formatHash . (hash :: LZ.ByteString -> SHA1) +pgpHash OpenPGP.RIPEMD160 = formatHash . (hash :: LZ.ByteString -> RIPEMD160) +pgpHash OpenPGP.SHA256 = formatHash . (hash :: LZ.ByteString -> SHA256) +pgpHash OpenPGP.SHA384 = formatHash . (hash :: LZ.ByteString -> SHA384) +pgpHash OpenPGP.SHA512 = formatHash . (hash :: LZ.ByteString -> SHA512) +pgpHash OpenPGP.SHA224 = formatHash . (hash :: LZ.ByteString -> SHA224) +pgpHash _ = error "Unsupported HashAlgorithm in pgpHash" -hash_ :: (Hash c d) => d -> LZ.ByteString -> (BS.ByteString, String) -hash_ d bs = (hbs, map toUpper $ pad $ hexString $ BS.unpack hbs) +formatHash :: (Hash c d) => d -> (BS.ByteString, String) +formatHash d = (hbs, map toUpper $ pad $ hexString $ BS.unpack hbs) where - hbs = Serialize.encode $ hashFunc d bs + hbs = Serialize.encode d pad s = replicate (len - length s) '0' ++ s len = (outputLength `for` d) `div` 8 @@ -195,8 +177,8 @@ -- fingerprint :: OpenPGP.Packet -> String fingerprint p - | OpenPGP.version p == 4 = snd $ hash OpenPGP.SHA1 material - | OpenPGP.version p `elem` [2, 3] = snd $ hash OpenPGP.MD5 material + | OpenPGP.version p == 4 = snd $ pgpHash OpenPGP.SHA1 material + | OpenPGP.version p `elem` [2, 3] = snd $ pgpHash OpenPGP.MD5 material | otherwise = error "Unsupported Packet version or type in fingerprint" where material = LZ.concat $ OpenPGP.fingerprint_material p @@ -213,12 +195,12 @@ (OpenPGP.signatures_over over) verifyOne :: OpenPGP.Message -> OpenPGP.Packet -> BS.ByteString -> Maybe OpenPGP.Packet -verifyOne keys sig over = fmap (const sig) $ maybeKey >>= - case OpenPGP.key_algorithm sig of +verifyOne keys sig over = fmap (const sig) $ maybeKey >>= verification >>= guard + where + verification = case OpenPGP.key_algorithm sig of OpenPGP.DSA -> dsaVerify alg | alg `elem` [OpenPGP.RSA,OpenPGP.RSA_S] -> rsaVerify | otherwise -> const Nothing - where dsaVerify k = let k' = dsaKey k in hush $ DSA.verify dsaSig (dsaTruncate k' . bhash) k' over rsaVerify k = hush $ RSA.verify bhash padding (rsaKey k) over rsaSig @@ -226,7 +208,7 @@ dsaSig = let [OpenPGP.MPI r, OpenPGP.MPI s] = OpenPGP.signature sig in (r, s) dsaTruncate (DSA.PublicKey (_,_,q) _) = BS.take (integerBytesize q) - bhash = fst . hash hash_algo . toLazyBS + bhash = fst . pgpHash hash_algo . toLazyBS padding = emsa_pkcs1_v1_5_hash_padding hash_algo hash_algo = OpenPGP.hash_algorithm sig maybeKey = OpenPGP.signature_issuer sig >>= find_key keys @@ -256,7 +238,7 @@ dta = toStrictBS $ encode over `LZ.append` OpenPGP.trailer sig sig = findSigOrDefault (listToMaybe $ OpenPGP.signatures_over over) padding = emsa_pkcs1_v1_5_hash_padding hsh - bhash = fst . hash hsh . toLazyBS + bhash = fst . pgpHash hsh . toLazyBS toNum = BS.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 Just k = find_key keys keyid @@ -336,10 +318,14 @@ (StateT $ genBytes 8) <*> pure 65536 s2kHashAlgorithmFor :: OpenPGP.SymmetricAlgorithm -> OpenPGP.HashAlgorithm -s2kHashAlgorithmFor OpenPGP.AES128 = s2kHashAlgorithm `for` (undefined :: AES128) -s2kHashAlgorithmFor OpenPGP.AES192 = s2kHashAlgorithm `for` (undefined :: AES192) -s2kHashAlgorithmFor OpenPGP.AES256 = s2kHashAlgorithm `for` (undefined :: AES256) -s2kHashAlgorithmFor OpenPGP.Blowfish = s2kHashAlgorithm `for` (undefined :: Blowfish128) +s2kHashAlgorithmFor OpenPGP.AES128 = + untag (s2kHashAlgorithm :: Tagged AES128 OpenPGP.HashAlgorithm) +s2kHashAlgorithmFor OpenPGP.AES192 = + untag (s2kHashAlgorithm :: Tagged AES192 OpenPGP.HashAlgorithm) +s2kHashAlgorithmFor OpenPGP.AES256 = + untag (s2kHashAlgorithm :: Tagged AES256 OpenPGP.HashAlgorithm) +s2kHashAlgorithmFor OpenPGP.Blowfish = + untag (s2kHashAlgorithm :: Tagged Blowfish128 OpenPGP.HashAlgorithm) s2kHashAlgorithmFor algo = error $ "Unsupported SymmetricAlgorithm " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.s2kHashAlgorithmFor" s2kHashAlgorithm :: (BlockCipher k) => Tagged k OpenPGP.HashAlgorithm @@ -349,10 +335,7 @@ _ | ksize <= 160 -> OpenPGP.SHA1 | ksize <= 256 -> OpenPGP.SHA256 | otherwise -> OpenPGP.SHA512 - ksize = keyLength `tagOfTag` v - -tagOfTag :: Tagged a c -> Tagged a b -> c -tagOfTag a b = a `for` (undefined `asTaggedTypeOf` b) + ksize = untag $ const <$> keyLength <*> v sessionFor :: (CryptoRandomGen g) => OpenPGP.SymmetricAlgorithm -> OpenPGP.Message -> StateT g (Either GenError) (LZ.ByteString, OpenPGP.Packet) sessionFor algo@OpenPGP.AES128 msg = do @@ -386,7 +369,7 @@ mkMDC :: LZ.ByteString -> LZ.ByteString -> OpenPGP.Packet mkMDC prefix msg = OpenPGP.ModificationDetectionCodePacket $ toLazyBS $ fst $ - hash OpenPGP.SHA1 $ LZ.concat [prefix, msg, LZ.pack [0xD3, 0x14]] + pgpHash OpenPGP.SHA1 $ LZ.concat [prefix, msg, LZ.pack [0xD3, 0x14]] checksum :: BS.ByteString -> Word16 checksum key = fromIntegral $ @@ -414,7 +397,7 @@ (OpenPGP.secret_key_fields kalgo)) material (material, chk) = LZ.splitAt (LZ.length decd - chkSize) decd (chkSize, chkF) - | OpenPGP.s2k_useage k == 254 = (20, fst . hash OpenPGP.SHA1) + | OpenPGP.s2k_useage k == 254 = (20, fst . pgpHash OpenPGP.SHA1) | otherwise = (2, Serialize.encode . checksum . toStrictBS) decd = string2sdecrypt salgo s2k (toLazyBS pass) (EncipheredWithIV encd) decryptSecretKey _ _ = Nothing @@ -511,10 +494,10 @@ (algoByte, rest) = BS.splitAt 1 sk decodeSymKey :: OpenPGP.SymmetricAlgorithm -> BS.ByteString -> Maybe Decrypt -decodeSymKey OpenPGP.AES128 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES128)) <$> sDecode k -decodeSymKey OpenPGP.AES192 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES192)) <$> sDecode k -decodeSymKey OpenPGP.AES256 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES256)) <$> sDecode k -decodeSymKey OpenPGP.Blowfish k = pgpUnCFB <$> (`asTypeOf` (undefined :: Blowfish128)) <$> sDecode k +decodeSymKey OpenPGP.AES128 k = (pgpUnCFB :: AES128 -> Decrypt) <$> sDecode k +decodeSymKey OpenPGP.AES192 k = (pgpUnCFB :: AES192 -> Decrypt) <$> sDecode k +decodeSymKey OpenPGP.AES256 k = (pgpUnCFB :: AES256 -> Decrypt) <$> sDecode k +decodeSymKey OpenPGP.Blowfish k = (pgpUnCFB :: Blowfish128 -> Decrypt) <$> sDecode k decodeSymKey _ _ = Nothing string2sencrypt :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> LZ.ByteString -> LZ.ByteString @@ -550,5 +533,5 @@ string2key s2k s = k where Just k = buildKey $ toStrictBS $ - LZ.take ksize $ OpenPGP.string2key (fst `oo` hash) s2k s + LZ.take ksize $ OpenPGP.string2key (fst `oo` pgpHash) s2k s ksize = fromIntegral (keyLength `for` k) `div` 8 diff --git a/openpgp-crypto-api.cabal b/openpgp-crypto-api.cabal --- a/openpgp-crypto-api.cabal +++ b/openpgp-crypto-api.cabal @@ -1,5 +1,5 @@ name: openpgp-crypto-api -version: 0.6.2 +version: 0.6.3 cabal-version: >= 1.8 license: OtherLicense license-file: COPYING @@ -62,7 +62,7 @@ bytestring, binary >= 0.6.4.0, openpgp >= 0.6, - crypto-api >= 0.11, + crypto-api >= 0.12.2.2, tagged, cryptocipher >= 0.3.6 && <= 0.3.7, cryptohash <= 0.9.1, @@ -79,7 +79,7 @@ binary >= 0.6.4.0, utf8-string, openpgp >= 0.6, - crypto-api >= 0.11, + crypto-api >= 0.12.2.2, tagged, cryptocipher >= 0.3.6 && <= 0.3.7, cryptohash <= 0.9.1, diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -10,6 +10,7 @@ import Data.List (find) import Crypto.Random import Data.Binary +import Data.Bits (xor) import qualified Data.OpenPGP as OpenPGP import qualified Data.OpenPGP.CryptoAPI as OpenPGP import qualified Data.ByteString.Lazy as LZ @@ -27,6 +28,11 @@ isLiteral (OpenPGP.LiteralDataPacket {}) = True isLiteral _ = False +modifyLiteralPacket :: OpenPGP.Packet -> OpenPGP.Packet +modifyLiteralPacket d@(OpenPGP.LiteralDataPacket { OpenPGP.content = cnt }) = + d { OpenPGP.content = LZ.cons 0x00 $ LZ.map (xor 0xFF) cnt } +modifyLiteralPacket nonliteral = nonliteral + testFingerprint :: FilePath -> String -> Assertion testFingerprint fp kf = do bs <- LZ.readFile $ "tests/data/" ++ fp @@ -41,6 +47,15 @@ OpenPGP.verify keys (head $ OpenPGP.signatures m) assertEqual (keyring ++ " for " ++ message) 1 (length ss) +testVerifyModifiedMessage :: FilePath -> FilePath -> Assertion +testVerifyModifiedMessage keyring message = do + keys <- fmap decode $ LZ.readFile $ "tests/data/" ++ keyring + OpenPGP.Message m <- fmap decode $ LZ.readFile $ "tests/data/" ++ message + let corrupt_message = OpenPGP.Message (map modifyLiteralPacket m) + let OpenPGP.DataSignature _ ss = + OpenPGP.verify keys (head $ OpenPGP.signatures corrupt_message) + assertEqual (keyring ++ " for " ++ message) 0 (length ss) + testVerifyKey :: FilePath -> Int -> Assertion testVerifyKey keyring count = do keys <- fmap decode $ LZ.readFile $ "tests/data/" ++ keyring @@ -117,7 +132,10 @@ testCase "uncompressed-ops-rsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-rsa.gpg"), testCase "compressedsig" (testVerifyMessage "pubring.gpg" "compressedsig.gpg"), testCase "compressedsig-zlib" (testVerifyMessage "pubring.gpg" "compressedsig-zlib.gpg"), - testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg") + testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg"), + testCase "corrupted-ops-dsa" (testVerifyModifiedMessage "pubring.gpg" "uncompressed-ops-dsa.gpg"), + testCase "corrupted-ops-dsa-sha384" (testVerifyModifiedMessage "pubring.gpg" "uncompressed-ops-dsa-sha384.txt.gpg"), + testCase "corrupted-ops-rsa" (testVerifyModifiedMessage "pubring.gpg" "uncompressed-ops-rsa.gpg") ], testGroup "Key verification" [ testCase "helloKey" (testVerifyKey "helloKey.gpg" 1)