path: root/Data/OpenPGP.hs

{-# LANGUAGE CPP           #-}
{-# LANGUAGE PatternGuards #-}
-- | 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,
                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,
        defaultFeatures
) 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
        } |
        -- ^ <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
                aead_algorithm      :: Maybe AEADAlgorithm,
                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 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
--
-- <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 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

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

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

defaultFeatures :: SignatureSubpacket
defaultFeatures =
    FeaturesPacket
        { supports_mdc  = True
        , supports_aead = False
        , supports_v5   = True
        }

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