{-# LANGUAGE CPP #-}
-- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880>
--
-- 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,
		symmetric_algorithm,
		timestamp,
		trailer,
		unhashed_subpackets,
		version
	),
	isSignaturePacket,
	signaturePacket,
	Message(..),
	SignatureSubpacket(..),
	S2K(..),
	string2key,
	HashAlgorithm(..),
	KeyAlgorithm(..),
	SymmetricAlgorithm(..),
	CompressionAlgorithm(..),
	RevocationCode(..),
	MPI(..),
	find_key,
	fingerprint_material,
	SignatureOver(..),
	signatures,
	signature_issuer,
	public_key_fields,
	secret_key_fields
) where

import Numeric
import Control.Monad
import Control.Arrow
#ifdef MIN_VERSION_base
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid
#endif
#else
import Control.Applicative
import Data.Monoid
#endif
import Data.Bits
import Data.Word
import Data.Char
import Data.List
import Data.OpenPGP.Internal
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LZ

#ifdef CEREAL
import Data.Serialize hiding (decode)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B (toString, fromString)
#define BINARY_CLASS Serialize
#else
import Data.Binary hiding (decode)
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString)
#define BINARY_CLASS Binary
#endif

import qualified Codec.Compression.Zlib.Raw as Zip
import qualified Codec.Compression.Zlib as Zlib
import qualified Codec.Compression.BZip as BZip2

#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

toStrictBS :: LZ.ByteString -> B.ByteString
toStrictBS = B.concat . LZ.toChunks

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

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

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

checksum :: B.ByteString -> Word16
checksum = fromIntegral .
	B.foldl (\c i -> (c + fromIntegral i) `mod` 65536) (0::Integer)

