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 DeprecatedV3 _ _ _ pk :: 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 V4 _ _ _ _)) = do
Word8 -> Put
putWord8 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 _ =
[Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putPKPforFingerprinting)"
putMPIforFingerprinting :: MPI -> Put
putMPIforFingerprinting :: MPI -> Put
putMPIforFingerprinting (MPI i :: 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 st :: SigType
st pka :: PubKeyAlgorithm
pka ha :: HashAlgorithm
ha hashed :: [SigSubPacket]
hashed _ _ _)) = do
Word8 -> Put
putWord8 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 _ =
[Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putPartialSigforSigning)"
putSigTrailer :: Pkt -> Put
putSigTrailer :: Pkt -> Put
putSigTrailer (SignaturePkt (SigV4 _ _ _ hs :: [SigSubPacket]
hs _ _ _)) = do
Word8 -> Put
putWord8 0x04
Word8 -> Put
putWord8 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
+ 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 _ = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putSigTrailer)"
putUforSigning :: Pkt -> Put
putUforSigning :: Pkt -> Put
putUforSigning u :: Pkt
u@(UserIdPkt _) = Pkt -> Put
putUIDforSigning Pkt
u
putUforSigning u :: Pkt
u@(UserAttributePkt _) = Pkt -> Put
putUAtforSigning Pkt
u
putUforSigning _ = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putUforSigning)"
putUIDforSigning :: Pkt -> Put
putUIDforSigning :: Pkt -> Put
putUIDforSigning (UserIdPkt u :: Text
u) = do
Word8 -> Put
putWord8 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 _ = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putUIDforSigning)"
putUAtforSigning :: Pkt -> Put
putUAtforSigning :: Pkt -> Put
putUAtforSigning (UserAttributePkt us :: [UserAttrSubPacket]
us) = do
Word8 -> Put
putWord8 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 _ = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error "This should never happen (putUAtforSigning)"
putSigforSigning :: Pkt -> Put
putSigforSigning :: Pkt -> Put
putSigforSigning (SignaturePkt (SigV4 st :: SigType
st pka :: PubKeyAlgorithm
pka ha :: HashAlgorithm
ha hashed :: [SigSubPacket]
hashed _ left16 :: Word16
left16 mpis :: NonEmpty MPI
mpis)) = do
Word8 -> Put
putWord8 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 _ = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error "Non-V4 not implemented."
putKeyforSigning :: Pkt -> Put
putKeyforSigning :: Pkt -> Put
putKeyforSigning (PublicKeyPkt pkp :: PKPayload
pkp) = PKPayload -> Put
putKeyForSigning' PKPayload
pkp
putKeyforSigning (PublicSubkeyPkt pkp :: PKPayload
pkp) = PKPayload -> Put
putKeyForSigning' PKPayload
pkp
putKeyforSigning (SecretKeyPkt pkp :: PKPayload
pkp _) = PKPayload -> Put
putKeyForSigning' PKPayload
pkp
putKeyforSigning (SecretSubkeyPkt pkp :: PKPayload
pkp _) = PKPayload -> Put
putKeyForSigning' PKPayload
pkp
putKeyforSigning x :: Pkt
x =
[Char] -> Put
forall a. HasCallStack => [Char] -> a
error
("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]
forall a. [a] -> [a] -> [a]
++ Pkt -> [Char]
forall a. Show a => a -> [Char]
show Pkt
x)
putKeyForSigning' :: PKPayload -> Put
putKeyForSigning' :: PKPayload -> Put
putKeyForSigning' pkp :: PKPayload
pkp = do
Word8 -> Put
putWord8 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 BinarySig state :: 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 CanonicalTextSig state :: PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
BinarySig PktStreamContext
state
payloadForSig StandaloneSig _ = ByteString
BL.empty
payloadForSig GenericCert state :: PktStreamContext
state =
Pkt -> Pkt -> ByteString
kandUPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state)
payloadForSig PersonaCert state :: PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig CasualCert state :: PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig PositiveCert state :: PktStreamContext
state = SigType -> PktStreamContext -> ByteString
payloadForSig SigType
GenericCert PktStreamContext
state
payloadForSig SubkeyBindingSig state :: PktStreamContext
state =
Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig PrimaryKeyBindingSig state :: PktStreamContext
state =
Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig SignatureDirectlyOnAKey state :: PktStreamContext
state =
Put -> ByteString
runPut (Pkt -> Put
putKeyforSigning (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state))
payloadForSig KeyRevocationSig state :: PktStreamContext
state =
SigType -> PktStreamContext -> ByteString
payloadForSig SigType
SignatureDirectlyOnAKey PktStreamContext
state
payloadForSig SubkeyRevocationSig state :: PktStreamContext
state =
Pkt -> Pkt -> ByteString
kandKPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastSubkey PktStreamContext
state)
payloadForSig CertRevocationSig state :: PktStreamContext
state =
Pkt -> Pkt -> ByteString
kandUPayload (PktStreamContext -> Pkt
lastPrimaryKey PktStreamContext
state) (PktStreamContext -> Pkt
lastUIDorUAt PktStreamContext
state)
payloadForSig st :: SigType
st _ = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ("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 k :: Pkt
k u :: 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 k1 :: Pkt
k1 k2 :: 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])