packages feed

hOpenPGP 2.2.1 → 2.3

raw patch · 18 files changed

+266/−180 lines, 18 filesdep +cryptonitedep +memorydep −crypto-pubkeydep −crypto-randomdep −cryptocipher

Dependencies added: cryptonite, memory

Dependencies removed: crypto-pubkey, crypto-random, cryptocipher, cryptohash

Files

Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -1,44 +1,42 @@ -- BlockCipher.hs: OpenPGP (RFC4880) block cipher stuff--- Copyright © 2013  Clint Adams+-- Copyright © 2013-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}  module Codec.Encryption.OpenPGP.BlockCipher (-    BCipher(..)-  , bcBlockSize-  , saBlockSize-  , keySize+    keySize+  , withSymmetricCipher ) where +import Codec.Encryption.OpenPGP.Internal+import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (HOWrappedOldCCT(..))+import Codec.Encryption.OpenPGP.Internal.Cryptonite (HOWrappedCCT(..))+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types -import Crypto.Cipher.Types (BlockCipher(..))-import qualified Crypto.Cipher as CC+import qualified Crypto.Cipher.Blowfish as Blowfish+import qualified Crypto.Cipher.TripleDES as TripleDES+import qualified Crypto.Cipher.AES as AES import qualified Crypto.Nettle.Ciphers as CNC--data BCipher = forall a. (BlockCipher a) => BCipher a--bcBlockSize :: BCipher -> Int-bcBlockSize (BCipher bc) = blockSize bc+import qualified Data.ByteString as B -saBlockSize :: SymmetricAlgorithm -> Int-saBlockSize = bcBlockSize . saToBCipher+type HOCipher a = forall cipher. HOBlockCipher cipher => cipher -> Either String a -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)+withSymmetricCipher :: SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either String a+withSymmetricCipher Plaintext _ _ = Left "this shouldn't have happened" -- FIXME: orphan instance?+withSymmetricCipher IDEA _ _ = Left "IDEA not yet implemented" -- FIXME: IDEA+withSymmetricCipher ReservedSAFER _ _ = Left "SAFER not implemented" -- FIXME: or not?+withSymmetricCipher ReservedDES _ _ = Left "DES not implemented" -- FIXME: or not?+withSymmetricCipher (OtherSA _) _ _ = Left "Unknown, unimplemented symmetric algorithm"+withSymmetricCipher CAST5 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.CAST128)) >>= f+withSymmetricCipher Twofish key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.TWOFISH)) >>= f+withSymmetricCipher TripleDES key f = (cipherInit key :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) >>= f+withSymmetricCipher Blowfish key f = (cipherInit key :: Either String (HOWrappedCCT Blowfish.Blowfish128)) >>= f+withSymmetricCipher AES128 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f+withSymmetricCipher AES192 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f+withSymmetricCipher AES256 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f  -- in octets; FIXME: co-opt Cipher's cipherKeySize or not? keySize :: SymmetricAlgorithm -> Int
Codec/Encryption/OpenPGP/CFB.hs view
@@ -1,5 +1,5 @@ -- CFB.hs: OpenPGP (RFC4880) CFB mode--- Copyright © 2013-2015  Clint Adams+-- Copyright © 2013-2016  Clint Adams -- Copyright © 2013  Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file).@@ -11,92 +11,57 @@  , encryptNoNonce ) where -import Codec.Encryption.OpenPGP.BlockCipher (BCipher(..), bcBlockSize)+import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher)+import Codec.Encryption.OpenPGP.Internal+import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes+import Codec.Encryption.OpenPGP.Internal.Cryptonite+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher 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.Cipher.AES as CCA+import qualified Crypto.Cipher.Blowfish as CCB+import qualified Crypto.Cipher.TripleDES as CC3 import qualified Crypto.Nettle.Ciphers as CNC+import Data.ByteArray (ByteArray) import qualified Data.ByteString as B-import Data.SecureMem (ToSecureMem)  decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext-decryptOpenPGPCfb sa ciphertext keydata = do-    bc <- mkBCipher sa keydata-    let nonce = decrypt1 ciphertext bc+decryptOpenPGPCfb sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do+    nonce <- decrypt1 ciphertext bc     cleartext <- decrypt2 ciphertext bc     if nonceCheck bc nonce then return cleartext else Left "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 -> 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))+        decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString+        decrypt1 ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (B.take (blockSize cipher + 2) ct)+        decrypt2 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString+        decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in (paddedCfbDecrypt 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-    let (nonce, cleartext) = B.splitAt (bcBlockSize bc + 2) (decrypt' ciphertext bc)+decrypt sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do+    (nonce, cleartext) <- decrypt' ciphertext bc >>= return . (B.splitAt (blockSize bc + 2))     if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed"     where-        decrypt' :: B.ByteString -> BCipher -> B.ByteString-        decrypt' ct (BCipher cipher) = cdecrypt sa cipher nullIV ct+        decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString+        decrypt' ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct  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)+    withSymmetricCipher sa keydata (decrypt' ciphertext)     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 (Left "this shouldn't have happened") -- FIXME: orphan instance?-mkBCipher IDEA = const (Left "IDEA not yet implemented") -- FIXME: IDEA-mkBCipher ReservedSAFER = const (Left "SAFER not implemented") -- FIXME: or not?-mkBCipher ReservedDES = const (Left "DES not implemented") -- FIXME: or not?-mkBCipher (OtherSA _) = const (Left "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)+        decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString+        decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct -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+nonceCheck :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool+nonceCheck bc = (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc)  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+    withSymmetricCipher sa keydata (encrypt' payload)     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+        encrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString+        encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -20,8 +20,8 @@     where         keyCreationTime = key^.tkKey._1.timestamp & posixSecondsToUTCTime . realToFrac         keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) +) . unThirtyTwoBitDuration . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (key^.tkUIDs) ++ concatMap snd (key^.tkUAts))-	newest [] = maxBound-	newest xs = maximum xs+        newest [] = maxBound+        newest xs = maximum xs  getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -1,5 +1,5 @@ -- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2015  Clint Adams+-- Copyright © 2012-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -9,8 +9,9 @@ ) where  import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Hash.SHA1 as SHA1+import Crypto.Hash (hashlazy, Digest)+import Crypto.Hash.Algorithms (MD5, SHA1)+import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL import Data.Binary.Put (runPut) @@ -26,5 +27,5 @@ eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (Right . EightOctetKeyId . BL.drop 12 . unTOF . fingerprint) p4  fingerprint :: PKPayload -> TwentyOctetFingerprint-fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . MD5.hashlazy) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))-fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . SHA1.hashlazy) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))+fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest MD5)) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))+fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest SHA1)) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))
Codec/Encryption/OpenPGP/Internal.hs view
@@ -1,5 +1,5 @@--- Internal.hs: private utility functions--- Copyright © 2012-2015  Clint Adams+-- Internal.hs: private utility functions and such+-- Copyright © 2012-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -10,7 +10,6 @@  , beBSToInteger  , integerToBEBS  , PktStreamContext(..)- , hashDescr  , issuer  , emptyPSC  , pubkeyToMPIs@@ -19,16 +18,24 @@  , sigPKA  , sigHA  , sigCT+ , truncatingVerify ) where -import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160)+import Crypto.Hash (hashWith)+import qualified Crypto.Hash.IO as CHI+import Crypto.Number.ModArithmetic (expFast, inverse)+import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA as RSA  import Data.Bits (testBit, shiftL, shiftR, (.&.))+import Data.ByteArray (ByteArrayAccess)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.List (find, mapAccumR, unfoldr)+import Data.Maybe (fromJust) import Data.Word (Word8, Word16)  import Codec.Encryption.OpenPGP.Types@@ -65,16 +72,6 @@         isIssuer _ = False issuer _ = Nothing -hashDescr :: HashAlgorithm -> Either String HashDescr-hashDescr SHA1 = Right hashDescrSHA1-hashDescr RIPEMD160 = Right hashDescrRIPEMD160-hashDescr SHA256 = Right hashDescrSHA256-hashDescr SHA384 = Right hashDescrSHA384-hashDescr SHA512 = Right hashDescrSHA512-hashDescr SHA224 = Right hashDescrSHA224-hashDescr DeprecatedMD5 = Right hashDescrMD5-hashDescr x = Left $ "Unknown hash problem: " ++ show x- pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = [MPI (RSA.public_n k), MPI (RSA.public_e k)] pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) = [@@ -82,7 +79,7 @@                              , pkParams DSA.params_q                              , pkParams DSA.params_g                              , MPI . DSA.public_y $ k-			     ]+                             ]   where pkParams f = MPI . f . DSA.public_params $ k  pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k@@ -115,4 +112,18 @@         isSigCreationTime _ = False sigCT _ = Nothing +truncatingVerify :: (ByteArrayAccess msg, CHI.HashAlgorithm hash) => hash -> DSA.PublicKey -> DSA.Signature -> msg -> Bool+truncatingVerify hashAlg pk (DSA.Signature r s) m+    -- Reject the signature if either 0 < r < q or 0 < s < q is not satisfied.+    | r <= 0 || r >= q || s <= 0 || s >= q = False+    | otherwise                            = v == r+    where (DSA.Params p g q) = DSA.public_params pk+          y       = DSA.public_y pk+          hm      = os2ip . dsaTruncate . BA.convert $ hashWith hashAlg m +          w       = fromJust $ inverse s q+          u1      = (hm*w) `mod` q+          u2      = (r*w) `mod` q+          v       = ((expFast g u1 p) * (expFast y u2 p)) `mod` p `mod` q+          dsaTruncate bs = let lbs = BL.fromStrict bs in if countBits lbs > dsaQLen then B.take (fromIntegral dsaQLen `div` 8) bs else bs -- FIXME: uneven bits+          dsaQLen = countBits . integerToBEBS $ q
+ Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs view
@@ -0,0 +1,43 @@+-- CryptoCipherTypes.hs: shim for crypto-cipher-types stuff (current nettle)+-- Copyright © 2016  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE UndecidableInstances #-}++module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (+    HOWrappedOldCCT(..)+) where++import Control.Error.Util (note)+import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT+import qualified "cryptonite" Crypto.Cipher.Types as CCT+import qualified Data.ByteString as B++import Codec.Encryption.OpenPGP.Internal.HOBlockCipher++newtype HOWrappedOldCCT a = HWOCCT a++instance OldCCT.BlockCipher cipher => HOBlockCipher (HOWrappedOldCCT cipher) where+    cipherInit = fmap HWOCCT . either (const (Left "nettle invalid key"))+                        (Right . OldCCT.cipherInit) . OldCCT.makeKey+    cipherName (HWOCCT c) = OldCCT.cipherName c+    cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c+    blockSize (HWOCCT c) = OldCCT.blockSize c+    cfbEncrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)+    cfbDecrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)+    paddedCfbEncrypt _ _ _ = Left "padding for nettle-encryption not implemented yet"+    paddedCfbDecrypt (HWOCCT cipher) iv ciphertext = hammerIV iv >>= \i -> return (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))+        where+            padded = ciphertext `B.append`+                             B.pack (replicate (OldCCT.blockSize cipher - (B.length ciphertext `mod` OldCCT.blockSize cipher)) 0)++convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier+convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b+convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as+convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a++hammerIV :: OldCCT.BlockCipher cipher => B.ByteString -> Either String (OldCCT.IV cipher)+hammerIV = note "nettle bad IV" . OldCCT.makeIV
+ Codec/Encryption/OpenPGP/Internal/Cryptonite.hs view
@@ -0,0 +1,34 @@+-- Cryptonite.hs: shim for cryptonite+-- Copyright © 2016  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE UndecidableInstances #-}++module Codec.Encryption.OpenPGP.Internal.Cryptonite (+    HOWrappedCCT(..)+) where++import Control.Error.Util (note)+import qualified "cryptonite" Crypto.Cipher.Types as CCT+import qualified Crypto.Error as CE+import Data.Bifunctor (bimap)+import qualified Data.ByteString as B++import Codec.Encryption.OpenPGP.Internal.HOBlockCipher++newtype HOWrappedCCT a = HWCCT a++instance CCT.BlockCipher cipher => HOBlockCipher (HOWrappedCCT cipher) where+    cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit+    cipherName (HWCCT c) = CCT.cipherName c+    cipherKeySize (HWCCT c) = CCT.cipherKeySize c+    blockSize (HWCCT c) = CCT.blockSize c+    cfbEncrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs)+    cfbDecrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs)++hammerIV :: CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher)+hammerIV = note "cryptonite bad IV" . CCT.makeIV
+ Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs view
@@ -0,0 +1,26 @@+-- HOBlockCipher.hs: abstraction for the different BlockCipher classes, plus crazy CFB mode stuff+-- Copyright © 2016  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++{-# LANGUAGE PackageImports #-}++module Codec.Encryption.OpenPGP.Internal.HOBlockCipher (+   HOBlockCipher(..)+) where++import qualified "cryptonite" Crypto.Cipher.Types as CCT++import qualified Data.ByteString as B++class HOBlockCipher cipher where+    cipherInit :: B.ByteString -> Either String cipher+    cipherName :: cipher -> String+    cipherKeySize :: cipher -> CCT.KeySizeSpecifier+    blockSize :: cipher -> Int+    cfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+    cfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+    paddedCfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+    paddedCfbEncrypt = cfbEncrypt+    paddedCfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+    paddedCfbDecrypt = cfbDecrypt
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -10,8 +10,6 @@  import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA-import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as B import Data.Bits (shiftR) import Data.List (unfoldr)
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -54,14 +54,14 @@     where         is = map unI (filter isI us)         as = map unA (filter isA us)-	isI (I _, _) = True-	isI _ = False-	isA (A _, _) = True-	isA _ = False-	unI (I x, y) = (x, y)-	unI x = error $ "unI should never be called on " ++ show x-	unA (A x, y) = (x, y)-	unA x = error $ "unA should never be called on " ++ show x+        isI (I _, _) = True+        isI _ = False+        isA (A _, _) = True+        isA _ = False+        unI (I x, y) = (x, y)+        unI x = error $ "unI should never be called on " ++ show x+        unA (A x, y) = (x, y)+        unA x = error $ "unA should never be called on " ++ show x  publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK) publicTK intolerant = do@@ -115,9 +115,9 @@         isSP True [SignaturePkt sp@(SigV4 {})] = isSP' sp         isSP False [SignaturePkt _] = True         isSP _ _ = False-	isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts-	isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts-	isSP' _ = False+        isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts+        isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts+        isSP' _ = False  signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUID intolerant = do [UserIdPkt u] <- satisfy isUID
Codec/Encryption/OpenPGP/S2K.hs view
@@ -1,5 +1,5 @@ -- S2K.hs: OpenPGP (RFC4880) string-to-key conversion--- Copyright © 2013-2015  Clint Adams+-- Copyright © 2013-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -12,8 +12,9 @@ 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 Crypto.Hash (hashlazy)+import qualified Crypto.Hash as CH+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -24,9 +25,9 @@ string2Key _ _ _ = error "FIXME: unimplemented S2K type"  hf :: HashAlgorithm -> BL.ByteString -> B.ByteString-hf SHA1 = SHA1.hashlazy-hf SHA512 = SHA512.hashlazy-hf _ = error "FIXME: unimplemented S2K hash"+hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)+hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)+hf _ _ = error "FIXME: unimplemented S2K hash"  skesk2Key :: SKESK -> BL.ByteString -> B.ByteString skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass@@ -37,4 +38,4 @@     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)+        bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize)
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -1,5 +1,5 @@--- SecretKey.hs: OpenPGP (RFC4880) secret key decryption--- Copyright © 2013-2015  Clint Adams+-- SecretKey.hs: OpenPGP (RFC4880) secret key encryption/decryption+-- Copyright © 2013-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -10,13 +10,16 @@  , reencryptSecretKeyIO ) where +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.BlockCipher (saBlockSize, keySize)+import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher, keySize) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce) import Codec.Encryption.OpenPGP.Serialize (getSecretKey) import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)-import qualified Crypto.Hash.SHA1 as SHA1-import Crypto.Random (createEntropyPool, cprgCreate, cprgGenerateWithEntropy, SystemRNG)+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import Crypto.Random.EntropyPool (createEntropyPool, getEntropyFrom)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Binary (put)@@ -25,6 +28,8 @@ import Data.Bifunctor (bimap) import qualified Crypto.PubKey.RSA as R +saBlockSize sa = either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize))+ 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)@@ -56,9 +61,8 @@     where         saltiv = do                     ep <- createEntropyPool-                    let gen = cprgCreate ep :: SystemRNG-		        bb = fst (cprgGenerateWithEntropy (8 + saBlockSize AES256) gen)-		    return $ B.splitAt 8 bb+                    bb <- getEntropyFrom ep (8 + saBlockSize AES256)+                    return $ B.splitAt 8 bb  -- |8-octet salt, IV must be length of cipher blocksize encryptPrivateKey :: B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum@@ -74,9 +78,9 @@     where         key = string2Key s2k (keySize AES256) pp         algospecific = runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)-	cksum = SHA1.hashlazy algospecific-	payload = algospecific `BL.append` BL.fromStrict cksum-	u = inverse q p+        cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1+        payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum)+        u = inverse q p encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal  inverse :: Integral a => a -> a -> a
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -1,5 +1,5 @@ -- Signatures.hs: OpenPGP (RFC4880) signature verification--- Copyright © 2012-2015  Clint Adams+-- Copyright © 2012-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -15,12 +15,11 @@ import Control.Lens ((^.), _1) import Control.Monad (liftM2) -import Crypto.PubKey.HashDescr (HashDescr(..))+import qualified Crypto.Hash.Algorithms as CHA import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA.PKCS15 as P15  import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Either (lefts, rights) import Data.IxSet.Typed ((@=))@@ -32,7 +31,7 @@ import Data.Binary.Put (runPut)  import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS, PktStreamContext(..), issuer, emptyPSC, hashDescr)+import Codec.Encryption.OpenPGP.Internal (integerToBEBS, PktStreamContext(..), issuer, emptyPSC, truncatingVerify) import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances ()@@ -124,22 +123,26 @@         subPKP' (PublicSubkeyPkt p) = p         subPKP' (SecretSubkeyPkt p _) = p         subPKP' _ = error "This should never happen (subPKP')"-        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) ha pl = hashDescr ha >>= \hd -> verify'' (pkaAndMPIs s) hd pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA1 pl = verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) RIPEMD160 pl = verify'' (pkaAndMPIs s) CHA.RIPEMD160 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA256 pl = verify'' (pkaAndMPIs s) CHA.SHA256 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA384 pl = verify'' (pkaAndMPIs s) CHA.SHA384 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA512 pl = verify'' (pkaAndMPIs s) CHA.SHA512 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA224 pl = verify'' (pkaAndMPIs s) CHA.SHA224 pub pkey pl+        verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) DeprecatedMD5 pl = verify'' (pkaAndMPIs s) CHA.MD5 pub pkey pl         verify' _ _ _ _ = error "This should never happen (verify')."         verify'' (DSA,mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = verify''' (dsaVerify mpis hd pkey bs) pub         verify'' (RSA,mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = verify''' (rsaVerify mpis hd pkey bs) pub         verify'' _ _ _ _ _ = Left "unimplemented key type"         verify''' f pub = if f then Right pub else Left "verification failed"-        dsaVerify (r:|[s]) hd pkey = DSA.verify (dsaTruncate pkey . hashFunction hd) pkey (dsaMPIsToSig r s)+        dsaVerify (r:|[s]) hd pkey = truncatingVerify hd pkey (dsaMPIsToSig r s)         dsaVerify _ _ _ = const False -- FIXME: this should be some sort of Either chain?-        rsaVerify mpis hd pkey bs = P15.verify hd pkey bs (BL.toStrict (rsaMPItoSig mpis))+        rsaVerify mpis hd pkey bs = P15.verify (Just hd) pkey bs (BL.toStrict (rsaMPItoSig mpis))         dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)-        rsaMPItoSig (sig:|[]) = integerToBEBS (unMPI sig)+        rsaMPItoSig (s:|[]) = integerToBEBS (unMPI s)         hashalgo :: Pkt -> HashAlgorithm         hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha         hashalgo _ = error "This should never happen (hashalgo)."-        dsaTruncate pkey bs = let lbs = BL.fromStrict bs in if countBits lbs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits-        dsaQLen = countBits . integerToBEBS . DSA.params_q . DSA.public_params         pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)         pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."         isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool
Codec/Encryption/OpenPGP/Types.hs view
@@ -1,5 +1,5 @@ -- Types.hs: OpenPGP (RFC4880) data types--- Copyright © 2012-2015  Clint Adams+-- Copyright © 2012-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -27,6 +27,7 @@ import Data.Aeson ((.=), object) import qualified Data.Aeson as A import Data.Byteable (Byteable)+import Data.ByteArray (ByteArrayAccess) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -740,7 +741,7 @@ instance A.ToJSON PKPayload  newtype IV = IV {unIV :: B.ByteString}-    deriving (Byteable, Data, Eq, Generic, Hashable, Monoid, Show, Typeable)+    deriving (Byteable, ByteArrayAccess, Data, Eq, Generic, Hashable, Monoid, Show, Typeable)  instance Newtype IV B.ByteString where     pack = IV
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -1,5 +1,5 @@ -- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption--- Copyright © 2013-2015  Clint Adams+-- Copyright © 2013-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -13,7 +13,9 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Resource (MonadBaseControl, MonadResource, MonadThrow, runResourceT) import qualified Control.Monad.Trans.State.Lazy as S-import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB@@ -49,14 +51,14 @@         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+            | otherwise = case i of                        (SKESKPkt {}) -> return (s { _lastSKESK = Just (fromPkt i) }, [])                        (SymEncDataPkt bs) -> do d <- decryptSEDP (_depth s) cb (fromJust . _lastSKESK $ s) bs                                                 return (processLDPs s d, d)                        (SymEncIntegrityProtectedDataPkt _ bs) -> do d <- decryptSEIPDP (_depth s) cb (fromJust . _lastSKESK $ s) bs                                                                     return (processLDPs s d, d)                        m@(ModificationDetectionCodePkt mdc) -> do when (isNothing (_lastLDP s)) $ fail "MDC with no referent"-                                                                  when (fmap (BL.fromStrict . SHA1.hashlazy . _literalDataPayload) (_lastLDP s) /= Just mdc) $ fail "MDC indicates tampering"+                                                                  when (fmap (BL.fromStrict . BA.convert . (CH.hashlazy :: BL.ByteString -> CH.Digest CHA.SHA1) . _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
bench/mark.hs view
@@ -1,8 +1,10 @@ -- mark.hs: hOpenPGP benchmark suite--- Copyright © 2014-2015  Clint Adams+-- Copyright © 2014-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE FlexibleContexts #-}+ import Criterion.Main  import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys, verifyAgainstKeyring)@@ -30,4 +32,4 @@                    , bench "self-verify keys" $ whnfIO (selfVerifyKeys "tests/data/debian-keyring.gpg")                    , bench "self-verify keyring" $ whnfIO (selfVerifyKeyring "tests/data/debian-keyring.gpg")                    ]-	       ]+               ]
hOpenPGP.cabal view
@@ -1,5 +1,5 @@ Name:                hOpenPGP-Version:             2.2.1+Version:             2.3 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-2015  Clint Adams+Copyright:           2012-2016  Clint Adams Category:            Codec, Data Build-type:          Simple Extra-source-files: tests/suite.hs@@ -169,6 +169,9 @@                      , Data.Conduit.OpenPGP.Keyring.Instances                      , Data.Conduit.OpenPGP.Verify   Other-Modules: Codec.Encryption.OpenPGP.Internal+               , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes+               , Codec.Encryption.OpenPGP.Internal.Cryptonite+               , Codec.Encryption.OpenPGP.Internal.HOBlockCipher                , Codec.Encryption.OpenPGP.SerializeForSigs                , Codec.Encryption.OpenPGP.BlockCipher   Build-depends: aeson@@ -184,17 +187,15 @@                , conduit               >= 0.5    && < 1.3                , conduit-extra         >= 1.1                , containers+               , cryptonite            >= 0.5                , crypto-cipher-types-               , crypto-pubkey         >= 0.2.3-               , crypto-random-               , cryptocipher-               , cryptohash                , data-default-class                , errors                , hashable                , incremental-parser                , ixset-typed                , lens                  >= 3.0+               , memory                , monad-loops                , nettle                , newtype@@ -235,17 +236,15 @@                , conduit                , conduit-extra                , containers+               , cryptonite            >= 0.5                , crypto-cipher-types-               , crypto-pubkey         >= 0.2.3-               , crypto-random-               , cryptocipher-               , cryptohash                , data-default-class                , errors                , hashable                , incremental-parser                , ixset-typed                , lens                  >= 3.0+               , memory                , monad-loops                , nettle                , newtype@@ -288,17 +287,15 @@                , conduit               >= 0.5    && < 1.3                , conduit-extra         >= 1.1                , containers+               , cryptonite            >= 0.5                , crypto-cipher-types-               , crypto-pubkey         >= 0.2.3-               , crypto-random-               , cryptocipher-               , cryptohash                , data-default-class                , errors                , hashable                , incremental-parser                , ixset-typed                , lens                  >= 3.0+               , memory                , monad-loops                , nettle                , newtype@@ -328,4 +325,4 @@ source-repository this   type:     git   location: git://git.debian.org/users/clint/hOpenPGP.git-  tag:      v2.2.1+  tag:      v2.3
tests/suite.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}  -- suite.hs: hOpenPGP test suite--- Copyright © 2012-2015  Clint Adams+-- Copyright © 2012-2016  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -88,8 +88,8 @@     case runGet (get :: Get Pkt) bs of         Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke."         Right (PublicKeyPkt pkp) -> do-	                               assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (fingerprint pkp)))-	                               assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (SpacedFingerprint (fingerprint pkp))))+                                       assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (fingerprint pkp)))+                                       assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (SpacedFingerprint (fingerprint pkp))))         _ -> assertFailure "Expected public key, got something else."     where         spaceless = filter (/=' ')