data Packet =
	AsymmetricSessionKeyPacket {
		version::Word8,
		key_id::String,
		key_algorithm::KeyAlgorithm,
		encrypted_data::B.ByteString
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.1>
	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
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.2>
	SymmetricSessionKeyPacket {
		version::Word8,
		symmetric_algorithm::SymmetricAlgorithm,
		s2k::S2K,
		encrypted_data::B.ByteString
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.3>
	OnePassSignaturePacket {
		version::Word8,
		signature_type::Word8,
		hash_algorithm::HashAlgorithm,
		key_algorithm::KeyAlgorithm,
		key_id::String,
		nested::Word8
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.4>
	PublicKeyPacket {
		version::Word8,
		timestamp::Word32,
		key_algorithm::KeyAlgorithm,
		key::[(Char,MPI)],
		is_subkey::Bool,
		v3_days_of_validity::Maybe Word16
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.5.1.1> (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
		symmetric_algorithm::SymmetricAlgorithm,
		encrypted_data::B.ByteString,
		is_subkey::Bool
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.5.1.3> (also subkey)
	CompressedDataPacket {
		compression_algorithm::CompressionAlgorithm,
		message::Message
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.6>
	MarkerPacket | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.8>
	LiteralDataPacket {
		format::Char,
		filename::String,
		timestamp::Word32,
		content::B.ByteString
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.9>
	TrustPacket B.ByteString | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.10>
	UserIDPacket String | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.11>
	EncryptedDataPacket {
		version::Word8,
		encrypted_data::B.ByteString
	} |
	-- ^ <http://tools.ietf.org/html/rfc4880#section-5.13>
	-- or <http://tools.ietf.org/html/rfc4880#section-5.7> when version is 0
	ModificationDetectionCodePacket B.ByteString | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.14>
	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 (tag .&. 64) /= 0 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
public_key_fields :: KeyAlgorithm -> [Char]
public_key_fields RSA     = ['n', 'e']
public_key_fields RSA_E   = public_key_fields RSA
public_key_fields RSA_S   = public_key_fields RSA
public_key_fields ELGAMAL = ['p', 'g', 'y']
public_key_fields DSA     = ['p', 'q', 'g', 'y']
public_key_fields _       = undefined -- Nothing in the spec. Maybe empty

-- http://tools.ietf.org/html/rfc4880#section-5.5.3
secret_key_fields :: KeyAlgorithm -> [Char]
secret_key_fields RSA     = ['d', 'p', 'q', 'u']
secret_key_fields RSA_E   = secret_key_fields RSA
secret_key_fields RSA_S   = secret_key_fields RSA
secret_key_fields ELGAMAL = ['x']
secret_key_fields DSA     = ['x']
secret_key_fields _       = undefined -- Nothing in the spec. Maybe empty

(!) :: (Eq k) => [(k,v)] -> k -> v
(!) xs k = let Just x = lookup k xs in x

-- Need this separate for trailer calculation
signature_packet_start :: Packet -> B.ByteString
signature_packet_start (SignaturePacket {
	version = 4,
	signature_type = signature_type,
	key_algorithm = key_algorithm,
	hash_algorithm = hash_algorithm,
	hashed_subpackets = hashed_subpackets
}) =
	B.concat [
		encode (0x04 :: 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 = 4}) =
	B.concat [
		signature_packet_start p,
		encode (0x04 :: Word8),
		encode (0xff :: Word8),
		encode (fromIntegral (B.length $ signature_packet_start p) :: Word32)
	]
calculate_signature_trailer x =
	error ("Trying to calculate signature trailer for: " ++ show x)

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 (SymmetricSessionKeyPacket version salgo s2k encd) =
	(B.concat [encode version, encode salgo, encode s2k, encd], 3)
put_packet (SignaturePacket { version = 4,
                              unhashed_subpackets = unhashed_subpackets,
                              hash_head = hash_head,
                              signature = signature,
                              trailer = trailer }) =
	(B.concat $ [
		trailer_top,
		encode (fromIntegral $ B.length unhashed :: Word16),
		unhashed, encode hash_head
	] ++ map encode signature, 2)
	where
	trailer_top = B.reverse $ B.drop 6 $ B.reverse trailer
	unhashed = B.concat $ map encode unhashed_subpackets
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,
                              symmetric_algorithm = symmetric_algorithm,
                              encrypted_data = encrypted_data,
                              is_subkey = is_subkey }) =
	(B.concat $ p :
	(if s2k_useage `elem` [254,255] then
		[encode s2k_useage, encode symmetric_algorithm, encode s2k]
	else
		[encode symmetric_algorithm]
	) ++
	(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 ++
		[encode $ checksum $ B.concat s]),
	if is_subkey then 7 else 5)
	where
	p = fst (put_packet $
		PublicKeyPacket version timestamp algorithm key False Nothing)
	s = map (encode . (key !)) (secret_key_fields algorithm)
put_packet p@(PublicKeyPacket { version = v, timestamp = timestamp,
                              key_algorithm = algorithm, key = key,
                              is_subkey = is_subkey })
	| v == 3 =
		final (B.concat $ [
			B.singleton 3, encode timestamp,
			encode v3_days,
			encode algorithm
		] ++ material)
	| v == 4 =
		final (B.concat $ [
			B.singleton 4, encode timestamp, encode algorithm
		] ++ material)
	where
	Just v3_days = v3_days_of_validity p
	final x = (x, if is_subkey then 14 else 6)
	material = map (encode . (key !)) (public_key_fields algorithm)
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)

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]
			}
		4 -> 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 [4, 0xff], encode ((6 + fromIntegral hashed_size) :: Word32)]
			}
		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
	(symmetric_algorithm, s2k) <- case () of
		_ | s2k_useage `elem` [255, 254] -> (,) <$> get <*> get
		_ | s2k_useage > 0 ->
			-- s2k_useage is symmetric_type in this case
			(,) <$> localGet get (encode s2k_useage) <*> pure (SimpleS2K MD5)
		_ ->
			return (Unencrypted, S2K 100 B.empty)
	if symmetric_algorithm /= Unencrypted then do {
		encrypted <- getRemainingByteString;
		return (k s2k symmetric_algorithm encrypted False)
	} else do
		skey <- foldM (\m f -> do
			mpi <- get :: Get MPI
			return $ (f,mpi):m) [] (secret_key_fields algorithm)
		chk <- get
		when (checksum (B.concat $ map (encode . snd) skey) /= chk) $
			fail "Checksum verification failed for unencrypted secret key"
		return ((k s2k 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 <- mapM (\f -> fmap ((,)f) get) (public_key_fields 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 <- mapM (\f -> fmap ((,)f) get) (public_key_fields algorithm)
			return PublicKeyPacket {
				version = 4,
				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 = do
	_ <- assertProp (== B.fromString "PGP") =<< getSomeByteString 3
	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

-- | Helper method for fingerprints and such
fingerprint_material :: Packet -> [B.ByteString]
fingerprint_material p | version p == 4 =
	[
		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 $ map (encode . (key p !))
		(public_key_fields $ key_algorithm p)
fingerprint_material p | version p `elem` [2, 3] = [n, e]
	where
	n = B.drop 2 (encode (key p ! 'n'))
	e = B.drop 2 (encode (key p ! 'e'))
fingerprint_material _ =
	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)

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)

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 | 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 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 (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)

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 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 Monoid Message where
	mempty = Message []
	mappend (Message a) (Message b) = Message (a ++ b)

#if MIN_VERSION_base(4,11,0)
instance Semigroup Message where
	x <> y = x `mappend` y
#endif

-- | 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
	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
--
-- <http://tools.ietf.org/html/rfc4880#section-11>
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 _ (p@(PublicKeyPacket {is_subkey = False}):ps) =
	KeySignature p (takeWhile isSignaturePacket ps) :
	paired_sigs (Just p) (dropWhile isSignaturePacket ps)
paired_sigs _ (p@(SecretKeyPacket {is_subkey = False}):ps) =
	KeySignature p (takeWhile isSignaturePacket ps) :
	paired_sigs (Just p) (dropWhile isSignaturePacket ps)
paired_sigs (Just k) (p@(PublicKeyPacket {is_subkey = True}):ps) =
	SubkeySignature k p (takeWhile isSignaturePacket ps) :
	paired_sigs (Just k) (dropWhile isSignaturePacket ps)
paired_sigs (Just k) (p@(SecretKeyPacket {is_subkey = True}):ps) =
	SubkeySignature k p (takeWhile isSignaturePacket ps) :
	paired_sigs (Just k) (dropWhile isSignaturePacket ps)
paired_sigs (Just k) (p@(UserIDPacket {}):ps) =
	CertificationSignature k p (takeWhile isSignaturePacket ps) :
	paired_sigs (Just k) (dropWhile isSignaturePacket ps)
paired_sigs k (_:ps) = paired_sigs k ps

-- | <http://tools.ietf.org/html/rfc4880#section-3.2>
newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord)
instance BINARY_CLASS MPI where
	put (MPI i)
		| i >= 0 = do
			put (bitl :: Word16)
			putSomeByteString bytes
		| otherwise = fail $ "MPI is less than 0: " ++ show i
		where
		(bytes, bitl)
			| B.null bytes' = (B.singleton 0, 1)
			| otherwise     =
				(bytes', (fromIntegral (B.length bytes') - 1) * 8 + sigBit)

		sigBit = fst $ until ((==0) . snd)
			(first (+1) . second (`shiftR` 1)) (0,B.index bytes 0)
		bytes' = B.reverse $ B.unfoldr (\x ->
				if x == 0 then Nothing else
					Just (fromIntegral x, x `shiftR` 8)
			) i
	get = do
		length <- fmap fromIntegral (get :: Get Word16)
		bytes <- getSomeByteString =<< assertProp (>0) ((length + 7) `div` 8)
		return (MPI (B.foldl (\a b ->
			a `shiftL` 8 .|. fromIntegral b) 0 bytes))

