-- SerializeForSigs.hs: OpenPGP (RFC9580) special serialization for signature purposes
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

module Codec.Encryption.OpenPGP.SerializeForSigs
    ( putPKPforFingerprinting
    , putPartialSigforSigning
    , putSigTrailer
    , putUforSigning
    , putUIDforSigning
    , putUAtforSigning
    , putKeyforSigning
    , putSigforSigning
    , payloadForSig
    , payloadForSigWith
    ) 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 Data.Word (Word8)

import Codec.Encryption.OpenPGP.Internal
    ( PktStreamContext (..)
    , pubkeyToMPIs
    )
import Codec.Encryption.OpenPGP.Internal.Whitespace
    ( canonicalizeLineEndings
    , stripTrailingWhitespacePerLine
    )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Subpackets
    ( TextNormalizationMode (..)
    )
import Codec.Encryption.OpenPGP.Types

data SignatureSerializationCase where
    SignatureSerializationCaseV4
        :: SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase
    SignatureSerializationCaseV6
        :: SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase

fromPktSignatureSerializationCase
    :: Pkt -> Maybe SignatureSerializationCase
fromPktSignatureSerializationCase :: Pkt -> Maybe SignatureSerializationCase
fromPktSignatureSerializationCase Pkt
pkt =
    case Pkt -> Either String SomeSignatureV
fromPktEitherSomeSignatureV Pkt
pkt of
        Right (SomeSignatureV (SignatureV4Packet SignaturePayloadV 'SigPayloadV4
payload)) ->
            SignatureSerializationCase -> Maybe SignatureSerializationCase
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase
SignatureSerializationCaseV4 SignaturePayloadV 'SigPayloadV4
payload)
        Right (SomeSignatureV (SignatureV6Packet SignaturePayloadV 'SigPayloadV6
payload)) ->
            SignatureSerializationCase -> Maybe SignatureSerializationCase
forall a. a -> Maybe a
Just (SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase
SignatureSerializationCaseV6 SignaturePayloadV 'SigPayloadV6
payload)
        Either String SomeSignatureV
_ -> Maybe SignatureSerializationCase
forall a. Maybe a
Nothing

