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