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 @@ -8,6 +8,7 @@ ) where import Control.Applicative ((<$>),(<*>)) +import Control.Lens ((^.)) import Control.Monad (guard, mplus, replicateM) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D @@ -750,18 +751,18 @@ getPubkey RSA = do MPI n <- get MPI e <- get return $ RSAPubKey (R.PublicKey (B.length . integerToBEBS $ n) n e) -getPubkey RSAEncryptOnly = getPubkey RSA -getPubkey RSASignOnly = getPubkey RSA +getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA +getPubkey DeprecatedRSASignOnly = getPubkey RSA getPubkey DSA = do MPI p <- get MPI q <- get MPI g <- get MPI y <- get return $ DSAPubKey (D.PublicKey (D.Params p g q) y) -getPubkey ElgamalEncryptOnly = getPubkey Elgamal -getPubkey Elgamal = do MPI p <- get - MPI g <- get - MPI y <- get - return $ ElGamalPubKey [p,g,y] +getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal +getPubkey ForbiddenElgamal = do MPI p <- get + MPI g <- get + MPI y <- get + return $ ElGamalPubKey [p,g,y] getPubkey t = fail ("Unsupported pubkey type " ++ show t) putPubkey :: PKey -> Put @@ -769,7 +770,7 @@ getSecretKey :: PKPayload -> Get SKey getSecretKey pkp - | _pkalgo pkp `elem` [RSA, RSAEncryptOnly, RSASignOnly] = + | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do MPI d <- get MPI p <- get MPI q <- get @@ -778,11 +779,11 @@ dP = 0 dQ = 0 qinv = 0 - pub = (\(RSAPubKey x) -> x) (_pubkey pkp) + pub = (\(RSAPubKey x) -> x) (pkp^.pubkey) return $ RSAPrivateKey (R.PrivateKey pub d p q dP dQ qinv) | _pkalgo pkp == DSA = do MPI x <- get return $ DSAPrivateKey (D.PrivateKey (D.Params 0 0 0) x) - | _pkalgo pkp `elem` [ElgamalEncryptOnly,Elgamal] = + | _pkalgo pkp `elem` [ElgamalEncryptOnly,ForbiddenElgamal] = do MPI x <- get return $ ElGamalPrivateKey [x] diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -15,6 +15,7 @@ , payloadForSig ) where +import Control.Lens ((^.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 @@ -100,7 +101,7 @@ putByteString bs payloadForSig :: SigType -> PktStreamContext -> ByteString -payloadForSig BinarySig state = (\(LiteralDataPkt _ _ _ bs) -> bs) (lastLD state) +payloadForSig BinarySig state = (fromPkt (lastLD state))^.literalDataPayload payloadForSig CanonicalTextSig state = payloadForSig BinarySig state payloadForSig StandaloneSig _ = B.empty payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -0,0 +1,143 @@ +-- Verify.hs: OpenPGP (RFC4880) signature verification +-- Copyright © 2012-2013 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.Signatures ( + verifySig + , verify + , verifyTK +) where + +import Control.Monad (guard, liftM2) + +import Crypto.PubKey.HashDescr (HashDescr(..)) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.RSA.PKCS15 as P15 + +import Control.Lens ((^.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Either (lefts, rights) +import Data.IxSet ((@=)) +import qualified Data.IxSet as IxSet +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(..), issuer, emptyPSC, hashDescr) +import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Keyring.Instances () + +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) + potentialmatches <- if IxSet.null (kr @= i) then Left "pubkey not found" else Right (kr @= i) + let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) (IxSet.toList potentialmatches)) + 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@(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'' _ _ _ _ _ = Left "unimplemented key type" + verify''' f pub = if f then Right pub else Left "verification failed" + dsaVerify mpis ha pkey bs = DSA.verify (dsaTruncate pkey . hashFunction (hashDescr ha)) pkey (dsaMPIsToSig mpis) bs + rsaVerify mpis ha pkey bs = P15.verify (hashDescr ha) pkey bs (rsaMPItoSig mpis) + dsaMPIsToSig mpis = (DSA.Signature (unMPI (mpis !! 0)) (unMPI (mpis !! 1))) + rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis)) + hashalgo :: Pkt -> HashAlgorithm + hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha + hashalgo _ = error "This should never happen." + 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." + 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 _ _ = False + +finalPayload :: Pkt -> ByteString -> ByteString +finalPayload s pl = B.concat [pl, sigbit s, trailer s] + where + sigbit s = runPut $ putPartialSigforSigning s + trailer :: Pkt -> ByteString + trailer s@(SignaturePkt (SigV4 {})) = runPut $ putSigTrailer s + trailer _ = B.empty diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -5,63 +5,7 @@ {-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, TemplateHaskell, TypeFamilies #-} -module Codec.Encryption.OpenPGP.Types ( - SigSubPacket(..) - , SigSubPacketPayload(..) - , CompressionAlgorithm(..) - , HashAlgorithm(..) - , PubKeyAlgorithm(..) - , SymmetricAlgorithm(..) - , MPI(..) - , S2K(..) - , SignaturePayload(..) - , UserAttrSubPacket(..) - , SigType(..) - , ImageHeader(..) - , ImageFormat(..) - , KeyVersion(..) - , PKPayload(..) - , SKAddendum(..) - , DataType(..) - , PKey(..) - , SKey(..) - , EightOctetKeyId(..) - , TwentyOctetFingerprint(..) - , TK(..) - , FutureFlag - , FutureVal - , Keyring - , fromFVal - , fromFFlag - , toFVal - , 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(..) - , KeyFlag(..) -) where +module Codec.Encryption.OpenPGP.Types where import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA @@ -165,12 +109,12 @@ toFFlag o = OtherNF (fromIntegral o) data SigSubPacket = SigSubPacket { - sspCriticality :: Bool - , sspPayload :: SigSubPacketPayload + _sspCriticality :: Bool + , _sspPayload :: SigSubPacketPayload } deriving (Data, Eq, Typeable) instance Show SigSubPacket where - show x = (if sspCriticality x then "*" else "") ++ (show . sspPayload) x + show x = (if _sspCriticality x then "*" else "") ++ (show . _sspPayload) x data SigSubPacketPayload = SigCreationTime TimeStamp | SigExpirationTime TimeStamp @@ -263,13 +207,13 @@ toFVal :: Word8 -> a data PubKeyAlgorithm = RSA - | RSAEncryptOnly - | RSASignOnly + | DeprecatedRSAEncryptOnly + | DeprecatedRSASignOnly | ElgamalEncryptOnly | DSA | EC | ECDSA - | Elgamal + | ForbiddenElgamal | DH | OtherPKA Word8 deriving (Show, Data, Typeable) @@ -282,23 +226,23 @@ instance FutureVal PubKeyAlgorithm where fromFVal RSA = 1 - fromFVal RSAEncryptOnly = 2 - fromFVal RSASignOnly = 3 + fromFVal DeprecatedRSAEncryptOnly = 2 + fromFVal DeprecatedRSASignOnly = 3 fromFVal ElgamalEncryptOnly = 16 fromFVal DSA = 17 fromFVal EC = 18 fromFVal ECDSA = 19 - fromFVal Elgamal = 20 + fromFVal ForbiddenElgamal = 20 fromFVal DH = 21 fromFVal (OtherPKA o) = o toFVal 1 = RSA - toFVal 2 = RSAEncryptOnly - toFVal 3 = RSASignOnly + toFVal 2 = DeprecatedRSAEncryptOnly + toFVal 3 = DeprecatedRSASignOnly toFVal 16 = ElgamalEncryptOnly toFVal 17 = DSA toFVal 18 = EC toFVal 19 = ECDSA - toFVal 20 = Elgamal + toFVal 20 = ForbiddenElgamal toFVal 21 = DH toFVal o = OtherPKA o @@ -865,3 +809,4 @@ $(makeLenses ''OtherPacket) $(makeLenses ''TK) $(makeLenses ''Verification) +$(makeLenses ''SigSubPacket) diff --git a/Codec/Encryption/OpenPGP/Verify.hs b/Codec/Encryption/OpenPGP/Verify.hs deleted file mode 100644 --- a/Codec/Encryption/OpenPGP/Verify.hs +++ /dev/null @@ -1,139 +0,0 @@ --- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2013 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 Crypto.PubKey.HashDescr (HashDescr(..)) -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.RSA.PKCS15 as P15 - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Either (lefts, rights) -import Data.IxSet ((@=)) -import qualified Data.IxSet as IxSet -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(..), issuer, emptyPSC, hashDescr) -import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) -import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Keyring.Instances () - -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) - potentialmatches <- if IxSet.null (kr @= i) then Left "pubkey not found" else Right (kr @= i) - let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) (IxSet.toList potentialmatches)) - 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@(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'' _ _ _ _ _ = Left "unimplemented key type" - verify''' f pub = if f then Right pub else Left "verification failed" - dsaVerify mpis ha pkey bs = DSA.verify (dsaTruncate pkey . hashFunction (hashDescr ha)) pkey (dsaMPIsToSig mpis) bs - rsaVerify mpis ha pkey bs = P15.verify (hashDescr ha) pkey bs (rsaMPItoSig mpis) - dsaMPIsToSig mpis = (DSA.Signature (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 = countBits . integerToBEBS . DSA.params_q . DSA.public_params - 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 _ _ = False diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -12,7 +12,7 @@ import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.Verify (verifySig) +import Codec.Encryption.OpenPGP.Signatures (verifySig) import qualified Data.Conduit.List as CL conduitVerify :: MonadResource m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification) diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.6.3 +Version: 0.7 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -120,7 +120,7 @@ , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Fingerprint - , Codec.Encryption.OpenPGP.Verify + , Codec.Encryption.OpenPGP.Signatures , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances