-- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes
-- Copyright © 2012-2016  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 Crypto.Number.Serialize (i2osp)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Binary (put)
import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, runPut)
import Data.Text.Encoding (encodeUtf8)

import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), 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 = i2osp 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 . 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])