hOpenPGP 1.2.1 → 1.3

raw patch · 6 files changed

+189/−159 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Codec/Encryption/OpenPGP/KeyringParser.hs +176/−0
• Data/Conduit/OpenPGP/Filter.hs +1/−1
• Data/Conduit/OpenPGP/Keyring.hs +6/−152
• Data/Conduit/OpenPGP/Verify.hs +1/−2
• hOpenPGP.cabal +3/−2
• tests/suite.hs +2/−2

@@ -0,0 +1,176 @@+-- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing+-- Copyright © 2012-2014  Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.KeyringParser (+   parseAChunk+ , finalizeParsing+ , parseTK+ , UidOrUat(..)+ , splitUs+ , publicTK+ , secretTK+ , brokenTK+ , pkPayload+ , signature+ , signedUID+ , signedUAt+ , signedOrRevokedPubSubkey+ , brokenPubSubkey+ , rawOrSignedOrRevokedSecSubkey+ , brokenSecSubkey+ , skPayload+ , broken+) where++import Control.Applicative (many, (<$>), (<|>))+import Data.IxSet (empty, insert)+import Data.Monoid (Monoid, (<>), mconcat)++import Codec.Encryption.OpenPGP.Types+import Data.Conduit.OpenPGP.Keyring.Instances ()+import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, feed, feedEof, inspect, satisfy, Parser)++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 _ 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 (_, 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 (_, 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++data UidOrUat = I String | A [UserAttrSubPacket]+    deriving Show++splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(String, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])+splitUs us = (is, as)+    where+        is = map unI (filter isI us)+        as = map unA (filter isA us)+	isI ((I _), _) = True+	isI _ = False+	isA ((A _), _) = True+	isA _ = False+	unI ((I x), y) = (x, y)+	unI x = error $ "unI should never be called on " ++ show x+	unA ((A x), y) = (x, y)+	unA x = error $ "unA should never be called on " ++ show x++publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK)+publicTK intolerant = do+    pkp <- pkPayload+    pkpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])+    (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant+    subs <- concatMany (pubsub intolerant)+    return $! Just (TK pkp pkpsigs uids uats subs)+        where+            pubsub True = signedOrRevokedPubSubkey True+            pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey+secretTK intolerant = do+    skp <- skPayload+    skpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])+    (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant?+    subs <- concatMany (secsub intolerant)+    return $! Just (TK skp skpsigs uids uats subs)+        where+            secsub True = rawOrSignedOrRevokedSecSubkey True+            secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey++brokenTK :: Int -> Parser [Pkt] (Maybe TK)+brokenTK 6 = do+    _ <- broken 6+    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])+    _ <- many (signedUID False <|> signedUAt False)+    _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)+    return Nothing+brokenTK 5 = do+    _ <- broken 5+    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])+    _ <- many (signedUID False <|> signedUAt False)+    _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey)+    return Nothing+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] (UidOrUat, [SignaturePayload])+signedUID intolerant = do [UserIdPkt u] <- satisfy isUID+                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])+                          return (I u, sigs)+    where+        isUID [UserIdPkt _] = True+        isUID _ = False++signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])+signedUAt intolerant = do [UserAttributePkt us] <- satisfy isUAt+                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])+                          return (A 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++brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]+brokenPubSubkey = do _ <- broken 14+                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])+                     return []++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++brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]+brokenSecSubkey = do _ <- broken 7+                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])+                     return []++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

@@ -109,7 +109,7 @@  ovToInt (OInt i) = i -conduitFilter :: MonadResource m => FilterPredicates -> Conduit Pkt m Pkt+conduitFilter :: Monad m => FilterPredicates -> Conduit Pkt m Pkt conduitFilter = CL.filter . superPredicate  superPredicate :: FilterPredicates -> Pkt -> Bool

