hOpenPGP 0.14 → 1.0

raw patch · 11 files changed

+187/−134 lines, 11 filesdep +incremental-parserdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: incremental-parser

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Codec/Encryption/OpenPGP/Expirations.hs +3/−2
• Codec/Encryption/OpenPGP/Fingerprint.hs +2/−2
• Codec/Encryption/OpenPGP/Internal.hs +15/−11
• Codec/Encryption/OpenPGP/KeyInfo.hs +6/−5
• Codec/Encryption/OpenPGP/Serialize.hs +2/−2
• Codec/Encryption/OpenPGP/SerializeForSigs.hs +8/−8
• Codec/Encryption/OpenPGP/Signatures.hs +36/−29
• Codec/Encryption/OpenPGP/Types.hs +6/−4
• Data/Conduit/OpenPGP/Filter.hs +4/−2
• Data/Conduit/OpenPGP/Keyring.hs +101/−67
• hOpenPGP.cabal +4/−2

@@ -8,6 +8,7 @@  , getKeyExpirationTimesFromSignature ) where +import Control.Lens ((&), (^.), _1) import Data.List (sort) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)@@ -18,8 +19,8 @@ isTKTimeValid :: UTCTime -> TK -> Bool isTKTimeValid ct key = ct >= keyCreationTime && ct < keyExpirationTime     where-        keyCreationTime = posixSecondsToUTCTime . realToFrac . _timestamp . _tkPKP $ key-        keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((+) (_timestamp . _tkPKP $ key)) . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (_tkUIDs key) ++ concatMap snd (_tkUAts key))+        keyCreationTime = key^.tkKey._1.timestamp & posixSecondsToUTCTime . realToFrac+        keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((+) (key^.tkKey._1.timestamp)) . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (key^.tkUIDs) ++ concatMap snd (key^.tkUAts)) 	newest [] = maxBound 	newest xs = last (sort xs) 

@@ -1,5 +1,5 @@ -- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2013  Clint Adams+-- Copyright © 2012-2014  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -21,7 +21,7 @@ eightOctetKeyID :: PKPayload -> EightOctetKeyId eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4-eightOctetKeyID _ = error "This should never happen."+eightOctetKeyID _ = error "This should never happen (eightOctetKeyID)."  fingerprint :: PKPayload -> TwentyOctetFingerprint fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))

@@ -3,6 +3,8 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE OverloadedStrings #-}+ module Codec.Encryption.OpenPGP.Internal (    countBits  , beBSToInteger@@ -31,7 +33,9 @@ import Codec.Encryption.OpenPGP.Types  countBits :: ByteString -> Word16-countBits bs = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7)+countBits bs+    | B.null bs = 0+    | otherwise = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7)     where         go :: Word8 -> Int -> Word8         go _ 0 = 7@@ -51,7 +55,7 @@                       }  emptyPSC :: PktStreamContext-emptyPSC = PktStreamContext (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty) (MarkerPkt B.empty)+emptyPSC = PktStreamContext (OtherPacketPkt 0 "lastLD placeholder") (OtherPacketPkt 0 "lastUIDorUAt placeholder") (OtherPacketPkt 0 "lastSig placeholder") (OtherPacketPkt 0 "lastPrimaryKey placeholder") (OtherPacketPkt 0 "lastSubkey placeholder")  issuer :: Pkt -> Maybe EightOctetKeyId issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuer usubs)@@ -60,15 +64,15 @@         isIssuer _ = False issuer _ = Nothing -hashDescr :: HashAlgorithm -> HashDescr-hashDescr SHA1 = hashDescrSHA1-hashDescr RIPEMD160 = hashDescrRIPEMD160-hashDescr SHA256 = hashDescrSHA256-hashDescr SHA384 = hashDescrSHA384-hashDescr SHA512 = hashDescrSHA512-hashDescr SHA224 = hashDescrSHA224-hashDescr DeprecatedMD5 = hashDescrMD5-hashDescr _ = error "Hash problem" -- FIXME+hashDescr :: HashAlgorithm -> Either String HashDescr+hashDescr SHA1 = Right hashDescrSHA1+hashDescr RIPEMD160 = Right hashDescrRIPEMD160+hashDescr SHA256 = Right hashDescrSHA256+hashDescr SHA384 = Right hashDescrSHA384+hashDescr SHA512 = Right hashDescrSHA512+hashDescr SHA224 = Right hashDescrSHA224+hashDescr DeprecatedMD5 = Right hashDescrMD5+hashDescr x = Left $ "Unknown hash problem: " ++ show x  pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey k) = [MPI (RSA.public_n k), MPI (RSA.public_e k)]