putPartialSigforSigningCase :: SignatureSerializationCase -> Put
putPartialSigforSigningCase :: SignatureSerializationCase -> Put
putPartialSigforSigningCase
    ( SignatureSerializationCaseV4
            (SigPayloadV4Data SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha [SigSubPacket]
hashed [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)
        ) = do
        Word8 -> Put
putWord8 Word8
4
        SigType -> Put
forall t. Binary t => t -> Put
put SigType
st
        PubKeyAlgorithm -> Put
forall t. Binary t => t -> Put
put PubKeyAlgorithm
pka
        HashAlgorithm -> Put
forall t. Binary t => t -> Put
put HashAlgorithm
ha
        let hb :: ByteString
hb = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ (SigSubPacket -> Put) -> [SigSubPacket] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SigSubPacket -> Put
forall t. Binary t => t -> Put
put [SigSubPacket]
hashed
        Word16 -> Put
putWord16be (Word16 -> Put) -> (ByteString -> Word16) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> (ByteString -> Int64) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
hb
        ByteString -> Put
putLazyByteString ByteString
hb
putPartialSigforSigningCase
    ( SignatureSerializationCaseV6
            (SigPayloadV6Data SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha SignatureSalt
_salt [SigSubPacket]
hashed [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)
        ) = do
        Word8 -> Put
putWord8 Word8
6
        SigType -> Put
forall t. Binary t => t -> Put
put SigType
st
        PubKeyAlgorithm -> Put
forall t. Binary t => t -> Put
put PubKeyAlgorithm
pka
        HashAlgorithm -> Put
forall t. Binary t => t -> Put
put HashAlgorithm
ha
        let hb :: ByteString
hb = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ (SigSubPacket -> Put) -> [SigSubPacket] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SigSubPacket -> Put
forall t. Binary t => t -> Put
put [SigSubPacket]
hashed
        Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
hb
        ByteString -> Put
putLazyByteString ByteString
hb

putSigTrailerCase :: SignatureSerializationCase -> Put
putSigTrailerCase :: SignatureSerializationCase -> Put
putSigTrailerCase (SignatureSerializationCaseV4 (SigPayloadV4Data SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
hs [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)) = do
    Word8 -> Put
putWord8 Word8
0x04
    Word8 -> Put
putWord8 Word8
0xff
    Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
6) (Int64 -> Int64) -> (ByteString -> Int64) -> ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$
        Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$
            (SigSubPacket -> Put) -> [SigSubPacket] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SigSubPacket -> Put
forall t. Binary t => t -> Put
put [SigSubPacket]
hs
-- this +6 seems like a bug in RFC4880
putSigTrailerCase signatureCase :: SignatureSerializationCase
signatureCase@(SignatureSerializationCaseV6 SignaturePayloadV 'SigPayloadV6
_) = do
    Word8 -> Put
putWord8 Word8
0x06
    Word8 -> Put
putWord8 Word8
0xff
    Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
6) (Int64 -> Int64) -> (ByteString -> Int64) -> ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$
        Put -> ByteString
runPut (SignatureSerializationCase -> Put
putPartialSigforSigningCase SignatureSerializationCase
signatureCase)

putSigforSigningCase :: SignatureSerializationCase -> Put
putSigforSigningCase :: SignatureSerializationCase -> Put
putSigforSigningCase
    ( SignatureSerializationCaseV4
            (SigPayloadV4Data SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha [SigSubPacket]
hashed [SigSubPacket]
_ Word16
left16 NonEmpty MPI
mpis)
        ) = do
        Word8 -> Put
putWord8 Word8
0x88
        let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SignaturePayload -> Put
forall t. Binary t => t -> Put
put (SigType
-> PubKeyAlgorithm
-> HashAlgorithm
-> [SigSubPacket]
-> [SigSubPacket]
-> Word16
-> NonEmpty MPI
-> SignaturePayload
SigV4 SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha [SigSubPacket]
hashed [] Word16
left16 NonEmpty MPI
mpis)
        Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
        ByteString -> Put
putLazyByteString ByteString
bs
putSigforSigningCase
    ( SignatureSerializationCaseV6
            (SigPayloadV6Data SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha SignatureSalt
salt [SigSubPacket]
hashed [SigSubPacket]
_ Word16
left16 NonEmpty MPI
mpis)
        ) = do
        Word8 -> Put
putWord8 Word8
0xC2
        let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SignaturePayload -> Put
forall t. Binary t => t -> Put
put (SigType
-> PubKeyAlgorithm
-> HashAlgorithm
-> SignatureSalt
-> [SigSubPacket]
-> [SigSubPacket]
-> Word16
-> NonEmpty MPI
-> SignaturePayload
SigV6 SigType
st PubKeyAlgorithm
pka HashAlgorithm
ha SignatureSalt
salt [SigSubPacket]
hashed [] Word16
left16 NonEmpty MPI
mpis)
        Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
        ByteString -> Put
putLazyByteString ByteString
bs

putPKPforFingerprinting :: Pkt -> Put
putPKPforFingerprinting :: Pkt -> Put
putPKPforFingerprinting (PublicKeyPkt (PKPayload KeyVersion
DeprecatedV3 ThirtyTwoBitTimeStamp
_ Word16
_ PubKeyAlgorithm
_ PKey
pk)) =
    (MPI -> Put) -> [MPI] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MPI -> Put
putMPIforFingerprinting (PKey -> [MPI]
pubkeyToMPIs PKey
pk)
putPKPforFingerprinting (PublicKeyPkt pkp :: SomePKPayload
pkp@(PKPayload KeyVersion
V4 ThirtyTwoBitTimeStamp
_ Word16
_ PubKeyAlgorithm
_ PKey
_)) = do
    Word8 -> Put
putWord8 Word8
0x99
    let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SomePKPayload -> Put
forall t. Binary t => t -> Put
put SomePKPayload
pkp
    Word16 -> Put
putWord16be (Word16 -> Put) -> (Int64 -> Word16) -> Int64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Put) -> Int64 -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
bs
    ByteString -> Put