@@ -9,27 +9,24 @@  , sinkKeyringMap ) where -import Control.Applicative (many, (<$>), (<|>))-import Control.Monad.Trans.Resource (MonadResource) import Data.Conduit import qualified Data.Conduit.List as CL import Data.IxSet (empty, insert)-import Data.Monoid (Monoid, (<>), mconcat) +import Codec.Encryption.OpenPGP.KeyringParser (finalizeParsing, parseAChunk, parseTK) 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) -conduitToTKs :: MonadResource m => Conduit Pkt m TK+conduitToTKs :: Monad m => Conduit Pkt m TK conduitToTKs = conduitToTKs' True -conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK+conduitToTKsDropping :: Monad m => Conduit Pkt m TK conduitToTKsDropping = conduitToTKs' False -fakecmAccum :: MonadResource m => (accum -> (accum, [b])) -> (a -> accum -> (accum, [b])) -> accum -> Conduit a m b+fakecmAccum :: Monad m => (accum -> (accum, [b])) -> (a -> accum -> (accum, [b])) -> accum -> Conduit a m b fakecmAccum finalizer f =     loop   where@@ -41,154 +38,11 @@             Prelude.mapM_ yield bs             loop accum' -conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK+conduitToTKs' :: Monad m => Bool -> Conduit Pkt m TK conduitToTKs' intolerant = CL.filter notTrustPacket =$= CL.map (:[]) =$= fakecmAccum finalizeParsing (parseAChunk (parseTK intolerant)) ([], Just (Nothing, parseTK intolerant)) =$= CL.catMaybes     where         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 _ 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 (_, 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 (_, 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--data UidOrUat = I String | A [UserAttrSubPacket]-    deriving Show--splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(String, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])-splitUs us = (is, as)-    where-        is = map unI (filter isI us)-        as = map unA (filter isA us)-	isI ((I _), _) = True-	isI _ = False-	isA ((A _), _) = True-	isA _ = False-	unI ((I x), y) = (x, y)-	unI x = error $ "unI should never be called on " ++ show x-	unA ((A x), y) = (x, y)-	unA x = error $ "unA should never be called on " ++ show x--publictk, secrettk :: Bool -> Parser [Pkt] (Maybe TK)-publictk intolerant = do-    pkp <- pkpayload-    pkpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])-    (uids, uats) <- fmap splitUs (many (signeduid intolerant <|> signeduat intolerant)) -- FIXME: require >=1 uid if intolerant-    subs <- concatMany (pubsub intolerant)-    return $! Just (TK pkp pkpsigs uids uats subs)-        where-            pubsub True = signedorrevokedpubsubkey True-            pubsub False = signedorrevokedpubsubkey False <|> brokenpubsubkey-secrettk intolerant = do-    skp <- skpayload-    skpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])-    (uids, uats) <- fmap splitUs (many (signeduid intolerant <|> signeduat intolerant)) -- FIXME: require >=1 uid if intolerant?-    subs <- concatMany (secsub intolerant)-    return $! Just (TK skp skpsigs uids uats subs)-        where-            secsub True = raworsignedorrevokedsecsubkey True-            secsub False = raworsignedorrevokedsecsubkey False <|> brokensecsubkey--brokentk :: Int -> Parser [Pkt] (Maybe TK)-brokentk 6 = do-    _ <- broken 6-    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])-    _ <- many (signeduid False <|> signeduat False)-    _ <- concatMany (signedorrevokedpubsubkey False <|> brokenpubsubkey)-    return Nothing-brokentk 5 = do-    _ <- broken 5-    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])-    _ <- many (signeduid False <|> signeduat False)-    _ <- concatMany (raworsignedorrevokedsecsubkey False <|> brokensecsubkey)-    return Nothing-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] (UidOrUat, [SignaturePayload])-signeduid intolerant = do [UserIdPkt u] <- satisfy isUID-                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])-                          return (I u, sigs)-    where-        isUID [UserIdPkt _] = True-        isUID _ = False--signeduat :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])-signeduat intolerant = do [UserAttributePkt us] <- satisfy isUAt-                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])-                          return (A 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--brokenpubsubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]-brokenpubsubkey = do _ <- broken 14-                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])-                     return []--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--brokensecsubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]-brokensecsubkey = do _ <- broken 7-                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])-                     return []--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 :: Monad m => Sink TK m Keyring sinkKeyringMap = CL.fold (flip insert) empty

@@ -7,7 +7,6 @@    conduitVerify ) where -import Control.Monad.Trans.Resource (MonadResource) import Data.Conduit import Data.Time.Clock (UTCTime) @@ -16,7 +15,7 @@ import Codec.Encryption.OpenPGP.Signatures (verifySigWith, verifyAgainstKeyring) import qualified Data.Conduit.List as CL -conduitVerify :: MonadResource m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification)+conduitVerify :: Monad m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification) conduitVerify kr mt = CL.concatMapAccum (flip push) emptyPSC     where         push state ld@(LiteralDataPkt {}) = (state { lastLD = ld }, [])

@@ -1,5 +1,5 @@ Name:                hOpenPGP-Version:             1.2.1+Version:             1.3 Synopsis:            native Haskell implementation of OpenPGP (RFC4880) Description:         native Haskell implementation of OpenPGP (RFC4880) Homepage:            http://floss.scru.org/hOpenPGP/@@ -151,6 +151,7 @@                      , Codec.Encryption.OpenPGP.Expirations                      , Codec.Encryption.OpenPGP.Fingerprint                      , Codec.Encryption.OpenPGP.KeyInfo+                     , Codec.Encryption.OpenPGP.KeyringParser                      , Codec.Encryption.OpenPGP.KeySelection                      , Codec.Encryption.OpenPGP.S2K                      , Codec.Encryption.OpenPGP.CFB@@ -248,4 +249,4 @@ source-repository this   type:     git   location: git://git.debian.org/users/clint/hOpenPGP.git-  tag:      v1.2.1+  tag:      v1.3

@@ -21,7 +21,7 @@ import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Error.Util (isRight)-import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)+import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Crypto.PubKey.RSA (PrivateKey(private_pub)) import Data.Conduit.Cereal (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress)@@ -68,7 +68,7 @@                           else                               assertEqual ("for " ++ fpr) firstpass secondpass -counter :: (MonadResource m) => DC.Sink a m Int+counter :: (Monad m) => DC.Sink a m Int counter = CL.fold (const . (1+)) 0  testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString (ResourceT IO) b -> Int -> Assertion