diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -13,6 +13,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Codec.Encryption.OpenPGP.Types +import Codec.Encryption.OpenPGP.Ontology (isKET) -- this assumes that all key expiration time subpackets are valid isTKTimeValid :: UTCTime -> TK -> Bool @@ -25,7 +26,3 @@ getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs - where - isKET (SigSubPacket _ (KeyExpirationTime _)) = True - isKET _ = False -getKeyExpirationTimesFromSignature _ = [] diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -38,6 +38,7 @@ import Data.Word (Word8, Word16) import Codec.Encryption.OpenPGP.Types +import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) countBits :: ByteString -> Word16 countBits bs @@ -59,10 +60,7 @@ 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) - where - isIssuer (SigSubPacket _ (Issuer _)) = True - isIssuer _ = False +issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs) issuer _ = Nothing pubkeyToMPIs :: PKey -> [MPI] @@ -100,9 +98,6 @@ sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT (SigV3 _ ct _ _ _ _ _) = Just ct sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) - where - isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True - isSigCreationTime _ = False sigCT _ = Nothing truncatingVerify :: (ByteArrayAccess msg, CHI.HashAlgorithm hash) => hash -> DSA.PublicKey -> DSA.Signature -> msg -> Bool diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -6,9 +6,10 @@ {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.KeyringParser ( + -- * Parsers parseAChunk , finalizeParsing - , parseTK + , anyTK , UidOrUat(..) , splitUs , publicTK @@ -24,13 +25,15 @@ , brokenSecSubkey , skPayload , broken + -- * Utilities + , parseTKs ) where import Control.Applicative (many, (<|>)) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif - +import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid, mconcat) #endif @@ -40,7 +43,7 @@ import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () -import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, feed, feedEof, inspect, satisfy, Parser) +import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, completeResults, feed, feedEof, inspect, Parser, satisfy) 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 @@ -52,9 +55,9 @@ 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 +anyTK :: Bool -> Parser [Pkt] (Maybe TK) +anyTK True = publicTK True <|> secretTK True +anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 data UidOrUat = I Text | A [UserAttrSubPacket] deriving Show @@ -184,3 +187,11 @@ where isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a isBroken _ = False + +-- | parse TKs from packets +parseTKs :: Bool -> [Pkt] -> [TK] +parseTKs intolerant ps = catMaybes (concatMap fst (completeResults (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant)))))) + where + notTrustPacket (TrustPkt _) = False + notTrustPacket _ = True + diff --git a/Codec/Encryption/OpenPGP/Ontology.hs b/Codec/Encryption/OpenPGP/Ontology.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Ontology.hs @@ -0,0 +1,77 @@ +-- Ontology.hs: OpenPGP (RFC4880) "is" functions +-- Copyright © 2012-2016 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.Ontology ( + -- * for signature payloads + isCertRevocationSig + , isRevokerP + , isPKBindingSig + , isSKBindingSig + , isSubkeyBindingSig + , isSubkeyRevocation + -- * for signature subpackets + , isCT + , isIssuerSSP + , isKET + , isKUF + , isPHA + , isRevocationKeySSP + , isSigCreationTime +) where + +import Codec.Encryption.OpenPGP.Types + +isCertRevocationSig :: SignaturePayload -> Bool +isCertRevocationSig (SigV4 CertRevocationSig _ _ _ _ _ _) = True +isCertRevocationSig _ = False + +isRevokerP :: SignaturePayload -> Bool +isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = any isRevocationKeySSP h && any isIssuerSSP u +isRevokerP _ = False + +isPKBindingSig :: SignaturePayload -> Bool +isPKBindingSig (SigV4 PrimaryKeyBindingSig _ _ _ _ _ _) = True +isPKBindingSig _ = False + +isSKBindingSig :: SignaturePayload -> Bool +isSKBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True +isSKBindingSig _ = False + +isSubkeyRevocation :: SignaturePayload -> Bool +isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True +isSubkeyRevocation _ = False + +isSubkeyBindingSig :: SignaturePayload -> Bool +isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True +isSubkeyBindingSig _ = False + + +isCT :: SigSubPacket -> Bool +isCT (SigSubPacket _ (SigCreationTime _)) = True +isCT _ = False + +isIssuerSSP :: SigSubPacket -> Bool +isIssuerSSP (SigSubPacket _ (Issuer _)) = True +isIssuerSSP _ = False + +isKET :: SigSubPacket -> Bool +isKET (SigSubPacket _ (KeyExpirationTime _)) = True +isKET _ = False + +isKUF :: SigSubPacket -> Bool +isKUF (SigSubPacket _ (KeyFlags _)) = True +isKUF _ = False + +isPHA :: SigSubPacket -> Bool +isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True +isPHA _ = False + +isRevocationKeySSP :: SigSubPacket -> Bool +isRevocationKeySSP (SigSubPacket _ (RevocationKey {})) = True +isRevocationKeySSP _ = False + +isSigCreationTime :: SigSubPacket -> Bool +isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True +isSigCreationTime _ = False diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -6,8 +6,11 @@ {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.Serialize ( + -- * Serialization functions putSKAddendum , getSecretKey + -- * Utilities + , parsePkts ) where #if !MIN_VERSION_base(4,8,0) @@ -1235,3 +1238,10 @@ putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps putSub' (p, sps) = put p >> mapM_ (put . Signature) sps + +-- | Parse the packets from a ByteString, with no error reporting +parsePkts :: ByteString -> [Pkt] +parsePkts lbs = + case runGetOrFail (some getPkt) lbs of + Left (_, _, e) -> [] + Right (_, _, p) -> p diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -37,6 +37,8 @@ import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), issuer, emptyPSC, truncatingVerify) +import Codec.Encryption.OpenPGP.Ontology (isRevokerP, isRevocationKeySSP, isSubkeyBindingSig, isSubkeyRevocation) + import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () @@ -83,16 +85,6 @@ (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [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] _ -> [] - 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 - isRevocationKeySSP _ = False - isIssuerSSP (SigSubPacket _ (Issuer _)) = True - isIssuerSSP _ = False vUid :: (Text, SignaturePayload) -> Either String Verification vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserIdPkt uid } mt vUAt :: ([UserAttrSubPacket], SignaturePayload) -> Either String Verification diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -13,7 +13,7 @@ import qualified Data.Conduit.List as CL import Data.IxSet.Typed (empty, insert) -import Codec.Encryption.OpenPGP.KeyringParser (finalizeParsing, parseAChunk, parseTK) +import Codec.Encryption.OpenPGP.KeyringParser (finalizeParsing, parseAChunk, anyTK) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () @@ -39,7 +39,7 @@ loop accum' 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 +conduitToTKs' intolerant = CL.filter notTrustPacket =$= CL.map (:[]) =$= fakecmAccum finalizeParsing (parseAChunk (anyTK intolerant)) ([], Just (Nothing, anyTK intolerant)) =$= CL.catMaybes where notTrustPacket (TrustPkt _) = False notTrustPacket _ = True diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 2.4.4 +Version: 2.5 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581) Homepage: http://floss.scru.org/hOpenPGP/ @@ -155,16 +155,17 @@ Library Exposed-modules: Codec.Encryption.OpenPGP.Types - , Codec.Encryption.OpenPGP.Serialize + , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection + , Codec.Encryption.OpenPGP.Ontology , Codec.Encryption.OpenPGP.S2K - , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.SecretKey + , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt @@ -335,4 +336,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v2.4.4 + tag: v2.5 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -16,9 +16,10 @@ import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts) import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.KeyringParser (parseTKs) import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) -import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Error.Util (isRight) @@ -162,7 +163,21 @@ newtruck = toPkt (SecretKey pkp newska):tail kr assertEqual "encrypted private key matches golden file" gkr newtruck +testParsePktsUtil :: FilePath -> Assertion +testParsePktsUtil fn = do + let fpath = "tests/data/" ++ fn + cp <- runResourceT $ CB.sourceFile fpath DC.$= conduitGet get DC.$$ CL.consume + pp <- BL.readFile fpath >>= return . parsePkts + assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pp +testParseTKsUtil :: FilePath -> Assertion +testParseTKsUtil fn = do + let fpath = "tests/data/" ++ fn + lbs <- BL.readFile fpath + cp <- runResourceT $ CB.sourceLbs lbs DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume + let pt = parseTKs True . parsePkts $ lbs + assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pt + tests :: TestTree tests = testGroup "Tests" [properties, unitTests] @@ -347,6 +362,10 @@ ], testGroup "Encrypting secret keys" [ testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt") + ], + testGroup "Utility function group" [ + testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") + , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") ] ]