@@ -1,10 +1,10 @@ -- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2013  Clint Adams+-- Copyright © 2012-2014  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).  module Codec.Encryption.OpenPGP.KeyInfo (-   keySize+   pubkeySize  , pkalgoAbbrev ) where @@ -18,9 +18,10 @@  import Codec.Encryption.OpenPGP.Types -keySize (RSAPubKey x) = RSA.public_size x * 8-keySize (DSAPubKey x) = bitcount . DSA.params_p . DSA.public_params $ x-keySize (ElGamalPubKey x) = bitcount $ head x+pubkeySize (RSAPubKey x) = Right (RSA.public_size x * 8)+pubkeySize (DSAPubKey x) = Right (bitcount . DSA.params_p . DSA.public_params $ x)+pubkeySize (ElGamalPubKey x) = Right (bitcount $ head x)+pubkeySize x = Left $ "Unable to calculate size of " ++ show x  bitcount = (*8) . length . unfoldr (\x -> if x == 0 then Nothing else Just (True, x `shiftR` 8)) 

@@ -496,12 +496,12 @@                        3 -> do len <- remaining                                bs <- getByteString len                                return (t, bs)-                       _ -> error "This should never happen."+                       _ -> error "This should never happen (getPacketTypeAndPayload/0x00)."         0x40 -> do                    len <- fmap fromIntegral getPacketLength                    bs <- getByteString len                    return (tag .&. 0x3f, bs)-        _ -> error "This should never happen."+        _ -> error "This should never happen (getPacketTypeAndPayload/???)."  getPkt :: Get Pkt getPkt = do

@@ -1,5 +1,5 @@ -- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes--- Copyright © 2012-2013  Clint Adams+-- Copyright © 2012-2014  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -34,7 +34,7 @@     let bs = runPut $ put pkp     putWord16be . fromIntegral $ B.length bs     putByteString bs-putPKPforFingerprinting _ = fail "This should never happen"+putPKPforFingerprinting _ = fail "This should never happen (putPKPforFingerprinting)"  putMPIforFingerprinting:: MPI -> Put putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putByteString bs@@ -48,7 +48,7 @@     let hb = runPut $ mapM_ put hashed     putWord16be . fromIntegral . B.length $ hb     putByteString hb-putPartialSigforSigning _ = fail "This should never happen"+putPartialSigforSigning _ = fail "This should never happen (putPartialSigforSigning)"  putSigTrailer :: Pkt -> Put putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do@@ -56,12 +56,12 @@             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"+putSigTrailer _ = fail "This should never happen (putSigTrailer)"  putUforSigning :: Pkt -> Put putUforSigning u@(UserIdPkt _) = putUIDforSigning u putUforSigning u@(UserAttributePkt _) = putUAtforSigning u-putUforSigning _ = fail "This should never happen"+putUforSigning _ = fail "This should never happen (putUforSigning)"  putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do@@ -69,7 +69,7 @@     let bs = encodeUtf8 . T.pack $ u     putWord32be . fromIntegral . B.length $ bs     putByteString bs-putUIDforSigning _ = fail "This should never happen"+putUIDforSigning _ = fail "This should never happen (putUIDforSigning)"  putUAtforSigning :: Pkt -> Put putUAtforSigning (UserAttributePkt us) = do@@ -77,7 +77,7 @@     let bs = runPut (mapM_ put us)     putWord32be . fromIntegral . B.length $ bs     putByteString bs-putUAtforSigning _ = fail "This should never happen"+putUAtforSigning _ = fail "This should never happen (putUAtforSigning)"  putSigforSigning :: Pkt -> Put putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do@@ -92,7 +92,7 @@ putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp-putKeyforSigning _ = fail "This should never happen"+putKeyforSigning x = fail ("This should never happen (putKeyforSigning) " ++ show (pktTag x) ++ "/" ++ show x)  putKeyForSigning' :: PKPayload -> Put putKeyForSigning' pkp = do