putLazyByteString ByteString
bs
putPKPforFingerprinting (PublicKeyPkt pkp :: SomePKPayload
pkp@(PKPayload KeyVersion
V6 ThirtyTwoBitTimeStamp
_ Word16
_ PubKeyAlgorithm
_ PKey
_)) = do
    Word8 -> Put
putWord8 Word8
0x9B
    let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SomePKPayload -> Put
forall t. Binary t => t -> Put
put SomePKPayload
pkp
    Word32 -> Put
putWord32be (Word32 -> Put) -> (Int64 -> Word32) -> Int64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Put) -> Int64 -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
bs
    ByteString -> Put
putLazyByteString ByteString
bs
putPKPforFingerprinting Pkt
_ =
    String -> Put
forall a. HasCallStack => String -> a
error String
"This should never happen (putPKPforFingerprinting)"

putMPIforFingerprinting :: MPI -> Put
putMPIforFingerprinting :: MPI -> Put
putMPIforFingerprinting (MPI Integer
i) =
    let bs :: ByteString
bs = Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
i
     in ByteString -> Put
putByteString ByteString
bs

putPartialSigforSigning :: Pkt -> Put
putPartialSigforSigning :: Pkt -> Put
putPartialSigforSigning Pkt
pkt =
    case Pkt -> Maybe SignatureSerializationCase
fromPktSignatureSerializationCase Pkt
pkt of
        Just SignatureSerializationCase
signatureCase -> SignatureSerializationCase -> Put
putPartialSigforSigningCase SignatureSerializationCase
signatureCase
        Maybe SignatureSerializationCase
Nothing ->
            String -> Put
forall a. HasCallStack => String -> a
error
                ( String
"putPartialSigforSigning: unsupported signature packet version: "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show (Pkt -> Word8
pktTag Pkt
pkt)
                )

putSigTrailer :: Pkt -> Put
putSigTrailer :: Pkt -> Put
putSigTrailer Pkt
pkt =
    case Pkt -> Maybe SignatureSerializationCase
fromPktSignatureSerializationCase Pkt
pkt of
        Just SignatureSerializationCase
signatureCase -> SignatureSerializationCase -> Put
putSigTrailerCase SignatureSerializationCase
signatureCase
        Maybe SignatureSerializationCase
Nothing -> String -> Put
forall a. HasCallStack => String -> a
error String
"This should never happen (putSigTrailer)"

putUforSigning :: Pkt -> Put
putUforSigning :: Pkt -> Put
putUforSigning u :: Pkt
u@(UserIdPkt Text
_) = Pkt -> Put
putUIDforSigning Pkt
u
putUforSigning u :: Pkt
u@(UserAttributePkt [UserAttrSubPacket]
_) = Pkt -> Put
putUAtforSigning Pkt
u
putUforSigning Pkt
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"This should never happen (putUforSigning)"

putUIDforSigning :: Pkt -> Put
putUIDforSigning :: Pkt -> Put
putUIDforSigning (UserIdPkt Text
u) = do
    Word8 -> Put
putWord8 Word8
0xB4
    let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 Text
u
    Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (ByteString -> Int) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
    ByteString -> Put
putByteString ByteString
bs
putUIDforSigning Pkt
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"This should never happen (putUIDforSigning)"

putUAtforSigning :: Pkt -> Put
putUAtforSigning :: Pkt -> Put
putUAtforSigning (UserAttributePkt [UserAttrSubPacket]
us) = do
    Word8 -> Put
putWord8 Word8
0xD1
    let bs :: ByteString
