    -- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes
    -- Copyright © 2012-2013  Clint Adams
    -- This software is released under the terms of the Expat license.
    -- (See the LICENSE file).

    module Codec.Encryption.OpenPGP.SerializeForSigs (
       putPKPforFingerprinting
     , putPartialSigforSigning
     , putSigTrailer
     , putUforSigning
     , putUIDforSigning
     , putUAtforSigning
     , putKeyforSigning
     , putSigforSigning
     , payloadForSig
    ) where

    import Control.Lens ((^.))
    import Data.ByteString (ByteString)
    import qualified Data.ByteString as B
    import Data.Serialize (Serialize, put)
    import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, runPut)
    import qualified Data.Text as T
    import Data.Text.Encoding (encodeUtf8)

    import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), integerToBEBS, pubkeyToMPIs)
    import Codec.Encryption.OpenPGP.Serialize ()
    import Codec.Encryption.OpenPGP.Types

    putPKPforFingerprinting :: Pkt -> Put
    putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk)
    putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do
        putWord8 0x99
        let bs = runPut $ put pkp
        putWord16be . fromIntegral $ B.length bs
        putByteString bs
    putPKPforFingerprinting _ = fail "This should never happen"

    putMPIforFingerprinting:: MPI -> Put
    putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putByteString bs

    putPartialSigforSigning :: Pkt -> Put
    putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do
        putWord8 4
        put st
        put pka
        put ha
        let hb = runPut $ mapM_ put hashed
        putWord16be . fromIntegral . B.length $ hb
        putByteString hb
    putPartialSigforSigning _ = fail "This should never happen"

    putSigTrailer :: Pkt -> Put
    putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do
                putWord8 0x04
                putWord8 0xff
                putWord32be . fromIntegral . (+6) . B.length $ runPut $ mapM_ put hs
                -- this +6 seems like a bug in RFC4880
    putSigTrailer _ = fail "This should never happen"

    putUforSigning :: Pkt -> Put
    putUforSigning u@(UserIdPkt _) = putUIDforSigning u
    putUforSigning u@(UserAttributePkt _) = putUAtforSigning u
    putUforSigning _ = fail "This should never happen"

    putUIDforSigning :: Pkt -> Put
    putUIDforSigning (UserIdPkt u) = do
        putWord8 0xB4
        let bs = encodeUtf8 . T.pack $ u
        putWord32be . fromIntegral . B.length $ bs
        putByteString bs
    putUIDforSigning _ = fail "This should never happen"

    putUAtforSigning :: Pkt -> Put
    putUAtforSigning (UserAttributePkt us) = do
        putWord8 0xD1
        let bs = runPut (mapM_ put us)
        putWord32be . fromIntegral . B.length $ bs
        putByteString bs
    putUAtforSigning _ = fail "This should never happen"

    putSigforSigning :: Pkt -> Put
    putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do
        putWord8 0x88
        let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)
        putWord32be . fromIntegral . B.length $ bs
        putByteString bs
    putSigforSigning _ = fail "Non-V4 not implemented."

    putKeyforSigning :: Pkt -> Put
    putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp
    putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp
    putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp
    putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp
    putKeyforSigning _ = fail "This should never happen"

    putKeyForSigning' :: PKPayload -> Put
    putKeyForSigning' pkp = do
        putWord8 0x99
        let bs = runPut $ put pkp
        putWord16be . fromIntegral . B.length $ bs
        putByteString bs

    payloadForSig :: SigType -> PktStreamContext -> ByteString
    payloadForSig BinarySig state = fromPkt (lastLD state)^.literalDataPayload
    payloadForSig CanonicalTextSig state = payloadForSig BinarySig state
    payloadForSig StandaloneSig _ = B.empty
    payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)
    payloadForSig PersonaCert state = payloadForSig GenericCert state
    payloadForSig CasualCert state = payloadForSig GenericCert state
    payloadForSig PositiveCert state = payloadForSig GenericCert state
    payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well
    payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state)
    payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state))
    payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state
    payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state)
    payloadForSig CertRevocationSig state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures
    payloadForSig st _ = error ("I dunno how to " ++ show st)

    kandUPayload :: Pkt -> Pkt -> ByteString
    kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u])

    kandKPayload :: Pkt -> Pkt -> ByteString
    kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])