{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} -- | Main implementation of the OpenPGP message format -- -- The recommended way to import this module is: -- -- > import qualified Data.OpenPGP as OpenPGP module Data.OpenPGP ( Packet( AsymmetricSessionKeyPacket, OnePassSignaturePacket, SymmetricSessionKeyPacket, PublicKeyPacket, SecretKeyPacket, CompressedDataPacket, MarkerPacket, LiteralDataPacket, TrustPacket, UserIDPacket, EncryptedDataPacket, ModificationDetectionCodePacket, UnsupportedPacket, compression_algorithm, content, encrypted_data, filename, format, hash_algorithm, hashed_subpackets, hash_head, key, is_subkey, v3_days_of_validity, key_algorithm, key_id, message, nested, s2k_useage, s2k, signature, signature_type, aead_algorithm, symmetric_algorithm, timestamp, trailer, unhashed_subpackets, version ), isSignaturePacket, signaturePacket, Message(..), SignatureSubpacket(..), S2K(..), string2key, HashAlgorithm(..), KeyAlgorithm(..), AEADAlgorithm(..), SymmetricAlgorithm(..), CompressionAlgorithm(..), RevocationCode(..), MPI(..), find_key, fingerprint_material, auto_fp_version, fingerprint_materialv, SignatureOver(..), signatures, signature_issuer, known_public_key_fields, known_secret_key_fields, public_key_fields, secret_key_fields, eccOID, encode_public_key_material, decode_public_key_material, getEllipticCurvePublicKey, encodeOID, hashLen ) where import Control.Applicative import Control.Arrow import Control.Monad import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LZ import Data.Char import Data.Function import Data.List import Data.Maybe import Data.Monoid import Data.OpenPGP.Internal import Data.Word import GHC.Stack import Numeric #ifdef CEREAL import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as B (fromString, toString) import Data.Serialize #define BINARY_CLASS Serialize #else import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.UTF8 as B (fromString, toString) #define BINARY_CLASS Binary #endif import qualified Codec.Compression.BZip as BZip2 import qualified Codec.Compression.Zlib as Zlib import qualified Codec.Compression.Zlib.Raw as Zip #ifdef CEREAL getRemainingByteString :: Get B.ByteString getRemainingByteString = remaining >>= getByteString getSomeByteString :: Word64 -> Get B.ByteString getSomeByteString = getByteString . fromIntegral putSomeByteString :: B.ByteString -> Put putSomeByteString = putByteString localGet :: Get a -> B.ByteString -> Get a localGet g bs = case runGet g bs of Left s -> fail s Right v -> return v compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString compress algo = toStrictBS . lazyCompress algo . toLazyBS decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString decompress algo = toStrictBS . lazyDecompress algo . toLazyBS toLazyBS :: B.ByteString -> LZ.ByteString toLazyBS = LZ.fromChunks . (:[]) lazyEncode :: (Serialize a) => a -> LZ.ByteString lazyEncode = toLazyBS . encode #else getRemainingByteString :: Get B.ByteString getRemainingByteString = getRemainingLazyByteString getSomeByteString :: Word64 -> Get B.ByteString getSomeByteString = getLazyByteString . fromIntegral putSomeByteString :: B.ByteString -> Put putSomeByteString = putLazyByteString #if MIN_VERSION_binary(0,6,4) localGet :: Get a -> B.ByteString -> Get a localGet g bs = case runGetOrFail g bs of Left (_,_,s) -> fail s Right (leftover,_,v) | B.null leftover -> return v | otherwise -> fail $ "Leftover in localGet: " ++ show leftover #else localGet :: Get a -> B.ByteString -> Get a localGet g bs = return $ runGet g bs #endif compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString compress = lazyCompress decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString decompress = lazyDecompress lazyEncode :: (Binary a) => a -> LZ.ByteString lazyEncode = encode #endif lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString lazyCompress Uncompressed = id lazyCompress ZIP = Zip.compress lazyCompress ZLIB = Zlib.compress lazyCompress BZip2 = BZip2.compress lazyCompress x = error ("No implementation for " ++ show x) lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString lazyDecompress Uncompressed = id lazyDecompress ZIP = Zip.decompress lazyDecompress ZLIB = Zlib.decompress lazyDecompress BZip2 = BZip2.decompress lazyDecompress x = error ("No implementation for " ++ show x) assertProp :: (Monad m, Show a) => (a -> Bool) -> a -> m a assertProp f x | f x = return $! x | otherwise = fail $ "Assertion failed for: " ++ show x pad :: Int -> String -> String pad l s = replicate (l - length s) '0' ++ s padBS :: Int -> B.ByteString -> B.ByteString padBS l s = B.replicate (fromIntegral l - B.length s) 0 `B.append` s data Packet = AsymmetricSessionKeyPacket { version :: Word8, key_id :: String, key_algorithm :: KeyAlgorithm, encrypted_data :: B.ByteString } | -- ^ SignaturePacket { version :: Word8, signature_type :: Word8, key_algorithm :: KeyAlgorithm, hash_algorithm :: HashAlgorithm, hashed_subpackets :: [SignatureSubpacket], unhashed_subpackets :: [SignatureSubpacket], hash_head :: Word16, signature :: [MPI], trailer :: B.ByteString } | -- ^ SymmetricSessionKeyPacket { version :: Word8, symmetric_algorithm :: SymmetricAlgorithm, s2k :: S2K, encrypted_data :: B.ByteString } | -- ^ OnePassSignaturePacket { version :: Word8, signature_type :: Word8, hash_algorithm :: HashAlgorithm, key_algorithm :: KeyAlgorithm, key_id :: String, nested :: Word8 } | -- ^ PublicKeyPacket { version :: Word8, timestamp :: Word32, key_algorithm :: KeyAlgorithm, key :: [(Char,MPI)], is_subkey :: Bool, v3_days_of_validity :: Maybe Word16 } | -- ^ (also subkey) SecretKeyPacket { version :: Word8, timestamp :: Word32, key_algorithm :: KeyAlgorithm, key :: [(Char,MPI)], s2k_useage :: Word8, s2k :: S2K, -- ^ This is meaningless if symmetric_algorithm == Unencrypted aead_algorithm :: Maybe AEADAlgorithm, symmetric_algorithm :: SymmetricAlgorithm, encrypted_data :: B.ByteString, is_subkey :: Bool } | -- ^ (also subkey) CompressedDataPacket { compression_algorithm :: CompressionAlgorithm, message :: Message } | -- ^ MarkerPacket | -- ^ LiteralDataPacket { format :: Char, filename :: String, timestamp :: Word32, content :: B.ByteString } | -- ^ TrustPacket B.ByteString | -- ^ UserIDPacket String | -- ^ EncryptedDataPacket { version :: Word8, encrypted_data :: B.ByteString } | -- ^ -- or when version is 0 ModificationDetectionCodePacket B.ByteString | -- ^ UnsupportedPacket Word8 B.ByteString deriving (Show, Read, Eq) instance BINARY_CLASS Packet where put p = do -- First two bits are 1 for new packet format put ((tag .|. 0xC0) :: Word8) case tag of 19 -> put =<< assertProp (<192) (blen :: Word8) _ -> do -- Use 5-octet lengths put (255 :: Word8) put (blen :: Word32) putSomeByteString body where blen :: (Num a) => a blen = fromIntegral $ B.length body (body, tag) = put_packet p get = do tag <- get let (t, l) = if testBit (tag :: Word8) 6 then (tag .&. 63, parse_new_length) else ((tag `shiftR` 2) .&. 15, (,) <$> parse_old_length tag <*> pure False) packet <- uncurry get_packet_bytes =<< l localGet (parse_packet t) (B.concat packet) get_packet_bytes :: Maybe Word32 -> Bool -> Get [B.ByteString] get_packet_bytes len partial = do -- This forces the whole packet to be consumed packet <- maybe getRemainingByteString (getSomeByteString . fromIntegral) len if not partial then return [packet] else (packet:) <$> (uncurry get_packet_bytes =<< parse_new_length) -- http://tools.ietf.org/html/rfc4880#section-4.2.2 parse_new_length :: Get (Maybe Word32, Bool) parse_new_length = fmap (first Just) $ do len <- fmap fromIntegral (get :: Get Word8) case len of -- One octet length _ | len < 192 -> return (len, False) -- Two octet length _ | len > 191 && len < 224 -> do second <- fmap fromIntegral (get :: Get Word8) return (((len - 192) `shiftL` 8) + second + 192, False) -- Five octet length 255 -> (,) <$> (get :: Get Word32) <*> pure False -- Partial length (streaming) _ | len >= 224 && len < 255 -> return (1 `shiftL` (fromIntegral len .&. 0x1F), True) _ -> fail "Unsupported new packet length." -- http://tools.ietf.org/html/rfc4880#section-4.2.1 parse_old_length :: Word8 -> Get (Maybe Word32) parse_old_length tag = case tag .&. 3 of -- One octet length 0 -> fmap (Just . fromIntegral) (get :: Get Word8) -- Two octet length 1 -> fmap (Just . fromIntegral) (get :: Get Word16) -- Four octet length 2 -> fmap Just get -- Indeterminate length 3 -> return Nothing -- Error _ -> fail "Unsupported old packet length." -- http://tools.ietf.org/html/rfc4880#section-5.5.2 known_public_key_fields :: KeyAlgorithm -> Maybe [Char] known_public_key_fields RSA = Just ['n', 'e'] known_public_key_fields RSA_E = known_public_key_fields RSA known_public_key_fields RSA_S = known_public_key_fields RSA known_public_key_fields ELGAMAL = Just ['p', 'g', 'y'] known_public_key_fields DSA = Just ['p', 'q', 'g', 'y'] known_public_key_fields ECDSA = Just ['c','l','x', 'y', 'f'] known_public_key_fields Ed25519 = Just ['c','l','x', 'y', 'n', 'f'] known_public_key_fields ECC = Just ['c','l','x', 'y', 'n', 'f', 'e'] known_public_key_fields _ = Nothing public_key_fields :: HasCallStack => KeyAlgorithm -> [Char] public_key_fields alg = fromMaybe (error $ "Unknown key fields for "++show alg) $ known_public_key_fields alg -- http://tools.ietf.org/html/rfc4880#section-5.5.3 known_secret_key_fields :: KeyAlgorithm -> Maybe [Char] known_secret_key_fields RSA = Just ['d', 'p', 'q', 'u'] known_secret_key_fields RSA_E = known_secret_key_fields RSA known_secret_key_fields RSA_S = known_secret_key_fields RSA known_secret_key_fields ELGAMAL = Just ['x'] known_secret_key_fields DSA = Just ['x'] known_secret_key_fields ECDSA = Just ['d'] known_secret_key_fields Ed25519 = Just ['d'] known_secret_key_fields ECC = Just ['d'] known_secret_key_fields _ = Nothing secret_key_fields :: HasCallStack => KeyAlgorithm -> [Char] secret_key_fields alg = fromMaybe (error $ "Unknown secret fields for "++show alg) (known_secret_key_fields alg) (!) :: (HasCallStack, Show k, Eq k) => [(k,v)] -> k -> v (!) xs k = case lookup k xs of Just v -> v Nothing -> error ("Missing field "++show k++" at "++prettyCallStack callStack) -- Need this seperate for trailer calculation signature_packet_start :: Packet -> B.ByteString signature_packet_start (SignaturePacket { version = v, signature_type = signature_type, key_algorithm = key_algorithm, hash_algorithm = hash_algorithm, hashed_subpackets = hashed_subpackets }) | v==4 || v==5 = B.concat [ encode (v :: Word8), encode signature_type, encode key_algorithm, encode hash_algorithm, encode ((fromIntegral $ B.length hashed_subs) :: Word16), hashed_subs ] where hashed_subs = B.concat $ map encode hashed_subpackets signature_packet_start x = error ("Trying to get start of signature packet for: " ++ show x) -- The trailer is just the top of the body plus some crap calculate_signature_trailer :: Packet -> B.ByteString calculate_signature_trailer (SignaturePacket { version = v, signature_type = signature_type, unhashed_subpackets = unhashed_subpackets }) | v `elem` [2,3] = B.concat [ encode signature_type, encode creation_time ] where Just (SignatureCreationTimePacket creation_time) = find isCreation unhashed_subpackets isCreation (SignatureCreationTimePacket {}) = True isCreation _ = False calculate_signature_trailer p@(SignaturePacket {version = v}) | v==4 || v==5 = B.concat [ signature_packet_start p, -- TODO: v5 document signatures (type 0x00 or 0x01) hash more fields here. encode (v :: Word8), encode (0xff :: Word8), if v==4 then encode (fromIntegral (B.length $ signature_packet_start p) :: Word32) else encode (fromIntegral (B.length $ signature_packet_start p) :: Word64) ] calculate_signature_trailer x = error ("Trying to calculate signature trailer for: " ++ show x) -- 0x2b06010401da470f01 -- common/openpgp-oid.c 50 { "Ed25519", "1.3.6.1.4.1.11591.15.1", 255, "ed25519", PUBKEY_ALGO_EDDSA }, -- -- 0x2b060104019755010501 -- common/openpgp-oid.c 49 { "Curve25519", "1.3.6.1.4.1.3029.1.5.1", 255, "cv25519", PUBKEY_ALGO_ECDH }, eccOID :: Packet -> Maybe BS.ByteString eccOID PublicKeyPacket { key = k } = lookup 'c' k >>= \(MPI oid) -> Just (snd $ putBigNum oid) eccOID SecretKeyPacket { key = k } = lookup 'c' k >>= \(MPI oid) -> Just (snd $ putBigNum oid) eccOID _ = Nothing encodeOID :: MPI -> B.ByteString encodeOID c = let (bitlen,oid) = B.splitAt 2 (encode c) len16 = decode bitlen :: Word16 (fullbytes,rembits) = len16 `quotRem` 8 len8 = fromIntegral (fullbytes + if rembits/=0 then 1 else 0) :: Word8 in len8 `B.cons` oid encode_public_key_material :: Packet -> [B.ByteString] encode_public_key_material k | key_algorithm k `elem` [ECDSA,Ed25519,ECC] = do -- http://tools.ietf.org/html/rfc6637 c <- maybeToList $ lookup 'c' (key k) MPI l <- maybeToList $ lookup 'l' (key k) MPI flag <- maybeToList $ lookup 'f' (key k) let oid = encodeOID c eccstuff = case lookup 'e' (key k) of Just (MPI stuff) -> encode (fromIntegral stuff :: Word32) Nothing -> B.empty case flag of 0x40 -> do MPI n <- maybeToList $ lookup 'n' (key k) let xy = flag*(4^l) + n [ oid, encode (MPI xy), eccstuff ] _ -> do MPI x <- maybeToList $ lookup 'x' (key k) MPI y <- maybeToList $ lookup 'y' (key k) let xy = flag*(4^l) + x*(2^l) + y [ oid, encode (MPI xy), eccstuff ] encode_public_key_material k | Just fs <- known_public_key_fields (key_algorithm k) = map (encode . (key k !)) fs encode_public_key_material k = -- encoding of a v5 opaque public key let MPI opaque = key k ! 'L' in [runPut . putByteString . integerToBS $ opaque] getEllipticCurvePublicKey :: Get [(Char,MPI)] getEllipticCurvePublicKey = do MPI fxy <- get let integerBytesize i = fromIntegral $ LZ.length (encode (MPI i)) - 2 width = ( integerBytesize fxy - 1 ) `div` 2 l = width*8 (flag,xy) = fxy `quotRem` (256^(2*width)) return $ case flag of 0x40 -> [('l',MPI l), ('n',MPI xy), ('f',MPI flag)] _ -> let (x,y) = xy `quotRem` (256^width) -- (fx,y) = xy `quotRem` (256^width) -- (flag,x) = fx `quotRem` (256^width) in [('l',MPI l), ('x',MPI x), ('y',MPI y), ('f',MPI flag)] getOID :: Get MPI getOID = do oidlen <- get :: Get Word8 oidbytes <- getSomeByteString (fromIntegral oidlen) let mpiFromBytes bytes = MPI (getBigNum $ B.toStrict bytes) oid = mpiFromBytes oidbytes return oid decode_public_key_material :: KeyAlgorithm -> Maybe (Get [(Char,MPI)]) decode_public_key_material algorithm | algorithm `elem` [ECDSA, Ed25519] = Just $ do -- http://tools.ietf.org/html/rfc6637 (9) Algorithm-Specific Fields for ECDSA keys oid <- getOID fmap (('c',oid) :) getEllipticCurvePublicKey decode_public_key_material ECC = Just $ do -- http://tools.ietf.org/html/rfc6637 (9) Algorithm-Specific Fields for ECDH keys: oid <- getOID result <- getEllipticCurvePublicKey eccstuff <- get :: Get Word32 {- eccstuff is 4 one-byte fields: flen <- get :: Get Word8 one <- get :: Get Word8 -- always 0x01 hashid <- get :: Get Word8 algoid <- get :: Get Word8 -} return $ ('c', oid) : result ++ [('e',MPI (fromIntegral eccstuff))] decode_public_key_material algorithm = mapM (\f -> fmap ((,)f) get) <$> known_public_key_fields algorithm put_packet :: Packet -> (B.ByteString, Word8) put_packet (AsymmetricSessionKeyPacket version key_id key_algorithm dta) = (B.concat [ encode version, encode (fst $ head $ readHex $ takeFromEnd 16 key_id :: Word64), encode key_algorithm, dta ], 1) put_packet (SignaturePacket { version = v, unhashed_subpackets = unhashed_subpackets, key_algorithm = key_algorithm, hash_algorithm = hash_algorithm, hash_head = hash_head, signature = signature, trailer = trailer }) | v `elem` [2,3] = -- TODO: Assert that there are no subpackets we cannot encode? (B.concat $ [ B.singleton v, B.singleton 0x05, trailer, -- signature_type and creation_time encode keyid, encode key_algorithm, encode hash_algorithm, encode hash_head ] ++ map encode signature, 2) where keyid = fst $ head $ readHex $ takeFromEnd 16 keyidS :: Word64 Just (IssuerPacket keyidS) = find isIssuer unhashed_subpackets isIssuer (IssuerPacket {}) = True isIssuer _ = False put_packet (SignaturePacket { version = v, unhashed_subpackets = unhashed_subpackets, hash_head = hash_head, signature = signature, trailer = trailer }) = (B.concat $ [ B.take n trailer, encode (fromIntegral $ B.length unhashed :: Word16), unhashed, encode hash_head ] ++ map encode signature, 2) where n = case B.length trailer - (if v==5 then 10 else 6) of x | x >=0 -> x | otherwise -> 0 -- Should never happen. unhashed = B.concat $ map encode unhashed_subpackets put_packet (SymmetricSessionKeyPacket version salgo s2k encd) = (B.concat [encode version, encode salgo, encode s2k, encd], 3) put_packet (OnePassSignaturePacket { version = version, signature_type = signature_type, hash_algorithm = hash_algorithm, key_algorithm = key_algorithm, key_id = key_id, nested = nested }) = (B.concat [ encode version, encode signature_type, encode hash_algorithm, encode key_algorithm, encode (fst $ head $ readHex $ takeFromEnd 16 key_id :: Word64), encode nested ], 4) put_packet (SecretKeyPacket { version = version, timestamp = timestamp, key_algorithm = algorithm, key = key, s2k_useage = s2k_useage, s2k = s2k, aead_algorithm = aead_algorithm, symmetric_algorithm = symmetric_algorithm, encrypted_data = encrypted_data, is_subkey = is_subkey }) = flip (,) (if is_subkey then 7 else 5) $ B.concat $ concat [ [p,s2kbyte] , if version == 5 then [ B.singleton (fromIntegral $ sum $ map B.length s2k_stuff) ] else [] , s2k_stuff , if version == 5 then [ encode (fromIntegral (sum $ map B.length key_stuff) :: Word32) ] else [] , key_stuff , if symmetric_algorithm == Unencrypted then [ encode (checksum $ B.concat s) ] else [] ] where (s2kbyte,s2k_stuff) = case s2k_useage of u | u `elem` [254,255] -> (encode s2k_useage, [encode symmetric_algorithm, encode s2k]) 253 | Just aead <- aead_algorithm -> (encode s2k_useage, [encode symmetric_algorithm, encode aead, encode s2k]) _ -> (encode symmetric_algorithm, []) key_stuff = if symmetric_algorithm /= Unencrypted then -- For V3 keys, the "encrypted data" has an unencrypted checksum -- of the unencrypted MPIs on the end [encrypted_data] else s p = fst (put_packet $ PublicKeyPacket version timestamp algorithm key False Nothing) s = case known_secret_key_fields algorithm of Nothing | Just (MPI opaque) <- lookup 'R' key -> [ runPut (putByteString (integerToBS opaque)) ] Just fs -> map (encode . (key !)) fs put_packet p@(PublicKeyPacket { version = v, timestamp = timestamp, key_algorithm = algorithm, key = key, is_subkey = is_subkey }) = case v of 3 -> final (B.concat $ [ B.singleton 3, encode timestamp, encode v3_days, encode algorithm ] ++ material) 4 -> final (B.concat $ [ B.singleton 4, encode timestamp, encode algorithm ] ++ material) 5 -> final (B.concat $ [ B.singleton 5, encode timestamp, encode algorithm, encode (fromIntegral (sum $ map B.length material) :: Word32) ] ++ material) where Just v3_days = v3_days_of_validity p final x = (x, if is_subkey then 14 else 6) material = encode_public_key_material p put_packet (CompressedDataPacket { compression_algorithm = algorithm, message = message }) = (B.append (encode algorithm) $ compress algorithm $ encode message, 8) put_packet MarkerPacket = (B.fromString "PGP", 10) put_packet (LiteralDataPacket { format = format, filename = filename, timestamp = timestamp, content = content }) = (B.concat [ encode format, encode filename_l, lz_filename, encode timestamp, content ], 11) where filename_l = (fromIntegral $ B.length lz_filename) :: Word8 lz_filename = B.fromString filename put_packet (TrustPacket bytes) = (bytes, 12) put_packet (UserIDPacket txt) = (B.fromString txt, 13) put_packet (EncryptedDataPacket 0 encrypted_data) = (encrypted_data, 9) put_packet (EncryptedDataPacket version encrypted_data) = (B.concat [encode version, encrypted_data], 18) put_packet (ModificationDetectionCodePacket bstr) = (bstr, 19) put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag) put_packet x = error ("Unsupported Packet version or type in put_packet: " ++ show x) opaqueKey :: Char -> BS.ByteString -> [(Char,MPI)] opaqueKey f bs = [(f, MPI $ getBigNum bs)] -- For reference, GnuPG (as of commit 3a403ab04) uses this: -- typedef enum -- { -- PKT_NONE = 0, -- PKT_PUBKEY_ENC = 1, /* Public key encrypted packet. */ -- PKT_SIGNATURE = 2, /* Secret key encrypted packet. */ -- PKT_SYMKEY_ENC = 3, /* Session key packet. */ -- PKT_ONEPASS_SIG = 4, /* One pass sig packet. */ -- PKT_SECRET_KEY = 5, /* Secret key. */ -- PKT_PUBLIC_KEY = 6, /* Public key. */ -- PKT_SECRET_SUBKEY = 7, /* Secret subkey. */ -- PKT_COMPRESSED = 8, /* Compressed data packet. */ -- PKT_ENCRYPTED = 9, /* Conventional encrypted data. */ -- PKT_MARKER = 10, /* Marker packet. */ -- PKT_PLAINTEXT = 11, /* Literal data packet. */ -- PKT_RING_TRUST = 12, /* Keyring trust packet. */ -- PKT_USER_ID = 13, /* User id packet. */ -- PKT_PUBLIC_SUBKEY = 14, /* Public subkey. */ -- PKT_OLD_COMMENT = 16, /* Comment packet from an OpenPGP draft. */ -- PKT_ATTRIBUTE = 17, /* PGP's attribute packet. */ -- PKT_ENCRYPTED_MDC = 18, /* Integrity protected encrypted data. */ -- PKT_MDC = 19, /* Manipulation detection code packet. */ -- PKT_ENCRYPTED_AEAD= 20, /* AEAD encrypted data packet. */ -- PKT_COMMENT = 61, /* new comment packet (GnuPG specific). */ -- PKT_GPG_CONTROL = 63 /* internal control packet (GnuPG specific). */ -- } -- pkttype_t; -- -- PKT_OLD_COMMENT, PKT_ATTRIBUTE, PKT_ENCRYPTED_AEAD, are not implemented here. -- Also ommitted are GnuPG-specific packets: PKT_COMMENT and PKT_GPG_CONTROL. parse_packet :: Word8 -> Get Packet -- AsymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.1 parse_packet 1 = AsymmetricSessionKeyPacket <$> (assertProp (==3) =<< get) <*> fmap (pad 16 . map toUpper . flip showHex "") (get :: Get Word64) <*> get <*> getRemainingByteString -- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2 parse_packet 2 = do version <- get case version of _ | version `elem` [2,3] -> do _ <- assertProp (==5) =<< (get :: Get Word8) signature_type <- get creation_time <- get :: Get Word32 keyid <- get :: Get Word64 key_algorithm <- get hash_algorithm <- get hash_head <- get signature <- listUntilEnd return SignaturePacket { version = version, signature_type = signature_type, key_algorithm = key_algorithm, hash_algorithm = hash_algorithm, hashed_subpackets = [], unhashed_subpackets = [ SignatureCreationTimePacket creation_time, IssuerPacket $ pad 16 $ map toUpper $ showHex keyid "" ], hash_head = hash_head, signature = signature, trailer = B.concat [encode signature_type, encode creation_time] } x | x==4 || x==5 -> do signature_type <- get key_algorithm <- get hash_algorithm <- get hashed_size <- fmap fromIntegral (get :: Get Word16) hashed_data <- getSomeByteString hashed_size hashed <- localGet listUntilEnd hashed_data unhashed_size <- fmap fromIntegral (get :: Get Word16) unhashed_data <- getSomeByteString unhashed_size unhashed <- localGet listUntilEnd unhashed_data hash_head <- get signature <- listUntilEnd return SignaturePacket { version = version, signature_type = signature_type, key_algorithm = key_algorithm, hash_algorithm = hash_algorithm, hashed_subpackets = hashed, unhashed_subpackets = unhashed, hash_head = hash_head, signature = signature, trailer = B.concat [ encode version , encode signature_type , encode key_algorithm , encode hash_algorithm , encode (fromIntegral hashed_size :: Word16) , hashed_data , B.pack [version , 0xff] , if version==4 then encode ((6 + fromIntegral hashed_size) :: Word32) else encode ((6 + fromIntegral hashed_size) :: Word64)] } x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "." -- SymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.3 parse_packet 3 = SymmetricSessionKeyPacket <$> (assertProp (==4) =<< get) <*> get <*> get <*> getRemainingByteString -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 parse_packet 4 = do version <- get signature_type <- get hash_algo <- get key_algo <- get key_id <- get :: Get Word64 nested <- get return OnePassSignaturePacket { version = version, signature_type = signature_type, hash_algorithm = hash_algo, key_algorithm = key_algo, key_id = pad 16 $ map toUpper $ showHex key_id "", nested = nested } -- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3 parse_packet 5 = do -- Parse PublicKey part (PublicKeyPacket { version = version, timestamp = timestamp, key_algorithm = algorithm, key = key }) <- parse_packet 6 s2k_useage <- get :: Get Word8 let k = SecretKeyPacket version timestamp algorithm key s2k_useage optlen1 <- if version == 5 then do len <- get return $ isolate (fromIntegral (len :: Word8)) else return id ((symmetric_algorithm, aead, s2k),iv) <- optlen1 $ do symdata <- case () of _ | s2k_useage `elem` [255, 254] -> do sym <- get s2k <- get return (sym,Nothing,s2k) _ | s2k_useage == 253 -> do sym <- get aead <- get :: Get AEADAlgorithm s2k <- get return (sym,Just aead,s2k) _ | s2k_useage > 0 -> do -- s2k_useage is symmetric_type in this case sym <- localGet get (encode s2k_useage) return $ (sym, Nothing, SimpleS2K MD5) _ -> return (Unencrypted, Nothing, S2K 100 B.empty) iv <- if version==5 then getRemainingByteString else return mempty -- For now, empty. It will be read later. return (symdata,iv) let -- We make an isolate5 utility to avoid running isolate for v4 keys. -- The reason for this is because apparently, Data.Serialize.isolate -- documents the unfortunate requirement: -- "The action is required to consume all the bytes that it is isolated to." -- This prevents using maxBound or some other large default isolation. isolate5 | version == 5 = isolate | otherwise = const id optlen2 <- if version == 5 then fromIntegral <$> (get :: Get Word32) else return 0 -- Value is not used. if symmetric_algorithm /= Unencrypted then do { isolate5 optlen2 $ do encrypted <- getRemainingByteString; return (k s2k aead symmetric_algorithm (iv <> encrypted) False) } else do (skey,skeybs) <- isolate5 optlen2 $ case known_secret_key_fields algorithm of Just fs -> do skey <- foldM (\m f -> do mpi <- get :: Get MPI return $ (f,mpi):m) [] fs return (skey, B.concat $ map (encode . snd) skey) Nothing -> do keybs <- getRemainingByteString return ([('R', MPI $ getBigNum $ toStrictBS keybs)], keybs) let (sumcnt0, csum) = checksumForKey s2k_useage sumcnt = fromIntegral sumcnt0 :: Int -- Note: Spec draft-ietf-openpgp-rfc4880bis-09.txt is unclear. -- I think checksum should be excluded from the optlen2 count -- when s2k_useage is 0 so I am excluding it. chk <- getByteString (fromIntegral sumcnt) when (csum skeybs /= chk) $ fail "Checksum verification failed for unencrypted secret key" return ((k s2k aead symmetric_algorithm B.empty False) {key = key ++ skey}) -- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2 parse_packet 6 = do version <- get :: Get Word8 case version of 3 -> do timestamp <- get days <- get algorithm <- get key <- fromMaybe (fail $ "Unknown public key fields for "++show algorithm) $ decode_public_key_material algorithm return PublicKeyPacket { version = version, timestamp = timestamp, key_algorithm = algorithm, key = key, is_subkey = False, v3_days_of_validity = Just days } 4 -> do timestamp <- get algorithm <- get key <- fromMaybe (fail $ "Unknown public key fields for "++show algorithm) $ decode_public_key_material algorithm return PublicKeyPacket { version = 4, timestamp = timestamp, key_algorithm = algorithm, key = key, is_subkey = False, v3_days_of_validity = Nothing } 5 -> do timestamp <- get algorithm <- get keylen <- fmap (fromIntegral :: Word32 -> Int) get key <- isolate keylen $ fromMaybe (opaqueKey 'L' <$> getByteString keylen) $ decode_public_key_material algorithm return PublicKeyPacket { version = 5, timestamp = timestamp, key_algorithm = algorithm, key = key, is_subkey = False, v3_days_of_validity = Nothing } x -> fail $ "Unsupported PublicKeyPacket version " ++ show x ++ "." -- Secret-SubKey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.4 parse_packet 7 = do p <- parse_packet 5 return p {is_subkey = True} -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 parse_packet 8 = do algorithm <- get message <- localGet get =<< (decompress algorithm <$> getRemainingByteString) return CompressedDataPacket { compression_algorithm = algorithm, message = message } -- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.7 parse_packet 9 = EncryptedDataPacket 0 <$> getRemainingByteString -- MarkerPacket, http://tools.ietf.org/html/rfc4880#section-5.8 parse_packet 10 = return MarkerPacket -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9 parse_packet 11 = do format <- get filenameLength <- get :: Get Word8 filename <- getSomeByteString (fromIntegral filenameLength) timestamp <- get content <- getRemainingByteString return LiteralDataPacket { format = format, filename = B.toString filename, timestamp = timestamp, content = content } -- TrustPacket, http://tools.ietf.org/html/rfc4880#section-5.10 parse_packet 12 = fmap TrustPacket getRemainingByteString -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 parse_packet 13 = fmap (UserIDPacket . B.toString) getRemainingByteString -- Public-Subkey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.2 parse_packet 14 = do p <- parse_packet 6 return p {is_subkey = True} -- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.13 parse_packet 18 = EncryptedDataPacket <$> get <*> getRemainingByteString -- ModificationDetectionCodePacket, http://tools.ietf.org/html/rfc4880#section-5.14 parse_packet 19 = fmap ModificationDetectionCodePacket getRemainingByteString -- Represent unsupported packets as their tag and literal bytes parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString auto_fp_version :: Packet -> Word8 auto_fp_version p | version p == 2 = 3 | otherwise = version p -- | Helper method for fingerprints and such fingerprint_material :: HasCallStack => Packet -> [B.ByteString] fingerprint_material p = fingerprint_materialv (auto_fp_version p) p -- | Helper method for fingerprints and such fingerprint_materialv :: HasCallStack => Word8 -> Packet -> [B.ByteString] fingerprint_materialv 5 p = [ B.singleton 0x9A, encode (10 + fromIntegral (B.length material) :: Word32), B.singleton 5, encode (timestamp p), encode (key_algorithm p), encode (fromIntegral (B.length material) :: Word32), material ] where material = B.concat $ encode_public_key_material p fingerprint_materialv 4 p = [ B.singleton 0x99, encode (6 + fromIntegral (B.length material) :: Word16), B.singleton 4, encode (timestamp p), encode (key_algorithm p), material ] where material = B.concat $ encode_public_key_material p fingerprint_materialv 3 p | key_algorithm p == RSA = [n, e] where n = B.drop 2 (encode (key p ! 'n')) e = B.drop 2 (encode (key p ! 'e')) fingerprint_materialv _ _ = error "Unsupported Packet version or type in fingerprint_material." enum_to_word8 :: (Enum a) => a -> Word8 enum_to_word8 = fromIntegral . fromEnum enum_from_word8 :: (Enum a) => Word8 -> a enum_from_word8 = toEnum . fromIntegral data S2K = SimpleS2K HashAlgorithm | SaltedS2K HashAlgorithm Word64 | IteratedSaltedS2K HashAlgorithm Word64 Word32 | S2K Word8 B.ByteString deriving (Show, Read, Eq, Ord) instance BINARY_CLASS S2K where put (SimpleS2K halgo) = put (0::Word8) >> put halgo put (SaltedS2K halgo salt) = put (1::Word8) >> put halgo >> put salt put (IteratedSaltedS2K halgo salt count) = put (3::Word8) >> put halgo >> put salt >> put (encode_s2k_count count) put (S2K t body) = put t >> putSomeByteString body get = do t <- get :: Get Word8 case t of 0 -> SimpleS2K <$> get 1 -> SaltedS2K <$> get <*> get 3 -> IteratedSaltedS2K <$> get <*> get <*> (decode_s2k_count <$> get) _ -> S2K t <$> getRemainingByteString -- | Take a hash function and an 'S2K' value and generate the bytes -- needed for creating a symmetric key. -- -- Return value is always infinite length. -- Take the first n bytes you need for your keysize. string2key :: (HashAlgorithm -> LZ.ByteString -> BS.ByteString) -> S2K -> LZ.ByteString -> LZ.ByteString string2key hsh (SimpleS2K halgo) s = infiniHashes (hsh halgo) s string2key hsh (SaltedS2K halgo salt) s = infiniHashes (hsh halgo) (lazyEncode salt `LZ.append` s) string2key hsh (IteratedSaltedS2K halgo salt count) s = infiniHashes (hsh halgo) $ LZ.take (max (fromIntegral count) (LZ.length s)) (LZ.cycle $ lazyEncode salt `LZ.append` s) string2key _ s2k _ = error $ "Unsupported S2K specifier: " ++ show s2k infiniHashes :: (LZ.ByteString -> BS.ByteString) -> LZ.ByteString -> LZ.ByteString infiniHashes hsh s = LZ.fromChunks (hs 0) where hs c = hsh (LZ.replicate c 0 `LZ.append` s) : hs (c+1) data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | HashAlgorithm Word8 deriving (Show, Read, Eq, Ord) hashLen :: HashAlgorithm -> Int hashLen MD5 = 16 hashLen SHA1 = 20 hashLen RIPEMD160 = 20 hashLen SHA256 = 32 hashLen SHA384 = 48 hashLen SHA512 = 64 hashLen SHA224 = 28 hashLen (HashAlgorithm _) = 0 instance Enum HashAlgorithm where toEnum 01 = MD5 toEnum 02 = SHA1 toEnum 03 = RIPEMD160 toEnum 08 = SHA256 toEnum 09 = SHA384 toEnum 10 = SHA512 toEnum 11 = SHA224 toEnum x = HashAlgorithm $ fromIntegral x fromEnum MD5 = 01 fromEnum SHA1 = 02 fromEnum RIPEMD160 = 03 fromEnum SHA256 = 08 fromEnum SHA384 = 09 fromEnum SHA512 = 10 fromEnum SHA224 = 11 fromEnum (HashAlgorithm x) = fromIntegral x instance BINARY_CLASS HashAlgorithm where put = put . enum_to_word8 get = fmap enum_from_word8 get data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | Ed25519 | KeyAlgorithm Word8 deriving (Show, Read, Eq) instance Enum KeyAlgorithm where toEnum 01 = RSA toEnum 02 = RSA_E toEnum 03 = RSA_S toEnum 16 = ELGAMAL toEnum 17 = DSA toEnum 18 = ECC toEnum 19 = ECDSA toEnum 21 = DH toEnum 22 = Ed25519 toEnum x = KeyAlgorithm $ fromIntegral x fromEnum RSA = 01 fromEnum RSA_E = 02 fromEnum RSA_S = 03 fromEnum ELGAMAL = 16 fromEnum DSA = 17 fromEnum ECC = 18 fromEnum ECDSA = 19 fromEnum DH = 21 fromEnum Ed25519 = 22 fromEnum (KeyAlgorithm x) = fromIntegral x instance BINARY_CLASS KeyAlgorithm where put = put . enum_to_word8 get = fmap enum_from_word8 get data SymmetricAlgorithm = Unencrypted | IDEA | TripleDES | CAST5 | Blowfish | AES128 | AES192 | AES256 | Twofish | SymmetricAlgorithm Word8 deriving (Show, Read, Eq, Ord) instance Enum SymmetricAlgorithm where toEnum 00 = Unencrypted toEnum 01 = IDEA toEnum 02 = TripleDES toEnum 03 = CAST5 toEnum 04 = Blowfish toEnum 07 = AES128 toEnum 08 = AES192 toEnum 09 = AES256 toEnum 10 = Twofish toEnum x = SymmetricAlgorithm $ fromIntegral x fromEnum Unencrypted = 00 fromEnum IDEA = 01 fromEnum TripleDES = 02 fromEnum CAST5 = 03 fromEnum Blowfish = 04 fromEnum AES128 = 07 fromEnum AES192 = 08 fromEnum AES256 = 09 fromEnum Twofish = 10 fromEnum (SymmetricAlgorithm x) = fromIntegral x instance BINARY_CLASS SymmetricAlgorithm where put = put . enum_to_word8 get = fmap enum_from_word8 get data AEADAlgorithm = EAX | OCB | AEADAlgorithm Word8 deriving (Show, Read, Eq, Ord) instance Enum AEADAlgorithm where toEnum 1 = EAX toEnum 2 = OCB toEnum x = AEADAlgorithm (fromIntegral x) fromEnum EAX = 1 fromEnum OCB = 2 fromEnum (AEADAlgorithm x) = fromIntegral x instance BINARY_CLASS AEADAlgorithm where put = put . enum_to_word8 get = fmap enum_from_word8 get data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | CompressionAlgorithm Word8 deriving (Show, Read, Eq) instance Enum CompressionAlgorithm where toEnum 0 = Uncompressed toEnum 1 = ZIP toEnum 2 = ZLIB toEnum 3 = BZip2 toEnum x = CompressionAlgorithm $ fromIntegral x fromEnum Uncompressed = 0 fromEnum ZIP = 1 fromEnum ZLIB = 2 fromEnum BZip2 = 3 fromEnum (CompressionAlgorithm x) = fromIntegral x instance BINARY_CLASS CompressionAlgorithm where put = put . enum_to_word8 get = fmap enum_from_word8 get data RevocationCode = NoReason | KeySuperseded | KeyCompromised | KeyRetired | UserIDInvalid | RevocationCode Word8 deriving (Show, Read, Eq) instance Enum RevocationCode where toEnum 00 = NoReason toEnum 01 = KeySuperseded toEnum 02 = KeyCompromised toEnum 03 = KeyRetired toEnum 32 = UserIDInvalid toEnum x = RevocationCode $ fromIntegral x fromEnum NoReason = 00 fromEnum KeySuperseded = 01 fromEnum KeyCompromised = 02 fromEnum KeyRetired = 03 fromEnum UserIDInvalid = 32 fromEnum (RevocationCode x) = fromIntegral x instance BINARY_CLASS RevocationCode where put = put . enum_to_word8 get = fmap enum_from_word8 get -- | A message is encoded as a list that takes the entire file newtype Message = Message [Packet] deriving (Show, Read, Eq) instance BINARY_CLASS Message where put (Message xs) = mapM_ put xs get = fmap Message listUntilEnd instance Semigroup Message where (<>) = mappend instance Monoid Message where mempty = Message [] mappend (Message a) (Message b) = Message (a ++ b) -- | Data needed to verify a signature data SignatureOver = DataSignature {literal::Packet, signatures_over::[Packet]} | KeySignature {topkey::Packet, signatures_over::[Packet]} | SubkeySignature {topkey::Packet, subkey::Packet, signatures_over::[Packet]} | CertificationSignature {topkey::Packet, user_id::Packet, signatures_over::[Packet]} deriving (Show, Read, Eq) -- To get the signed-over bytes instance BINARY_CLASS SignatureOver where put (DataSignature (LiteralDataPacket {content = c}) _) = putSomeByteString c -- TODO: This is incorrect for v5 signatures. See section 5.10. put (KeySignature k _) = mapM_ putSomeByteString (fingerprint_material k) put (SubkeySignature k s _) = mapM_ (mapM_ putSomeByteString) [fingerprint_material k, fingerprint_material s] put (CertificationSignature k (UserIDPacket s) _) = mapM_ (mapM_ putSomeByteString) [fingerprint_material k, [ B.singleton 0xB4, encode ((fromIntegral $ B.length bs) :: Word32), bs ]] where bs = B.fromString s put x = fail $ "Malformed signature: " ++ show x get = fail "Cannot meaningfully parse bytes to be signed over." -- | Extract signed objects from a well-formatted message -- -- Recurses into CompressedDataPacket -- -- signatures :: Message -> [SignatureOver] signatures (Message [CompressedDataPacket _ m]) = signatures m signatures (Message ps) = maybe (paired_sigs Nothing ps) (\p -> [DataSignature p sigs]) (find isDta ps) where sigs = filter isSignaturePacket ps isDta (LiteralDataPacket {}) = True isDta _ = False -- TODO: UserAttribute paired_sigs :: Maybe Packet -> [Packet] -> [SignatureOver] paired_sigs _ [] = [] paired_sigs mk (p:ps) = ($ span isSignaturePacket ps) $ case p of PublicKeyPacket {is_subkey = False} -> \(ss,qs) -> KeySignature p ss : paired_sigs (Just p) qs SecretKeyPacket {is_subkey = False} -> \(ss,qs) -> KeySignature p ss : paired_sigs (Just p) qs PublicKeyPacket {is_subkey = True} | Just k <- mk -> \(ss,qs) -> SubkeySignature k p ss : paired_sigs mk qs SecretKeyPacket {is_subkey = True} | Just k <- mk -> \(ss,qs) -> SubkeySignature k p ss : paired_sigs mk qs UserIDPacket {} | Just k <- mk -> \(ss,qs) -> CertificationSignature k p ss : paired_sigs mk qs _ -> \_ -> paired_sigs mk ps -- | newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) instance BINARY_CLASS MPI where put (MPI i) | i >= 0 = do put (bitl :: Word16) putSomeByteString $ B.fromStrict bytes | otherwise = fail $ "MPI is less than 0: " ++ show i where (bitl, bytes) = putBigNum i get = do length <- fmap fromIntegral (get :: Get Word16) bytes <- getSomeByteString =<< assertProp (>0) ((length + 7) `div` 8) return $ MPI $ getBigNum (B.toStrict bytes) listUntilEnd :: (BINARY_CLASS a) => Get [a] listUntilEnd = do done <- isEmpty if done then return [] else do next <- get rest <- listUntilEnd return (next:rest) -- | data SignatureSubpacket = SignatureCreationTimePacket Word32 | SignatureExpirationTimePacket Word32 | -- ^ seconds after CreationTime ExportableCertificationPacket Bool | TrustSignaturePacket {depth::Word8, trust::Word8} | RegularExpressionPacket String | RevocablePacket Bool | KeyExpirationTimePacket Word32 | -- ^ seconds after key CreationTime PreferredSymmetricAlgorithmsPacket [SymmetricAlgorithm] | RevocationKeyPacket { sensitive :: Bool, revocation_key_algorithm :: KeyAlgorithm, revocation_key_fingerprint :: String } | IssuerPacket String | NotationDataPacket { human_readable :: Bool, notation_name :: String, notation_value :: String } | PreferredHashAlgorithmsPacket [HashAlgorithm] | PreferredCompressionAlgorithmsPacket [CompressionAlgorithm] | KeyServerPreferencesPacket {keyserver_no_modify :: Bool} | PreferredKeyServerPacket String | PrimaryUserIDPacket Bool | PolicyURIPacket String | KeyFlagsPacket { certify_keys :: Bool, sign_data :: Bool, encrypt_communication :: Bool, encrypt_storage :: Bool, split_key :: Bool, authentication :: Bool, group_key :: Bool } | SignerUserIDPacket String | ReasonForRevocationPacket RevocationCode String | FeaturesPacket { supports_mdc :: Bool, supports_aead :: Bool, supports_v5 :: Bool } | SignatureTargetPacket { target_key_algorithm :: KeyAlgorithm, target_hash_algorithm :: HashAlgorithm, hash :: B.ByteString } | EmbeddedSignaturePacket Packet | IssuerFingerprintPacket { fingerprint_version :: Word8, issuer_fingerprint :: BS.ByteString } | UnsupportedSignatureSubpacket Word8 B.ByteString deriving (Show, Read, Eq) instance BINARY_CLASS SignatureSubpacket where put p = do -- Use 5-octet-length + 1 for tag as the first packet body octet put (255 :: Word8) put (fromIntegral (B.length body) + 1 :: Word32) put tag putSomeByteString body where (body, tag) = put_signature_subpacket p get = do len <- fmap fromIntegral (get :: Get Word8) len <- case len of _ | len >= 192 && len < 255 -> do -- Two octet length second <- fmap fromIntegral (get :: Get Word8) return $ ((len - 192) `shiftL` 8) + second + 192 255 -> -- Five octet length fmap fromIntegral (get :: Get Word32) _ -> -- One octet length, no furthur processing return len tag <- fmap stripCrit get :: Get Word8 -- This forces the whole packet to be consumed packet <- getSomeByteString (len-1) localGet (parse_signature_subpacket tag) packet where -- TODO: Decide how to actually encode the "is critical" data -- instead of just ignoring it stripCrit tag = if tag .&. 0x80 == 0x80 then tag .&. 0x7f else tag put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8) put_signature_subpacket (SignatureCreationTimePacket time) = (encode time, 2) put_signature_subpacket (SignatureExpirationTimePacket time) = (encode time, 3) put_signature_subpacket (ExportableCertificationPacket exportable) = (encode $ enum_to_word8 exportable, 4) put_signature_subpacket (TrustSignaturePacket depth trust) = (B.concat [encode depth, encode trust], 5) put_signature_subpacket (RegularExpressionPacket regex) = (B.concat [B.fromString regex, B.singleton 0], 6) put_signature_subpacket (RevocablePacket exportable) = (encode $ enum_to_word8 exportable, 7) put_signature_subpacket (KeyExpirationTimePacket time) = (encode time, 9) put_signature_subpacket (PreferredSymmetricAlgorithmsPacket algos) = (B.concat $ map encode algos, 11) put_signature_subpacket (RevocationKeyPacket sensitive kalgo fpr) = (B.concat [encode bitfield, encode kalgo, fprb], 12) where bitfield = 0x80 .|. (if sensitive then 0x40 else 0x0) :: Word8 fprb = padBS 20 $ B.drop 2 $ encode (MPI fpri) fpri = fst $ head $ readHex fpr put_signature_subpacket (IssuerPacket keyid) = case length keyid of 64 -> (encode (fst $ head $ readHex $ take 16 keyid :: Word64), 16) _ -> (encode (fst $ head $ readHex $ takeFromEnd 16 keyid :: Word64), 16) put_signature_subpacket (NotationDataPacket human_readable name value) = (B.concat [ B.pack [flag1,0,0,0], encode (fromIntegral (B.length namebs) :: Word16), encode (fromIntegral (B.length valuebs) :: Word16), namebs, valuebs ], 20) where valuebs = B.fromString value namebs = B.fromString name flag1 = if human_readable then 0x80 else 0x0 put_signature_subpacket (PreferredHashAlgorithmsPacket algos) = (B.concat $ map encode algos, 21) put_signature_subpacket (PreferredCompressionAlgorithmsPacket algos) = (B.concat $ map encode algos, 22) put_signature_subpacket (KeyServerPreferencesPacket no_modify) = (B.singleton (if no_modify then 0x80 else 0x0), 23) put_signature_subpacket (PreferredKeyServerPacket uri) = (B.fromString uri, 24) put_signature_subpacket (PrimaryUserIDPacket isprimary) = (encode $ enum_to_word8 isprimary, 25) put_signature_subpacket (PolicyURIPacket uri) = (B.fromString uri, 26) put_signature_subpacket (KeyFlagsPacket certify sign encryptC encryptS split auth group) = (B.singleton $ flag 0x01 certify .|. flag 0x02 sign .|. flag 0x04 encryptC .|. flag 0x08 encryptS .|. flag 0x10 split .|. flag 0x20 auth .|. flag 0x80 group , 27) where flag x True = x flag _ False = 0x0 put_signature_subpacket (SignerUserIDPacket userid) = (B.fromString userid, 28) put_signature_subpacket (ReasonForRevocationPacket code string) = (B.concat [encode code, B.fromString string], 29) put_signature_subpacket (FeaturesPacket supports_mdc supports_aead supports_v5) = (B.singleton $ mdc .|. aead .|. v5, 30) where mdc = if supports_mdc then 0x01 else 0x00 aead = if supports_aead then 0x02 else 0x00 v5 = if supports_v5 then 0x04 else 0x00 put_signature_subpacket (SignatureTargetPacket kalgo halgo hash) = (B.concat [encode kalgo, encode halgo, hash], 31) put_signature_subpacket (EmbeddedSignaturePacket packet) | isSignaturePacket packet = (fst $ put_packet packet, 32) | otherwise = error $ "Tried to put non-SignaturePacket in EmbeddedSignaturePacket: " ++ show packet put_signature_subpacket (IssuerFingerprintPacket v fp) = (runPut . putByteString $ v `BS.cons` fp,33) put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) = (bytes, tag) parse_signature_subpacket :: Word8 -> Get SignatureSubpacket -- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4 parse_signature_subpacket 2 = fmap SignatureCreationTimePacket get -- SignatureExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.10 parse_signature_subpacket 3 = fmap SignatureExpirationTimePacket get -- ExportableCertificationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.11 parse_signature_subpacket 4 = fmap (ExportableCertificationPacket . enum_from_word8) get -- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.13 parse_signature_subpacket 5 = liftM2 TrustSignaturePacket get get -- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.14 parse_signature_subpacket 6 = fmap (RegularExpressionPacket . B.toString . B.init) getRemainingByteString -- RevocablePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.12 parse_signature_subpacket 7 = fmap (RevocablePacket . enum_from_word8) get -- KeyExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.6 parse_signature_subpacket 9 = fmap KeyExpirationTimePacket get -- PreferredSymmetricAlgorithms, http://tools.ietf.org/html/rfc4880#section-5.2.3.7 parse_signature_subpacket 11 = fmap PreferredSymmetricAlgorithmsPacket listUntilEnd -- RevocationKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.15 parse_signature_subpacket 12 = do bitfield <- get :: Get Word8 kalgo <- get fpr <- getSomeByteString 20 -- bitfield must have bit 0x80 set, says the spec return RevocationKeyPacket { sensitive = bitfield .&. 0x40 == 0x40, revocation_key_algorithm = kalgo, revocation_key_fingerprint = pad 40 $ map toUpper $ foldr (padB `oo` showHex) "" (B.unpack fpr) } where oo = (.) . (.) padB s | odd $ length s = '0':s | otherwise = s -- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5 parse_signature_subpacket 16 = do keyid <- get :: Get Word64 return $ IssuerPacket (pad 16 $ map toUpper $ showHex keyid "") -- NotationDataPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.16 parse_signature_subpacket 20 = do (flag1,_,_,_) <- get4word8 (m,n) <- liftM2 (,) get get :: Get (Word16,Word16) name <- fmap B.toString $ getSomeByteString $ fromIntegral m value <- fmap B.toString $ getSomeByteString $ fromIntegral n return NotationDataPacket { human_readable = flag1 .&. 0x80 == 0x80, notation_name = name, notation_value = value } where get4word8 :: Get (Word8,Word8,Word8,Word8) get4word8 = liftM4 (,,,) get get get get -- PreferredHashAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.8 parse_signature_subpacket 21 = fmap PreferredHashAlgorithmsPacket listUntilEnd -- PreferredCompressionAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.9 parse_signature_subpacket 22 = fmap PreferredCompressionAlgorithmsPacket listUntilEnd -- KeyServerPreferencesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.17 parse_signature_subpacket 23 = do empty <- isEmpty flag1 <- if empty then return 0 else get :: Get Word8 return KeyServerPreferencesPacket { keyserver_no_modify = flag1 .&. 0x80 == 0x80 } -- PreferredKeyServerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.18 parse_signature_subpacket 24 = fmap (PreferredKeyServerPacket . B.toString) getRemainingByteString -- PrimaryUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.19 parse_signature_subpacket 25 = fmap (PrimaryUserIDPacket . enum_from_word8) get -- PolicyURIPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.20 parse_signature_subpacket 26 = fmap (PolicyURIPacket . B.toString) getRemainingByteString -- KeyFlagsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.21 parse_signature_subpacket 27 = do empty <- isEmpty flag1 <- if empty then return 0 else get :: Get Word8 return KeyFlagsPacket { certify_keys = flag1 .&. 0x01 == 0x01, sign_data = flag1 .&. 0x02 == 0x02, encrypt_communication = flag1 .&. 0x04 == 0x04, encrypt_storage = flag1 .&. 0x08 == 0x08, split_key = flag1 .&. 0x10 == 0x10, authentication = flag1 .&. 0x20 == 0x20, group_key = flag1 .&. 0x80 == 0x80 } -- SignerUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.22 parse_signature_subpacket 28 = fmap (SignerUserIDPacket . B.toString) getRemainingByteString -- ReasonForRevocationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.23 parse_signature_subpacket 29 = liftM2 ReasonForRevocationPacket get (fmap B.toString getRemainingByteString) -- FeaturesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.24 parse_signature_subpacket 30 = do empty <- isEmpty flag1 <- if empty then return 0 else get :: Get Word8 return FeaturesPacket { supports_mdc = flag1 .&. 0x01 /= 0, supports_aead = flag1 .&. 0x02 /= 0, supports_v5 = flag1 .&. 0x04 /= 0 } -- SignatureTargetPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.25 parse_signature_subpacket 31 = liftM3 SignatureTargetPacket get get getRemainingByteString -- EmbeddedSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.26 parse_signature_subpacket 32 = fmap EmbeddedSignaturePacket (parse_packet 2) -- IssuerFingerprintPacket parse_signature_subpacket 33 = do v <- get fp <- getByteString (if v==4 then 20 else 32) return $ IssuerFingerprintPacket v fp -- Represent unsupported packets as their tag and literal bytes parse_signature_subpacket tag = fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString -- | Find the keyid that issued a SignaturePacket signature_issuer :: Packet -> Maybe String signature_issuer (SignaturePacket {hashed_subpackets = hashed, unhashed_subpackets = unhashed}) = case fps of IssuerFingerprintPacket _ fp : _ -> Just $ hexify fp _ -> case issuers of IssuerPacket issuer : _ -> Just issuer _ -> Nothing where fps = filter isFingerprint hashed issuers = filter isIssuer hashed ++ filter isIssuer unhashed isIssuer (IssuerPacket {}) = True isIssuer _ = False isFingerprint (IssuerFingerprintPacket {}) = True isFingerprint _ = False signature_issuer _ = Nothing -- | Find a key with the given Fingerprint/KeyID find_key :: (Packet -> String) -- ^ Extract Fingerprint/KeyID from packet -> Message -- ^ List of packets (some of which are keys) -> String -- ^ Fingerprint/KeyID to search for -> Maybe Packet find_key fpr (Message (x@(PublicKeyPacket {}):xs)) keyid = find_key' fpr x xs keyid find_key fpr (Message (x@(SecretKeyPacket {}):xs)) keyid = find_key' fpr x xs keyid find_key fpr (Message (_:xs)) keyid = find_key fpr (Message xs) keyid find_key _ _ _ = Nothing find_key' :: (Packet -> String) -> Packet -> [Packet] -> String -> Maybe Packet find_key' fpr x xs keyid | thisid == keyid = Just x | otherwise = find_key fpr (Message xs) keyid where thisid = (if version x >= 5 then take else takeFromEnd) (length keyid) (fpr x) takeFromEnd :: Int -> String -> String takeFromEnd l = reverse . take l . reverse -- | SignaturePacket smart constructor -- -- signaturePacket :: Word8 -- ^ Signature version (probably 4) -> Word8 -- ^ Signature type -> KeyAlgorithm -> HashAlgorithm -> [SignatureSubpacket] -- ^ Hashed subpackets (these get signed) -> [SignatureSubpacket] -- ^ Unhashed subpackets (these do not get signed) -> Word16 -- ^ Left 16 bits of the signed hash value -> [MPI] -- ^ The raw MPIs of the signature -> Packet signaturePacket version signature_type key_algorithm hash_algorithm hashed_subpackets unhashed_subpackets hash_head signature = let p = SignaturePacket { version = version, signature_type = signature_type, key_algorithm = key_algorithm, hash_algorithm = hash_algorithm, hashed_subpackets = hashed_subpackets, unhashed_subpackets = unhashed_subpackets, hash_head = hash_head, signature = signature, trailer = undefined } in p { trailer = calculate_signature_trailer p } isSignaturePacket :: Packet -> Bool isSignaturePacket (SignaturePacket {}) = True isSignaturePacket _ = False