@@ -10,7 +10,8 @@  , verifyTKWith ) where -import Control.Monad (guard, liftM2)+import Control.Lens ((^.), _1)+import Control.Monad (liftM2)  import Crypto.PubKey.HashDescr (HashDescr(..)) import qualified Crypto.PubKey.DSA as DSA@@ -34,46 +35,50 @@ verifySigWith :: (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification) -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? verifySigWith vf sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do     v <- vf sig mt (payloadForSig st state)-    _ <- mapM_ (checkIssuer (eightOctetKeyID (_verificationSigner v)) . _sspPayload) hs+    _ <- mapM_ (checkIssuer (eightOctetKeyID (v^.verificationSigner)) . _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-verifySigWith _ _ _ _ = Left "This should never happen."+verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)."  verifyTKWith :: (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification) -> Maybe UTCTime -> TK -> Either String TK verifyTKWith vsf mt key = do     revokers <- checkRevokers key     revs <- checkKeyRevocations revokers key-    let uids = filter (\(_, sps) -> sps /= []) . checkUidSigs $ _tkUIDs key -- FIXME: check revocations here?-    let uats = filter (\(_, sps) -> sps /= []) . checkUAtSigs $ _tkUAts key -- FIXME: check revocations here?-    let subs = concatMap checkSub $ _tkSubs key -- FIXME: check revocations here?-    return (TK (_tkPKP key) (_tkmSKA key) revs uids uats subs)+    let uids = filter (\(_, sps) -> sps /= []) . checkUidSigs $ key^.tkUIDs -- FIXME: check revocations here?+    let uats = filter (\(_, sps) -> sps /= []) . checkUAtSigs $ key^.tkUAts -- FIXME: check revocations here?+    let subs = concatMap checkSub $ key^.tkSubs -- FIXME: check revocations here?+    return (TK (key^.tkKey) 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) . _tkRevs $ k+        checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) vSig) $ k^.tkRevs         checkUidSigs :: [(String, [SignaturePayload])] -> [(String, [SignaturePayload])]         checkUidSigs = map (\(uid, sps) -> (uid, (rights . map (\sp -> fmap (const sp) (vUid (uid, sp)))) sps))         checkUAtSigs :: [([UserAttrSubPacket], [SignaturePayload])] -> [([UserAttrSubPacket], [SignaturePayload])]         checkUAtSigs = map (\(uat, sps) -> (uat, (rights . map (\sp -> fmap (const sp) (vUAt (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 p rp-        checkSub' :: Pkt -> SignaturePayload -> [(Pkt, SignaturePayload, Maybe SignaturePayload)]-        checkSub' p sp = guard (vSubSig p sp) >> return (p, sp, Nothing)+        checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]+        checkSub (pkt, sps) = if revokedSub pkt sps then [] else checkSub' pkt sps+        revokedSub :: Pkt -> [SignaturePayload] -> Bool+        revokedSub _ [] = False+        revokedSub p sigs = any (vSubSig p) (filter isSubkeyRevocation sigs)+        checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]+        checkSub' p sps = let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps) in if null goodsigs then [] else [(p, goodsigs)]         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 (_verificationSigner v == _tkPKP key) || any (\(p,f) -> p == pka && f == fingerprint (_verificationSigner v)) vokers then [Left "Key revoked"] else [Right s]+                                     (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> if (v^.verificationSigner == key ^. tkKey._1) || any (\(p,f) -> p == pka && f == fingerprint (v^.verificationSigner)) vokers then [Left "Key revoked"] else [Right s] 				     _ -> []         isKeyRevocation (SigV4 KeyRevocationSig _ _ _ _ _ _) = True         isKeyRevocation _ = False+        isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True+        isSubkeyRevocation _ = False+        isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True+        isSubkeyBindingSig _ = False         isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = any isRevocationKeySSP h && any isIssuerSSP u         isRevokerP _ = False         isRevocationKeySSP (SigSubPacket _ (RevocationKey {})) = True@@ -81,13 +86,13 @@         isIssuerSSP (SigSubPacket _ (Issuer _)) = True         isIssuerSSP _ = False         vUid :: (String, SignaturePayload) -> Either String Verification-        vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserIdPkt uid } mt+        vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserIdPkt uid } mt         vUAt :: ([UserAttrSubPacket], SignaturePayload) -> Either String Verification-        vUAt (uat, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserAttributePkt uat } mt+        vUAt (uat, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserAttributePkt uat } mt         vSig :: SignaturePayload -> Either String Verification-        vSig sp = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key) } mt+        vSig sp = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1) } mt         vSubSig :: Pkt -> SignaturePayload -> Bool-        vSubSig sk sp = case vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastSubkey = sk} mt of+        vSubSig sk sp = case vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastSubkey = sk} mt of                                 Left _ -> False 				Right _ -> True         verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)]@@ -103,7 +108,7 @@  verifyAgainstKeys :: [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification verifyAgainstKeys ks sig mt payload = do-    let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) ks)+    let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> (x ^. tkKey._1):map subPKP (_tkSubs x)) ks)     let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps     case rights results of         [] -> Left (concatMap (++"/") (lefts results))@@ -111,26 +116,28 @@ 	          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 (pack, _) = subPKP' pack         subPKP' (PublicSubkeyPkt p) = p         subPKP' (SecretSubkeyPkt p _) = p         verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ 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' _ _ _ _ = error "This should never happen (verify')."+        verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis (hashDescr ha) pkey bs) pub+        verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis (hashDescr ha) pkey bs) pub         verify'' _ _ _ _ _ = Left "unimplemented key type" 	verify''' f pub = if f then Right pub else Left "verification failed"-	dsaVerify mpis ha pkey = DSA.verify (dsaTruncate pkey . hashFunction (hashDescr ha)) pkey (dsaMPIsToSig mpis)-	rsaVerify mpis ha pkey bs = P15.verify (hashDescr ha) pkey bs (rsaMPItoSig mpis)+	dsaVerify mpis (Right hd) pkey = DSA.verify (dsaTruncate pkey . hashFunction hd) pkey (dsaMPIsToSig mpis)+	dsaVerify _ (Left _) _ = const False  -- FIXME: this should be some sort of Either chain+	rsaVerify mpis (Right hd) pkey bs = P15.verify hd pkey bs (rsaMPItoSig mpis)+	rsaVerify _ (Left _) _ _ = False  -- FIXME: this should be some sort of Either chain         dsaMPIsToSig mpis = DSA.Signature (unMPI (head mpis)) (unMPI (mpis !! 1))         rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis))         hashalgo :: Pkt -> HashAlgorithm         hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha-        hashalgo _ = error "This should never happen."+        hashalgo _ = error "This should never happen (hashalgo)."         dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits         dsaQLen = countBits . integerToBEBS . DSA.params_q . DSA.public_params 	pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)-	pkaAndMPIs _ = error "This should never happen."+	pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."         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

