-- 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.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

canonicalizeLineEndings :: ByteString -> ByteString
canonicalizeLineEndings :: ByteString -> ByteString
canonicalizeLineEndings = [Word8] -> ByteString
BL.pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall {a}. (Eq a, Num a) => [a] -> [a]
go ([Word8] -> [Word8])
-> (ByteString -> [Word8]) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BL.unpack
  where
    go :: [a] -> [a]
go [] = []
    go (a
0x0d:a
0x0a:[a]
rest) = a
0x0d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
0x0a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
rest
    go (a
0x0d:[a]
rest) = a
0x0d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
0x0a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
rest
    go (a
0x0a:[a]
rest) = a
0x0d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
0x0a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
rest
    go (a
w:[a]
rest) = a
w a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
rest

stripTrailingWhitespacePerLine :: ByteString -> ByteString
stripTrailingWhitespacePerLine :: ByteString -> ByteString
stripTrailingWhitespacePerLine = [Word8] -> ByteString
BL.pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8] -> [Word8]
go [] ([Word8] -> [Word8])
-> (ByteString -> [Word8]) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BL.unpack
  where
    go :: [Word8] -> [Word8] -> [Word8]
go [Word8]
lineRev [] = [Word8] -> [Word8]
reverseTrimmed [Word8]
lineRev
    go [Word8]
lineRev (Word8
0x0d:Word8
0x0a:[Word8]
rest) =
      [Word8] -> [Word8]
reverseTrimmed [Word8]
lineRev [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
0x0d, Word8
0x0a] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8] -> [Word8] -> [Word8]
go [] [Word8]
rest
    go [Word8]
lineRev (Word8
w:[Word8]
rest) = [Word8] -> [Word8] -> [Word8]
go (Word8
w Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
lineRev) [Word8]
rest

    reverseTrimmed :: [Word8] -> [Word8]
    reverseTrimmed :: [Word8] -> [Word8]
reverseTrimmed = [Word8] -> [Word8]
forall a. [a] -> [a]
reverse ([Word8] -> [Word8]) -> ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> [Word8] -> [Word8]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Word8 -> Bool
isTrailingWhitespace

    isTrailingWhitespace :: Word8 -> Bool
    isTrailingWhitespace :: Word8 -> Bool
isTrailingWhitespace Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x09

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