-- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes
-- Copyright © 2012-2015  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.Lazy (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Binary (Binary, put)
import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, runPut)
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 $ BL.length bs
    putLazyByteString bs
putPKPforFingerprinting _ = fail "This should never happen (putPKPforFingerprinting)"

putMPIforFingerprinting:: MPI -> Put
putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putLazyByteString 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 . BL.length $ hb
    putLazyByteString hb
putPartialSigforSigning _ = fail "This should never happen (putPartialSigforSigning)"

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

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

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

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

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 . BL.length $ bs
    putLazyByteString 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 x = fail ("This should never happen (putKeyforSigning) " ++ show (pktTag x) ++ "/" ++ show x)

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

payloadForSig :: SigType -> PktStreamContext -> ByteString
payloadForSig BinarySig state = fromPkt (lastLD state)^.literalDataPayload
payloadForSig CanonicalTextSig state = payloadForSig BinarySig state
payloadForSig StandaloneSig _ = BL.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])