listUntilEnd :: (BINARY_CLASS a) => Get [a]
listUntilEnd = do
	done <- isEmpty
	if done then return [] else do
		next <- get
		rest <- listUntilEnd
		return (next:rest)

-- | <http://tools.ietf.org/html/rfc4880#section-5.2.3.1>
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} |
	SignatureTargetPacket {
		target_key_algorithm::KeyAlgorithm,
		target_hash_algorithm::HashAlgorithm,
		hash::B.ByteString
	} |
	EmbeddedSignaturePacket Packet |
	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) =
	(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) =
	(B.singleton $ if supports_mdc then 0x01 else 0x00, 30)
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 (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 == 0x01
	}
-- 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)
-- 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 issuers of
		IssuerPacket issuer : _ -> Just issuer
		_                       -> Nothing
	where
	issuers = filter isIssuer hashed ++ filter isIssuer unhashed
	isIssuer (IssuerPacket {}) = True
	isIssuer _ = 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 = takeFromEnd (length keyid) (fpr x)

takeFromEnd :: Int -> String -> String
takeFromEnd l = reverse . take l . reverse

-- | SignaturePacket smart constructor
--
--   <http://tools.ietf.org/html/rfc4880#section-5.2>
signaturePacket ::
	Word8    -- ^ Signature version (probably 4)
	-> Word8 -- ^ Signature type <http://tools.ietf.org/html/rfc4880#section-5.2.1>
	-> 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