bs = Put -> ByteString
runPut ((UserAttrSubPacket -> Put) -> [UserAttrSubPacket] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UserAttrSubPacket -> Put
forall t. Binary t => t -> Put
put [UserAttrSubPacket]
us)
    Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
    ByteString -> Put
putLazyByteString ByteString
bs
putUAtforSigning Pkt
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"This should never happen (putUAtforSigning)"

putSigforSigning :: Pkt -> Put
putSigforSigning :: Pkt -> Put
putSigforSigning Pkt
pkt =
    case Pkt -> Maybe SignatureSerializationCase
fromPktSignatureSerializationCase Pkt
pkt of
        Just SignatureSerializationCase
signatureCase -> SignatureSerializationCase -> Put
putSigforSigningCase SignatureSerializationCase
signatureCase
        Maybe SignatureSerializationCase
Nothing ->
            String -> Put
forall a. HasCallStack => String -> a
error
                ( String
"putSigforSigning: unsupported signature packet version: "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show (Pkt -> Word8
pktTag Pkt
pkt)
                )

putKeyforSigning :: Pkt -> Put
putKeyforSigning :: Pkt -> Put
putKeyforSigning (PublicKeyPkt SomePKPayload
pkp) = SomePKPayload -> Put
putKeyForSigning' SomePKPayload
pkp
putKeyforSigning (PublicSubkeyPkt SomePKPayload
pkp) = SomePKPayload -> Put
putKeyForSigning' SomePKPayload
pkp
putKeyforSigning (SecretKeyPkt SomePKPayload
pkp SKAddendum
_) = SomePKPayload -> Put
putKeyForSigning' SomePKPayload
pkp
putKeyforSigning (SecretSubkeyPkt SomePKPayload
pkp SKAddendum
_) = SomePKPayload -> Put
putKeyForSigning' SomePKPayload
pkp
putKeyforSigning Pkt
x =
    String -> Put
forall a. HasCallStack => String -> a
error
        ( String
"This should never happen (putKeyforSigning) "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show (Pkt -> Word8
pktTag Pkt
x)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pkt -> String
forall a. Show a => a -> String
show Pkt
x
        )

putKeyForSigning' :: SomePKPayload -> Put
putKeyForSigning' :: SomePKPayload -> Put
putKeyForSigning' pkp :: SomePKPayload
pkp@(PKPayload KeyVersion
V6 ThirtyTwoBitTimeStamp
_ Word16
_ PubKeyAlgorithm
_ PKey
_) = do
    Word8 -> Put
putWord8 Word8
0x9B
    let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SomePKPayload -> Put
forall t. Binary t => t -> Put
put SomePKPayload
pkp
    Word32 -> Put
putWord32be (Word32 -> Put) -> (ByteString -> Word32) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (ByteString -> Int64) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
    ByteString -> Put
putLazyByteString ByteString
bs
putKeyForSigning' SomePKPayload
pkp = do
    Word8 -> Put
putWord8 Word8
0x99
    let bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ SomePKPayload -> Put
forall t. Binary t => t -> Put
put SomePKPayload
pkp
    Word16 -> Put
putWord16be (Word16 -> Put) -> (ByteString -> Word16) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> (ByteString -> Int64) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteString
bs
    ByteString -> Put
putLazyByteString ByteString
bs

payloadForSig :: SigType -> PktStreamContext -> ByteString
payloadForSig :: SigType -> PktStreamContext -> ByteString
payloadForSig SigType
BinarySig PktStreamContext
state =
    case (Pkt -> Either String LiteralData
forall a. Packet a => Pkt -> Either String a
fromPktEither (PktStreamContext -> Pkt
lastLD PktStreamContext
state) :: Either String LiteralData) of
        Right LiteralData
ld -> LiteralData
ld LiteralData
-> Getting ByteString LiteralData ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString LiteralData ByteString
Lens' LiteralData ByteString
literalDataPayload
        Left String
