packages feed

hOpenPGP 2.4.4 → 2.5

raw patch · 9 files changed

+136/−34 lines, 9 files

Files

Codec/Encryption/OpenPGP/Expirations.hs view
@@ -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 _ = []
Codec/Encryption/OpenPGP/Internal.hs view
@@ -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
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -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+
+ Codec/Encryption/OpenPGP/Ontology.hs view
@@ -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
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -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
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -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
Data/Conduit/OpenPGP/Keyring.hs view
@@ -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
hOpenPGP.cabal view
@@ -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
tests/suite.hs view
@@ -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")    ]  ]