@@ -394,6 +394,9 @@                 | SUUnencrypted SKey Word16     deriving (Data, Eq, Show, Typeable) +instance Ord SKAddendum where+    compare a b = show a `compare` show b -- FIXME: this is ridiculous+ data DataType = BinaryData               | TextData               | UTF8Data@@ -549,16 +552,15 @@ hexToW8s = concatMap readHex . chunksOf 2 . map toLower  data TK = TK {-    _tkPKP :: PKPayload-  , _tkmSKA :: Maybe SKAddendum+    _tkKey  :: (PKPayload, Maybe SKAddendum)   , _tkRevs :: [SignaturePayload]   , _tkUIDs :: [(String, [SignaturePayload])]   , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]-  , _tkSubs :: [(Pkt, SignaturePayload, Maybe SignaturePayload)]+  , _tkSubs :: [(Pkt, [SignaturePayload])]   } deriving (Data, Eq, Show, Typeable)  instance Ord TK where-    compare = comparing _tkPKP -- FIXME: is this ridiculous?+    compare = comparing _tkKey -- FIXME: is this ridiculous?  type Keyring = IxSet TK 

@@ -21,12 +21,14 @@  , OValue(..) ) where +import Control.Error.Util (hush) import qualified Data.ByteString as B import Data.Conduit import qualified Data.Conduit.List as CL+import Data.Maybe (fromMaybe)  import Codec.Encryption.OpenPGP.Internal (sigType, sigPKA, sigHA)-import Codec.Encryption.OpenPGP.KeyInfo (keySize)+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Codec.Encryption.OpenPGP.Types  data FilterPredicates = FilterPredicates {@@ -122,7 +124,7 @@         opreduce PKGreaterThan = (>)         vreduce (PKPVVersion, p) = PKPInt (kv (_keyVersion p))         vreduce (PKPVPKA, p) = PKPPKA (_pkalgo p)-        vreduce (PKPVKeysize, p) = PKPInt (keySize . _pubkey $ p)+        vreduce (PKPVKeysize, p) = PKPInt (fromMaybe 0 . hush . pubkeySize . _pubkey $ p) -- FIXME: a Left here should invalidate the predicate or something         vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp p)) 	kv DeprecatedV3 = 3 	kv V4 = 4

