-- 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 qualified Data.ByteString.Char8 as BC8
import Data.Serialize (Serialize, put)
import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, runPut)

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 = BC8.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])