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 @@ -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) diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -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)) 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 @@ -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)] diff --git a/Codec/Encryption/OpenPGP/KeyInfo.hs b/Codec/Encryption/OpenPGP/KeyInfo.hs --- a/Codec/Encryption/OpenPGP/KeyInfo.hs +++ b/Codec/Encryption/OpenPGP/KeyInfo.hs @@ -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)) 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs --- a/Data/Conduit/OpenPGP/Filter.hs +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -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 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 @@ -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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -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