@@ -9,15 +9,15 @@  , sinkKeyringMap ) where -import qualified Data.ByteString as B+import Control.Applicative (many, some, (<$>), (<*>), (<|>), (<*)) import Data.Conduit import qualified Data.Conduit.List as CL import Data.IxSet (empty, insert)-import Data.Foldable (traverse_)+import Data.Monoid (Monoid, (<>), mconcat) -import Codec.Encryption.OpenPGP.Internal (sigType) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances ()+import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, feed, feedEof, inspect, satisfy, Parser)  data Phase = MainKey | Revs | Uids | UAts | Subs | SkippingBroken     deriving (Eq, Ord, Show)@@ -28,81 +28,115 @@ conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK conduitToTKsDropping = conduitToTKs' False -fakecmAccum :: Monad m => (a -> (Phase, Maybe TK) -> ((Phase, Maybe TK), [TK])) -> (Phase, Maybe TK) -> Conduit a m TK-fakecmAccum f =+fakecmAccum :: Monad m => (accum -> (accum, [b])) -> (a -> accum -> (accum, [b])) -> accum -> Conduit a m b+fakecmAccum finalizer f =     loop   where     loop accum =-        await >>= maybe (finalyield accum) go+        await >>= maybe (Prelude.mapM_ yield (snd (finalizer accum))) go       where         go a = do             let (accum', bs) = f a accum             Prelude.mapM_ yield bs             loop accum'-        finalyield = traverse_ yield . snd  conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK-conduitToTKs' intolerant = fakecmAccum push (MainKey, Nothing)+conduitToTKs' intolerant = CL.filter notTrustPacket =$= CL.map (:[]) =$= fakecmAccum finalizeParsing (parseAChunk (parseTK intolerant)) ([], Just (Nothing, parseTK intolerant)) =$= CL.catMaybes     where-        push i s = case (s, i) of-                       ((MainKey, _), PublicKeyPkt pkp) -> ((Revs, Just (TK pkp Nothing [] [] [] [])), [])-                       ((MainKey, _), SecretKeyPkt pkp ska) -> ((Revs, Just (TK pkp (Just ska) [] [] [] [])), [])-                       ((MainKey, _), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [])-                       ((MainKey, _), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [])-                       ((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp Nothing (revs ++ [sp]) uids uats subs)), [])-                       ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)), [])-                       ((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp Nothing revs (addUidSig sp uids) uats subs)), [])-                       ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), [])-                       ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)), [])-                       ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((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) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])-                       ((Uids, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])-                       ((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp Nothing revs uids (addUAtSig sp uats) subs)), [])-                       ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)), [])-                       ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), [])-                       ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((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) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])-                       ((UAts, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])-                       ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> ((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 sp) -> case sigType sp of-                                                                                Just SubkeyBindingSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setBSig sp subs))), [])-                                                                                Just SubkeyRevocationSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setRSig sp subs))), [])-                                                                                _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i-                       ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs])-                       ((Subs, Just (TK pkp Nothing revs uids uats subs)), BrokenPacketPkt _ 6 _) -> ((SkippingBroken, Nothing), [TK pkp Nothing revs uids uats subs])-                       ((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp mska (revs ++ [sp]) uids uats subs)), [])-                       ((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs [(u, [])] uats subs)), [])-                       ((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp mska revs (addUidSig sp uids) uats subs)), [])-                       ((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), [])-                       ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids [(u, [])] subs)), [])-                       ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), [])-                       ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [TK pkp mska revs uids uats subs])-                       ((Uids, Just (TK pkp mska revs uids uats subs)), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [TK pkp mska revs uids uats subs])-                       ((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp mska revs uids (addUAtSig sp uats) subs)), [])-                       ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)), [])-                       ((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), [])-                       ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), [])-                       ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p ss) -> ((Revs, Just (TK p (Just ss) [] [] [] [])), [TK pkp mska revs uids uats subs])-                       ((UAts, Just (TK pkp mska revs uids uats subs)), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [TK pkp mska revs uids uats subs])-                       ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)]))), [])-                       ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> case sigType sp of-                                                                                Just SubkeyBindingSig -> ((Subs, Just (TK pkp mska revs uids uats (setBSig sp subs))), [])-                                                                                Just SubkeyRevocationSig -> ((Subs, Just (TK pkp mska revs uids uats (setRSig sp subs))), [])-                                                                                _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i-                       ((Subs, Just tk), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [tk])-                       ((Subs, Just tk), BrokenPacketPkt _ 5 _) -> ((SkippingBroken, Nothing), [tk])-                       ((SkippingBroken, _), PublicKeyPkt pkp) -> ((Revs, Just (TK pkp Nothing [] [] [] [])), [])-                       ((SkippingBroken, _), SecretKeyPkt pkp ska) -> ((Revs, Just (TK pkp (Just ska) [] [] [] [])), [])-                       ((SkippingBroken, _), _) -> (s, [])-                       ((_,_), TrustPkt _) -> (s, [])-                       _ -> dropOrError intolerant s $ "Unexpected packet: " ++ show (fst s) ++ "/" ++ show i-        addUidSig s uids = init uids ++ [(\(u, us) -> (u, us ++ [s])) (last uids)]-        addUAtSig s uats = init uats ++ [(\(u, us) -> (u, us ++ [s])) (last uats)]-        setBSig s subs = init subs ++ [(\(p, _, r) -> (p, s, r)) (last subs)]-        setRSig s subs = init subs ++ [(\(p, b, _) -> (p, b, Just s)) (last subs)]-        dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ((Phase, Maybe TK), [TK])-        dropOrError True _ e = error e-        dropOrError False s _ = (s, [])+        notTrustPacket (TrustPkt _) = False+        notTrustPacket _ = True++parseAChunk :: (Monoid s, Show s) => Parser s r -> s -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])+parseAChunk op a ([], Nothing) = error $ "Failure before " ++ show a+parseAChunk op a (cr, Nothing) = (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr)+parseAChunk _ a (cr, Just (_, p)) = (inspect (feed a p), [])++finalizeParsing :: Monoid s => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])+finalizeParsing ([], Nothing) = error $ "Unexpected finalization failure"+finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr)+finalizeParsing (cr, Just (_, p)) = finalizeParsing (inspect (feedEof p))++parseTK :: Bool -> Parser [Pkt] (Maybe TK)+parseTK True = publictk True <|> secrettk True+parseTK False = publictk False <|> secrettk False <|> brokentk 6 <|> brokentk 5++(.::.) = (.) . (.) . (.) . (.) . (.)++publictk, secrettk :: Bool -> Parser [Pkt] (Maybe TK)+publictk intolerant = (Just .::. TK) <$> pkpayload <*> concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey]) <*> (if intolerant then some else many) (signeduid intolerant) <*> many (signeduat intolerant) <*> many (signedorrevokedpubsubkey intolerant)+secrettk intolerant = (Just .::. TK) <$> skpayload <*> concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey]) <*> (if intolerant then some else many) (signeduid intolerant) <*> many (signeduat intolerant) <*> many (raworsignedorrevokedsecsubkey intolerant)++brokentk :: Int -> Parser [Pkt] (Maybe TK)+brokentk 6 = const Nothing <$> broken 6 <* many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey]) <* many (signeduid False) <* many (signeduat False) <* many (signedorrevokedpubsubkey False)+brokentk 5 = const Nothing <$> broken 5 <* many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey]) <* many (signeduid False) <* many (signeduat False) <* many (raworsignedorrevokedsecsubkey False)+brokentk _ = fail "Unexpected broken packet type"++pkpayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)+pkpayload = do [PublicKeyPkt p] <- satisfy isPKP+               return (p, Nothing)+    where+        isPKP [PublicKeyPkt _] = True+        isPKP _ = False++signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]+signature intolerant rts = if intolerant then signature' else (signature' <|> brokensig')+    where+        signature' = do [SignaturePkt sp] <- satisfy (isSP intolerant)+                        return $! (if intolerant then id else filter isSP') [sp]+        brokensig' = const [] <$> broken 2+        isSP True [SignaturePkt sp@(SigV3 {})] = isSP' sp+        isSP True [SignaturePkt sp@(SigV4 {})] = isSP' sp+        isSP False [SignaturePkt _] = True+        isSP _ _ = False+	isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts+	isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts+	isSP' _ = False++signeduid :: Bool -> Parser [Pkt] (String, [SignaturePayload])+signeduid intolerant = do [UserIdPkt u] <- satisfy isUID+                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])+                          return (u, sigs)+    where+        isUID [UserIdPkt _] = True+        isUID _ = False++signeduat :: Bool -> Parser [Pkt] ([UserAttrSubPacket], [SignaturePayload])+signeduat intolerant = do [UserAttributePkt us] <- satisfy isUAt+                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])+                          return (us, sigs)+    where+        isUAt [UserAttributePkt _] = True+        isUAt _ = False++signedorrevokedpubsubkey :: Bool -> Parser [Pkt] (Pkt, [SignaturePayload])+signedorrevokedpubsubkey intolerant = do [p] <- satisfy isPSKP+                                         sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+                                         return (p, sigs)+    where+        isPSKP [PublicSubkeyPkt _] = True+        isPSKP _ = False++raworsignedorrevokedsecsubkey :: Bool -> Parser [Pkt] (Pkt, [SignaturePayload])+raworsignedorrevokedsecsubkey intolerant = do [p] <- satisfy isSSKP+                                              sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+                                              return (p, sigs)+    where+        isSSKP [SecretSubkeyPkt _ _] = True+        isSSKP _ = False++skpayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)+skpayload = do [SecretKeyPkt p ska] <- satisfy isSKP+               return (p, Just ska)+    where+        isSKP [SecretKeyPkt _ _] = True+        isSKP _ = False++broken :: Int -> Parser [Pkt] Pkt+broken t = do [bp] <- satisfy isBroken+              return bp+    where+        isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a+        isBroken _ = False  sinkKeyringMap :: MonadResource m => Sink TK m Keyring sinkKeyringMap = CL.fold (flip insert) empty

@@ -1,5 +1,5 @@ Name:                hOpenPGP-Version:             0.14+Version:             1.0 Synopsis:            native Haskell implementation of OpenPGP (RFC4880) Description:         native Haskell implementation of OpenPGP (RFC4880) Homepage:            http://floss.scru.org/hOpenPGP/@@ -180,6 +180,7 @@                , cryptohash                , data-default                , errors+               , incremental-parser                , ixset                 >= 1.0                , lens                  >= 3.0                , monad-loops@@ -216,6 +217,7 @@                , cryptohash                , data-default                , errors+               , incremental-parser                , ixset                 >= 1.0                , lens                  >= 3.0                , monad-loops@@ -242,4 +244,4 @@ source-repository this   type:     git   location: git://git.debian.org/users/clint/hOpenPGP.git-  tag:      v0.14+  tag:      v1.0