err -> String -> ByteString
forall a. HasCallStack => String -> a
error (String
"payloadForSig expected literal data packet: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
payloadForSig SigType
CanonicalTextSig PktStreamContext
state =
    ByteString -> ByteString
stripTrailingWhitespacePerLine
        (ByteString -> ByteString
canonicalizeLineEndings (SigType -> PktStreamContext -> ByteString
payloadForSig SigType
BinarySig PktStreamContext
state))
payloadForSig SigType
StandaloneSig PktStreamContext
_ = ByteString
BL.empty
payloadForSig SigType
GenericCert PktStreamContext
state =
    Pkt -> Pkt -> ByteString
kandUPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state)
payloadForSig SigType
PersonaCert PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig SigType
CasualCert PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig SigType
PositiveCert PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig SigType
SubkeyBindingSig PktStreamContext
state =
    Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig SigType
PrimaryKeyBindingSig PktStreamContext
state =
    Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig SigType
SignatureDirectlyOnAKey PktStreamContext
state =
    Put -> ByteString
runPut (Pkt -> Put
putKeyforSigning (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state))
payloadForSig SigType
KeyRevocationSig PktStreamContext
state =
    SigType -> PktStreamContext -> ByteString
payloadForSig SigType
SignatureDirectlyOnAKey PktStreamContext
state
payloadForSig SigType
SubkeyRevocationSig PktStreamContext
state =
    Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig SigType
CertRevocationSig PktStreamContext
state =
    -- RFC 9580 §5.2.1: 0x30 revokes a UID certification when a UID/UAt is in
    -- scope, but when there is no UID/UAt in scope it revokes a direct-key sig
    -- (0x1F) and the payload is just the primary key material.
    case PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state of
        UserIdPkt Text
_ ->
            Pkt -> Pkt -> ByteString
kandUPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state)
        UserAttributePkt [UserAttrSubPacket]
_ -> Pkt -> Pkt -> ByteString
kandUPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state)
        Pkt
_ ->
            Put -> ByteString
runPut (Pkt -> Put
putKeyforSigning (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state))
payloadForSig SigType
st PktStreamContext
_ = String -> ByteString
forall a. HasCallStack => String -> a
error (String
"payloadForSig: unhandled signature type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SigType -> String
forall a. Show a => a -> String
show SigType
st)

{- | Like 'payloadForSig' but accepts an explicit 'TextNormalizationMode'
that controls whether trailing whitespace is stripped for CanonicalTextSig.

Use 'RFC9580Strict' for inline type 0x01 document signatures.
Use 'CleartextCompat' (or 'payloadForSig') for cleartext-armored messages.
-}
payloadForSigWith
    :: TextNormalizationMode
    -> SigType
    -> PktStreamContext
    -> ByteString
payloadForSigWith :: TextNormalizationMode -> SigType -> PktStreamContext -> ByteString
payloadForSigWith TextNormalizationMode
RFC9580Strict SigType
CanonicalTextSig PktStreamContext
state =
    ByteString -> ByteString
canonicalizeLineEndings (SigType -> PktStreamContext -> ByteString
payloadForSig SigType
BinarySig PktStreamContext
state)
payloadForSigWith TextNormalizationMode
_ SigType
st PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
st PktStreamContext
state

kandUPayload :: Pkt -> Pkt -> ByteString
kandUPayload :: Pkt -> Pkt -> ByteString
kandUPayload Pkt
k Pkt
u = Put -> ByteString
runPut ([Put] -> Put
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Pkt -> Put
putKeyforSigning Pkt
k, Pkt -> Put
putUforSigning Pkt
u])

kandKPayload :: Pkt -> Pkt -> ByteString
kandKPayload :: Pkt -> Pkt -> ByteString
kandKPayload Pkt
k1 Pkt
k2 =
    Put -> ByteString
runPut ([Put] -> Put
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Pkt -> Put
putKeyforSigning Pkt
k1, Pkt -> Put
putKeyforSigning Pkt
k2])