    -- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes
    -- Copyright © 2012-2020  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 :: 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 :: PKPayload
    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
    $ PKPayload -> Put
    forall t. Binary t => t -> Put
    put PKPayload
    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 Pkt
    _ =
      [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "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 (SignaturePkt (SigV4 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
    putPartialSigforSigning Pkt
    _ =
      [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "This should never happen (putPartialSigforSigning)"

    putSigTrailer :: Pkt -> Put
    putSigTrailer :: Pkt -> Put
    putSigTrailer (SignaturePkt (SigV4 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
    putSigTrailer Pkt
    _ = [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "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
    _ = [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "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
    _ = [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "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
    _ = [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "This should never happen (putUAtforSigning)"

    putSigforSigning :: Pkt -> Put
    putSigforSigning :: Pkt -> Put
    putSigforSigning (SignaturePkt (SigV4 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
    putSigforSigning Pkt
    _ = [Char] -> Put
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Non-V4 not implemented."

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

    putKeyForSigning' :: PKPayload -> Put
    putKeyForSigning' :: PKPayload -> Put
    putKeyForSigning' PKPayload
    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
    $ PKPayload -> Put
    forall t. Binary t => t -> Put
    put PKPayload
    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 = Pkt -> LiteralData
    forall a. Packet a => Pkt -> a
    fromPkt (PktStreamContext -> Pkt
    lastLD PktStreamContext
    state) LiteralData
    -> Getting ByteString LiteralData ByteString -> ByteString
    forall s a. s -> Getting a s a -> a
    ^. Getting ByteString LiteralData ByteString
    Lens' LiteralData ByteString
    literalDataPayload
    payloadForSig SigType
    CanonicalTextSig PktStreamContext
    state = 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) -- FIXME: embedded primary key binding sig should be verified as well
    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 =
      Pkt -> Pkt -> ByteString
    kandUPayload (PktStreamContext -> Pkt
    lastPrimaryKey PktStreamContext
    state) (PktStreamContext -> Pkt
    lastUIDorUAt PktStreamContext
    state) -- FIXME: this doesn't handle revocation of direct key signatures
    payloadForSig SigType
    st PktStreamContext
    _ = [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error ([Char]
    "I dunno how to " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ SigType -> [Char]
    forall a. Show a => a -> [Char]
    show SigType
    st)

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