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
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)
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)
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])