packages feed

hOpenPGP 0.4 → 0.5

raw patch · 27 files changed

+885/−457 lines, 27 filesdep +timebinary-added

Dependencies added: time

Files

Codec/Encryption/OpenPGP/Compression.hs view
@@ -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"
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -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))
Codec/Encryption/OpenPGP/Internal.hs view
@@ -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
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -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
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -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])
Codec/Encryption/OpenPGP/Types.hs view
@@ -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+    }
+ Codec/Encryption/OpenPGP/Verify.hs view
@@ -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
Data/Conduit/OpenPGP/Compression.hs view
@@ -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
− Data/Conduit/OpenPGP/Internal.hs 
@@ -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 []
Data/Conduit/OpenPGP/Keyring.hs view
@@ -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
Data/Conduit/OpenPGP/Verify.hs view
@@ -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."
hOpenPGP.cabal view
@@ -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
+ tests/data/6F87040E-cr.pubkey view

binary file changed (absent → 909 bytes)

+ tests/data/6F87040E.pubkey view

binary file changed (absent → 683 bytes)

+ tests/data/compressedsig-bzip2.gpg view

binary file changed (absent → 442 bytes)

+ tests/data/compressedsig-zlib.gpg view

binary file changed (absent → 322 bytes)

+ tests/data/minimized.gpg view

binary file changed (absent → 429 bytes)

+ tests/data/onepass_sig view

binary file changed (absent → 15 bytes)

+ tests/data/prikey-rev.gpg view

binary file changed (absent → 376 bytes)

+ tests/data/primary-binding.gpg view

binary file changed (absent → 528 bytes)

+ tests/data/signing-subkey.gpg view

binary file changed (absent → 976 bytes)

+ tests/data/simple.seckey view

binary file changed (absent → 868 bytes)

+ tests/data/subkey-rev.gpg view

binary file changed (absent → 547 bytes)

+ tests/data/subkey.gpg view

binary file changed (absent → 575 bytes)

+ tests/data/uat.gpg view

binary file changed (absent → 711 bytes)

+ tests/data/v3.key view

binary file changed (absent → 143 bytes)

tests/suite.hs view
@@ -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)