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 @@ -507,7 +507,7 @@ getPkt = do (t, pl) <- getPacketTypeAndPayload case runGet (getPkt' t (B.length pl)) pl of - Left e -> fail e + Left e -> return $! BrokenPacketPkt e t pl Right p -> return p where getPkt' :: Word8 -> Int -> Get Pkt @@ -519,13 +519,13 @@ remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of - Left e -> error e + Left e -> fail ("PKESK MPIs " ++ e) Right sk -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk | t == 2 = do remainder <- remaining bs <- getBytes remainder case runGet get bs of - Left e -> error e + Left e -> fail ("signature packet " ++ e) Right sp -> return $ SignaturePkt sp | t == 3 = do pv <- getWord8 @@ -548,7 +548,7 @@ ska <- getSKAddendum pkp return $ SecretKeyPkt pkp ska case ps of - Left err -> error err + Left err -> fail ("secret key " ++ err) Right key -> return key | t == 6 = do pkp <- getPKPayload @@ -559,7 +559,7 @@ ska <- getSKAddendum pkp return $ SecretSubkeyPkt pkp ska case ps of - Left err -> error err + Left err -> fail ("secret subkey " ++ err) Right key -> return key | t == 8 = do ca <- getWord8 @@ -590,7 +590,7 @@ | t == 17 = do bs <- getBytes len case runGet (many getUserAttrSubPacket) bs of - Left err -> error err + Left err -> fail ("user attribute " ++ err) Right uas -> return $ UserAttributePkt uas | t == 18 = do pv <- getWord8 -- should be 1 @@ -745,10 +745,11 @@ putWord8 (0xc0 .|. t) -- FIXME: restrict t putPacketLength . fromIntegral . B.length $ payload putByteString payload +putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) getMPI :: Get MPI getMPI = do mpilen <- getWord16be - bs <- getByteString ((fromIntegral (mpilen - 1) `div` 8) + 1) + bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) return $ MPI (beBSToInteger bs) getPubkey :: PubKeyAlgorithm -> Get PKey @@ -767,9 +768,10 @@ MPI g <- get MPI y <- get return $ ElGamalPubKey [p,g,y] -getPubkey t = fail ("Unsupported pubkey type " ++ show t) +getPubkey _ = UnknownPKey <$> (getByteString =<< remaining) putPubkey :: PKey -> Put +putPubkey (UnknownPKey bs) = put bs putPubkey p = mapM_ put (pubkeyToMPIs p) getSecretKey :: PKPayload -> Get SKey @@ -1155,7 +1157,7 @@ remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of - Left e -> error e + Left e -> fail ("v3 sig MPIs " ++ e) Right mpis -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 mpis 4 -> do st <- getWord8 @@ -1164,18 +1166,18 @@ hlen <- getWord16be hb <- getBytes (fromIntegral hlen) let hashed = case runGet (many getSigSubPacket) hb of - Left err -> error err + Left err -> fail ("v4 sig hasheds " ++ err) Right h -> h ulen <- getWord16be ub <- getBytes (fromIntegral ulen) let unhashed = case runGet (many getSigSubPacket) ub of - Left err -> error err + Left err -> fail ("v4 sig unhasheds " ++ err) Right u -> u left16 <- getWord16be remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of - Left e -> error e + Left e -> fail ("v4 sig MPIs " ++ e) Right mpis -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis _ -> do remainder <- remaining 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 @@ -1,5 +1,5 @@ -- Types.hs: OpenPGP (RFC4880) data types --- 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). @@ -18,6 +18,8 @@ import Data.Data (Data) import Data.IxSet (IxSet) import Data.List.Split (chunksOf) +import Data.Monoid ((<>)) +import Data.Ord (comparing) import Data.Set (Set) import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32) @@ -381,8 +383,7 @@ , _v3exp :: V3Expiration , _pkalgo :: PubKeyAlgorithm , _pubkey :: PKey - } - deriving (Data, Eq, Show, Typeable) + } deriving (Data, Eq, Show, Typeable) instance Ord PKPayload where compare a b = show a `compare` show b -- FIXME: this is ridiculous @@ -505,14 +506,19 @@ toFVal 0x50 = ThirdPartyConfirmationSig toFVal o = OtherSig o +instance Ord DSA.PublicKey +instance Ord RSA.PublicKey + data PKey = RSAPubKey RSA.PublicKey | DSAPubKey DSA.PublicKey | ElGamalPubKey [Integer] - deriving (Data, Eq, Show, Typeable) + | UnknownPKey ByteString + deriving (Data, Eq, Ord, Show, Typeable) data SKey = RSAPrivateKey RSA.PrivateKey | DSAPrivateKey DSA.PrivateKey | ElGamalPrivateKey [Integer] + | UnknownSKey ByteString deriving (Data, Eq, Show, Typeable) newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance @@ -552,7 +558,7 @@ } deriving (Data, Eq, Show, Typeable) instance Ord TK where - compare a b = show a `compare` show b -- FIXME: this is ridiculous + compare = comparing _tkPKP -- FIXME: is this ridiculous? type Keyring = IxSet TK @@ -582,7 +588,8 @@ | SymEncIntegrityProtectedDataPkt PacketVersion ByteString | ModificationDetectionCodePkt ByteString | OtherPacketPkt Word8 ByteString - deriving (Show, Eq, Data, Typeable) -- FIXME + | BrokenPacketPkt String Word8 ByteString + deriving (Data, Eq, Show, Typeable) -- FIXME pktTag :: Pkt -> Word8 pktTag (PKESKPkt {}) = 1 @@ -802,6 +809,18 @@ packetCode _ = undefined -- FIXME toPkt (OtherPacket a b) = OtherPacketPkt a b fromPkt (OtherPacketPkt a b) = OtherPacket a b + +data BrokenPacket = BrokenPacket + { _brokenPacketParseError :: String + , _brokenPacketType :: Word8 + , _brokenPacketPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet BrokenPacket where + data PacketType BrokenPacket = BrokenPacketType deriving (Show, Eq) + packetType _ = BrokenPacketType + packetCode _ = undefined + toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c + fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c data Verification = Verification { _verificationSigner :: PKPayload 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 @@ -19,7 +19,7 @@ import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () -data Phase = MainKey | Revs | Uids | UAts | Subs +data Phase = MainKey | Revs | Uids | UAts | Subs | SkippingBroken deriving (Eq, Ord, Show) conduitToTKs :: MonadResource m => Conduit Pkt m TK @@ -47,6 +47,8 @@ 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)), []) @@ -54,17 +56,20 @@ ((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)), []) @@ -72,17 +77,23 @@ ((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 pkp mska revs uids uats subs)), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [TK pkp mska revs uids uats subs]) + ((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)] diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.13.1 +Version: 0.14 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -242,4 +242,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v0.13.1 + tag: v0.14