-- 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.Binary (put)
import Data.Binary.Put
  ( Put
  , putByteString
  , putLazyByteString
  , putWord16be
  , putWord32be
  , putWord8
  , runPut
  )
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
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])