diff --git a/Codec/Encryption/OpenPGP/Compression.hs b/Codec/Encryption/OpenPGP/Compression.hs --- a/Codec/Encryption/OpenPGP/Compression.hs +++ b/Codec/Encryption/OpenPGP/Compression.hs @@ -1,5 +1,5 @@ -- Compression.hs: OpenPGP (RFC4880) compression and decompression --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -26,10 +26,11 @@ Right packs -> unBlock packs where decompressPkt' :: CompressionAlgorithm -> ByteString -> BL.ByteString - decompressPkt' ZIP bs = ZlibRaw.decompress $ BL.fromChunks [bs] - decompressPkt' ZLIB bs = Zlib.decompress $ BL.fromChunks [bs] - decompressPkt' BZip2 bs = BZip.decompress $ BL.fromChunks [bs] - decompressPkt' _ _ = error "Compression algorithm not supported" + decompressPkt' ca bs = dfunc ca (BL.fromChunks [bs]) + dfunc ZIP = ZlibRaw.decompress + dfunc ZLIB = Zlib.decompress + dfunc BZip2 = BZip.decompress + dfunc _ = error "Compression algorithm not supported" decompressPkt p = [p] compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt @@ -39,7 +40,8 @@ CompressedDataPkt ca cbs where compressPkts' :: CompressionAlgorithm -> ByteString -> BL.ByteString - compressPkts' ZIP bs = ZlibRaw.compress $ BL.fromChunks [bs] - compressPkts' ZLIB bs = Zlib.compress $ BL.fromChunks [bs] - compressPkts' BZip2 bs = BZip.compress $ BL.fromChunks [bs] - compressPkts' _ _ = error "Compression algorithm not supported" + compressPkts' ca bs = cfunc ca (BL.fromChunks [bs]) + cfunc ZIP = ZlibRaw.compress + cfunc ZLIB = Zlib.compress + cfunc BZip2 = BZip.compress + cfunc _ = error "Compression algorithm not supported" diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -1,5 +1,5 @@ -- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -8,7 +8,7 @@ , fingerprint ) where -import qualified Crypto.Cipher.RSA as RSA +import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as B diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -1,5 +1,5 @@ -- Internal.hs: private utility functions --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -8,31 +8,21 @@ , beBSToInteger , integerToBEBS , PktStreamContext(..) - , asn1Prefix - , hash + , hashDescr , issuer , emptyPSC , pubkeyToMPIs ) where -import qualified Crypto.Cipher.DSA as DSA -import qualified Crypto.Cipher.RSA as RSA - -import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA224 as SHA224 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.Hash.SHA384 as SHA384 -import qualified Crypto.Hash.SHA512 as SHA512 +import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.RSA as RSA -import qualified Data.ASN1.BinaryEncoding as ASN1BE -import qualified Data.ASN1.Encoding as ASN1E -import qualified Data.ASN1.Stream as ASN1S import Data.Bits (testBit, shiftL, shiftR, (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC8 import Data.List (find, mapAccumR, unfoldr) import Data.Word (Word8, Word16) @@ -68,42 +58,15 @@ isIssuer _ = False issuer _ = Nothing -hash :: HashAlgorithm -> ByteString -> ByteString -hash SHA1 = SHA1.hash -hash RIPEMD160 = RIPEMD160.hash -hash SHA256 = SHA256.hash -hash SHA384 = SHA384.hash -hash SHA512 = SHA512.hash -hash SHA224 = SHA224.hash -hash DeprecatedMD5 = MD5.hash -hash _ = id -- FIXME - -asn1Prefix :: HashAlgorithm -> ByteString -asn1Prefix ha = do - let start = ASN1S.Start ASN1S.Sequence - let (blen, oid) = (bitLength ha, hashOid ha) - let numpty = ASN1S.Null - let end = ASN1S.End ASN1S.Sequence - let fakeint = ASN1S.OctetString (BL.pack (replicate ((blen `div` 8) - 1) 0 ++ [1])) - B.concat . BL.toChunks $ getPrefix (ASN1E.encodeASN1 ASN1BE.DER [start,start,oid,numpty,end,fakeint,end]) - where - getPrefix = BL.reverse . BL.dropWhile (==0) . BL.drop 1 . BL.reverse - bitLength DeprecatedMD5 = 128 - bitLength SHA1 = 160 - bitLength RIPEMD160 = 160 - bitLength SHA256 = 256 - bitLength SHA384 = 384 - bitLength SHA512 = 512 - bitLength SHA224 = 224 - bitLength _ = 0 - hashOid DeprecatedMD5 = ASN1S.OID [1,2,840,113549,2,5] - hashOid RIPEMD160 = ASN1S.OID [1,3,36,3,2,1] - hashOid SHA1 = ASN1S.OID [1,3,14,3,2,26] - hashOid SHA224 = ASN1S.OID [2,16,840,1,101,3,4,2,4] - hashOid SHA256 = ASN1S.OID [2,16,840,1,101,3,4,2,1] - hashOid SHA384 = ASN1S.OID [2,16,840,1,101,3,4,2,2] - hashOid SHA512 = ASN1S.OID [2,16,840,1,101,3,4,2,3] - hashOid _ = ASN1S.OID [] +hashDescr :: HashAlgorithm -> HashDescr +hashDescr SHA1 = hashDescrSHA1 +hashDescr RIPEMD160 = HashDescr (RIPEMD160.hash) (B.append (BC8.pack "\x30\x21\x30\x09\x06\x05\x2b\x24\x03\x02\x01\x05\x00\x04\x14")) +hashDescr SHA256 = hashDescrSHA256 +hashDescr SHA384 = hashDescrSHA384 +hashDescr SHA512 = hashDescrSHA512 +hashDescr SHA224 = hashDescrSHA224 +hashDescr DeprecatedMD5 = hashDescrMD5 +hashDescr _ = error "Hash problem" -- FIXME pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey k) = [MPI (RSA.public_n k), MPI (RSA.public_e k)] 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 @@ -1,5 +1,5 @@ -- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -8,10 +8,10 @@ ) where import Control.Applicative ((<$>),(<*>)) -import Control.Monad (replicateM, mplus) -import qualified Crypto.Cipher.RSA as R -import qualified Crypto.Cipher.DSA as D -import Data.Bits ((.&.), (.|.), shiftL, shiftR) +import Control.Monad (guard, mplus, replicateM) +import qualified Crypto.PubKey.RSA as R +import qualified Crypto.PubKey.DSA as D +import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 @@ -471,7 +471,8 @@ getPacketTypeAndPayload :: Get (Word8, ByteString) getPacketTypeAndPayload = do - tag <- getWord8 -- FIXME: bit 7 must be 1, check? + tag <- getWord8 + guard (testBit tag 7) case tag .&. 0x40 of 0x00 -> do let t = shiftR (tag .&. 0x3c) 2 @@ -784,22 +785,10 @@ do MPI x <- get return $ ElGamalPrivateKey [x] --- indefiniteMPIs :: ByteString -> [MPI] --- indefiniteMPIs bs = do --- case runGet (many getMPI) bs of --- Left e -> error e --- Right mpis -> mpis - putMPI :: MPI -> Put putMPI (MPI i) = do let bs = integerToBEBS i putWord16be . countBits $ bs putByteString bs - --- getPackets :: Get (Block Pkt) --- getPackets = Block `fmap` many getPkt - --- putPackets :: Block Pkt -> Put --- putPackets = mapM_ putPkt . unBlock getPKPayload :: Get PKPayload getPKPayload = do diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -1,5 +1,5 @@ -- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). 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 @@ -1,9 +1,9 @@ -- Types.hs: OpenPGP (RFC4880) data types --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). -{-# LANGUAGE ExistentialQuantification, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, TemplateHaskell, TypeFamilies #-} module Codec.Encryption.OpenPGP.Types ( SigSubPacket(..) @@ -61,16 +61,19 @@ , Verification(..) ) where -import qualified Crypto.Cipher.RSA as RSA -import qualified Crypto.Cipher.DSA as DSA +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.DSA as DSA import Control.Arrow ((***)) +import Control.Lens (makeLenses) import Data.ByteString (ByteString) -import Data.Char (toLower, toUpper) import qualified Data.ByteString as B +import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.IxSet (IxSet) import Data.List.Split (chunksOf) -import Data.Map (Map) import Data.Set (Set) +import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32) import Numeric (readHex, showHex) @@ -108,7 +111,7 @@ | AES256 | Twofish | OtherSA Word8 - deriving (Show) + deriving (Data, Show, Typeable) instance Eq SymmetricAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -144,7 +147,7 @@ data NotationFlag = HumanReadable | OtherNF Int - deriving (Show) + deriving (Data, Show, Typeable) instance Eq NotationFlag where (==) a b = fromFFlag a == fromFFlag b @@ -162,7 +165,7 @@ data SigSubPacket = SigSubPacket { sspCriticality :: Bool , sspPayload :: SigSubPacketPayload - } deriving Eq + } deriving (Data, Eq, Typeable) instance Show SigSubPacket where show x = (if sspCriticality x then "*" else "") ++ (show . sspPayload) x @@ -192,7 +195,7 @@ | EmbeddedSignature SignaturePayload | UserDefinedSigSub Word8 ByteString | OtherSigSub Word8 ByteString - deriving (Show, Eq) -- FIXME + deriving (Data, Eq, Show, Typeable) -- FIXME data HashAlgorithm = DeprecatedMD5 | SHA1 @@ -202,7 +205,7 @@ | SHA512 | SHA224 | OtherHA Word8 - deriving (Show) + deriving (Data, Show, Typeable) instance Eq HashAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -233,7 +236,7 @@ | ZLIB | BZip2 | OtherCA Word8 - deriving (Show) + deriving (Show, Data, Typeable) instance Eq CompressionAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -267,7 +270,7 @@ | Elgamal | DH | OtherPKA Word8 - deriving (Show) + deriving (Show, Data, Typeable) instance Eq PubKeyAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -303,7 +306,7 @@ data KSPFlag = NoModify | KSPOther Int - deriving (Show) + deriving (Data, Show, Typeable) instance Eq KSPFlag where (==) a b = fromFFlag a == fromFFlag b @@ -326,7 +329,7 @@ | SignDataKey | CertifyKeysKey | KFOther Int - deriving (Show) + deriving (Data, Show, Typeable) instance Eq KeyFlag where (==) a b = fromFFlag a == fromFFlag b @@ -355,7 +358,7 @@ data RevocationClass = SensitiveRK | RClOther Int - deriving (Show) + deriving (Data, Show, Typeable) instance Eq RevocationClass where (==) a b = fromFFlag a == fromFFlag b @@ -376,7 +379,7 @@ | KeyRetiredAndNoLongerUsed | UserIdInfoNoLongerValid | RCoOther Word8 - deriving (Show) + deriving (Show, Data, Typeable) instance Eq RevocationCode where (==) a b = fromFVal a == fromFVal b @@ -400,7 +403,7 @@ data FeatureFlag = ModificationDetection | FeatureOther Int - deriving (Show) + deriving (Show, Data, Typeable) instance Eq FeatureFlag where (==) a b = fromFFlag a == fromFFlag b @@ -416,28 +419,31 @@ toFFlag i = FeatureOther (fromIntegral i) newtype MPI = MPI {unMPI :: Integer} - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) data SignaturePayload = SigV3 SigType Word32 EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 [MPI] | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 [MPI] | SigVOther Word8 ByteString - deriving (Show, Eq) -- FIXME + deriving (Data, Eq, Show, Typeable) -- FIXME data PKPayload = DeprecatedPubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey | PubV4 TimeStamp PubKeyAlgorithm PKey - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) +instance Ord PKPayload where + compare a b = show a `compare` show b -- FIXME: this is ridiculous + data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString | SUSSHA1 SymmetricAlgorithm S2K IV ByteString | SUSym SymmetricAlgorithm IV ByteString | SUUnencrypted SKey Word16 - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) data DataType = BinaryData | TextData | UTF8Data | OtherData Word8 - deriving (Show) + deriving (Show, Data, Typeable) instance Eq DataType where (==) a b = fromFVal a == fromFVal b @@ -460,18 +466,18 @@ | Salted HashAlgorithm Salt | IteratedSalted HashAlgorithm Salt Count | OtherS2K Word8 ByteString - deriving (Show, Eq) -- FIXME + deriving (Data, Eq, Show, Typeable) -- FIXME data UserAttrSubPacket = ImageAttribute ImageHeader ImageData | OtherUASub Word8 ByteString - deriving (Show, Eq) -- FIXME + deriving (Data, Eq, Show, Typeable) -- FIXME data ImageHeader = ImageHV1 ImageFormat - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) data ImageFormat = JPEG | OtherImage Word8 - deriving (Show) + deriving (Data, Show, Typeable) instance Eq ImageFormat where (==) a b = fromFVal a == fromFVal b @@ -502,7 +508,7 @@ | TimestampSig | ThirdPartyConfirmationSig | OtherSig Word8 - deriving (Show) + deriving (Data, Show, Typeable) instance Eq SigType where (==) a b = fromFVal a == fromFVal b @@ -548,18 +554,18 @@ data PKey = RSAPubKey RSA.PublicKey | DSAPubKey DSA.PublicKey | ElGamalPubKey [Integer] - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) data SKey = RSAPrivateKey RSA.PrivateKey | DSAPrivateKey DSA.PrivateKey | ElGamalPrivateKey [Integer] - deriving (Show, Eq) + deriving (Data, Eq, Show, Typeable) newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance deriving (Show, Eq) newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString} - deriving (Eq, Ord) -- FIXME + deriving (Eq, Ord, Data, Typeable) -- FIXME instance Show EightOctetKeyId where show = w8sToHex . B.unpack . unEOKI @@ -568,7 +574,7 @@ readsPrec _ = map ((EightOctetKeyId . B.pack *** concat) . unzip) . chunksOf 8 . hexToW8s newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString} - deriving (Eq) + deriving (Eq, Ord, Data, Typeable) instance Show TwentyOctetFingerprint where show = take 50 . concatMap (++" ") . concatMap (++[""]) . chunksOf 5 . chunksOf 4 . w8sToHex . B.unpack . unTOF @@ -583,24 +589,23 @@ hexToW8s = concatMap readHex . chunksOf 2 . map toLower data TK = TK { - tkPKP :: PKPayload - , tkmSKA :: Maybe SKAddendum - , tkRevs :: [SignaturePayload] - , tkUIDs :: [(String, [SignaturePayload])] - , tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] - , tkSubs :: [(Pkt, SignaturePayload, Maybe SignaturePayload)] - } - deriving (Eq, Show) + _tkPKP :: PKPayload + , _tkmSKA :: Maybe SKAddendum + , _tkRevs :: [SignaturePayload] + , _tkUIDs :: [(String, [SignaturePayload])] + , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] + , _tkSubs :: [(Pkt, SignaturePayload, Maybe SignaturePayload)] + } deriving (Data, Eq, Show, Typeable) instance Ord TK where compare a b = show a `compare` show b -- FIXME: this is ridiculous -type Keyring = Map EightOctetKeyId (Set TK) +type Keyring = IxSet TK class Packet a where data PacketType a :: * packetType :: a -> PacketType a -   packetCode :: PacketType a -> Word8 + packetCode :: PacketType a -> Word8 toPkt :: a -> Pkt fromPkt :: Pkt -> a @@ -623,14 +628,14 @@ | SymEncIntegrityProtectedDataPkt PacketVersion ByteString | ModificationDetectionCodePkt ByteString | OtherPacketPkt Word8 ByteString - deriving (Show, Eq) -- FIXME + deriving (Show, Eq, Data, Typeable) -- FIXME data PKESK = PKESK { pkeskPacketVersion :: PacketVersion , pkeskEightOctetKeyId :: EightOctetKeyId , pkeskPubKeyAlgorithm :: PubKeyAlgorithm , pkeskMPIs :: [MPI] - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet PKESK where data PacketType PKESK = PKESKType packetType _ = PKESKType @@ -640,7 +645,7 @@ data Signature = Signature -- FIXME? { signaturePayload :: SignaturePayload - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet Signature where data PacketType Signature = SignatureType packetType _ = SignatureType @@ -653,7 +658,7 @@ , skeskSymmetricAlgorithm :: SymmetricAlgorithm , skeskS2K :: S2K , skeskMPIs :: [MPI] - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet SKESK where data PacketType SKESK = SKESKType packetType _ = SKESKType @@ -668,7 +673,7 @@ , onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm , onePassSignatureEightOctetKeyId :: EightOctetKeyId , onePassSignatureNestedFlag :: NestedFlag - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet OnePassSignature where data PacketType OnePassSignature = OnePassSignatureType packetType _ = OnePassSignatureType @@ -679,7 +684,7 @@ data SecretKey = SecretKey { secretKeyPKPayload :: PKPayload , secretKeySKAddendum :: SKAddendum - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet SecretKey where data PacketType SecretKey = SecretKeyType packetType _ = SecretKeyType @@ -689,7 +694,7 @@ data PublicKey = PublicKey { publicKeyPKPayload :: PKPayload - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet PublicKey where data PacketType PublicKey = PublicKeyType packetType _ = PublicKeyType @@ -700,7 +705,7 @@ data SecretSubkey = SecretSubkey { secretSubkeyPKPayload :: PKPayload , secretSubkeySKAddendum :: SKAddendum - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet SecretSubkey where data PacketType SecretSubkey = SecretSubkeyType packetType _ = SecretSubkeyType @@ -711,7 +716,7 @@ data CompressedData = CompressedData { compressedDataCompressionAlgorithm :: CompressionAlgorithm , compressedDataPayload :: CompressedDataPayload - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet CompressedData where data PacketType CompressedData = CompressedDataType packetType _ = CompressedDataType @@ -721,7 +726,7 @@ data SymEncData = SymEncData { symEncDataPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet SymEncData where data PacketType SymEncData = SymEncDataType packetType _ = SymEncDataType @@ -731,7 +736,7 @@ data Marker = Marker { markerPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet Marker where data PacketType Marker = MarkerType packetType _ = MarkerType @@ -744,7 +749,7 @@ , literalDataFileName :: FileName , literalDataTimeStamp :: TimeStamp , literalDataPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet LiteralData where data PacketType LiteralData = LiteralDataType packetType _ = LiteralDataType @@ -754,7 +759,7 @@ data Trust = Trust { trustPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet Trust where data PacketType Trust = TrustType packetType _ = TrustType @@ -764,7 +769,7 @@ data UserId = UserId { userIdPayload :: String - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet UserId where data PacketType UserId = UserIdType packetType _ = UserIdType @@ -774,7 +779,7 @@ data PublicSubkey = PublicSubkey { publicSubkeyPKPayload :: PKPayload - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet PublicSubkey where data PacketType PublicSubkey = PublicSubkeyType packetType _ = PublicSubkeyType @@ -784,7 +789,7 @@ data UserAttribute = UserAttribute { userAttributeSubPackets :: [UserAttrSubPacket] - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet UserAttribute where data PacketType UserAttribute = UserAttributeType packetType _ = UserAttributeType @@ -795,7 +800,7 @@ data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData { symEncIntegrityProtectedDataPacketVersion :: PacketVersion , symEncIntegrityProtectedDataPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet SymEncIntegrityProtectedData where data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType packetType _ = SymEncIntegrityProtectedDataType @@ -805,7 +810,7 @@ data ModificationDetectionCode = ModificationDetectionCode { modificationDetectionCodePayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet ModificationDetectionCode where data PacketType ModificationDetectionCode = ModificationDetectionCodeType packetType _ = ModificationDetectionCodeType @@ -816,7 +821,7 @@ data OtherPacket = OtherPacket { otherPacketType :: Word8 , otherPacketPayload :: ByteString - } deriving (Show, Eq) + } deriving (Data, Eq, Show, Typeable) instance Packet OtherPacket where data PacketType OtherPacket = OtherPacketType packetType _ = OtherPacketType @@ -828,3 +833,5 @@ verificationSigner :: PKPayload , verificationSignature :: SignaturePayload } + +$(makeLenses ''TK) diff --git a/Codec/Encryption/OpenPGP/Verify.hs b/Codec/Encryption/OpenPGP/Verify.hs --- a/Codec/Encryption/OpenPGP/Verify.hs +++ b/Codec/Encryption/OpenPGP/Verify.hs @@ -1,5 +1,5 @@ -- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -11,22 +11,25 @@ import Control.Monad (guard, liftM2) -import qualified Crypto.Cipher.DSA as DSA -import qualified Crypto.Cipher.RSA as RSA +import Crypto.PubKey.HashDescr (HashDescr(..)) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as P15 import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Either (lefts, rights) -import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.IxSet ((@=)) +import qualified Data.IxSet as IxSet import Data.Time.Clock (UTCTime(..), diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Serialize.Put (runPut) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS, PktStreamContext(..), hash, issuer, emptyPSC, asn1Prefix) +import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS, PktStreamContext(..), issuer, emptyPSC, hashDescr) import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Keyring.Instances () verifySig :: Keyring -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? verifySig kr sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do @@ -43,14 +46,14 @@ verifyTK kr mt key = do revokers <- checkRevokers key revs <- checkKeyRevocations revokers key - let uids = filter (\(_, sps) -> sps == []) . checkUidSigs $ tkUIDs key -- FIXME: check revocations here? - let uats = filter (\(_, sps) -> sps == []) . checkUAtSigs $ tkUAts key -- FIXME: check revocations here? - let subs = concatMap checkSub $ tkSubs key -- FIXME: check revocations here? - return (TK (tkPKP key) (tkmSKA key) revs uids uats subs) + let uids = filter (\(_, sps) -> sps /= []) . checkUidSigs $ _tkUIDs key -- FIXME: check revocations here? + let uats = filter (\(_, sps) -> sps /= []) . checkUAtSigs $ _tkUAts key -- FIXME: check revocations here? + let subs = concatMap checkSub $ _tkSubs key -- FIXME: check revocations here? + return (TK (_tkPKP key) (_tkmSKA key) revs uids uats subs) where - checkRevokers = Right . concat . rights . map verifyRevoker . filter isRevokerP . tkRevs + checkRevokers = Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkRevs checkKeyRevocations :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> TK -> Either String [SignaturePayload] - checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) (vSig kr)) . tkRevs $ k + checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) (vSig kr)) . _tkRevs $ k checkUidSigs :: [(String, [SignaturePayload])] -> [(String, [SignaturePayload])] checkUidSigs = map (\(uid, sps) -> (uid, (rights . map (\sp -> fmap (const sp) (vUid kr (uid, sp)))) sps)) checkUAtSigs :: [([UserAttrSubPacket], [SignaturePayload])] -> [([UserAttrSubPacket], [SignaturePayload])] @@ -78,13 +81,13 @@ isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False vUid :: Keyring -> (String, SignaturePayload) -> Either String Verification - vUid keyring (uid, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (tkPKP key), lastUIDorUAt = UserIdPkt uid } mt + vUid keyring (uid, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserIdPkt uid } mt vUAt :: Keyring -> ([UserAttrSubPacket], SignaturePayload) -> Either String Verification - vUAt keyring (uat, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (tkPKP key), lastUIDorUAt = UserAttributePkt uat } mt + vUAt keyring (uat, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserAttributePkt uat } mt vSig :: Keyring -> SignaturePayload -> Either String Verification - vSig keyring sp = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (tkPKP key) } mt + vSig keyring sp = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key) } mt vSubSig :: Keyring -> Pkt -> SignaturePayload -> Bool - vSubSig keyring sk sp = case verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (tkPKP key), lastSubkey = sk} mt of + vSubSig keyring sk sp = case verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastSubkey = sk} mt of Left _ -> False Right _ -> True verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)] @@ -95,8 +98,8 @@ verify :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification verify kr sig mt payload = do i <- maybe (Left "issuer not found") Right (issuer sig) - tpkset <- maybe (Left "pubkey not found") Right (Map.lookup i kr) - let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> tkPKP x:map subPKP (tkSubs x)) (Set.toAscList tpkset)) + potentialmatches <- if IxSet.null (kr @= i) then Left "pubkey not found" else Right (kr @= i) + let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) (IxSet.toList potentialmatches)) let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps case rights results of [] -> Left (concatMap (++"/") (lefts results)) @@ -112,12 +115,9 @@ verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis ha pkey bs) pub verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis ha pkey bs) pub verify'' _ _ _ _ _ = Left "unimplemented key type" - verify''' f pub = case f of - Left _ -> Left "invalid signature" - Right False -> Left "verification failed" - Right True -> Right pub - dsaVerify mpis ha pkey bs = DSA.verify (dsaMPIsToSig mpis) (dsaTruncate pkey . hash ha) pkey bs - rsaVerify mpis ha pkey bs = RSA.verify (hash ha) (asn1Prefix ha) pkey bs (rsaMPItoSig mpis) + 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 + rsaVerify mpis ha pkey bs = P15.verify (hashDescr ha) pkey bs (rsaMPItoSig mpis) dsaMPIsToSig mpis = (unMPI (mpis !! 0), unMPI (mpis !! 1)) rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis)) finalPayload s pl = B.concat [pl, sigbit s, trailer s] @@ -137,4 +137,4 @@ isSignatureExpired s (Just t) = if any (expiredBefore t) ((\(SigV4 _ _ _ h _ _ _) -> h) . signaturePayload . fromPkt $ s) then Left "signature expired" else return True expiredBefore :: UTCTime -> SigSubPacket -> Bool expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < 0 - expiredBefore ct _ = False + expiredBefore _ _ = False diff --git a/Data/Conduit/OpenPGP/Compression.hs b/Data/Conduit/OpenPGP/Compression.hs --- a/Data/Conduit/OpenPGP/Compression.hs +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -1,5 +1,5 @@ -- Compression.hs: OpenPGP (RFC4880) compression conduits --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -1,5 +1,5 @@ -- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -11,13 +11,12 @@ import qualified Data.ByteString as B import Data.Conduit +import qualified Data.Conduit.List as CL import qualified Data.Conduit.Util as CU - -import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.IxSet (empty, insert) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Keyring.Instances () data Phase = MainKey | Revs | Uids | UAts | Subs deriving (Eq, Ord, Show) @@ -86,13 +85,4 @@ dropOrError False s _ = CU.StateProducing s [] sinkKeyringMap :: MonadResource m => Sink TK m Keyring -sinkKeyringMap = CU.sinkState Map.empty push close - where - push :: MonadResource m => Keyring -> TK -> m (CU.SinkStateResult Keyring TK Keyring) - push state input = return . CU.StateProcessing $ foldl (\m x -> Map.insert x (newset x input m) m) state (eoks input) - close = return - eoks (TK pkp _ _ _ _ subs) = eightOctetKeyID pkp:map (eightOctetKeyID . pl . \(x,_,_) -> x) subs - pl (PublicSubkeyPkt pkp) = pkp - pl (SecretSubkeyPkt pkp _) = pkp - newset eok i s = Set.insert i (oldset eok s) - oldset = Map.findWithDefault Set.empty +sinkKeyringMap = CL.fold (flip insert) empty diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -0,0 +1,28 @@ +-- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys +-- Copyright © 2012-2013 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + +module Data.Conduit.OpenPGP.Keyring.Instances ( +) where + +import Data.IxSet (Proxy(..), Indexable(..), ixSet, ixGen, ixFun) + +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Types + +import Control.Lens ((^..)) +import Data.Data.Lens (biplate) + +instance Indexable TK where + empty = ixSet + [ ixGen (Proxy :: Proxy PKPayload) + , ixFun getEOKIs + , ixFun getTOFs + ] + +getEOKIs :: TK -> [EightOctetKeyId] +getEOKIs tk = map eightOctetKeyID (tk ^.. biplate :: [PKPayload]) +getTOFs :: TK -> [TwentyOctetFingerprint] +getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload]) + diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -1,5 +1,5 @@ -- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright © 2012 Clint Adams +Copyright © 2012-2013 Clint Adams Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.5.2 +Version: 0.6 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 -Copyright: 2012, Clint Adams +Copyright: 2012-2013 Clint Adams Category: Codec, Data Build-type: Simple Extra-source-files: tests/suite.hs @@ -123,11 +123,11 @@ , Codec.Encryption.OpenPGP.Verify , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Keyring + , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Verify Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.SerializeForSigs - Build-depends: asn1-data > 0.7 - , attoparsec + Build-depends: attoparsec , base > 4 && < 5 , base64-bytestring , bytestring @@ -136,8 +136,10 @@ , cereal-conduit >= 0.6 && < 0.7 , conduit >= 0.5 && < 0.6 , containers - , cryptocipher >= 0.3.6 + , crypto-pubkey >= 0.1.1 , cryptohash + , ixset >= 1.0 + , lens >= 3.0 , mtl , openpgp-asciiarmor >= 0.1 , split @@ -150,20 +152,18 @@ type: exitcode-stdio-1.0 main-is: tests/suite.hs Ghc-options: -Wall - Build-depends: asn1-data > 0.7 - , attoparsec + Build-depends: hOpenPGP , base > 4 && < 5 - , base64-bytestring , bytestring , bzlib , cereal , cereal-conduit >= 0.6 && < 0.7 , conduit >= 0.5 && < 0.6 , containers - , cryptocipher >= 0.3.6 + , crypto-pubkey >= 0.1.1 , cryptohash - , mtl - , openpgp-asciiarmor >= 0.1 + , ixset >= 1.0 + , lens >= 3.0 , split , time >= 1.1 , zlib diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- suite.hs: hOpenPGP test suite --- Copyright © 2012 Clint Adams +-- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the ISC license. -- (See the LICENSE file). @@ -20,7 +20,7 @@ import Data.Conduit.OpenPGP.Verify (conduitVerify) import qualified Data.ByteString as B -import qualified Data.Map as Map +import Data.IxSet ((@=), getOne) import Data.Maybe (isJust) import Data.Serialize (get, put) import Data.Serialize.Get (runGet, Get) @@ -77,7 +77,7 @@ testKeyringLookup :: FilePath -> String -> Bool -> Assertion testKeyringLookup fpr eok expected = do kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap - let key = (Map.lookup (read eok) kr) + let key = getOne (kr @= (read eok :: EightOctetKeyId)) assertEqual (eok ++ " in " ++ fpr) expected (isJust key) testVerifyMessage :: FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion