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 @@ -4,8 +4,8 @@ -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Compression ( - decompressPacket - , compressPackets + decompressPkt + , compressPkts ) where import qualified Codec.Compression.BZip as BZip @@ -20,26 +20,26 @@ import Data.Serialize.Get (runGet) import Data.Serialize.Put (runPut) -decompressPacket :: Packet -> [Packet] -decompressPacket (CompressedData algo bs') = case (runGet get . B.concat . BL.toChunks) (decompressPacket' algo bs') of +decompressPkt :: Pkt -> [Pkt] +decompressPkt (CompressedDataPkt algo bs') = case (runGet get . B.concat . BL.toChunks) (decompressPkt' algo bs') of Left _ -> [] Right packs -> unBlock packs where - decompressPacket' :: CompressionAlgorithm -> ByteString -> BL.ByteString - decompressPacket' ZIP bs = ZlibRaw.decompress $ BL.fromChunks [bs] - decompressPacket' ZLIB bs = Zlib.decompress $ BL.fromChunks [bs] - decompressPacket' BZip2 bs = BZip.decompress $ BL.fromChunks [bs] - decompressPacket' _ _ = error "Compression algorithm not supported" -decompressPacket p = [p] + 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 p = [p] -compressPackets :: CompressionAlgorithm -> [Packet] -> Packet -compressPackets ca packs = do +compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt +compressPkts ca packs = do let bs' = runPut $ put (Block packs) - let cbs = B.concat . BL.toChunks $ compressPackets' ca bs' - CompressedData ca cbs + let cbs = B.concat . BL.toChunks $ compressPkts' ca bs' + CompressedDataPkt ca cbs where - compressPackets' :: CompressionAlgorithm -> ByteString -> BL.ByteString - compressPackets' ZIP bs = ZlibRaw.compress $ BL.fromChunks [bs] - compressPackets' ZLIB bs = Zlib.compress $ BL.fromChunks [bs] - compressPackets' BZip2 bs = BZip.compress $ BL.fromChunks [bs] - compressPackets' _ _ = error "Compression algorithm not supported" + 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" 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 @@ -8,16 +8,21 @@ , fingerprint ) where +import qualified Crypto.Cipher.RSA as RSA +import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as B import Data.Serialize.Put (runPut) import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting) +import Codec.Encryption.OpenPGP.Internal (integerToBEBS) import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: PKPayload -> EightOctetKeyId -eightOctetKeyID = EightOctetKeyId . B.drop 12 . unTOF . fingerprint +eightOctetKeyID (DeprecatedPubV3 _ _ RSA (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp +eightOctetKeyID p4@(PubV4 {}) = (EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4 +eightOctetKeyID _ = error "This should never happen." fingerprint :: PKPayload -> TwentyOctetFingerprint -fingerprint (PubV4 ts pka pk) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKey (PubV4 ts pka pk))) -fingerprint _ = error "non-V4 not implemented" +fingerprint p3@(DeprecatedPubV3 {}) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3)) +fingerprint p4@(PubV4 {}) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4)) 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 @@ -7,14 +7,35 @@ countBits , beBSToInteger , integerToBEBS + , PktStreamContext(..) + , asn1Prefix + , hash + , 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 qualified Data.ASN1.DER as DER import Data.Bits (testBit, shiftL, shiftR, (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Data.List (mapAccumR, unfoldr) +import qualified Data.ByteString.Lazy as BL +import Data.List (find, mapAccumR, unfoldr) import Data.Word (Word8, Word16) +import Codec.Encryption.OpenPGP.Types + countBits :: ByteString -> Word16 countBits bs = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7) where @@ -27,3 +48,64 @@ integerToBEBS :: Integer -> ByteString integerToBEBS = B.pack . reverse . unfoldr (\x -> if x == 0 then Nothing else Just ((fromIntegral x :: Word8) .&. 0xff, x `shiftR` 8)) + +data PktStreamContext = PktStreamContext { lastLD :: Pkt + , lastUIDorUAt :: Pkt + , lastSig :: Pkt + , lastPrimaryKey :: Pkt + , lastSubkey :: Pkt + } + +emptyPSC :: PktStreamContext +emptyPSC = PktStreamContext (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty) + +issuer :: Pkt -> Maybe EightOctetKeyId +issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuer usubs) + where + isIssuer (SigSubPacket _ (Issuer _)) = True + 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 = DER.Start DER.Sequence + let (blen, oid) = (bitLength ha, hashOid ha) + let numpty = DER.Null + let end = DER.End DER.Sequence + let fakeint = DER.OctetString (BL.pack (replicate ((blen `div` 8) - 1) 0 ++ [1])) + case DER.encodeASN1Stream [start,start,oid,numpty,end,fakeint,end] of + Left _ -> error "encodeASN1 failure" + Right l -> B.concat . BL.toChunks $ getPrefix l + 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 = DER.OID [1,2,840,113549,2,5] + hashOid RIPEMD160 = DER.OID [1,3,36,3,2,1] + hashOid SHA1 = DER.OID [1,3,14,3,2,26] + hashOid SHA224 = DER.OID [2,16,840,1,101,3,4,2,4] + hashOid SHA256 = DER.OID [2,16,840,1,101,3,4,2,1] + hashOid SHA384 = DER.OID [2,16,840,1,101,3,4,2,2] + hashOid SHA512 = DER.OID [2,16,840,1,101,3,4,2,3] + hashOid _ = DER.OID [] + +pubkeyToMPIs :: PKey -> [MPI] +pubkeyToMPIs (RSAPubKey k) = [MPI (RSA.public_n k), MPI (RSA.public_e k)] +pubkeyToMPIs (DSAPubKey k) = (\(p,g,q) y -> [MPI p,MPI q,MPI g,MPI y]) (DSA.public_params k) (DSA.public_y k) +pubkeyToMPIs (ElGamalPubKey k) = fmap MPI 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 @@ -23,7 +23,7 @@ import qualified Data.Set as Set import Data.Word (Word8, Word32) -import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS) +import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs) import Codec.Encryption.OpenPGP.Types instance Serialize SigSubPacket where @@ -65,10 +65,82 @@ get = getS2K put = putS2K -instance Serialize Packet where - get = getPacket - put = putPacket +instance Serialize PKESK where + get = fmap fromPkt getPkt + put = putPkt . toPkt +instance Serialize Signature where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize SKESK where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize OnePassSignature where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize SecretKey where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize PublicKey where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize SecretSubkey where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize CompressedData where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize SymEncData where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize Marker where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize LiteralData where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize Trust where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize UserId where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize PublicSubkey where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize UserAttribute where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize SymEncIntegrityProtectedData where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize ModificationDetectionCode where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize OtherPacket where + get = fmap fromPkt getPkt + put = putPkt . toPkt + +instance Serialize Pkt where + get = getPkt + put = putPkt + instance Serialize a => Serialize (Block a) where get = Block `fmap` many get put = mapM_ put . unBlock @@ -91,136 +163,136 @@ getSigSubPacket' pt crit l | pt == 2 = do et <- getWord32be - return $ SigCreationTime crit et + return $ SigSubPacket crit (SigCreationTime et) | pt == 3 = do et <- getWord32be - return $ SigExpirationTime crit et + return $ SigSubPacket crit (SigExpirationTime et) | pt == 4 = do e <- get - return $ ExportableCertification crit e + return $ SigSubPacket crit (ExportableCertification e) | pt == 5 = do tl <- getWord8 ta <- getWord8 - return $ TrustSignature crit tl ta + return $ SigSubPacket crit (TrustSignature tl ta) | pt == 6 = do apdre <- getByteString (l - 2) - return $ RegularExpression crit (B.copy apdre) + return $ SigSubPacket crit (RegularExpression (B.copy apdre)) | pt == 7 = do r <- get - return $ Revocable crit r + return $ SigSubPacket crit (Revocable r) | pt == 9 = do et <- getWord32be - return $ KeyExpirationTime crit et + return $ SigSubPacket crit (KeyExpirationTime et) | pt == 11 = do sa <- replicateM (l - 1) get - return $ PreferredSymmetricAlgorithms crit sa + return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) | pt == 12 = do rclass <- getWord8 algid <- get fp <- getByteString 20 - return $ RevocationKey crit (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp) + return $ SigSubPacket crit (RevocationKey (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp)) | pt == 16 = do keyid <- getByteString (l - 1) - return $ Issuer crit (EightOctetKeyId keyid) + return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) | pt == 20 = do flags <- getByteString 4 nl <- getWord16be vl <- getWord16be nd <- getByteString (fromIntegral nl) nv <- getByteString (fromIntegral vl) - return $ NotationData crit (bsToFFSet flags) nd nv + return $ SigSubPacket crit (NotationData (bsToFFSet flags) nd nv) | pt == 21 = do ha <- replicateM (l - 1) get - return $ PreferredHashAlgorithms crit ha + return $ SigSubPacket crit (PreferredHashAlgorithms ha) | pt == 22 = do ca <- replicateM (l - 1) get - return $ PreferredCompressionAlgorithms crit ca + return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) | pt == 23 = do ksps <- getByteString (l - 1) - return $ KeyServerPreferences crit (bsToFFSet ksps) + return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) | pt == 24 = do pks <- getByteString (l - 1) - return $ PreferredKeyServer crit pks + return $ SigSubPacket crit (PreferredKeyServer pks) | pt == 25 = do primacy <- get - return $ PreferredKeyServer crit primacy + return $ SigSubPacket crit (PreferredKeyServer primacy) | pt == 26 = do url <- getByteString (l - 1) - return $ PolicyURL crit url + return $ SigSubPacket crit (PolicyURL url) | pt == 27 = do kfs <- getByteString (l - 1) - return $ KeyFlags crit (bsToFFSet kfs) + return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) | pt == 28 = do uid <- getByteString (l - 1) - return $ SignersUserId crit uid + return $ SigSubPacket crit (SignersUserId (BC8.unpack uid)) | pt == 29 = do rcode <- getWord8 rreason <- getByteString (l - 2) - return $ ReasonForRevocation crit (toFVal rcode) rreason + return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) | pt == 30 = do fbs <- getByteString (l - 1) - return $ Features crit (bsToFFSet fbs) + return $ SigSubPacket crit (Features (bsToFFSet fbs)) | pt == 31 = do pka <- get ha <- get hash <- getByteString (l - 3) - return $ SignatureTarget crit pka ha hash + return $ SigSubPacket crit (SignatureTarget pka ha hash) | pt == 32 = do sp <- get :: Get SignaturePayload - return $ EmbeddedSignature crit sp + return $ SigSubPacket crit (EmbeddedSignature sp) | pt > 99 && pt < 111 = do payload <- getByteString (l - 1) - return $ UserDefinedSigSub crit pt payload + return $ SigSubPacket crit (UserDefinedSigSub pt payload) | otherwise = do payload <- getByteString (l - 1) - return $ OtherSigSub crit pt payload + return $ SigSubPacket crit (OtherSigSub pt payload) putSigSubPacket :: SigSubPacket -> Put -putSigSubPacket (SigCreationTime crit et) = do +putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 2 putWord32be et -putSigSubPacket (SigExpirationTime crit et) = do +putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 3 putWord32be et -putSigSubPacket (ExportableCertification crit e) = do +putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do putSubPacketLength 2 putSigSubPacketType crit 4 put e -putSigSubPacket (TrustSignature crit tl ta) = do +putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do putSubPacketLength 3 putSigSubPacketType crit 5 put tl put ta -putSigSubPacket (RegularExpression crit apdre) = do +putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do putSubPacketLength . fromIntegral $ (2 + B.length apdre) putSigSubPacketType crit 6 putByteString apdre putWord8 0 -putSigSubPacket (Revocable crit r) = do +putSigSubPacket (SigSubPacket crit (Revocable r)) = do putSubPacketLength 2 putSigSubPacketType crit 7 put r -putSigSubPacket (KeyExpirationTime crit et) = do +putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 9 putWord32be et -putSigSubPacket (PreferredSymmetricAlgorithms crit ess) = do +putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do putSubPacketLength . fromIntegral $ (1 + length ess) putSigSubPacketType crit 11 mapM_ put ess -putSigSubPacket (RevocationKey crit rclass algid fp) = do +putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do putSubPacketLength 23 putSigSubPacketType crit 12 putByteString . ffSetToFixedLengthBS 1 $ rclass put algid putByteString (unTOF fp) -- 20 octets -putSigSubPacket (Issuer crit keyid) = do +putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do putSubPacketLength 9 putSigSubPacketType crit 16 putByteString (unEOKI keyid) -- 8 octets -putSigSubPacket (NotationData crit nfs nn nv) = do +putSigSubPacket (SigSubPacket crit (NotationData nfs nn nv)) = do putSubPacketLength . fromIntegral $ (9 + B.length nn + B.length nv) putSigSubPacketType crit 20 putByteString . ffSetToFixedLengthBS 4 $ nfs @@ -228,66 +300,67 @@ putWord16be . fromIntegral . B.length $ nv putByteString nn putByteString nv -putSigSubPacket (PreferredHashAlgorithms crit ehs) = do +putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do putSubPacketLength . fromIntegral $ (1 + length ehs) putSigSubPacketType crit 21 mapM_ put ehs -putSigSubPacket (PreferredCompressionAlgorithms crit ecs) = do +putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do putSubPacketLength . fromIntegral $ (1 + length ecs) putSigSubPacketType crit 22 mapM_ put ecs -putSigSubPacket (KeyServerPreferences crit ksps) = do +putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do let kbs = ffSetToBS ksps putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 23 putByteString kbs -putSigSubPacket (PreferredKeyServer crit ks) = do +putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do putSubPacketLength . fromIntegral $ (1 + B.length ks) putSigSubPacketType crit 24 putByteString ks -putSigSubPacket (PrimaryUserId crit primacy) = do +putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do putSubPacketLength 2 putSigSubPacketType crit 25 put primacy -putSigSubPacket (PolicyURL crit url) = do +putSigSubPacket (SigSubPacket crit (PolicyURL url)) = do putSubPacketLength . fromIntegral $ (1 + B.length url) putSigSubPacketType crit 26 putByteString url -putSigSubPacket (KeyFlags crit kfs) = do +putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do let kbs = ffSetToBS kfs putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 27 putByteString kbs -putSigSubPacket (SignersUserId crit userid) = do - putSubPacketLength . fromIntegral $ (1 + B.length userid) +putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do + let bs = BC8.pack userid + putSubPacketLength . fromIntegral $ (1 + B.length bs) putSigSubPacketType crit 28 - putByteString userid -putSigSubPacket (ReasonForRevocation crit rcode rreason) = do + putByteString bs +putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do putSubPacketLength . fromIntegral $ (2 + B.length rreason) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode putByteString rreason -putSigSubPacket (Features crit fs) = do +putSigSubPacket (SigSubPacket crit (Features fs)) = do let fbs = ffSetToBS fs putSubPacketLength . fromIntegral $ (1 + B.length fbs) putSigSubPacketType crit 30 putByteString fbs -putSigSubPacket (SignatureTarget crit pka ha hash) = do +putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do putSubPacketLength . fromIntegral $ (3 + B.length hash) putSigSubPacketType crit 31 put pka put ha putByteString hash -putSigSubPacket (EmbeddedSignature crit sp) = do +putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do let spb = runPut (put sp) putSubPacketLength . fromIntegral $ (1 + B.length spb) putSigSubPacketType crit 32 putByteString spb -putSigSubPacket (UserDefinedSigSub crit ptype payload) = do +putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = do putSubPacketLength . fromIntegral $ (1 + B.length payload) putSigSubPacketType crit ptype putByteString payload -putSigSubPacket (OtherSigSub crit ptype payload) = do +putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do putSubPacketLength . fromIntegral $ (1 + B.length payload) putSigSubPacketType crit ptype putByteString payload @@ -310,8 +383,8 @@ putSubPacketLength l | l < 192 = putWord8 (fromIntegral l) | l < 8384 = putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l - 192) .&. 0xff) - | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l) - | otherwise = fail "too big" + | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l) + | otherwise = fail ("too big (" ++ show l ++ ")") getSigSubPacketType :: Get (Bool, Word8) getSigSubPacketType = do @@ -421,15 +494,15 @@ return (tag .&. 0x3f, bs) _ -> error "This should never happen." -getPacket :: Get Packet -getPacket = do +getPkt :: Get Pkt +getPkt = do (t, pl) <- getPacketTypeAndPayload - case runGet (getPacket' t (B.length pl)) pl of + case runGet (getPkt' t (B.length pl)) pl of Left e -> fail e Right p -> return p where - getPacket' :: Word8 -> Int -> Get Packet - getPacket' t len + getPkt' :: Word8 -> Int -> Get Pkt + getPkt' t len | t == 1 = do pv <- getWord8 eokeyid <- getByteString 8 @@ -438,13 +511,13 @@ mpib <- getBytes remainder case runGet (many getMPI) mpib of Left e -> error e - Right sk -> return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk + Right sk -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk | t == 2 = do remainder <- remaining bs <- getBytes remainder case runGet get bs of Left e -> error e - Right sp -> return $ Signature sp + Right sp -> return $ SignaturePkt sp | t == 3 = do pv <- getWord8 symalgo <- getWord8 @@ -452,8 +525,8 @@ remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of - Left _ -> return $ SKESK pv (toFVal symalgo) s2k [] - Right mpis -> return $ SKESK pv (toFVal symalgo) s2k mpis + Left _ -> return $ SKESKPkt pv (toFVal symalgo) s2k [] + Right mpis -> return $ SKESKPkt pv (toFVal symalgo) s2k mpis | t == 4 = do pv <- getWord8 sigtype <- getWord8 @@ -461,67 +534,67 @@ pka <- getWord8 skeyid <- getByteString 8 nested <- getWord8 - return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0) + return $ OnePassSignaturePkt pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0) | t == 5 = do bs <- getBytes len let ps = flip runGet bs $ do pkp <- getPKPayload ska <- getSKAddendum (pubKeyAlgo pkp) - return $ SecretKey pkp ska + return $ SecretKeyPkt pkp ska case ps of Left err -> error err Right key -> return key | t == 6 = do pkp <- getPKPayload - return $ PublicKey pkp + return $ PublicKeyPkt pkp | t == 7 = do bs <- getBytes len let ps = flip runGet bs $ do pkp <- getPKPayload ska <- getSKAddendum (pubKeyAlgo pkp) - return $ SecretSubkey pkp ska + return $ SecretSubkeyPkt pkp ska case ps of Left err -> error err Right key -> return key | t == 8 = do ca <- getWord8 cdata <- getByteString (len - 1) - return $ CompressedData (toFVal ca) cdata + return $ CompressedDataPkt (toFVal ca) cdata | t == 9 = do sdata <- getByteString len - return $ SymEncData sdata + return $ SymEncDataPkt sdata | t == 10 = do marker <- getByteString len - return $ Marker marker + return $ MarkerPkt marker | t == 11 = do dt <- getWord8 flen <- getWord8 fn <- getByteString (fromIntegral flen) ts <- getWord32be ldata <- getByteString (len - (6 + (fromIntegral flen))) - return $ LiteralData (toFVal dt) fn ts ldata + return $ LiteralDataPkt (toFVal dt) fn ts ldata | t == 12 = do tdata <- getByteString len - return $ Trust tdata + return $ TrustPkt tdata | t == 13 = do udata <- getBytes len - return $ UserId (BC8.unpack udata) + return $ UserIdPkt (BC8.unpack udata) | t == 14 = do pkp <- getPKPayload - return $ PublicSubkey pkp + return $ PublicSubkeyPkt pkp | t == 17 = do bs <- getBytes len case runGet (many getUserAttrSubPacket) bs of Left err -> error err - Right uas -> return $ UserAttribute uas + Right uas -> return $ UserAttributePkt uas | t == 18 = do pv <- getWord8 -- should be 1 b <- getByteString (len - 1) - return $ SymEncIntegrityProtectedData pv b + return $ SymEncIntegrityProtectedDataPkt pv b | t == 19 = do hash <- getByteString 20 - return $ ModificationDetectionCode hash + return $ ModificationDetectionCodePkt hash | otherwise = do payload <- getByteString len - return $ OtherPacket t payload + return $ OtherPacketPkt t payload getUserAttrSubPacket :: Get UserAttrSubPacket getUserAttrSubPacket = do @@ -559,8 +632,8 @@ putWord8 t putByteString bs -putPacket :: Packet -> Put -putPacket (PKESK pv eokeyid pkalgo mpis) = do +putPkt :: Pkt -> Put +putPkt (PKESKPkt pv eokeyid pkalgo mpis) = do putWord8 (0xc0 .|. 1) let bsk = runPut $ mapM_ put mpis putPacketLength . fromIntegral $ 10 + (B.length bsk) @@ -568,12 +641,12 @@ putByteString (unEOKI eokeyid) -- must be 8 octets putWord8 $ fromIntegral . fromFVal $ pkalgo putByteString bsk -putPacket (Signature sp) = do +putPkt (SignaturePkt sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp putPacketLength . fromIntegral . B.length $ bs putByteString bs -putPacket (SKESK pv symalgo s2k mpis) = do +putPkt (SKESKPkt pv symalgo s2k mpis) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k let bsk = runPut $ mapM_ put mpis @@ -582,7 +655,7 @@ putWord8 $ fromIntegral . fromFVal $ symalgo putByteString bs2k putByteString bsk -putPacket (OnePassSignature pv sigtype ha pka skeyid nested) = do +putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do putWord8 (0xc0 .|. 4) let bs = runPut $ do putWord8 pv -- should be 3 @@ -593,37 +666,37 @@ putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean? putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (SecretKey pkp ska) = do +putPkt (SecretKeyPkt pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (PublicKey pkp) = do +putPkt (PublicKeyPkt pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (SecretSubkey pkp ska) = do +putPkt (SecretSubkeyPkt pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (CompressedData ca cdata) = do +putPkt (CompressedDataPkt ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca putByteString cdata putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (SymEncData b) = do +putPkt (SymEncDataPkt b) = do putWord8 (0xc0 .|. 9) putPacketLength . fromIntegral $ B.length b putByteString b -putPacket (Marker b) = do +putPkt (MarkerPkt b) = do putWord8 (0xc0 .|. 10) putPacketLength . fromIntegral $ B.length b putByteString b -putPacket (LiteralData dt fn ts b) = do +putPkt (LiteralDataPkt dt fn ts b) = do putWord8 (0xc0 .|. 11) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ dt @@ -633,35 +706,35 @@ putByteString b putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (Trust b) = do +putPkt (TrustPkt b) = do putWord8 (0xc0 .|. 12) putPacketLength . fromIntegral . B.length $ b putByteString b -putPacket (UserId u) = do +putPkt (UserIdPkt u) = do putWord8 (0xc0 .|. 13) let bs = BC8.pack u putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (PublicSubkey pkp) = do +putPkt (PublicSubkeyPkt pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (UserAttribute us) = do +putPkt (UserAttributePkt us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us putPacketLength . fromIntegral $ B.length bs putByteString bs -putPacket (SymEncIntegrityProtectedData pv b) = do +putPkt (SymEncIntegrityProtectedDataPkt pv b) = do putWord8 (0xc0 .|. 18) putPacketLength . fromIntegral $ (B.length b) + 1 putWord8 pv -- should be 1 putByteString b -putPacket (ModificationDetectionCode hash) = do +putPkt (ModificationDetectionCodePkt hash) = do putWord8 (0xc0 .|. 19) putPacketLength . fromIntegral . B.length $ hash putByteString hash -putPacket (OtherPacket t payload) = do +putPkt (OtherPacketPkt t payload) = do putWord8 (0xc0 .|. t) -- FIXME: restrict t putPacketLength . fromIntegral . B.length $ payload putByteString payload @@ -689,11 +762,6 @@ return $ ElGamalPubKey [p,g,y] getPubkey t = fail ("Unsupported pubkey type " ++ show t) -pubkeyToMPIs :: PKey -> [MPI] -pubkeyToMPIs (RSAPubKey k) = [MPI (R.public_n k), MPI (R.public_e k)] -pubkeyToMPIs (DSAPubKey k) = (\(p,g,q) y -> [MPI p,MPI q,MPI g,MPI y]) (D.public_params k) (D.public_y k) -pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k - putPubkey :: PKey -> Put putPubkey p = mapM_ put (pubkeyToMPIs p) @@ -726,11 +794,11 @@ putWord16be . countBits $ bs putByteString bs --- getPackets :: Get (Block Packet) --- getPackets = Block `fmap` many getPacket +-- getPackets :: Get (Block Pkt) +-- getPackets = Block `fmap` many getPkt --- putPackets :: Block Packet -> Put --- putPackets = mapM_ putPacket . unBlock +-- putPackets :: Block Pkt -> Put +-- putPackets = mapM_ putPkt . unBlock getPKPayload :: Get PKPayload getPKPayload = do @@ -740,14 +808,14 @@ do v3exp <- getWord16be pka <- get pk <- getPubkey pka - return $ PubV3 ctime v3exp pka pk + return $ DeprecatedPubV3 ctime v3exp pka pk else do pka <- get pk <- getPubkey pka return $ PubV4 ctime pka pk putPKPayload :: PKPayload -> Put -putPKPayload (PubV3 ctime v3exp pka pk) = do +putPKPayload (DeprecatedPubV3 ctime v3exp pka pk) = do putWord8 3 putWord32be ctime putWord16be v3exp @@ -760,7 +828,7 @@ putPubkey pk pubKeyAlgo :: PKPayload -> PubKeyAlgorithm -pubKeyAlgo (PubV3 _ _ pka _) = pka +pubKeyAlgo (DeprecatedPubV3 _ _ pka _) = pka pubKeyAlgo (PubV4 _ pka _) = pka getSKAddendum :: PubKeyAlgorithm -> Get SKAddendum 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 @@ -12,27 +12,33 @@ , putUAtforSigning , putKeyforSigning , putSigforSigning --- , putSigforSigning + , payloadForSig ) where +import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import Data.Serialize (Serialize, put) import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, runPut) -import Codec.Encryption.OpenPGP.Serialize (putSKAddendum) +import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), integerToBEBS, pubkeyToMPIs) +import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types -putPKPforFingerprinting :: Packet -> Put -- FIXME -putPKPforFingerprinting (PublicKey pkp) = do +putPKPforFingerprinting :: Pkt -> Put +putPKPforFingerprinting (PublicKeyPkt pkp@(DeprecatedPubV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) +putPKPforFingerprinting (PublicKeyPkt pkp@(PubV4 {})) = do putWord8 0x99 let bs = runPut $ put pkp putWord16be . fromIntegral $ B.length bs putByteString bs putPKPforFingerprinting _ = fail "This should never happen" -putPartialSigforSigning :: Packet -> Put -putPartialSigforSigning (Signature (SigV4 st pka ha hashed _ _ _)) = do +putMPIforFingerprinting:: MPI -> Put +putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putByteString bs + +putPartialSigforSigning :: Pkt -> Put +putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do putWord8 4 put st put pka @@ -42,48 +48,48 @@ putByteString hb putPartialSigforSigning _ = fail "This should never happen" -putSigTrailer :: Packet -> Put -putSigTrailer (Signature (SigV4 _ _ _ hs _ _ _)) = do +putSigTrailer :: Pkt -> Put +putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do putWord8 0x04 putWord8 0xff putWord32be . fromIntegral . (+6) . B.length $ runPut $ mapM_ put hs -- this +6 seems like a bug in RFC4880 putSigTrailer _ = fail "This should never happen" -putUforSigning :: Packet -> Put -putUforSigning u@(UserId _) = putUIDforSigning u -putUforSigning u@(UserAttribute _) = putUAtforSigning u +putUforSigning :: Pkt -> Put +putUforSigning u@(UserIdPkt _) = putUIDforSigning u +putUforSigning u@(UserAttributePkt _) = putUAtforSigning u putUforSigning _ = fail "This should never happen" -putUIDforSigning :: Packet -> Put -putUIDforSigning (UserId u) = do +putUIDforSigning :: Pkt -> Put +putUIDforSigning (UserIdPkt u) = do putWord8 0xB4 let bs = BC8.pack u putWord32be . fromIntegral . B.length $ bs putByteString bs putUIDforSigning _ = fail "This should never happen" -putUAtforSigning :: Packet -> Put -putUAtforSigning (UserAttribute us) = do +putUAtforSigning :: Pkt -> Put +putUAtforSigning (UserAttributePkt us) = do putWord8 0xD1 let bs = runPut (mapM_ put us) putWord32be . fromIntegral . B.length $ bs putByteString bs putUAtforSigning _ = fail "This should never happen" -putSigforSigning :: Packet -> Put -putSigforSigning (Signature (SigV4 st pka ha hashed _ left16 mpis)) = do +putSigforSigning :: Pkt -> Put +putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do putWord8 0x88 let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis) putWord32be . fromIntegral . B.length $ bs putByteString bs putSigforSigning _ = fail "Non-V4 not implemented." -putKeyforSigning :: Packet -> Put -putKeyforSigning (PublicKey pkp) = putKeyForSigning' pkp -putKeyforSigning (PublicSubkey pkp) = putKeyForSigning' pkp -putKeyforSigning (SecretKey pkp _) = putKeyForSigning' pkp -putKeyforSigning (SecretSubkey pkp _) = putKeyForSigning' pkp +putKeyforSigning :: Pkt -> Put +putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp +putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp +putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp +putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning _ = fail "This should never happen" putKeyForSigning' :: PKPayload -> Put @@ -92,3 +98,25 @@ let bs = runPut $ put pkp putWord16be . fromIntegral . B.length $ bs putByteString bs + +payloadForSig :: SigType -> PktStreamContext -> ByteString +payloadForSig BinarySig state = (\(LiteralDataPkt _ _ _ bs) -> bs) (lastLD state) +payloadForSig CanonicalTextSig state = payloadForSig BinarySig state +payloadForSig StandaloneSig _ = B.empty +payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) +payloadForSig PersonaCert state = payloadForSig GenericCert state +payloadForSig CasualCert state = payloadForSig GenericCert state +payloadForSig PositiveCert state = payloadForSig GenericCert state +payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well +payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) +payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state)) +payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state +payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) +payloadForSig CertRevocationSig state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures +payloadForSig st _ = error ("I dunno how to " ++ show st) + +kandUPayload :: Pkt -> Pkt -> ByteString +kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) + +kandKPayload :: Pkt -> Pkt -> ByteString +kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2]) 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 @@ -3,14 +3,16 @@ -- This software is released under the terms of the ISC license. -- (See the LICENSE file). +{-# LANGUAGE ExistentialQuantification, TypeFamilies #-} + module Codec.Encryption.OpenPGP.Types ( SigSubPacket(..) + , SigSubPacketPayload(..) , CompressionAlgorithm(..) , HashAlgorithm(..) , PubKeyAlgorithm(..) , SymmetricAlgorithm(..) , MPI(..) - , Packet(..) , S2K(..) , SignaturePayload(..) , UserAttrSubPacket(..) @@ -34,6 +36,29 @@ , toFFlag , Block(Block) , unBlock + , Pkt(..) + , Packet + , PKESK(..) + , Signature(..) + , SKESK(..) + , OnePassSignature(..) + , SecretKey(..) + , PublicKey(..) + , SecretSubkey(..) + , CompressedData(..) + , SymEncData(..) + , Marker(..) + , LiteralData(..) + , Trust(..) + , UserId(..) + , PublicSubkey(..) + , UserAttribute(..) + , SymEncIntegrityProtectedData(..) + , ModificationDetectionCode(..) + , OtherPacket(..) + , fromPkt + , toPkt + , Verification(..) ) where import qualified Crypto.Cipher.RSA as RSA @@ -60,7 +85,6 @@ type URL = ByteString type NotationName = ByteString type NotationValue = ByteString -type UserId = ByteString type SignatureHash = ByteString type PacketVersion = Word8 type Salt = ByteString @@ -135,31 +159,39 @@ toFFlag 0 = HumanReadable toFFlag o = OtherNF (fromIntegral o) -data SigSubPacket = SigCreationTime Bool TimeStamp - | SigExpirationTime Bool TimeStamp - | ExportableCertification Bool Exportability - | TrustSignature Bool TrustLevel TrustAmount - | RegularExpression Bool AlmostPublicDomainRegex - | Revocable Bool Revocability - | KeyExpirationTime Bool TimeStamp - | PreferredSymmetricAlgorithms Bool [SymmetricAlgorithm] - | RevocationKey Bool (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint - | Issuer Bool EightOctetKeyId - | NotationData Bool (Set NotationFlag) NotationName NotationValue - | PreferredHashAlgorithms Bool [HashAlgorithm] - | PreferredCompressionAlgorithms Bool [CompressionAlgorithm] - | KeyServerPreferences Bool (Set KSPFlag) - | PreferredKeyServer Bool KeyServer - | PrimaryUserId Bool Bool - | PolicyURL Bool URL - | KeyFlags Bool (Set KeyFlag) - | SignersUserId Bool UserId - | ReasonForRevocation Bool RevocationCode RevocationReason - | Features Bool (Set FeatureFlag) - | SignatureTarget Bool PubKeyAlgorithm HashAlgorithm SignatureHash - | EmbeddedSignature Bool SignaturePayload - | UserDefinedSigSub Bool Word8 ByteString - | OtherSigSub Bool Word8 ByteString +data SigSubPacket = SigSubPacket { + sspCriticality :: Bool + , sspPayload :: SigSubPacketPayload + } deriving Eq + +instance Show SigSubPacket where + show x = (if sspCriticality x then "*" else "") ++ (show . sspPayload) x + +data SigSubPacketPayload = SigCreationTime TimeStamp + | SigExpirationTime TimeStamp + | ExportableCertification Exportability + | TrustSignature TrustLevel TrustAmount + | RegularExpression AlmostPublicDomainRegex + | Revocable Revocability + | KeyExpirationTime TimeStamp + | PreferredSymmetricAlgorithms [SymmetricAlgorithm] + | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint + | Issuer EightOctetKeyId + | NotationData (Set NotationFlag) NotationName NotationValue + | PreferredHashAlgorithms [HashAlgorithm] + | PreferredCompressionAlgorithms [CompressionAlgorithm] + | KeyServerPreferences (Set KSPFlag) + | PreferredKeyServer KeyServer + | PrimaryUserId Bool + | PolicyURL URL + | KeyFlags (Set KeyFlag) + | SignersUserId String + | ReasonForRevocation RevocationCode RevocationReason + | Features (Set FeatureFlag) + | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash + | EmbeddedSignature SignaturePayload + | UserDefinedSigSub Word8 ByteString + | OtherSigSub Word8 ByteString deriving (Show, Eq) -- FIXME data HashAlgorithm = DeprecatedMD5 @@ -391,7 +423,7 @@ | SigVOther Word8 ByteString deriving (Show, Eq) -- FIXME -data PKPayload = PubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey +data PKPayload = DeprecatedPubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey | PubV4 TimeStamp PubKeyAlgorithm PKey deriving (Show, Eq) @@ -424,26 +456,6 @@ toFVal 0x75 = UTF8Data toFVal o = OtherData o -data Packet = PKESK PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI] - | Signature SignaturePayload - | SKESK PacketVersion SymmetricAlgorithm S2K [MPI] - | OnePassSignature PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag - | SecretKey PKPayload SKAddendum - | PublicKey PKPayload - | SecretSubkey PKPayload SKAddendum - | CompressedData CompressionAlgorithm CompressedDataPayload - | SymEncData ByteString - | Marker ByteString - | LiteralData DataType FileName TimeStamp ByteString - | Trust ByteString - | UserId String - | PublicSubkey PKPayload - | UserAttribute [UserAttrSubPacket] - | SymEncIntegrityProtectedData PacketVersion ByteString - | ModificationDetectionCode ByteString - | OtherPacket Word8 ByteString - deriving (Show, Eq) -- FIXME - data S2K = Simple HashAlgorithm | Salted HashAlgorithm Salt | IteratedSalted HashAlgorithm Salt Count @@ -572,11 +584,11 @@ data TK = TK { tkPKP :: PKPayload - , tkmSKA :: (Maybe SKAddendum) + , tkmSKA :: Maybe SKAddendum , tkRevs :: [SignaturePayload] , tkUIDs :: [(String, [SignaturePayload])] , tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] - , tkSubs :: [(Packet, SignaturePayload, Maybe SignaturePayload)] + , tkSubs :: [(Pkt, SignaturePayload, Maybe SignaturePayload)] } deriving (Eq, Show) @@ -584,3 +596,235 @@ compare a b = show a `compare` show b -- FIXME: this is ridiculous type Keyring = Map EightOctetKeyId (Set TK) + +class Packet a where + data PacketType a :: * + packetType :: a -> PacketType a +   packetCode :: PacketType a -> Word8 + toPkt :: a -> Pkt + fromPkt :: Pkt -> a + +-- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a +data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI] + | SignaturePkt SignaturePayload + | SKESKPkt PacketVersion SymmetricAlgorithm S2K [MPI] + | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag + | SecretKeyPkt PKPayload SKAddendum + | PublicKeyPkt PKPayload + | SecretSubkeyPkt PKPayload SKAddendum + | CompressedDataPkt CompressionAlgorithm CompressedDataPayload + | SymEncDataPkt ByteString + | MarkerPkt ByteString + | LiteralDataPkt DataType FileName TimeStamp ByteString + | TrustPkt ByteString + | UserIdPkt String + | PublicSubkeyPkt PKPayload + | UserAttributePkt [UserAttrSubPacket] + | SymEncIntegrityProtectedDataPkt PacketVersion ByteString + | ModificationDetectionCodePkt ByteString + | OtherPacketPkt Word8 ByteString + deriving (Show, Eq) -- FIXME + +data PKESK = PKESK + { pkeskPacketVersion :: PacketVersion + , pkeskEightOctetKeyId :: EightOctetKeyId + , pkeskPubKeyAlgorithm :: PubKeyAlgorithm + , pkeskMPIs :: [MPI] + } deriving (Show, Eq) +instance Packet PKESK where + data PacketType PKESK = PKESKType + packetType _ = PKESKType + packetCode _ = 1 + toPkt (PKESK a b c d) = PKESKPkt a b c d + fromPkt (PKESKPkt a b c d) = PKESK a b c d + +data Signature = Signature -- FIXME? + { signaturePayload :: SignaturePayload + } deriving (Show, Eq) +instance Packet Signature where + data PacketType Signature = SignatureType + packetType _ = SignatureType + packetCode _ = 2 + toPkt (Signature a ) = SignaturePkt a + fromPkt (SignaturePkt a) = Signature a + +data SKESK = SKESK + { skeskPacketVersion :: PacketVersion + , skeskSymmetricAlgorithm :: SymmetricAlgorithm + , skeskS2K :: S2K + , skeskMPIs :: [MPI] + } deriving (Show, Eq) +instance Packet SKESK where + data PacketType SKESK = SKESKType + packetType _ = SKESKType + packetCode _ = 3 + toPkt (SKESK a b c d) = SKESKPkt a b c d + fromPkt (SKESKPkt a b c d) = SKESK a b c d + +data OnePassSignature = OnePassSignature + { onePassSignaturePacketVersion :: PacketVersion + , onePassSignatureSigType :: SigType + , onePassSignatureHashAlgorithm :: HashAlgorithm + , onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm + , onePassSignatureEightOctetKeyId :: EightOctetKeyId + , onePassSignatureNestedFlag :: NestedFlag + } deriving (Show, Eq) +instance Packet OnePassSignature where + data PacketType OnePassSignature = OnePassSignatureType + packetType _ = OnePassSignatureType + packetCode _ = 4 + toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f + fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f + +data SecretKey = SecretKey + { secretKeyPKPayload :: PKPayload + , secretKeySKAddendum :: SKAddendum + } deriving (Show, Eq) +instance Packet SecretKey where + data PacketType SecretKey = SecretKeyType + packetType _ = SecretKeyType + packetCode _ = 5 + toPkt (SecretKey a b) = SecretKeyPkt a b + fromPkt (SecretKeyPkt a b) = SecretKey a b + +data PublicKey = PublicKey + { publicKeyPKPayload :: PKPayload + } deriving (Show, Eq) +instance Packet PublicKey where + data PacketType PublicKey = PublicKeyType + packetType _ = PublicKeyType + packetCode _ = 6 + toPkt (PublicKey a) = PublicKeyPkt a + fromPkt (PublicKeyPkt a) = PublicKey a + +data SecretSubkey = SecretSubkey + { secretSubkeyPKPayload :: PKPayload + , secretSubkeySKAddendum :: SKAddendum + } deriving (Show, Eq) +instance Packet SecretSubkey where + data PacketType SecretSubkey = SecretSubkeyType + packetType _ = SecretSubkeyType + packetCode _ = 7 + toPkt (SecretSubkey a b) = SecretSubkeyPkt a b + fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b + +data CompressedData = CompressedData + { compressedDataCompressionAlgorithm :: CompressionAlgorithm + , compressedDataPayload :: CompressedDataPayload + } deriving (Show, Eq) +instance Packet CompressedData where + data PacketType CompressedData = CompressedDataType + packetType _ = CompressedDataType + packetCode _ = 8 + toPkt (CompressedData a b) = CompressedDataPkt a b + fromPkt (CompressedDataPkt a b) = CompressedData a b + +data SymEncData = SymEncData + { symEncDataPayload :: ByteString + } deriving (Show, Eq) +instance Packet SymEncData where + data PacketType SymEncData = SymEncDataType + packetType _ = SymEncDataType + packetCode _ = 9 + toPkt (SymEncData a) = SymEncDataPkt a + fromPkt (SymEncDataPkt a) = SymEncData a + +data Marker = Marker + { markerPayload :: ByteString + } deriving (Show, Eq) +instance Packet Marker where + data PacketType Marker = MarkerType + packetType _ = MarkerType + packetCode _ = 10 + toPkt (Marker a) = MarkerPkt a + fromPkt (MarkerPkt a) = Marker a + +data LiteralData = LiteralData + { literalDataDataType :: DataType + , literalDataFileName :: FileName + , literalDataTimeStamp :: TimeStamp + , literalDataPayload :: ByteString + } deriving (Show, Eq) +instance Packet LiteralData where + data PacketType LiteralData = LiteralDataType + packetType _ = LiteralDataType + packetCode _ = 11 + toPkt (LiteralData a b c d) = LiteralDataPkt a b c d + fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d + +data Trust = Trust + { trustPayload :: ByteString + } deriving (Show, Eq) +instance Packet Trust where + data PacketType Trust = TrustType + packetType _ = TrustType + packetCode _ = 12 + toPkt (Trust a) = TrustPkt a + fromPkt (TrustPkt a) = Trust a + +data UserId = UserId + { userIdPayload :: String + } deriving (Show, Eq) +instance Packet UserId where + data PacketType UserId = UserIdType + packetType _ = UserIdType + packetCode _ = 13 + toPkt (UserId a) = UserIdPkt a + fromPkt (UserIdPkt a) = UserId a + +data PublicSubkey = PublicSubkey + { publicSubkeyPKPayload :: PKPayload + } deriving (Show, Eq) +instance Packet PublicSubkey where + data PacketType PublicSubkey = PublicSubkeyType + packetType _ = PublicSubkeyType + packetCode _ = 14 + toPkt (PublicSubkey a) = PublicSubkeyPkt a + fromPkt (PublicSubkeyPkt a) = PublicSubkey a + +data UserAttribute = UserAttribute + { userAttributeSubPackets :: [UserAttrSubPacket] + } deriving (Show, Eq) +instance Packet UserAttribute where + data PacketType UserAttribute = UserAttributeType + packetType _ = UserAttributeType + packetCode _ = 17 + toPkt (UserAttribute a) = UserAttributePkt a + fromPkt (UserAttributePkt a) = UserAttribute a + +data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData + { symEncIntegrityProtectedDataPacketVersion :: PacketVersion + , symEncIntegrityProtectedDataPayload :: ByteString + } deriving (Show, Eq) +instance Packet SymEncIntegrityProtectedData where + data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType + packetType _ = SymEncIntegrityProtectedDataType + packetCode _ = 18 + toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b + fromPkt (SymEncIntegrityProtectedDataPkt a b) = SymEncIntegrityProtectedData a b + +data ModificationDetectionCode = ModificationDetectionCode + { modificationDetectionCodePayload :: ByteString + } deriving (Show, Eq) +instance Packet ModificationDetectionCode where + data PacketType ModificationDetectionCode = ModificationDetectionCodeType + packetType _ = ModificationDetectionCodeType + packetCode _ = 19 + toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a + fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a + +data OtherPacket = OtherPacket + { otherPacketType :: Word8 + , otherPacketPayload :: ByteString + } deriving (Show, Eq) +instance Packet OtherPacket where + data PacketType OtherPacket = OtherPacketType + packetType _ = OtherPacketType + packetCode _ = undefined -- FIXME + toPkt (OtherPacket a b) = OtherPacketPkt a b + fromPkt (OtherPacketPkt a b) = OtherPacket a b + +data Verification = Verification { + verificationSigner :: PKPayload + , verificationSignature :: SignaturePayload + } diff --git a/Codec/Encryption/OpenPGP/Verify.hs b/Codec/Encryption/OpenPGP/Verify.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Verify.hs @@ -0,0 +1,140 @@ +-- Verify.hs: OpenPGP (RFC4880) signature verification +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.Verify ( + verifySig + , verify + , verifyTK +) where + +import Control.Monad (guard, liftM2) + +import qualified Crypto.Cipher.DSA as DSA +import qualified Crypto.Cipher.RSA as RSA + +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.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.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) +import Codec.Encryption.OpenPGP.Types + +verifySig :: Keyring -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? +verifySig kr sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do + v <- verify kr sig mt (payloadForSig st state) + _ <- mapM_ (checkIssuer (eightOctetKeyID (verificationSigner v)) . sspPayload) hs + return v + where + checkIssuer :: EightOctetKeyId -> SigSubPacketPayload -> Either String Bool + checkIssuer signer (Issuer i) = if signer == i then Right True else Left "issuer subpacket does not match" + checkIssuer _ _ = Right True +verifySig _ _ _ _ = Left "This should never happen." + +verifyTK :: Keyring -> Maybe UTCTime -> TK -> Either String TK +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) + where + 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 + 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])] + checkUAtSigs = map (\(uat, sps) -> (uat, (rights . map (\sp -> fmap (const sp) (vUAt kr (uat, sp)))) sps)) + checkSub :: (Pkt, SignaturePayload, Maybe SignaturePayload) -> [(Pkt, SignaturePayload, Maybe SignaturePayload)] + checkSub (pkt, sp, mrp) = if revokedSub pkt mrp then [] else checkSub' pkt sp + revokedSub :: Pkt -> Maybe SignaturePayload -> Bool + revokedSub _ Nothing = False + revokedSub p (Just rp) = vSubSig kr p rp + checkSub' :: Pkt -> SignaturePayload -> [(Pkt, SignaturePayload, Maybe SignaturePayload)] + checkSub' p sp = guard (vSubSig kr p sp) >> return (p, sp, Nothing) + getHasheds (SigV4 _ _ _ ha _ _ _) = ha + getHasheds _ = [] + filterRevs :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> (SignaturePayload, Verification) -> [Either String SignaturePayload] + filterRevs vokers spv = case spv of + (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s] + (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> if any (\(p,f) -> p == pka && f == fingerprint (verificationSigner v)) vokers then [Left "Key revoked"] else [Right s] + _ -> [] + isKeyRevocation (SigV4 KeyRevocationSig _ _ _ _ _ _) = True + isKeyRevocation _ = False + isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = any isRevocationKeySSP h && any isIssuerSSP u + isRevokerP _ = False + isRevocationKeySSP (SigSubPacket _ (RevocationKey {})) = True + isRevocationKeySSP _ = False + 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 + vUAt :: Keyring -> ([UserAttrSubPacket], SignaturePayload) -> Either String Verification + 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 + vSubSig :: Keyring -> Pkt -> SignaturePayload -> Bool + 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)] + verifyRevoker sp = do + _ <- vSig kr sp + return (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . filter isRevocationKeySSP $ getHasheds sp) + +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)) + let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps + case rights results of + [] -> Left (concatMap (++"/") (lefts results)) + [r] -> do _ <- isSignatureExpired sig mt + return (Verification r ((signaturePayload . fromPkt) sig)) -- FIXME: this should also check expiration time and flags of the signing key + _ -> Left "multiple successes; unexpected condition" + where + subPKP (pack, _, _) = subPKP' pack + subPKP' (PublicSubkeyPkt p) = p + subPKP' (SecretSubkeyPkt p _) = p + verify' (SignaturePkt s) (pub@(PubV4 _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl + verify' _ _ _ _ = error "This should never happen." + 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) + dsaMPIsToSig mpis = (unMPI (mpis !! 0), unMPI (mpis !! 1)) + rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis)) + finalPayload s pl = B.concat [pl, sigbit s, trailer s] + sigbit s = runPut $ putPartialSigforSigning s + hashalgo :: Pkt -> HashAlgorithm + hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha + hashalgo _ = error "This should never happen." + trailer :: Pkt -> ByteString + trailer s@(SignaturePkt (SigV4 {})) = runPut $ putSigTrailer s + trailer _ = B.empty + dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits + dsaQLen pk = (\(_,_,z) -> countBits (integerToBEBS z)) (DSA.public_params pk) + pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis) + pkaAndMPIs _ = error "This should never happen." + isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool + isSignatureExpired s Nothing = return False + 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 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 @@ -13,11 +13,11 @@ import Data.Conduit import qualified Data.Conduit.List as CL -conduitCompress :: MonadThrow m => CompressionAlgorithm -> Conduit Packet m Packet +conduitCompress :: MonadThrow m => CompressionAlgorithm -> Conduit Pkt m Pkt conduitCompress algo = conduitState [] push (close algo) where push state input = return $ StateProducing (input : state) [] - close a state = return [compressPackets a state] + close a state = return [compressPkts a state] -conduitDecompress :: MonadThrow m => Conduit Packet m Packet -conduitDecompress = CL.concatMap decompressPacket +conduitDecompress :: MonadThrow m => Conduit Pkt m Pkt +conduitDecompress = CL.concatMap decompressPkt diff --git a/Data/Conduit/OpenPGP/Internal.hs b/Data/Conduit/OpenPGP/Internal.hs deleted file mode 100644 --- a/Data/Conduit/OpenPGP/Internal.hs +++ /dev/null @@ -1,105 +0,0 @@ --- Internal.hs: OpenPGP (RFC4880) private routines for conduit stuff --- Copyright © 2012 Clint Adams --- This software is released under the terms of the ISC license. --- (See the LICENSE file). - -module Data.Conduit.OpenPGP.Internal ( - PacketStreamContext(..) - , payloadForSig - , asn1Prefix - , hash - , issuer -) where - -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 qualified Data.ASN1.DER as DER -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.List (find) -import Data.Serialize.Put (runPut) - -import Codec.Encryption.OpenPGP.SerializeForSigs (putKeyforSigning, putUforSigning) -import Codec.Encryption.OpenPGP.Types - -data PacketStreamContext = PacketStreamContext { lastLD :: Packet - , lastUIDorUAt :: Packet - , lastSig :: Packet - , lastPrimaryKey :: Packet - , lastSubkey :: Packet - } - -payloadForSig :: SigType -> PacketStreamContext -> ByteString -payloadForSig BinarySig state = (\(LiteralData _ _ _ bs) -> bs) (lastLD state) -payloadForSig CanonicalTextSig state = payloadForSig BinarySig state -payloadForSig StandaloneSig _ = B.empty -payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -payloadForSig PersonaCert state = payloadForSig GenericCert state -payloadForSig CasualCert state = payloadForSig GenericCert state -payloadForSig PositiveCert state = payloadForSig GenericCert state -payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well -payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state)) -payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state -payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -payloadForSig CertRevocationSig state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures -payloadForSig st _ = error ("I dunno how to " ++ show st) - -kandUPayload :: Packet -> Packet -> ByteString -kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) - -kandKPayload :: Packet -> Packet -> ByteString -kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2]) - -issuer :: Packet -> Maybe EightOctetKeyId -issuer (Signature (SigV4 _ _ _ _ usubs _ _)) = fmap (\(Issuer _ i) -> i) (find isIssuer usubs) - where - isIssuer (Issuer _ _) = True - 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 = DER.Start DER.Sequence - let (blen, oid) = (bitLength ha, hashOid ha) - let numpty = DER.Null - let end = DER.End DER.Sequence - let fakeint = DER.OctetString (BL.pack (replicate ((blen `div` 8) - 1) 0 ++ [1])) - case DER.encodeASN1Stream [start,start,oid,numpty,end,fakeint,end] of - Left _ -> error "encodeASN1 failure" - Right l -> B.concat . BL.toChunks $ getPrefix l - 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 = DER.OID [1,2,840,113549,2,5] - hashOid RIPEMD160 = DER.OID [1,3,36,3,2,1] - hashOid SHA1 = DER.OID [1,3,14,3,2,26] - hashOid SHA224 = DER.OID [2,16,840,1,101,3,4,2,4] - hashOid SHA256 = DER.OID [2,16,840,1,101,3,4,2,1] - hashOid SHA384 = DER.OID [2,16,840,1,101,3,4,2,2] - hashOid SHA512 = DER.OID [2,16,840,1,101,3,4,2,3] - hashOid _ = DER.OID [] 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 @@ -21,55 +21,55 @@ data Phase = MainKey | Revs | Uids | UAts | Subs deriving (Eq, Ord, Show) -conduitToTKs :: MonadResource m => Conduit Packet m TK +conduitToTKs :: MonadResource m => Conduit Pkt m TK conduitToTKs = conduitToTKs' True -conduitToTKsDropping :: MonadResource m => Conduit Packet m TK +conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK conduitToTKsDropping = conduitToTKs' False -conduitToTKs' :: MonadResource m => Bool -> Conduit Packet m TK +conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK conduitToTKs' intolerant = conduitState (MainKey, Nothing) push close where push state input = case (state, input) of - ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) [] - ((MainKey, _), SecretKey pkp ska) -> return $ StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) [] - ((Revs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) [] - ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkey p, SigVOther 0 B.empty, Nothing)]))) [] - ((Subs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> case sType s of + ((MainKey, _), PublicKeyPkt pkp) -> return $ StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) [] + ((MainKey, _), SecretKeyPkt pkp ska) -> return $ StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) [] + ((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) [] + ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)]))) [] + ((Subs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> case sType s of SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setBSig s subs))) [] SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setRSig s subs))) [] _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) - ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((Revs, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) [] - ((Revs, Just (TK pkp mska revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] - ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) [] - ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((UAts, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] - ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]))) [] - ((Subs, Just (TK pkp mska revs uids uats subs)), Signature s) -> case sType s of + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) [] + ((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] + ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) [] + ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] + ((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] + ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)]))) [] + ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> case sType s of SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setBSig s subs))) [] SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setRSig s subs))) [] _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) - ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((_,_), Trust _) -> return $ StateProducing state [] + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] + ((_,_), TrustPkt _) -> return $ StateProducing state [] _ -> return (dropOrError intolerant state $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input) close (_, Nothing) = return [] close (_, Just tk) = return [tk] @@ -80,7 +80,7 @@ sType (SigV3 st _ _ _ _ _ _) = st sType (SigV4 st _ _ _ _ _ _) = st sType _ = error "This should never happen." - dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ConduitStateResult (Phase, Maybe TK) Packet TK + dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ConduitStateResult (Phase, Maybe TK) Pkt TK dropOrError True _ e = error e dropOrError False s _ = StateProducing s [] @@ -90,8 +90,8 @@ push :: MonadResource m => Keyring -> TK -> m (SinkStateResult Keyring TK Keyring) push state input = return . 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 (PublicSubkey pkp) = pkp - pl (SecretSubkey pkp _) = pkp + 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 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 @@ -7,79 +7,25 @@ conduitVerify ) where -import qualified Crypto.Cipher.DSA as DSA -import qualified Crypto.Cipher.RSA as RSA - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B import Data.Conduit -import Data.Either (lefts, rights) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Serialize.Put (runPut) +import Data.Time.Clock (UTCTime) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) -import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS) -import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer) +import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Internal (PacketStreamContext(..), payloadForSig, asn1Prefix, hash, issuer) +import Codec.Encryption.OpenPGP.Verify (verifySig) -conduitVerify :: MonadResource m => Keyring -> Conduit Packet m (Either String PKPayload) -conduitVerify kr = conduitState (PacketStreamContext (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty)) push close +conduitVerify :: MonadResource m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification) +conduitVerify kr mt = conduitState emptyPSC push close where - push state ld@(LiteralData {}) = return $ StateProducing (state { lastLD = ld }) [] - push state uid@(UserId _) = return $ StateProducing (state { lastUIDorUAt = uid }) [] - push state uat@(UserAttribute _) = return $ StateProducing (state { lastUIDorUAt = uat }) [] - push state pk@(PublicKey _) = return $ StateProducing (state { lastPrimaryKey = pk }) [] - push state pk@(PublicSubkey _) = return $ StateProducing (state { lastSubkey = pk }) [] - push state sk@(SecretKey _ _) = return $ StateProducing (state { lastPrimaryKey = sk }) [] - push state sk@(SecretSubkey _ _) = return $ StateProducing (state { lastSubkey = sk }) [] - push state sig@(Signature (SigV4 {})) = return $ StateProducing state { lastSig = sig } [verifySig kr sig state] - push state (OnePassSignature _ _ _ _ _ False) = return $ StateProducing state [] + push state ld@(LiteralDataPkt {}) = return $ StateProducing (state { lastLD = ld }) [] + push state uid@(UserIdPkt _) = return $ StateProducing (state { lastUIDorUAt = uid }) [] + push state uat@(UserAttributePkt _) = return $ StateProducing (state { lastUIDorUAt = uat }) [] + push state pk@(PublicKeyPkt _) = return $ StateProducing (state { lastPrimaryKey = pk }) [] + push state pk@(PublicSubkeyPkt _) = return $ StateProducing (state { lastSubkey = pk }) [] + push state sk@(SecretKeyPkt _ _) = return $ StateProducing (state { lastPrimaryKey = sk }) [] + push state sk@(SecretSubkeyPkt _ _) = return $ StateProducing (state { lastSubkey = sk }) [] + push state sig@(SignaturePkt (SigV4 {})) = return $ StateProducing state { lastSig = sig } [verifySig kr sig state mt] + push state (OnePassSignaturePkt _ _ _ _ _ False) = return $ StateProducing state [] push state _ = return $ StateProducing state [] close _ = return [] normLineEndings = id -- FIXME - -verifySig :: Keyring -> Packet -> PacketStreamContext -> Either String PKPayload -- FIXME: this should be more informative -verifySig kr sig@(Signature (SigV4 st _ _ _ _ _ _)) state = verify kr sig (payloadForSig st state) -verifySig _ _ _ = Left "This should never happen." - -verify :: Keyring -> Packet -> ByteString -> Either String PKPayload -verify kr sig 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)) - let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps - case rights results of - [] -> Left (concatMap (++"/") (lefts results)) - [r] -> Right r -- FIXME: this should also check expiration time and flags of the signing key - _ -> Left "multiple successes; unexpected condition" - where - subPKP (pack, _, _) = subPKP' pack - subPKP' (PublicSubkey p) = p - subPKP' (SecretSubkey p _) = p - verify' (Signature s) (pub@(PubV4 _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl - verify' _ _ _ _ = error "This should never happen." - 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) - dsaMPIsToSig mpis = (unMPI (mpis !! 0), unMPI (mpis !! 1)) - rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis)) - finalPayload s pl = B.concat [pl, sigbit s, trailer s] - sigbit s = runPut $ putPartialSigforSigning s - hashalgo :: Packet -> HashAlgorithm - hashalgo (Signature (SigV4 _ _ ha _ _ _ _)) = ha - hashalgo _ = error "This should never happen." - trailer :: Packet -> ByteString - trailer s@(Signature (SigV4 {})) = runPut $ putSigTrailer s - trailer _ = B.empty - dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits - dsaQLen pk = (\(_,_,z) -> countBits (integerToBEBS z)) (DSA.public_params pk) - pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis) - pkaAndMPIs _ = error "This should never happen." diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.4 +Version: 0.5 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -97,6 +97,20 @@ , tests/data/uncompressed-ops-dsa.gpg , tests/data/uncompressed-ops-dsa-sha384.txt.gpg , tests/data/encryption.gpg + , tests/data/compressedsig-zlib.gpg + , tests/data/compressedsig-bzip2.gpg + , tests/data/onepass_sig + , tests/data/simple.seckey + , tests/data/minimized.gpg + , tests/data/subkey.gpg + , tests/data/signing-subkey.gpg + , tests/data/uat.gpg + , tests/data/prikey-rev.gpg + , tests/data/subkey-rev.gpg + , tests/data/6F87040E.pubkey + , tests/data/6F87040E-cr.pubkey + , tests/data/v3.key + , tests/data/primary-binding.gpg Cabal-version: >= 1.10 @@ -106,12 +120,12 @@ , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Fingerprint + , Codec.Encryption.OpenPGP.Verify , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Verify Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.SerializeForSigs - , Data.Conduit.OpenPGP.Internal Build-depends: asn1-data , attoparsec , base > 4 && < 5 @@ -127,6 +141,7 @@ , mtl , openpgp-asciiarmor >= 0.1 , split + , time >= 1.1 , zlib default-language: Haskell2010 @@ -134,6 +149,7 @@ Test-Suite tests type: exitcode-stdio-1.0 main-is: tests/suite.hs + Ghc-options: -Wall Build-depends: asn1-data , attoparsec , base > 4 && < 5 @@ -149,6 +165,7 @@ , mtl , openpgp-asciiarmor >= 0.1 , split + , time >= 1.1 , zlib , HUnit , test-framework diff --git a/tests/data/6F87040E-cr.pubkey b/tests/data/6F87040E-cr.pubkey new file mode 100644 Binary files /dev/null and b/tests/data/6F87040E-cr.pubkey differ diff --git a/tests/data/6F87040E.pubkey b/tests/data/6F87040E.pubkey new file mode 100644 Binary files /dev/null and b/tests/data/6F87040E.pubkey differ diff --git a/tests/data/compressedsig-bzip2.gpg b/tests/data/compressedsig-bzip2.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig-bzip2.gpg differ diff --git a/tests/data/compressedsig-zlib.gpg b/tests/data/compressedsig-zlib.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig-zlib.gpg differ diff --git a/tests/data/minimized.gpg b/tests/data/minimized.gpg new file mode 100644 Binary files /dev/null and b/tests/data/minimized.gpg differ diff --git a/tests/data/onepass_sig b/tests/data/onepass_sig new file mode 100644 Binary files /dev/null and b/tests/data/onepass_sig differ diff --git a/tests/data/prikey-rev.gpg b/tests/data/prikey-rev.gpg new file mode 100644 Binary files /dev/null and b/tests/data/prikey-rev.gpg differ diff --git a/tests/data/primary-binding.gpg b/tests/data/primary-binding.gpg new file mode 100644 Binary files /dev/null and b/tests/data/primary-binding.gpg differ diff --git a/tests/data/signing-subkey.gpg b/tests/data/signing-subkey.gpg new file mode 100644 Binary files /dev/null and b/tests/data/signing-subkey.gpg differ diff --git a/tests/data/simple.seckey b/tests/data/simple.seckey new file mode 100644 Binary files /dev/null and b/tests/data/simple.seckey differ diff --git a/tests/data/subkey-rev.gpg b/tests/data/subkey-rev.gpg new file mode 100644 Binary files /dev/null and b/tests/data/subkey-rev.gpg differ diff --git a/tests/data/subkey.gpg b/tests/data/subkey.gpg new file mode 100644 Binary files /dev/null and b/tests/data/subkey.gpg differ diff --git a/tests/data/uat.gpg b/tests/data/uat.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uat.gpg differ diff --git a/tests/data/v3.key b/tests/data/v3.key new file mode 100644 Binary files /dev/null and b/tests/data/v3.key differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -11,7 +11,7 @@ import Test.HUnit (Assertion, assertFailure, assertEqual) import Codec.Encryption.OpenPGP.Serialize () -import Codec.Encryption.OpenPGP.Compression (decompressPacket, compressPackets) +import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types import Data.Conduit.Cereal (conduitGet) @@ -20,7 +20,6 @@ import Data.Conduit.OpenPGP.Verify (conduitVerify) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC8 import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Serialize (get, put) @@ -32,60 +31,60 @@ import qualified Data.Conduit.List as CL testSerialization :: FilePath -> Assertion -testSerialization fp = do - bs <- B.readFile $ "tests/data/" ++ fp +testSerialization fpr = do + bs <- B.readFile $ "tests/data/" ++ fpr let firstpass = runGet get bs case fmap unBlock firstpass of - Left err -> assertFailure $ "First pass failed on " ++ fp - Right [] -> assertFailure $ "First pass of " ++ fp ++ " decoded to nothing." + Left err -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." Right packs -> do let roundtrip = runPut $ put (Block packs) - let secondpass = runGet (get :: Get (Block Packet)) roundtrip + let secondpass = runGet (get :: Get (Block Pkt)) roundtrip if fmap unBlock secondpass == Right [] then - assertFailure $ "Second pass of " ++ fp ++ " decoded to nothing." + assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." else - assertEqual ("for " ++ fp) firstpass secondpass + assertEqual ("for " ++ fpr) firstpass secondpass testCompression :: FilePath -> Assertion -testCompression fp = do - bs <- B.readFile $ "tests/data/" ++ fp - let firstpass = fmap (concatMap decompressPacket) . fmap unBlock . runGet get $ bs +testCompression fpr = do + bs <- B.readFile $ "tests/data/" ++ fpr + let firstpass = fmap (concatMap decompressPkt) . fmap unBlock . runGet get $ bs case firstpass of - Left _ -> assertFailure $ "First pass failed on " ++ fp - Right [] -> assertFailure $ "First pass of " ++ fp ++ " decoded to nothing." - Right packs -> do let roundtrip = runPut $ put . Block $ [compressPackets ZIP packs] - let secondpass = fmap (concatMap decompressPacket) . fmap unBlock . runGet get $ roundtrip + Left _ -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." + Right packs -> do let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] + let secondpass = fmap (concatMap decompressPkt) . fmap unBlock . runGet get $ roundtrip if secondpass == Right [] then - assertFailure $ "Second pass of " ++ fp ++ " decoded to nothing." + assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." else - assertEqual ("for " ++ fp) firstpass secondpass + assertEqual ("for " ++ fpr) firstpass secondpass counter :: (DC.MonadResource m) => DC.Sink a m Int counter = CL.fold (const . (1+)) 0 testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString (DC.ResourceT IO) b -> Int -> Assertion -testConduitOutputLength fp c target = do - len <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= c DC.$$ counter +testConduitOutputLength fpr c target = do + len <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= c DC.$$ counter assertEqual ("expected length" ++ show target) target len testKeyIDandFingerprint :: FilePath -> String -> Assertion -testKeyIDandFingerprint fp kf = do - bs <- B.readFile $ "tests/data/" ++ fp - case runGet (get :: Get Packet) bs of - Left _ -> assertFailure $ "Decoding of " ++ fp ++ " broke." - Right (PublicKey pkp) -> assertEqual ("for " ++ fp) kf (show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) +testKeyIDandFingerprint fpr kf = do + bs <- B.readFile $ "tests/data/" ++ fpr + case runGet (get :: Get Pkt) bs of + Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." + Right (PublicKeyPkt pkp) -> assertEqual ("for " ++ fpr) kf (show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) _ -> assertFailure "Expected public key, got something else." testKeyringLookup :: FilePath -> String -> Bool -> Assertion -testKeyringLookup fp eok expected = do - kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap +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) - assertEqual (eok ++ " in " ++ fp) expected (isJust key) + assertEqual (eok ++ " in " ++ fpr) expected (isJust key) testVerifyMessage :: FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion testVerifyMessage keyring message issuers = do kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap - verification <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr DC.$$ CL.consume - let verification' = map (fmap fingerprint) verification + verification <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr Nothing DC.$$ CL.consume + let verification' = map (fmap (fingerprint . verificationSigner)) verification assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' tests :: [Test] @@ -178,6 +177,10 @@ , testCase "uncompressed-ops-dsa.gpg" (testSerialization "uncompressed-ops-dsa.gpg") , testCase "uncompressed-ops-rsa.gpg" (testSerialization "uncompressed-ops-rsa.gpg") , testCase "simple.seckey" (testSerialization "simple.seckey") + ], + testGroup "KeyID/fingerprint group" [ + testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E ") + , testCase "v4 key" (testKeyIDandFingerprint "000001-006.public_key" "D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") ], testGroup "Keyring group" [ testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)