-- 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 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
            -- this +6 seems like a bug in RFC4880
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) -- FIXME: embedded primary key binding sig should be verified as well
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) -- FIXME: this doesn't handle revocation of direct key signatures
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])