-- Encrypt.hs: OpenPGP (RFC9580) packet-level encryption helpers
-- Copyright © 2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.Encrypt
  ( PKESKEncryptError(..)
  , RecipientCapabilityNegotiationMode(..)
  , RecipientCapabilityError(..)
  , renderRecipientCapabilityError
  , RecipientCapabilities(..)
  , recipientCapabilitiesFromSubpacketPayloads
  , recipientCapabilitySupportsEncryption
  , RecipientTargetRejectionReason(..)
  , RecipientEncryptionTargetRejected(..)
  , RecipientEncryptionTargetsReport(..)
  , recipientEncryptionTargetsReportFromTKAtTimestamp
  , recipientEncryptionTargetsReportFromTK
  , recipientEncryptionTargetFromTKAtTimestamp
  , recipientEncryptionTargetFromTKAtTimestampWithPolicy
  , recipientEncryptionTargetsFromTKAtTimestamp
  , recipientEncryptionTargetFromTK
  , recipientEncryptionTargetFromTKWithPolicy
  , recipientEncryptionTargetsFromTK
  , RecipientTargetSelectionPolicy(..)
  , PassphraseSKESKVersionPolicy(..)
  , PassphraseEncryptRequest(..)
  , encryptPassphraseWithPolicy
  , PKESKVersionPolicy(..)
  , RecipientPKESKVersionStrategy(..)
  , RecipientPKESKVersionStrategyW(..)
  , SomeRecipientPKESKVersionStrategyW(..)
  , RecipientPKESKVersionSelector
  , RecipientPKESKVersionSelectorTyped
  , EncryptCompatibilityProfile(..)
  , EncryptCompatibilityProfileW(..)
  , SomeEncryptCompatibilityProfileW(..)
  , RecipientEncryptionTarget(..)
  , recipientEncryptionTarget
  , recipientEncryptionTargetWithStrategy
  , recipientEncryptionTargetWithCapabilities
  , recipientEncryptionTargetWithStrategyTyped
  , recipientVersionStrategyForProfile
  , recipientVersionStrategyForProfileTyped
  , RecipientPayloadShape(..)
  , defaultRecipientPayloadShape
  , SEIPDVersion(..)
  , RecipientEncryptResult(..)
  , RecipientEncryptRequest(..)
  , RecipientEncryptRequestOverrides(..)
  , encryptForRecipients
  , encryptForRecipientsLegacy
  , encryptForRecipientsWithCapabilityNegotiation
  , PKESKV3SessionMaterial
  , PKESKV6RawSessionMaterial
  , PKESKSessionMaterial
  , pkeskSessionAlgorithm
  , pkeskSessionKey
  , mkPKESKSessionMaterial
  , mkPKESKV3SessionMaterial
  , mkPKESKV6RawSessionMaterial
  , pkeskV3SessionMaterial
  , pkeskV6RawSessionMaterial
  , encodeOpenPGPSessionMaterial
  , generateSessionKeyMaterial
  , canonicalizePKESKRecipientId
  , canonicalizePKESKPacketRecipientIds
  , buildPKESKv3PayloadForRecipient
  , buildPKESKv3PktForRecipient
  , buildPKESKPayloadForRecipient
  , buildPKESKPktForRecipient
  , buildPKESKPktsForRecipientTargetsWithSelector
  , buildPKESKPktsForRecipientTargetsWithSelectorTyped
  , encryptSEIPDv2Payload
  , encryptSEIPDv1Payload
  , encryptSEIPDv2WithSKESK
  , encryptSEIPDv2WithSKESKBlock
  , encryptSEIPDv2LiteralDataWithSKESK
  , composeMessageWithSEIPDv2
  ) where

import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher)
import Codec.Encryption.OpenPGP.CFB
  ( OpenPGPCFBModeW(..)
  , encryptOpenPGPCfbRaw
  , mdcTrailerForSEIPDv1
  )
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..))
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS)
import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
  ( normalizeMontgomeryPublic
  , buildECDHKDFParam
  , deriveECDHKek
  )
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
  ( aeadModeAndNonceSizeForSEIPDv2
  , deriveSKESK6KEK
  , encryptSKESK6SessionKey
  , seipdv2SymmetricKeySize
  )
import Codec.Encryption.OpenPGP.Policy
  ( PKESKVersionPolicy(..)
  , OpenPGPRFC(..)
  , MessageEncryptionPolicy
  , policyForRFC
  , policyMessageEncryption
  , messageDefaultSymmetricAlgorithm
  , messageSEIPDv2SymmetricAlgorithms
  , messageDefaultAEADAlgorithm
  , messageDefaultChunkSize
  , messageSEIPDv2SaltOctets
  , defaultPKESKVersionPolicy
  )
import Codec.Encryption.OpenPGP.Expirations
  ( effectiveKeyPreferencesAtTimestamp
  , isPKTimeValidWithSelfSignatures
  , keyStateAt
  , keyStateValid
  , signatureEffectiveAt
  )
import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isSubkeyRevocation)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT, signatureHashedSubpacketsKnown)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (encryptWithOCBRFC7253)
import Control.Applicative ((<|>))
import Control.Lens ((.~), ix)
import Control.Monad (when)
import Data.List (find, foldl', maximumBy)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified "crypton" Crypto.Cipher.Types as CCT
import qualified Crypto.Error as CE
import qualified Crypto.Hash.Algorithms as CHAlg
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.Curve25519 as C25519
import qualified Crypto.PubKey.Curve448 as C448
import qualified Crypto.PubKey.ECC.DH as ECCDH
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Generate as ECCGen
import qualified Crypto.PubKey.RSA.PKCS15 as RSA15
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Binary (put)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Bits ((.&.), shiftL, shiftR, xor)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Set as Set
import Data.Word (Word8, Word16, Word64)
import Data.Int (Int64)

-- | Typed failures from one-pass signature packet construction.
data OPSBuildError
  = OPSBuildMissingIssuerKeyId
  | OPSBuildMissingIssuerFingerprint
  | OPSBuildFingerprintWrongLength Int64
  | OPSBuildUnsupportedSigVersion PacketVersion
  deriving (OPSBuildError -> OPSBuildError -> Bool
(OPSBuildError -> OPSBuildError -> Bool)
-> (OPSBuildError -> OPSBuildError -> Bool) -> Eq OPSBuildError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OPSBuildError -> OPSBuildError -> Bool
== :: OPSBuildError -> OPSBuildError -> Bool
$c/= :: OPSBuildError -> OPSBuildError -> Bool
/= :: OPSBuildError -> OPSBuildError -> Bool
Eq, Int -> OPSBuildError -> ShowS
[OPSBuildError] -> ShowS
OPSBuildError -> String
(Int -> OPSBuildError -> ShowS)
-> (OPSBuildError -> String)
-> ([OPSBuildError] -> ShowS)
-> Show OPSBuildError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OPSBuildError -> ShowS
showsPrec :: Int -> OPSBuildError -> ShowS
$cshow :: OPSBuildError -> String
show :: OPSBuildError -> String
$cshowList :: [OPSBuildError] -> ShowS
showList :: [OPSBuildError] -> ShowS
Show)

renderOPSBuildError :: OPSBuildError -> String
renderOPSBuildError :: OPSBuildError -> String
renderOPSBuildError OPSBuildError
OPSBuildMissingIssuerKeyId =
  String
"cannot build OPS3 packet from v4 signature without issuer metadata"
renderOPSBuildError OPSBuildError
OPSBuildMissingIssuerFingerprint =
  String
"cannot build OPS6 packet from v6 signature without issuer fingerprint"
renderOPSBuildError (OPSBuildFingerprintWrongLength Int64
n) =
  String
"cannot build OPS6 packet: issuer fingerprint must be 32 octets, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
n
renderOPSBuildError (OPSBuildUnsupportedSigVersion Word8
v) =
  String
"cannot build one-pass signature packet for unsupported signature version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
v

-- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers.
data PKESKEncryptError
  = UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String
  | InvalidSessionKeyLength SymmetricAlgorithm Int Int
  | InvalidRecipientIdentifier String
  | UnsupportedRecipientAlgorithm PubKeyAlgorithm
  | InvalidRecipientKeyMaterial PubKeyAlgorithm String
  | RecipientKdfFailure PubKeyAlgorithm String
  | RecipientKeyWrapFailure PubKeyAlgorithm String
  | RecipientCapabilitySelectionFailure RecipientCapabilityError
  | PayloadBuildFailure String
  | NoRecipientsProvided
  deriving (PKESKEncryptError -> PKESKEncryptError -> Bool
(PKESKEncryptError -> PKESKEncryptError -> Bool)
-> (PKESKEncryptError -> PKESKEncryptError -> Bool)
-> Eq PKESKEncryptError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKEncryptError -> PKESKEncryptError -> Bool
== :: PKESKEncryptError -> PKESKEncryptError -> Bool
$c/= :: PKESKEncryptError -> PKESKEncryptError -> Bool
/= :: PKESKEncryptError -> PKESKEncryptError -> Bool
Eq, Int -> PKESKEncryptError -> ShowS
[PKESKEncryptError] -> ShowS
PKESKEncryptError -> String
(Int -> PKESKEncryptError -> ShowS)
-> (PKESKEncryptError -> String)
-> ([PKESKEncryptError] -> ShowS)
-> Show PKESKEncryptError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKEncryptError -> ShowS
showsPrec :: Int -> PKESKEncryptError -> ShowS
$cshow :: PKESKEncryptError -> String
show :: PKESKEncryptError -> String
$cshowList :: [PKESKEncryptError] -> ShowS
showList :: [PKESKEncryptError] -> ShowS
Show)

renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm SymmetricAlgorithm
algo String
reason) =
  String
"unsupported session key algorithm " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError (InvalidSessionKeyLength SymmetricAlgorithm
algo Int
expected Int
actual) =
  String
"invalid session key length for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
actual
renderPKESKEncryptError (InvalidRecipientIdentifier String
reason) =
  String
"invalid recipient identifier: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError (UnsupportedRecipientAlgorithm PubKeyAlgorithm
algo) =
  String
"unsupported recipient public-key algorithm: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
algo
renderPKESKEncryptError (InvalidRecipientKeyMaterial PubKeyAlgorithm
algo String
reason) =
  String
"invalid recipient key material for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError (RecipientKdfFailure PubKeyAlgorithm
algo String
reason) =
  String
"KDF failure for recipient algorithm " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError (RecipientKeyWrapFailure PubKeyAlgorithm
algo String
reason) =
  String
"key wrap failure for recipient algorithm " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError (RecipientCapabilitySelectionFailure RecipientCapabilityError
err) =
  RecipientCapabilityError -> String
renderRecipientCapabilityError RecipientCapabilityError
err
renderPKESKEncryptError (PayloadBuildFailure String
reason) =
  String
"payload build failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
renderPKESKEncryptError PKESKEncryptError
NoRecipientsProvided =
  String
"no recipients provided"

data RecipientCapabilityNegotiationMode
  = RecipientCapabilityNegotiationOff
  | RecipientCapabilityNegotiationOn
  deriving (RecipientCapabilityNegotiationMode
-> RecipientCapabilityNegotiationMode -> Bool
(RecipientCapabilityNegotiationMode
 -> RecipientCapabilityNegotiationMode -> Bool)
-> (RecipientCapabilityNegotiationMode
    -> RecipientCapabilityNegotiationMode -> Bool)
-> Eq RecipientCapabilityNegotiationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientCapabilityNegotiationMode
-> RecipientCapabilityNegotiationMode -> Bool
== :: RecipientCapabilityNegotiationMode
-> RecipientCapabilityNegotiationMode -> Bool
$c/= :: RecipientCapabilityNegotiationMode
-> RecipientCapabilityNegotiationMode -> Bool
/= :: RecipientCapabilityNegotiationMode
-> RecipientCapabilityNegotiationMode -> Bool
Eq, Int -> RecipientCapabilityNegotiationMode -> ShowS
[RecipientCapabilityNegotiationMode] -> ShowS
RecipientCapabilityNegotiationMode -> String
(Int -> RecipientCapabilityNegotiationMode -> ShowS)
-> (RecipientCapabilityNegotiationMode -> String)
-> ([RecipientCapabilityNegotiationMode] -> ShowS)
-> Show RecipientCapabilityNegotiationMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientCapabilityNegotiationMode -> ShowS
showsPrec :: Int -> RecipientCapabilityNegotiationMode -> ShowS
$cshow :: RecipientCapabilityNegotiationMode -> String
show :: RecipientCapabilityNegotiationMode -> String
$cshowList :: [RecipientCapabilityNegotiationMode] -> ShowS
showList :: [RecipientCapabilityNegotiationMode] -> ShowS
Show)

data RecipientCapabilityError
  = RecipientCapabilityMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag)
  | RecipientCapabilityNoEncryptableKeyMaterialInTK
  | RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
  | RecipientCapabilityMissingSEIPDv2Support [SomePKPayload]
  | RecipientCapabilityNoCommonSymmetricAlgorithms [SymmetricAlgorithm]
  | RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm]
  deriving (RecipientCapabilityError -> RecipientCapabilityError -> Bool
(RecipientCapabilityError -> RecipientCapabilityError -> Bool)
-> (RecipientCapabilityError -> RecipientCapabilityError -> Bool)
-> Eq RecipientCapabilityError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientCapabilityError -> RecipientCapabilityError -> Bool
== :: RecipientCapabilityError -> RecipientCapabilityError -> Bool
$c/= :: RecipientCapabilityError -> RecipientCapabilityError -> Bool
/= :: RecipientCapabilityError -> RecipientCapabilityError -> Bool
Eq, Int -> RecipientCapabilityError -> ShowS
[RecipientCapabilityError] -> ShowS
RecipientCapabilityError -> String
(Int -> RecipientCapabilityError -> ShowS)
-> (RecipientCapabilityError -> String)
-> ([RecipientCapabilityError] -> ShowS)
-> Show RecipientCapabilityError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientCapabilityError -> ShowS
showsPrec :: Int -> RecipientCapabilityError -> ShowS
$cshow :: RecipientCapabilityError -> String
show :: RecipientCapabilityError -> String
$cshowList :: [RecipientCapabilityError] -> ShowS
showList :: [RecipientCapabilityError] -> ShowS
Show)

renderRecipientCapabilityError :: RecipientCapabilityError -> String
renderRecipientCapabilityError :: RecipientCapabilityError -> String
renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags SomePKPayload
recipient Set KeyFlag
flags) =
  String
"recipient " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (KeyVersion, PubKeyAlgorithm) -> String
forall a. Show a => a -> String
show (SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
recipient, SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient) String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
" does not advertise encryption-capable key flags; observed flags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [KeyFlag] -> String
forall a. Show a => a -> String
show (Set KeyFlag -> [KeyFlag]
forall a. Set a -> [a]
Set.toList Set KeyFlag
flags)
renderRecipientCapabilityError RecipientCapabilityError
RecipientCapabilityNoEncryptableKeyMaterialInTK =
  String
"no encryption-capable primary key or subkey was found in transferable key material"
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
recipients) =
  String
"recipient set does not advertise SEIPDv1 (MDC) support: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [(KeyVersion, PubKeyAlgorithm)] -> String
forall a. Show a => a -> String
show ((SomePKPayload -> (KeyVersion, PubKeyAlgorithm))
-> [SomePKPayload] -> [(KeyVersion, PubKeyAlgorithm)]
forall a b. (a -> b) -> [a] -> [b]
map (\SomePKPayload
r -> (SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
r, SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
r)) [SomePKPayload]
recipients)
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support [SomePKPayload]
recipients) =
  String
"recipient set does not advertise SEIPDv2 support: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [(KeyVersion, PubKeyAlgorithm)] -> String
forall a. Show a => a -> String
show ((SomePKPayload -> (KeyVersion, PubKeyAlgorithm))
-> [SomePKPayload] -> [(KeyVersion, PubKeyAlgorithm)]
forall a b. (a -> b) -> [a] -> [b]
map (\SomePKPayload
r -> (SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
r, SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
r)) [SomePKPayload]
recipients)
renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms [SymmetricAlgorithm]
syms) =
  String
"no common recipient-supported symmetric algorithms: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [SymmetricAlgorithm] -> String
forall a. Show a => a -> String
show [SymmetricAlgorithm]
syms
renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm]
aeads) =
  String
"no common recipient-supported AEAD algorithms: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [AEADAlgorithm] -> String
forall a. Show a => a -> String
show [AEADAlgorithm]
aeads

data RecipientCapabilities =
  RecipientCapabilities
    { RecipientCapabilities -> KeyVersion
recipientCapabilityKeyVersion :: KeyVersion
    , RecipientCapabilities -> PubKeyAlgorithm
recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm
    , RecipientCapabilities -> Set KeyFlag
recipientCapabilityKeyFlags :: Set.Set KeyFlag
    , RecipientCapabilities -> Set FeatureFlag
recipientCapabilityFeatures :: Set.Set FeatureFlag
    , RecipientCapabilities -> [SymmetricAlgorithm]
recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
    , RecipientCapabilities -> [AEADAlgorithm]
recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm]
    }
  deriving (RecipientCapabilities -> RecipientCapabilities -> Bool
(RecipientCapabilities -> RecipientCapabilities -> Bool)
-> (RecipientCapabilities -> RecipientCapabilities -> Bool)
-> Eq RecipientCapabilities
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientCapabilities -> RecipientCapabilities -> Bool
== :: RecipientCapabilities -> RecipientCapabilities -> Bool
$c/= :: RecipientCapabilities -> RecipientCapabilities -> Bool
/= :: RecipientCapabilities -> RecipientCapabilities -> Bool
Eq, Int -> RecipientCapabilities -> ShowS
[RecipientCapabilities] -> ShowS
RecipientCapabilities -> String
(Int -> RecipientCapabilities -> ShowS)
-> (RecipientCapabilities -> String)
-> ([RecipientCapabilities] -> ShowS)
-> Show RecipientCapabilities
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientCapabilities -> ShowS
showsPrec :: Int -> RecipientCapabilities -> ShowS
$cshow :: RecipientCapabilities -> String
show :: RecipientCapabilities -> String
$cshowList :: [RecipientCapabilities] -> ShowS
showList :: [RecipientCapabilities] -> ShowS
Show)

data RecipientTargetRejectionReason
  = RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm
  | RecipientTargetMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag)
  | RecipientTargetRevoked SomePKPayload
  | RecipientTargetNotValidAtTimestamp SomePKPayload ThirtyTwoBitTimeStamp
  deriving (RecipientTargetRejectionReason
-> RecipientTargetRejectionReason -> Bool
(RecipientTargetRejectionReason
 -> RecipientTargetRejectionReason -> Bool)
-> (RecipientTargetRejectionReason
    -> RecipientTargetRejectionReason -> Bool)
-> Eq RecipientTargetRejectionReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientTargetRejectionReason
-> RecipientTargetRejectionReason -> Bool
== :: RecipientTargetRejectionReason
-> RecipientTargetRejectionReason -> Bool
$c/= :: RecipientTargetRejectionReason
-> RecipientTargetRejectionReason -> Bool
/= :: RecipientTargetRejectionReason
-> RecipientTargetRejectionReason -> Bool
Eq, Int -> RecipientTargetRejectionReason -> ShowS
[RecipientTargetRejectionReason] -> ShowS
RecipientTargetRejectionReason -> String
(Int -> RecipientTargetRejectionReason -> ShowS)
-> (RecipientTargetRejectionReason -> String)
-> ([RecipientTargetRejectionReason] -> ShowS)
-> Show RecipientTargetRejectionReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientTargetRejectionReason -> ShowS
showsPrec :: Int -> RecipientTargetRejectionReason -> ShowS
$cshow :: RecipientTargetRejectionReason -> String
show :: RecipientTargetRejectionReason -> String
$cshowList :: [RecipientTargetRejectionReason] -> ShowS
showList :: [RecipientTargetRejectionReason] -> ShowS
Show)

data RecipientEncryptionTargetRejected =
  RecipientEncryptionTargetRejected
    { RecipientEncryptionTargetRejected -> SomePKPayload
recipientEncryptionTargetRejectedKey :: SomePKPayload
    , RecipientEncryptionTargetRejected -> Maybe RecipientCapabilities
recipientEncryptionTargetRejectedCapabilities :: Maybe RecipientCapabilities
    , RecipientEncryptionTargetRejected -> RecipientTargetRejectionReason
recipientEncryptionTargetRejectedReason :: RecipientTargetRejectionReason
    }
  deriving (RecipientEncryptionTargetRejected
-> RecipientEncryptionTargetRejected -> Bool
(RecipientEncryptionTargetRejected
 -> RecipientEncryptionTargetRejected -> Bool)
-> (RecipientEncryptionTargetRejected
    -> RecipientEncryptionTargetRejected -> Bool)
-> Eq RecipientEncryptionTargetRejected
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientEncryptionTargetRejected
-> RecipientEncryptionTargetRejected -> Bool
== :: RecipientEncryptionTargetRejected
-> RecipientEncryptionTargetRejected -> Bool
$c/= :: RecipientEncryptionTargetRejected
-> RecipientEncryptionTargetRejected -> Bool
/= :: RecipientEncryptionTargetRejected
-> RecipientEncryptionTargetRejected -> Bool
Eq, Int -> RecipientEncryptionTargetRejected -> ShowS
[RecipientEncryptionTargetRejected] -> ShowS
RecipientEncryptionTargetRejected -> String
(Int -> RecipientEncryptionTargetRejected -> ShowS)
-> (RecipientEncryptionTargetRejected -> String)
-> ([RecipientEncryptionTargetRejected] -> ShowS)
-> Show RecipientEncryptionTargetRejected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientEncryptionTargetRejected -> ShowS
showsPrec :: Int -> RecipientEncryptionTargetRejected -> ShowS
$cshow :: RecipientEncryptionTargetRejected -> String
show :: RecipientEncryptionTargetRejected -> String
$cshowList :: [RecipientEncryptionTargetRejected] -> ShowS
showList :: [RecipientEncryptionTargetRejected] -> ShowS
Show)

data RecipientEncryptionTargetsReport =
  RecipientEncryptionTargetsReport
    { RecipientEncryptionTargetsReport -> [RecipientEncryptionTarget]
recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget]
    , RecipientEncryptionTargetsReport
-> [RecipientEncryptionTargetRejected]
recipientEncryptionTargetsRejected :: [RecipientEncryptionTargetRejected]
    }
  deriving (RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport -> Bool
(RecipientEncryptionTargetsReport
 -> RecipientEncryptionTargetsReport -> Bool)
-> (RecipientEncryptionTargetsReport
    -> RecipientEncryptionTargetsReport -> Bool)
-> Eq RecipientEncryptionTargetsReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport -> Bool
== :: RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport -> Bool
$c/= :: RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport -> Bool
/= :: RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport -> Bool
Eq, Int -> RecipientEncryptionTargetsReport -> ShowS
[RecipientEncryptionTargetsReport] -> ShowS
RecipientEncryptionTargetsReport -> String
(Int -> RecipientEncryptionTargetsReport -> ShowS)
-> (RecipientEncryptionTargetsReport -> String)
-> ([RecipientEncryptionTargetsReport] -> ShowS)
-> Show RecipientEncryptionTargetsReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientEncryptionTargetsReport -> ShowS
showsPrec :: Int -> RecipientEncryptionTargetsReport -> ShowS
$cshow :: RecipientEncryptionTargetsReport -> String
show :: RecipientEncryptionTargetsReport -> String
$cshowList :: [RecipientEncryptionTargetsReport] -> ShowS
showList :: [RecipientEncryptionTargetsReport] -> ShowS
Show)

-- | Extract encrypt-relevant recipient capabilities from effective
-- self-signature subpackets.
--
-- RFC 9580 preferred AEAD ciphersuites are currently carried through
-- 'OtherSigSub' type 39 and decoded into AEAD preferences here.
recipientCapabilitiesFromSubpacketPayloads ::
     SomePKPayload
  -> [SigSubPacketPayload]
  -> RecipientCapabilities
recipientCapabilitiesFromSubpacketPayloads :: SomePKPayload -> [SigSubPacketPayload] -> RecipientCapabilities
recipientCapabilitiesFromSubpacketPayloads SomePKPayload
recipient [SigSubPacketPayload]
payloads =
  (RecipientCapabilities
 -> SigSubPacketPayload -> RecipientCapabilities)
-> RecipientCapabilities
-> [SigSubPacketPayload]
-> RecipientCapabilities
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RecipientCapabilities
-> SigSubPacketPayload -> RecipientCapabilities
step (SomePKPayload -> RecipientCapabilities
emptyRecipientCapabilities SomePKPayload
recipient) [SigSubPacketPayload]
payloads
  where
    preferredAEADCiphersuitesSubpacketType :: Word8
    preferredAEADCiphersuitesSubpacketType :: Word8
preferredAEADCiphersuitesSubpacketType = Word8
39

    step :: RecipientCapabilities
-> SigSubPacketPayload -> RecipientCapabilities
step RecipientCapabilities
caps SigSubPacketPayload
payload =
      case SigSubPacketPayload
payload of
        KeyFlags Set KeyFlag
flags ->
          RecipientCapabilities
caps
            { recipientCapabilityKeyFlags =
                recipientCapabilityKeyFlags caps `Set.union` flags
            }
        Features Set FeatureFlag
features ->
          RecipientCapabilities
caps
            { recipientCapabilityFeatures =
                recipientCapabilityFeatures caps `Set.union` features
            }
        PreferredSymmetricAlgorithms [SymmetricAlgorithm]
syms ->
          RecipientCapabilities
caps
            { recipientCapabilityPreferredSymmetricAlgorithms =
                recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms
            }
        OtherSigSub Word8
subpacketType ByteString
rawPayload
          | Word8
subpacketType Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
preferredAEADCiphersuitesSubpacketType ->
              RecipientCapabilities
caps
                { recipientCapabilityPreferredAEADAlgorithms =
                    recipientCapabilityPreferredAEADAlgorithms caps ++
                    preferredAEADAlgorithmsFromCiphersuites rawPayload
                }
        SigSubPacketPayload
_ -> RecipientCapabilities
caps

    emptyRecipientCapabilities :: SomePKPayload -> RecipientCapabilities
emptyRecipientCapabilities SomePKPayload
key =
      RecipientCapabilities
        { recipientCapabilityKeyVersion :: KeyVersion
recipientCapabilityKeyVersion = SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
key
        , recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm
recipientCapabilityPublicKeyAlgorithm = SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
key
        , recipientCapabilityKeyFlags :: Set KeyFlag
recipientCapabilityKeyFlags = Set KeyFlag
forall a. Set a
Set.empty
        , recipientCapabilityFeatures :: Set FeatureFlag
recipientCapabilityFeatures = Set FeatureFlag
forall a. Set a
Set.empty
        , recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
recipientCapabilityPreferredSymmetricAlgorithms = []
        , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm]
recipientCapabilityPreferredAEADAlgorithms = []
        }

    preferredAEADAlgorithmsFromCiphersuites :: BL.ByteString -> [AEADAlgorithm]
    preferredAEADAlgorithmsFromCiphersuites :: ByteString -> [AEADAlgorithm]
preferredAEADAlgorithmsFromCiphersuites =
      [AEADAlgorithm] -> [AEADAlgorithm]
dedupePreservingOrder ([AEADAlgorithm] -> [AEADAlgorithm])
-> (ByteString -> [AEADAlgorithm]) -> ByteString -> [AEADAlgorithm]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [AEADAlgorithm]
parsePairs ([Word8] -> [AEADAlgorithm])
-> (ByteString -> [Word8]) -> ByteString -> [AEADAlgorithm]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BL.unpack
      where
        parsePairs :: [Word8] -> [AEADAlgorithm]
parsePairs (Word8
_symAlgo:Word8
aeadAlgo:[Word8]
rest) =
          (Word8 -> AEADAlgorithm
forall a. FutureVal a => Word8 -> a
toFVal Word8
aeadAlgo :: AEADAlgorithm) AEADAlgorithm -> [AEADAlgorithm] -> [AEADAlgorithm]
forall a. a -> [a] -> [a]
: [Word8] -> [AEADAlgorithm]
parsePairs [Word8]
rest
        parsePairs [Word8]
_ = []

        dedupePreservingOrder :: [AEADAlgorithm] -> [AEADAlgorithm]
dedupePreservingOrder = ([AEADAlgorithm] -> AEADAlgorithm -> [AEADAlgorithm])
-> [AEADAlgorithm] -> [AEADAlgorithm] -> [AEADAlgorithm]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [AEADAlgorithm] -> AEADAlgorithm -> [AEADAlgorithm]
forall {a}. Eq a => [a] -> a -> [a]
addIfMissing []
        addIfMissing :: [a] -> a -> [a]
addIfMissing [a]
acc a
x
          | a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
acc = [a]
acc
          | Bool
otherwise = [a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]

recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool
recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool
recipientCapabilitySupportsEncryption RecipientCapabilities
caps =
  let flags :: Set KeyFlag
flags = RecipientCapabilities -> Set KeyFlag
recipientCapabilityKeyFlags RecipientCapabilities
caps
   in Set KeyFlag -> Bool
forall a. Set a -> Bool
Set.null Set KeyFlag
flags Bool -> Bool -> Bool
||
      KeyFlag -> Set KeyFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member KeyFlag
EncryptStorageKey Set KeyFlag
flags Bool -> Bool -> Bool
||
      KeyFlag -> Set KeyFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member KeyFlag
EncryptCommunicationsKey Set KeyFlag
flags

recipientCapabilityAdvertisesSEIPDv1Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support RecipientCapabilities
caps =
  let features :: Set FeatureFlag
features = RecipientCapabilities -> Set FeatureFlag
recipientCapabilityFeatures RecipientCapabilities
caps
   in Set FeatureFlag -> Bool
forall a. Set a -> Bool
Set.null Set FeatureFlag
features Bool -> Bool -> Bool
|| FeatureFlag -> Set FeatureFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FeatureFlag
FeatureSEIPDv1 Set FeatureFlag
features

recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv2Support RecipientCapabilities
caps =
  RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support RecipientCapabilities
caps Bool -> Bool -> Bool
&&
  FeatureFlag -> Set FeatureFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FeatureFlag
FeatureSEIPDv2 (RecipientCapabilities -> Set FeatureFlag
recipientCapabilityFeatures RecipientCapabilities
caps)

recipientEncryptionTargetFromTKAtTimestamp ::
     ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestamp :: ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk =
  RecipientTargetSelectionPolicy
-> ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy
    RecipientTargetSelectionPolicy
RecipientTargetSelectionFirstValid
    ThirtyTwoBitTimeStamp
timestamp
    TKUnknown
tk

data RecipientTargetSelectionPolicy
  = RecipientTargetSelectionFirstValid
  | RecipientTargetSelectionPreferPrimary
  | RecipientTargetSelectionPreferSubkey
  | RecipientTargetSelectionPreferNewestCreationTime
  deriving (RecipientTargetSelectionPolicy
-> RecipientTargetSelectionPolicy -> Bool
(RecipientTargetSelectionPolicy
 -> RecipientTargetSelectionPolicy -> Bool)
-> (RecipientTargetSelectionPolicy
    -> RecipientTargetSelectionPolicy -> Bool)
-> Eq RecipientTargetSelectionPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientTargetSelectionPolicy
-> RecipientTargetSelectionPolicy -> Bool
== :: RecipientTargetSelectionPolicy
-> RecipientTargetSelectionPolicy -> Bool
$c/= :: RecipientTargetSelectionPolicy
-> RecipientTargetSelectionPolicy -> Bool
/= :: RecipientTargetSelectionPolicy
-> RecipientTargetSelectionPolicy -> Bool
Eq, Int -> RecipientTargetSelectionPolicy -> ShowS
[RecipientTargetSelectionPolicy] -> ShowS
RecipientTargetSelectionPolicy -> String
(Int -> RecipientTargetSelectionPolicy -> ShowS)
-> (RecipientTargetSelectionPolicy -> String)
-> ([RecipientTargetSelectionPolicy] -> ShowS)
-> Show RecipientTargetSelectionPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientTargetSelectionPolicy -> ShowS
showsPrec :: Int -> RecipientTargetSelectionPolicy -> ShowS
$cshow :: RecipientTargetSelectionPolicy -> String
show :: RecipientTargetSelectionPolicy -> String
$cshowList :: [RecipientTargetSelectionPolicy] -> ShowS
showList :: [RecipientTargetSelectionPolicy] -> ShowS
Show)

recipientEncryptionTargetFromTKAtTimestampWithPolicy ::
     RecipientTargetSelectionPolicy
  -> ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy :: RecipientTargetSelectionPolicy
-> ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy RecipientTargetSelectionPolicy
policy ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk =
  case RecipientTargetSelectionPolicy
-> TKUnknown
-> [RecipientEncryptionTarget]
-> Maybe RecipientEncryptionTarget
chooseRecipientTarget RecipientTargetSelectionPolicy
policy TKUnknown
tk [RecipientEncryptionTarget]
acceptedTargets of
    Just RecipientEncryptionTarget
target -> RecipientEncryptionTarget
-> Either RecipientCapabilityError RecipientEncryptionTarget
forall a b. b -> Either a b
Right RecipientEncryptionTarget
target
    Maybe RecipientEncryptionTarget
Nothing -> RecipientCapabilityError
-> Either RecipientCapabilityError RecipientEncryptionTarget
forall a b. a -> Either a b
Left RecipientCapabilityError
RecipientCapabilityNoEncryptableKeyMaterialInTK
  where
    acceptedTargets :: [RecipientEncryptionTarget]
acceptedTargets =
      RecipientEncryptionTargetsReport -> [RecipientEncryptionTarget]
recipientEncryptionTargetsAccepted
        (ThirtyTwoBitTimeStamp
-> TKUnknown -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk)

recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTK :: TK 'PublicTK
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTK TK 'PublicTK
tk =
  RecipientTargetSelectionPolicy
-> ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy
    RecipientTargetSelectionPolicy
RecipientTargetSelectionFirstValid
    (SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (KeyPkt 'PublicPkt -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (TK 'PublicTK -> KeyPkt (TKKindToKeyPktKind 'PublicTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'PublicTK
tk)))
    (TK 'PublicTK -> TKUnknown
forall (k :: TKKind). TK k -> TKUnknown
tkToUnknown TK 'PublicTK
tk)

recipientEncryptionTargetFromTKWithPolicy ::
     RecipientTargetSelectionPolicy
  -> TK 'PublicTK
  -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKWithPolicy :: RecipientTargetSelectionPolicy
-> TK 'PublicTK
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKWithPolicy RecipientTargetSelectionPolicy
policy TK 'PublicTK
tk =
  RecipientTargetSelectionPolicy
-> ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy
    RecipientTargetSelectionPolicy
policy
    (SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (KeyPkt 'PublicPkt -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (TK 'PublicTK -> KeyPkt (TKKindToKeyPktKind 'PublicTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'PublicTK
tk)))
    (TK 'PublicTK -> TKUnknown
forall (k :: TKKind). TK k -> TKUnknown
tkToUnknown TK 'PublicTK
tk)

recipientEncryptionTargetsFromTKAtTimestamp ::
     ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTKAtTimestamp :: ThirtyTwoBitTimeStamp -> TKUnknown -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTKAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk =
  RecipientEncryptionTargetsReport -> [RecipientEncryptionTarget]
recipientEncryptionTargetsAccepted (ThirtyTwoBitTimeStamp
-> TKUnknown -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk)

recipientEncryptionTargetsReportFromTKAtTimestamp ::
     ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp :: ThirtyTwoBitTimeStamp
-> TKUnknown -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk =
  (SomePKPayload
 -> RecipientEncryptionTargetsReport
 -> RecipientEncryptionTargetsReport)
-> RecipientEncryptionTargetsReport
-> [SomePKPayload]
-> RecipientEncryptionTargetsReport
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SomePKPayload
-> RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport
classifyCandidate RecipientEncryptionTargetsReport
emptyReport ([SomePKPayload]
subkeyCandidates [SomePKPayload] -> [SomePKPayload] -> [SomePKPayload]
forall a. [a] -> [a] -> [a]
++ [SomePKPayload
primaryCandidate])
  where
    emptyReport :: RecipientEncryptionTargetsReport
emptyReport = [RecipientEncryptionTarget]
-> [RecipientEncryptionTargetRejected]
-> RecipientEncryptionTargetsReport
RecipientEncryptionTargetsReport [] []
    primaryCandidate :: SomePKPayload
primaryCandidate = (SomePKPayload, Maybe SKAddendum) -> SomePKPayload
forall a b. (a, b) -> a
fst (TKUnknown -> (SomePKPayload, Maybe SKAddendum)
_tkuKey TKUnknown
tk)
    primaryPreferencePayloads :: [SigSubPacketPayload]
primaryPreferencePayloads =
      [SigSubPacketPayload]
-> Maybe [SigSubPacketPayload] -> [SigSubPacketPayload]
forall a. a -> Maybe a -> a
fromMaybe [] (ThirtyTwoBitTimeStamp -> TKUnknown -> Maybe [SigSubPacketPayload]
effectiveKeyPreferencesAtTimestamp ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk)
    subkeyCandidates :: [SomePKPayload]
subkeyCandidates =
      ((Pkt, [SignaturePayload]) -> Maybe SomePKPayload)
-> [(Pkt, [SignaturePayload])] -> [SomePKPayload]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\(Pkt
pkt, [SignaturePayload]
_) ->
           case Pkt
pkt of
             PublicSubkeyPkt SomePKPayload
pkp -> SomePKPayload -> Maybe SomePKPayload
forall a. a -> Maybe a
Just SomePKPayload
pkp
             SecretSubkeyPkt SomePKPayload
pkp SKAddendum
_ -> SomePKPayload -> Maybe SomePKPayload
forall a. a -> Maybe a
Just SomePKPayload
pkp
             Pkt
_ -> Maybe SomePKPayload
forall a. Maybe a
Nothing)
        (TKUnknown -> [(Pkt, [SignaturePayload])]
_tkuSubs TKUnknown
tk)
    classifyCandidate :: SomePKPayload
-> RecipientEncryptionTargetsReport
-> RecipientEncryptionTargetsReport
classifyCandidate SomePKPayload
key RecipientEncryptionTargetsReport
report =
      let caps :: RecipientCapabilities
caps =
            SomePKPayload -> [SigSubPacketPayload] -> RecipientCapabilities
recipientCapabilitiesFromSubpacketPayloads
              SomePKPayload
key
              ([SigSubPacketPayload]
primaryPreferencePayloads [SigSubPacketPayload]
-> [SigSubPacketPayload] -> [SigSubPacketPayload]
forall a. [a] -> [a] -> [a]
++ ThirtyTwoBitTimeStamp
-> TKUnknown -> SomePKPayload -> [SigSubPacketPayload]
subkeyBindingCapabilityPayloads ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk SomePKPayload
key)
          keyStateRejection :: Maybe RecipientTargetRejectionReason
keyStateRejection = ThirtyTwoBitTimeStamp
-> TKUnknown
-> SomePKPayload
-> Maybe RecipientTargetRejectionReason
recipientValidityRejectionReason ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk SomePKPayload
key
       in case Maybe RecipientTargetRejectionReason
keyStateRejection of
            Just RecipientTargetRejectionReason
rejectionReason ->
             RecipientEncryptionTargetsReport
report
               { recipientEncryptionTargetsRejected =
                   RecipientEncryptionTargetRejected
                     { recipientEncryptionTargetRejectedKey = key
                     , recipientEncryptionTargetRejectedCapabilities = Just caps
                     , recipientEncryptionTargetRejectedReason = rejectionReason
                     } :
                   recipientEncryptionTargetsRejected report
               }
            Maybe RecipientTargetRejectionReason
Nothing ->
             if Bool -> Bool
not (SomePKPayload -> Bool
supportsPKESKRecipientAlgorithm SomePKPayload
key)
               then
                 RecipientEncryptionTargetsReport
report
                   { recipientEncryptionTargetsRejected =
                       RecipientEncryptionTargetRejected
                         { recipientEncryptionTargetRejectedKey = key
                         , recipientEncryptionTargetRejectedCapabilities = Just caps
                         , recipientEncryptionTargetRejectedReason =
                             RecipientTargetUnsupportedAlgorithm (_pkalgo key)
                         } :
                       recipientEncryptionTargetsRejected report
                   }
               else
                 if RecipientCapabilities -> Bool
recipientCapabilitySupportsEncryption RecipientCapabilities
caps
                   then
                     RecipientEncryptionTargetsReport
report
                       { recipientEncryptionTargetsAccepted =
                           recipientEncryptionTargetWithCapabilities key caps :
                           recipientEncryptionTargetsAccepted report
                       }
                   else
                     RecipientEncryptionTargetsReport
report
                       { recipientEncryptionTargetsRejected =
                           RecipientEncryptionTargetRejected
                             { recipientEncryptionTargetRejectedKey = key
                             , recipientEncryptionTargetRejectedCapabilities = Just caps
                             , recipientEncryptionTargetRejectedReason =
                                 RecipientTargetMissingEncryptionFlags key (recipientCapabilityKeyFlags caps)
                             } :
                           recipientEncryptionTargetsRejected report
                       }

recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTK TK 'PublicTK
tk =
  ThirtyTwoBitTimeStamp -> TKUnknown -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTKAtTimestamp
    (SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (KeyPkt 'PublicPkt -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (TK 'PublicTK -> KeyPkt (TKKindToKeyPktKind 'PublicTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'PublicTK
tk)))
    (TK 'PublicTK -> TKUnknown
forall (k :: TKKind). TK k -> TKUnknown
tkToUnknown TK 'PublicTK
tk)

recipientEncryptionTargetsReportFromTK :: TK 'PublicTK -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTK :: TK 'PublicTK -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTK TK 'PublicTK
tk =
  ThirtyTwoBitTimeStamp
-> TKUnknown -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp
    (SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (KeyPkt 'PublicPkt -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (TK 'PublicTK -> KeyPkt (TKKindToKeyPktKind 'PublicTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'PublicTK
tk)))
    (TK 'PublicTK -> TKUnknown
forall (k :: TKKind). TK k -> TKUnknown
tkToUnknown TK 'PublicTK
tk)

subkeyBindingCapabilityPayloads ::
     ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> SomePKPayload
  -> [SigSubPacketPayload]
subkeyBindingCapabilityPayloads :: ThirtyTwoBitTimeStamp
-> TKUnknown -> SomePKPayload -> [SigSubPacketPayload]
subkeyBindingCapabilityPayloads ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk SomePKPayload
recipient =
  [SigSubPacketPayload]
-> ((Pkt, [SignaturePayload]) -> [SigSubPacketPayload])
-> Maybe (Pkt, [SignaturePayload])
-> [SigSubPacketPayload]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Pkt, [SignaturePayload]) -> [SigSubPacketPayload]
latestEffectiveBindingPayloads Maybe (Pkt, [SignaturePayload])
matchingSubkey
  where
    matchingSubkey :: Maybe (Pkt, [SignaturePayload])
matchingSubkey =
      ((Pkt, [SignaturePayload]) -> Bool)
-> [(Pkt, [SignaturePayload])] -> Maybe (Pkt, [SignaturePayload])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
        (\(Pkt
pkt, [SignaturePayload]
_) ->
           case Pkt
pkt of
             PublicSubkeyPkt SomePKPayload
pkp -> SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint SomePKPayload
recipient
             SecretSubkeyPkt SomePKPayload
pkp SKAddendum
_ -> SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint SomePKPayload
recipient
             Pkt
_ -> Bool
False)
        (TKUnknown -> [(Pkt, [SignaturePayload])]
_tkuSubs TKUnknown
tk)
    latestEffectiveBindingPayloads :: (Pkt, [SignaturePayload]) -> [SigSubPacketPayload]
latestEffectiveBindingPayloads (Pkt
_, [SignaturePayload]
sigs) =
      [SigSubPacketPayload]
-> (SignaturePayload -> [SigSubPacketPayload])
-> Maybe SignaturePayload
-> [SigSubPacketPayload]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] SignaturePayload -> [SigSubPacketPayload]
signaturePayloadsFromSignature (ThirtyTwoBitTimeStamp
-> [SignaturePayload] -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignature ThirtyTwoBitTimeStamp
timestamp [SignaturePayload]
sigs)

latestEffectiveSubkeyBindingSignature ::
     ThirtyTwoBitTimeStamp
  -> [SignaturePayload]
  -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignature :: ThirtyTwoBitTimeStamp
-> [SignaturePayload] -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignature ThirtyTwoBitTimeStamp
timestamp [SignaturePayload]
sigs =
  case (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter (ThirtyTwoBitTimeStamp -> SignaturePayload -> Bool
isEffectiveSubkeyBindingSignature ThirtyTwoBitTimeStamp
timestamp) [SignaturePayload]
sigs of
    [] -> Maybe SignaturePayload
forall a. Maybe a
Nothing
    [SignaturePayload]
candidates -> SignaturePayload -> Maybe SignaturePayload
forall a. a -> Maybe a
Just ((SignaturePayload -> SignaturePayload -> Ordering)
-> [SignaturePayload] -> SignaturePayload
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((SignaturePayload -> ThirtyTwoBitTimeStamp)
-> SignaturePayload -> SignaturePayload -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SignaturePayload -> ThirtyTwoBitTimeStamp
signatureCreationTimestamp) [SignaturePayload]
candidates)

isEffectiveSubkeyBindingSignature ::
     ThirtyTwoBitTimeStamp
  -> SignaturePayload
  -> Bool
isEffectiveSubkeyBindingSignature :: ThirtyTwoBitTimeStamp -> SignaturePayload -> Bool
isEffectiveSubkeyBindingSignature ThirtyTwoBitTimeStamp
timestamp SignaturePayload
sig =
  SignaturePayload -> Bool
isSubkeyBindingSig SignaturePayload
sig Bool -> Bool -> Bool
&&
  Bool
-> (ThirtyTwoBitTimeStamp -> Bool)
-> Maybe ThirtyTwoBitTimeStamp
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
    (\ThirtyTwoBitTimeStamp
created ->
       let tsValue :: Integer
tsValue = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp
timestamp)
           createdValue :: Integer
createdValue = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp
created)
        in Integer
createdValue Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
tsValue Bool -> Bool -> Bool
&&
           Bool
-> (ThirtyTwoBitDuration -> Bool)
-> Maybe ThirtyTwoBitDuration
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True
             (\ThirtyTwoBitDuration
duration ->
                if ThirtyTwoBitDuration -> Word32
unThirtyTwoBitDuration ThirtyTwoBitDuration
duration Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
                  then Bool
True
                  else Integer
tsValue Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
createdValue Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (ThirtyTwoBitDuration -> Word32
unThirtyTwoBitDuration ThirtyTwoBitDuration
duration))
             (SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration SignaturePayload
sig))
    (SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
sigCT SignaturePayload
sig)

signatureCreationTimestamp :: SignaturePayload -> ThirtyTwoBitTimeStamp
signatureCreationTimestamp :: SignaturePayload -> ThirtyTwoBitTimeStamp
signatureCreationTimestamp SignaturePayload
sig =
  ThirtyTwoBitTimeStamp
-> Maybe ThirtyTwoBitTimeStamp -> ThirtyTwoBitTimeStamp
forall a. a -> Maybe a -> a
fromMaybe (Word32 -> ThirtyTwoBitTimeStamp
ThirtyTwoBitTimeStamp Word32
0) (SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
sigCT SignaturePayload
sig)

signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration SignaturePayload
sig =
  case SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig of
    Just [SigSubPacket]
hashed ->
      (SigSubPacket
 -> Maybe ThirtyTwoBitDuration -> Maybe ThirtyTwoBitDuration)
-> Maybe ThirtyTwoBitDuration
-> [SigSubPacket]
-> Maybe ThirtyTwoBitDuration
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\SigSubPacket
subpacket Maybe ThirtyTwoBitDuration
acc ->
           case SigSubPacket
subpacket of
             SigSubPacket Bool
_ (SigExpirationTime ThirtyTwoBitDuration
duration) -> ThirtyTwoBitDuration -> Maybe ThirtyTwoBitDuration
forall a. a -> Maybe a
Just ThirtyTwoBitDuration
duration
             SigSubPacket
_ -> Maybe ThirtyTwoBitDuration
acc)
        Maybe ThirtyTwoBitDuration
forall a. Maybe a
Nothing
        [SigSubPacket]
hashed
    Maybe [SigSubPacket]
Nothing -> Maybe ThirtyTwoBitDuration
forall a. Maybe a
Nothing

signaturePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload]
signaturePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload]
signaturePayloadsFromSignature SignaturePayload
sig =
  case SignaturePayload -> Maybe [SigSubPacket]
signatureHashedSubpacketsKnown SignaturePayload
sig of
    Just [SigSubPacket]
hashed -> (SigSubPacket -> SigSubPacketPayload)
-> [SigSubPacket] -> [SigSubPacketPayload]
forall a b. (a -> b) -> [a] -> [b]
map (\(SigSubPacket Bool
_ SigSubPacketPayload
payload) -> SigSubPacketPayload
payload) [SigSubPacket]
hashed
    Maybe [SigSubPacket]
Nothing -> []

recipientValidityRejectionReason ::
     ThirtyTwoBitTimeStamp
  -> TKUnknown
  -> SomePKPayload
  -> Maybe RecipientTargetRejectionReason
recipientValidityRejectionReason :: ThirtyTwoBitTimeStamp
-> TKUnknown
-> SomePKPayload
-> Maybe RecipientTargetRejectionReason
recipientValidityRejectionReason ThirtyTwoBitTimeStamp
timestamp TKUnknown
tk SomePKPayload
key
  | SomePKPayload -> Fingerprint
fingerprint SomePKPayload
key Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint ((SomePKPayload, Maybe SKAddendum) -> SomePKPayload
forall a b. (a, b) -> a
fst (TKUnknown -> (SomePKPayload, Maybe SKAddendum)
_tkuKey TKUnknown
tk)) =
      if KeyState -> Bool
keyStateValid (UTCTime -> TKUnknown -> KeyState
keyStateAt (ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC ThirtyTwoBitTimeStamp
timestamp) TKUnknown
tk)
        then Maybe RecipientTargetRejectionReason
forall a. Maybe a
Nothing
        else RecipientTargetRejectionReason
-> Maybe RecipientTargetRejectionReason
forall a. a -> Maybe a
Just (SomePKPayload
-> ThirtyTwoBitTimeStamp -> RecipientTargetRejectionReason
RecipientTargetNotValidAtTimestamp SomePKPayload
key ThirtyTwoBitTimeStamp
timestamp)
  | Bool
otherwise =
      case TKUnknown -> SomePKPayload -> Maybe [SignaturePayload]
findMatchingSubkeySignatures TKUnknown
tk SomePKPayload
key of
        Maybe [SignaturePayload]
Nothing -> Maybe RecipientTargetRejectionReason
forall a. Maybe a
Nothing
        Just [SignaturePayload]
sigs
          | ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool
subkeyRevokedAtTimestamp ThirtyTwoBitTimeStamp
timestamp [SignaturePayload]
sigs ->
              RecipientTargetRejectionReason
-> Maybe RecipientTargetRejectionReason
forall a. a -> Maybe a
Just (SomePKPayload -> RecipientTargetRejectionReason
RecipientTargetRevoked SomePKPayload
key)
          | UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool
isPKTimeValidWithSelfSignatures (ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC ThirtyTwoBitTimeStamp
timestamp) SomePKPayload
key [SignaturePayload]
sigs ->
              Maybe RecipientTargetRejectionReason
forall a. Maybe a
Nothing
          | Bool
otherwise ->
              RecipientTargetRejectionReason
-> Maybe RecipientTargetRejectionReason
forall a. a -> Maybe a
Just (SomePKPayload
-> ThirtyTwoBitTimeStamp -> RecipientTargetRejectionReason
RecipientTargetNotValidAtTimestamp SomePKPayload
key ThirtyTwoBitTimeStamp
timestamp)

findMatchingSubkeySignatures :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload]
findMatchingSubkeySignatures :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload]
findMatchingSubkeySignatures TKUnknown
tk SomePKPayload
recipient =
  (Pkt, [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd ((Pkt, [SignaturePayload]) -> [SignaturePayload])
-> Maybe (Pkt, [SignaturePayload]) -> Maybe [SignaturePayload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  ((Pkt, [SignaturePayload]) -> Bool)
-> [(Pkt, [SignaturePayload])] -> Maybe (Pkt, [SignaturePayload])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
    (\(Pkt
pkt, [SignaturePayload]
_) ->
       case Pkt
pkt of
         PublicSubkeyPkt SomePKPayload
pkp -> SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint SomePKPayload
recipient
         SecretSubkeyPkt SomePKPayload
pkp SKAddendum
_ -> SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SomePKPayload -> Fingerprint
fingerprint SomePKPayload
recipient
         Pkt
_ -> Bool
False)
    (TKUnknown -> [(Pkt, [SignaturePayload])]
_tkuSubs TKUnknown
tk)

subkeyRevokedAtTimestamp :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool
subkeyRevokedAtTimestamp :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool
subkeyRevokedAtTimestamp ThirtyTwoBitTimeStamp
timestamp =
  (SignaturePayload -> Bool) -> [SignaturePayload] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\SignaturePayload
sig -> SignaturePayload -> Bool
isSubkeyRevocation SignaturePayload
sig Bool -> Bool -> Bool
&& UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt (ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC ThirtyTwoBitTimeStamp
timestamp) SignaturePayload
sig)

timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC =
  POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (ThirtyTwoBitTimeStamp -> POSIXTime)
-> ThirtyTwoBitTimeStamp
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Word32 -> POSIXTime)
-> (ThirtyTwoBitTimeStamp -> Word32)
-> ThirtyTwoBitTimeStamp
-> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp

supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool
supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool
supportsPKESKRecipientAlgorithm SomePKPayload
recipient =
  case SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient of
    PubKeyAlgorithm
RSA -> Bool
True
    PubKeyAlgorithm
DeprecatedRSAEncryptOnly -> Bool
True
    PubKeyAlgorithm
ECDH -> Bool
True
    PubKeyAlgorithm
X25519 -> Bool
True
    PubKeyAlgorithm
X448 -> Bool
True
    PubKeyAlgorithm
_ -> Bool
False

chooseRecipientTarget ::
     RecipientTargetSelectionPolicy
  -> TKUnknown
  -> [RecipientEncryptionTarget]
  -> Maybe RecipientEncryptionTarget
chooseRecipientTarget :: RecipientTargetSelectionPolicy
-> TKUnknown
-> [RecipientEncryptionTarget]
-> Maybe RecipientEncryptionTarget
chooseRecipientTarget RecipientTargetSelectionPolicy
policy TKUnknown
tk [RecipientEncryptionTarget]
targets =
  case RecipientTargetSelectionPolicy
policy of
    RecipientTargetSelectionPolicy
RecipientTargetSelectionFirstValid -> [RecipientEncryptionTarget] -> Maybe RecipientEncryptionTarget
forall a. [a] -> Maybe a
listToMaybe [RecipientEncryptionTarget]
targets
    RecipientTargetSelectionPolicy
RecipientTargetSelectionPreferPrimary ->
      [RecipientEncryptionTarget] -> Maybe RecipientEncryptionTarget
forall a. [a] -> Maybe a
listToMaybe ((RecipientEncryptionTarget -> Bool)
-> [RecipientEncryptionTarget] -> [RecipientEncryptionTarget]
forall a. (a -> Bool) -> [a] -> [a]
filter (TKUnknown -> RecipientEncryptionTarget -> Bool
isPrimaryTarget TKUnknown
tk) [RecipientEncryptionTarget]
targets) Maybe RecipientEncryptionTarget
-> Maybe RecipientEncryptionTarget
-> Maybe RecipientEncryptionTarget
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [RecipientEncryptionTarget] -> Maybe RecipientEncryptionTarget
forall a. [a] -> Maybe a
listToMaybe [RecipientEncryptionTarget]
targets
    RecipientTargetSelectionPolicy
RecipientTargetSelectionPreferSubkey ->
      [RecipientEncryptionTarget] -> Maybe RecipientEncryptionTarget
forall a. [a] -> Maybe a
listToMaybe ((RecipientEncryptionTarget -> Bool)
-> [RecipientEncryptionTarget] -> [RecipientEncryptionTarget]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (RecipientEncryptionTarget -> Bool)
-> RecipientEncryptionTarget
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TKUnknown -> RecipientEncryptionTarget -> Bool
isPrimaryTarget TKUnknown
tk) [RecipientEncryptionTarget]
targets) Maybe RecipientEncryptionTarget
-> Maybe RecipientEncryptionTarget
-> Maybe RecipientEncryptionTarget
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [RecipientEncryptionTarget] -> Maybe RecipientEncryptionTarget
forall a. [a] -> Maybe a
listToMaybe [RecipientEncryptionTarget]
targets
    RecipientTargetSelectionPolicy
RecipientTargetSelectionPreferNewestCreationTime ->
      case [RecipientEncryptionTarget]
targets of
        [] -> Maybe RecipientEncryptionTarget
forall a. Maybe a
Nothing
        (RecipientEncryptionTarget
target:[RecipientEncryptionTarget]
rest) ->
          RecipientEncryptionTarget -> Maybe RecipientEncryptionTarget
forall a. a -> Maybe a
Just
            ((RecipientEncryptionTarget
 -> RecipientEncryptionTarget -> RecipientEncryptionTarget)
-> RecipientEncryptionTarget
-> [RecipientEncryptionTarget]
-> RecipientEncryptionTarget
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
               (\RecipientEncryptionTarget
best RecipientEncryptionTarget
candidate ->
                  if SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
candidate) ThirtyTwoBitTimeStamp -> ThirtyTwoBitTimeStamp -> Bool
forall a. Ord a => a -> a -> Bool
>
                     SomePKPayload -> ThirtyTwoBitTimeStamp
_timestamp (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
best)
                    then RecipientEncryptionTarget
candidate
                    else RecipientEncryptionTarget
best)
               RecipientEncryptionTarget
target
               [RecipientEncryptionTarget]
rest)
  where
    isPrimaryTarget :: TKUnknown -> RecipientEncryptionTarget -> Bool
isPrimaryTarget TKUnknown
currentTK RecipientEncryptionTarget
target =
      SomePKPayload -> Fingerprint
fingerprint (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
target) Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
==
      SomePKPayload -> Fingerprint
fingerprint ((SomePKPayload, Maybe SKAddendum) -> SomePKPayload
forall a b. (a, b) -> a
fst (TKUnknown -> (SomePKPayload, Maybe SKAddendum)
_tkuKey TKUnknown
currentTK))

-- | Session-key bundle for PKESK/SKESK packet construction.
newtype PKESKV3SessionMaterial =
  PKESKV3SessionMaterial
    { PKESKV3SessionMaterial -> ByteString
unPKESKV3SessionMaterial :: B.ByteString
    }
  deriving (PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool
(PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool)
-> (PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool)
-> Eq PKESKV3SessionMaterial
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool
== :: PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool
$c/= :: PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool
/= :: PKESKV3SessionMaterial -> PKESKV3SessionMaterial -> Bool
Eq, Int -> PKESKV3SessionMaterial -> ShowS
[PKESKV3SessionMaterial] -> ShowS
PKESKV3SessionMaterial -> String
(Int -> PKESKV3SessionMaterial -> ShowS)
-> (PKESKV3SessionMaterial -> String)
-> ([PKESKV3SessionMaterial] -> ShowS)
-> Show PKESKV3SessionMaterial
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKV3SessionMaterial -> ShowS
showsPrec :: Int -> PKESKV3SessionMaterial -> ShowS
$cshow :: PKESKV3SessionMaterial -> String
show :: PKESKV3SessionMaterial -> String
$cshowList :: [PKESKV3SessionMaterial] -> ShowS
showList :: [PKESKV3SessionMaterial] -> ShowS
Show)

newtype PKESKV6RawSessionMaterial =
  PKESKV6RawSessionMaterial
    { PKESKV6RawSessionMaterial -> ByteString
unPKESKV6RawSessionMaterial :: B.ByteString
    }
  deriving (PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool
(PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool)
-> (PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool)
-> Eq PKESKV6RawSessionMaterial
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool
== :: PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool
$c/= :: PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool
/= :: PKESKV6RawSessionMaterial -> PKESKV6RawSessionMaterial -> Bool
Eq, Int -> PKESKV6RawSessionMaterial -> ShowS
[PKESKV6RawSessionMaterial] -> ShowS
PKESKV6RawSessionMaterial -> String
(Int -> PKESKV6RawSessionMaterial -> ShowS)
-> (PKESKV6RawSessionMaterial -> String)
-> ([PKESKV6RawSessionMaterial] -> ShowS)
-> Show PKESKV6RawSessionMaterial
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKV6RawSessionMaterial -> ShowS
showsPrec :: Int -> PKESKV6RawSessionMaterial -> ShowS
$cshow :: PKESKV6RawSessionMaterial -> String
show :: PKESKV6RawSessionMaterial -> String
$cshowList :: [PKESKV6RawSessionMaterial] -> ShowS
showList :: [PKESKV6RawSessionMaterial] -> ShowS
Show)

data PKESKSessionMaterial =
  PKESKSessionMaterial
    { PKESKSessionMaterial -> SymmetricAlgorithm
pkeskSessionAlgorithm :: SymmetricAlgorithm
    , PKESKSessionMaterial -> SessionKey
pkeskSessionKey :: SessionKey
    , PKESKSessionMaterial -> ByteString
pkeskEncodedSessionMaterial :: B.ByteString
    }
  deriving (PKESKSessionMaterial -> PKESKSessionMaterial -> Bool
(PKESKSessionMaterial -> PKESKSessionMaterial -> Bool)
-> (PKESKSessionMaterial -> PKESKSessionMaterial -> Bool)
-> Eq PKESKSessionMaterial
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKSessionMaterial -> PKESKSessionMaterial -> Bool
== :: PKESKSessionMaterial -> PKESKSessionMaterial -> Bool
$c/= :: PKESKSessionMaterial -> PKESKSessionMaterial -> Bool
/= :: PKESKSessionMaterial -> PKESKSessionMaterial -> Bool
Eq, Int -> PKESKSessionMaterial -> ShowS
[PKESKSessionMaterial] -> ShowS
PKESKSessionMaterial -> String
(Int -> PKESKSessionMaterial -> ShowS)
-> (PKESKSessionMaterial -> String)
-> ([PKESKSessionMaterial] -> ShowS)
-> Show PKESKSessionMaterial
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKSessionMaterial -> ShowS
showsPrec :: Int -> PKESKSessionMaterial -> ShowS
$cshow :: PKESKSessionMaterial -> String
show :: PKESKSessionMaterial -> String
$cshowList :: [PKESKSessionMaterial] -> ShowS
showList :: [PKESKSessionMaterial] -> ShowS
Show)

mkPKESKSessionMaterial ::
     SymmetricAlgorithm
  -> SessionKey
  -> Either PKESKEncryptError PKESKSessionMaterial
mkPKESKSessionMaterial :: SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKSessionMaterial
mkPKESKSessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey = do
  v3Material <- SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey
  _v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey
  pure
    PKESKSessionMaterial
      { pkeskSessionAlgorithm = symalgo
      , pkeskSessionKey = sessionKey
      , pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material
      }

mkPKESKV3SessionMaterial ::
     SymmetricAlgorithm
  -> SessionKey
  -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial :: SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey = do
  keyBytes <- SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError ByteString
validatedSessionKeyBytes SymmetricAlgorithm
symalgo SessionKey
sessionKey
  pure $
    PKESKV3SessionMaterial
      (B.singleton (fromFVal symalgo) <> keyBytes <> checksum16Bytes keyBytes)

mkPKESKV6RawSessionMaterial ::
     SymmetricAlgorithm
  -> SessionKey
  -> Either PKESKEncryptError PKESKV6RawSessionMaterial
mkPKESKV6RawSessionMaterial :: SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKV6RawSessionMaterial
mkPKESKV6RawSessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey =
  ByteString -> PKESKV6RawSessionMaterial
PKESKV6RawSessionMaterial (ByteString -> PKESKV6RawSessionMaterial)
-> Either PKESKEncryptError ByteString
-> Either PKESKEncryptError PKESKV6RawSessionMaterial
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError ByteString
validatedSessionKeyBytes SymmetricAlgorithm
symalgo SessionKey
sessionKey

pkeskV3SessionMaterial :: PKESKSessionMaterial -> PKESKV3SessionMaterial
pkeskV3SessionMaterial :: PKESKSessionMaterial -> PKESKV3SessionMaterial
pkeskV3SessionMaterial =
  ByteString -> PKESKV3SessionMaterial
PKESKV3SessionMaterial (ByteString -> PKESKV3SessionMaterial)
-> (PKESKSessionMaterial -> ByteString)
-> PKESKSessionMaterial
-> PKESKV3SessionMaterial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PKESKSessionMaterial -> ByteString
pkeskEncodedSessionMaterial

pkeskV6RawSessionMaterial :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial =
  ByteString -> PKESKV6RawSessionMaterial
PKESKV6RawSessionMaterial (ByteString -> PKESKV6RawSessionMaterial)
-> (PKESKSessionMaterial -> ByteString)
-> PKESKSessionMaterial
-> PKESKV6RawSessionMaterial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionKey -> ByteString
unSessionKey (SessionKey -> ByteString)
-> (PKESKSessionMaterial -> SessionKey)
-> PKESKSessionMaterial
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PKESKSessionMaterial -> SessionKey
pkeskSessionKey

validatedSessionKeyBytes ::
     SymmetricAlgorithm
  -> SessionKey
  -> Either PKESKEncryptError B.ByteString
validatedSessionKeyBytes :: SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError ByteString
validatedSessionKeyBytes SymmetricAlgorithm
symalgo (SessionKey ByteString
sessionKey) = do
  keyLen <-
    (CipherError -> PKESKEncryptError)
-> Either CipherError Int -> Either PKESKEncryptError Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
      (SymmetricAlgorithm -> String -> PKESKEncryptError
UnsupportedSessionKeyAlgorithm SymmetricAlgorithm
symalgo (String -> PKESKEncryptError)
-> (CipherError -> String) -> CipherError -> PKESKEncryptError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CipherError -> String
renderCipherError)
      (SymmetricAlgorithm -> Either CipherError Int
keySize SymmetricAlgorithm
symalgo)
  let actualLen = ByteString -> Int
B.length ByteString
sessionKey
  if actualLen /= keyLen
    then Left (InvalidSessionKeyLength symalgo keyLen actualLen)
    else Right sessionKey

data RecipientPKESKVersionStrategy
  = RecipientPreferV6
  | RecipientForceV3Interop
  deriving (RecipientPKESKVersionStrategy
-> RecipientPKESKVersionStrategy -> Bool
(RecipientPKESKVersionStrategy
 -> RecipientPKESKVersionStrategy -> Bool)
-> (RecipientPKESKVersionStrategy
    -> RecipientPKESKVersionStrategy -> Bool)
-> Eq RecipientPKESKVersionStrategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientPKESKVersionStrategy
-> RecipientPKESKVersionStrategy -> Bool
== :: RecipientPKESKVersionStrategy
-> RecipientPKESKVersionStrategy -> Bool
$c/= :: RecipientPKESKVersionStrategy
-> RecipientPKESKVersionStrategy -> Bool
/= :: RecipientPKESKVersionStrategy
-> RecipientPKESKVersionStrategy -> Bool
Eq, Int -> RecipientPKESKVersionStrategy -> ShowS
[RecipientPKESKVersionStrategy] -> ShowS
RecipientPKESKVersionStrategy -> String
(Int -> RecipientPKESKVersionStrategy -> ShowS)
-> (RecipientPKESKVersionStrategy -> String)
-> ([RecipientPKESKVersionStrategy] -> ShowS)
-> Show RecipientPKESKVersionStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientPKESKVersionStrategy -> ShowS
showsPrec :: Int -> RecipientPKESKVersionStrategy -> ShowS
$cshow :: RecipientPKESKVersionStrategy -> String
show :: RecipientPKESKVersionStrategy -> String
$cshowList :: [RecipientPKESKVersionStrategy] -> ShowS
showList :: [RecipientPKESKVersionStrategy] -> ShowS
Show)

data RecipientPKESKVersionStrategyW (strategy :: RecipientPKESKVersionStrategy) where
  RecipientPreferV6W :: RecipientPKESKVersionStrategyW 'RecipientPreferV6
  RecipientForceV3InteropW :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop

data SomeRecipientPKESKVersionStrategyW where
  SomeRecipientPKESKVersionStrategyW ::
       RecipientPKESKVersionStrategyW strategy
    -> SomeRecipientPKESKVersionStrategyW

type RecipientPKESKVersionSelector =
  SomePKPayload -> Either PKESKEncryptError RecipientPKESKVersionStrategy

type RecipientPKESKVersionSelectorTyped =
  SomePKPayload -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW

data EncryptCompatibilityProfile
  = EncryptStrictDefault
  | EncryptInteropLegacy
  deriving (EncryptCompatibilityProfile -> EncryptCompatibilityProfile -> Bool
(EncryptCompatibilityProfile
 -> EncryptCompatibilityProfile -> Bool)
-> (EncryptCompatibilityProfile
    -> EncryptCompatibilityProfile -> Bool)
-> Eq EncryptCompatibilityProfile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncryptCompatibilityProfile -> EncryptCompatibilityProfile -> Bool
== :: EncryptCompatibilityProfile -> EncryptCompatibilityProfile -> Bool
$c/= :: EncryptCompatibilityProfile -> EncryptCompatibilityProfile -> Bool
/= :: EncryptCompatibilityProfile -> EncryptCompatibilityProfile -> Bool
Eq, Int -> EncryptCompatibilityProfile -> ShowS
[EncryptCompatibilityProfile] -> ShowS
EncryptCompatibilityProfile -> String
(Int -> EncryptCompatibilityProfile -> ShowS)
-> (EncryptCompatibilityProfile -> String)
-> ([EncryptCompatibilityProfile] -> ShowS)
-> Show EncryptCompatibilityProfile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncryptCompatibilityProfile -> ShowS
showsPrec :: Int -> EncryptCompatibilityProfile -> ShowS
$cshow :: EncryptCompatibilityProfile -> String
show :: EncryptCompatibilityProfile -> String
$cshowList :: [EncryptCompatibilityProfile] -> ShowS
showList :: [EncryptCompatibilityProfile] -> ShowS
Show)

data EncryptCompatibilityProfileW (profile :: EncryptCompatibilityProfile) where
  EncryptStrictDefaultW :: EncryptCompatibilityProfileW 'EncryptStrictDefault
  EncryptInteropLegacyW :: EncryptCompatibilityProfileW 'EncryptInteropLegacy

data SomeEncryptCompatibilityProfileW where
  SomeEncryptCompatibilityProfileW ::
       EncryptCompatibilityProfileW profile
    -> SomeEncryptCompatibilityProfileW

data SEIPDVersion
  = SEIPDv1
  | SEIPDv2
  deriving (SEIPDVersion -> SEIPDVersion -> Bool
(SEIPDVersion -> SEIPDVersion -> Bool)
-> (SEIPDVersion -> SEIPDVersion -> Bool) -> Eq SEIPDVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SEIPDVersion -> SEIPDVersion -> Bool
== :: SEIPDVersion -> SEIPDVersion -> Bool
$c/= :: SEIPDVersion -> SEIPDVersion -> Bool
/= :: SEIPDVersion -> SEIPDVersion -> Bool
Eq, Int -> SEIPDVersion -> ShowS
[SEIPDVersion] -> ShowS
SEIPDVersion -> String
(Int -> SEIPDVersion -> ShowS)
-> (SEIPDVersion -> String)
-> ([SEIPDVersion] -> ShowS)
-> Show SEIPDVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SEIPDVersion -> ShowS
showsPrec :: Int -> SEIPDVersion -> ShowS
$cshow :: SEIPDVersion -> String
show :: SEIPDVersion -> String
$cshowList :: [SEIPDVersion] -> ShowS
showList :: [SEIPDVersion] -> ShowS
Show)

type family PayloadVersionForProfile (profile :: EncryptCompatibilityProfile) :: SEIPDVersion where
  PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2
  PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1

type family ProfileForPayloadVersion (version :: SEIPDVersion) :: EncryptCompatibilityProfile where
  ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy
  ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault

data RecipientEncryptionTarget =
  RecipientEncryptionTarget
    { -- | Recipient key packet selected for PKESK wrapping.
      RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey :: SomePKPayload
      -- | Optional explicit PKESK version strategy hint.
      --   When absent, profile defaults and auto-detection apply.
    , RecipientEncryptionTarget -> Maybe RecipientPKESKVersionStrategy
recipientEncryptionTargetStrategy :: Maybe RecipientPKESKVersionStrategy
      -- | Optional recipient capability hints used by negotiation-enabled
      --   encryption to choose common symmetric/AEAD algorithms.
    , RecipientEncryptionTarget -> Maybe RecipientCapabilities
recipientEncryptionTargetCapabilities :: Maybe RecipientCapabilities
    }
  deriving (RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool
(RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool)
-> (RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool)
-> Eq RecipientEncryptionTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool
== :: RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool
$c/= :: RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool
/= :: RecipientEncryptionTarget -> RecipientEncryptionTarget -> Bool
Eq, Int -> RecipientEncryptionTarget -> ShowS
[RecipientEncryptionTarget] -> ShowS
RecipientEncryptionTarget -> String
(Int -> RecipientEncryptionTarget -> ShowS)
-> (RecipientEncryptionTarget -> String)
-> ([RecipientEncryptionTarget] -> ShowS)
-> Show RecipientEncryptionTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientEncryptionTarget -> ShowS
showsPrec :: Int -> RecipientEncryptionTarget -> ShowS
$cshow :: RecipientEncryptionTarget -> String
show :: RecipientEncryptionTarget -> String
$cshowList :: [RecipientEncryptionTarget] -> ShowS
showList :: [RecipientEncryptionTarget] -> ShowS
Show)

recipientEncryptionTarget :: SomePKPayload -> RecipientEncryptionTarget
recipientEncryptionTarget :: SomePKPayload -> RecipientEncryptionTarget
recipientEncryptionTarget SomePKPayload
recipient =
  SomePKPayload
-> Maybe RecipientPKESKVersionStrategy
-> Maybe RecipientCapabilities
-> RecipientEncryptionTarget
RecipientEncryptionTarget SomePKPayload
recipient Maybe RecipientPKESKVersionStrategy
forall a. Maybe a
Nothing Maybe RecipientCapabilities
forall a. Maybe a
Nothing

recipientEncryptionTargetWithStrategy :: SomePKPayload -> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategy :: SomePKPayload
-> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategy SomePKPayload
recipient RecipientPKESKVersionStrategy
strategy =
  SomePKPayload
-> Maybe RecipientPKESKVersionStrategy
-> Maybe RecipientCapabilities
-> RecipientEncryptionTarget
RecipientEncryptionTarget SomePKPayload
recipient (RecipientPKESKVersionStrategy
-> Maybe RecipientPKESKVersionStrategy
forall a. a -> Maybe a
Just RecipientPKESKVersionStrategy
strategy) Maybe RecipientCapabilities
forall a. Maybe a
Nothing

recipientEncryptionTargetWithCapabilities ::
     SomePKPayload
  -> RecipientCapabilities
  -> RecipientEncryptionTarget
recipientEncryptionTargetWithCapabilities :: SomePKPayload -> RecipientCapabilities -> RecipientEncryptionTarget
recipientEncryptionTargetWithCapabilities SomePKPayload
recipient RecipientCapabilities
capabilities =
  SomePKPayload
-> Maybe RecipientPKESKVersionStrategy
-> Maybe RecipientCapabilities
-> RecipientEncryptionTarget
RecipientEncryptionTarget SomePKPayload
recipient Maybe RecipientPKESKVersionStrategy
forall a. Maybe a
Nothing (RecipientCapabilities -> Maybe RecipientCapabilities
forall a. a -> Maybe a
Just RecipientCapabilities
capabilities)

recipientEncryptionTargetWithStrategyTyped :: SomePKPayload
  -> RecipientPKESKVersionStrategyW strategy
  -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategyTyped :: forall (strategy :: RecipientPKESKVersionStrategy).
SomePKPayload
-> RecipientPKESKVersionStrategyW strategy
-> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategyTyped SomePKPayload
recipient RecipientPKESKVersionStrategyW strategy
strategyW =
  SomePKPayload
-> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategy SomePKPayload
recipient (RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
forall (strategy :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
demoteRecipientStrategy RecipientPKESKVersionStrategyW strategy
strategyW)

recipientVersionStrategyForProfile ::
     EncryptCompatibilityProfile
  -> RecipientEncryptionTarget
  -> Either PKESKEncryptError RecipientPKESKVersionStrategy
recipientVersionStrategyForProfile :: EncryptCompatibilityProfile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
recipientVersionStrategyForProfile EncryptCompatibilityProfile
profile RecipientEncryptionTarget
target =
  case EncryptCompatibilityProfile -> SomeEncryptCompatibilityProfileW
promoteEncryptCompatibilityProfile EncryptCompatibilityProfile
profile of
    SomeEncryptCompatibilityProfileW EncryptCompatibilityProfileW profile
profileW ->
      SomeRecipientPKESKVersionStrategyW -> RecipientPKESKVersionStrategy
demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW
 -> RecipientPKESKVersionStrategy)
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      EncryptCompatibilityProfileW profile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
forall (profile :: EncryptCompatibilityProfile).
EncryptCompatibilityProfileW profile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped EncryptCompatibilityProfileW profile
profileW RecipientEncryptionTarget
target

recipientVersionStrategyForProfileTyped ::
     EncryptCompatibilityProfileW profile
  -> RecipientEncryptionTarget
  -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped :: forall (profile :: EncryptCompatibilityProfile).
EncryptCompatibilityProfileW profile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped EncryptCompatibilityProfileW profile
profile RecipientEncryptionTarget
target =
  SomeRecipientPKESKVersionStrategyW
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
forall a b. b -> Either a b
Right (SomeRecipientPKESKVersionStrategyW
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> SomeRecipientPKESKVersionStrategyW
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
forall a b. (a -> b) -> a -> b
$
    case RecipientEncryptionTarget -> Maybe RecipientPKESKVersionStrategy
recipientEncryptionTargetStrategy RecipientEncryptionTarget
target of
      Just RecipientPKESKVersionStrategy
strategy ->
        RecipientPKESKVersionStrategy -> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy RecipientPKESKVersionStrategy
strategy
      Maybe RecipientPKESKVersionStrategy
Nothing ->
        case EncryptCompatibilityProfileW profile
profile of
          EncryptCompatibilityProfileW profile
EncryptStrictDefaultW ->
            SomePKPayload -> SomeRecipientPKESKVersionStrategyW
autoDetectRecipientVersionStrategy
              (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
target)
          EncryptCompatibilityProfileW profile
EncryptInteropLegacyW ->
            RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
RecipientForceV3InteropW

profileForPayloadVersionW ::
     RecipientEncryptRequestOverrides version
  -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
profileForPayloadVersionW :: forall (version :: SEIPDVersion).
RecipientEncryptRequestOverrides version
-> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
profileForPayloadVersionW RecipientEncryptRequestOverrides version
overrides =
  case RecipientEncryptRequestOverrides version
overrides of
    RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
EncryptCompatibilityProfileW 'EncryptStrictDefault
EncryptStrictDefaultW
    RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
EncryptCompatibilityProfileW 'EncryptInteropLegacy
EncryptInteropLegacyW

autoDetectRecipientVersionStrategy :: SomePKPayload
  -> SomeRecipientPKESKVersionStrategyW
autoDetectRecipientVersionStrategy :: SomePKPayload -> SomeRecipientPKESKVersionStrategyW
autoDetectRecipientVersionStrategy SomePKPayload
recipient
  | SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
recipient KeyVersion -> KeyVersion -> Bool
forall a. Eq a => a -> a -> Bool
== KeyVersion
V6 =
      RecipientPKESKVersionStrategyW 'RecipientPreferV6
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientPreferV6
RecipientPreferV6W
  | SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient PubKeyAlgorithm -> [PubKeyAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PubKeyAlgorithm
X25519, PubKeyAlgorithm
X448] =
      RecipientPKESKVersionStrategyW 'RecipientPreferV6
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientPreferV6
RecipientPreferV6W
  | Bool
otherwise =
      RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
RecipientForceV3InteropW

data RecipientPayloadShape =
  RecipientPayloadShape
    { RecipientPayloadShape -> DataType
recipientPayloadDataType :: DataType
    , RecipientPayloadShape -> ByteString
recipientPayloadFileName :: FileName
    , RecipientPayloadShape -> ThirtyTwoBitTimeStamp
recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp
    , RecipientPayloadShape -> Bool
recipientPayloadUseOnePassSignatures :: Bool
    , RecipientPayloadShape -> [SignaturePayload]
recipientPayloadSignatures :: [SignaturePayload]
    }
  deriving (RecipientPayloadShape -> RecipientPayloadShape -> Bool
(RecipientPayloadShape -> RecipientPayloadShape -> Bool)
-> (RecipientPayloadShape -> RecipientPayloadShape -> Bool)
-> Eq RecipientPayloadShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientPayloadShape -> RecipientPayloadShape -> Bool
== :: RecipientPayloadShape -> RecipientPayloadShape -> Bool
$c/= :: RecipientPayloadShape -> RecipientPayloadShape -> Bool
/= :: RecipientPayloadShape -> RecipientPayloadShape -> Bool
Eq, Int -> RecipientPayloadShape -> ShowS
[RecipientPayloadShape] -> ShowS
RecipientPayloadShape -> String
(Int -> RecipientPayloadShape -> ShowS)
-> (RecipientPayloadShape -> String)
-> ([RecipientPayloadShape] -> ShowS)
-> Show RecipientPayloadShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientPayloadShape -> ShowS
showsPrec :: Int -> RecipientPayloadShape -> ShowS
$cshow :: RecipientPayloadShape -> String
show :: RecipientPayloadShape -> String
$cshowList :: [RecipientPayloadShape] -> ShowS
showList :: [RecipientPayloadShape] -> ShowS
Show)

data PassphraseSKESKVersionPolicy
  = PassphraseSKESKPreferV6
  | PassphraseSKESKForceV4Interop
  deriving (PassphraseSKESKVersionPolicy
-> PassphraseSKESKVersionPolicy -> Bool
(PassphraseSKESKVersionPolicy
 -> PassphraseSKESKVersionPolicy -> Bool)
-> (PassphraseSKESKVersionPolicy
    -> PassphraseSKESKVersionPolicy -> Bool)
-> Eq PassphraseSKESKVersionPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PassphraseSKESKVersionPolicy
-> PassphraseSKESKVersionPolicy -> Bool
== :: PassphraseSKESKVersionPolicy
-> PassphraseSKESKVersionPolicy -> Bool
$c/= :: PassphraseSKESKVersionPolicy
-> PassphraseSKESKVersionPolicy -> Bool
/= :: PassphraseSKESKVersionPolicy
-> PassphraseSKESKVersionPolicy -> Bool
Eq, Int -> PassphraseSKESKVersionPolicy -> ShowS
[PassphraseSKESKVersionPolicy] -> ShowS
PassphraseSKESKVersionPolicy -> String
(Int -> PassphraseSKESKVersionPolicy -> ShowS)
-> (PassphraseSKESKVersionPolicy -> String)
-> ([PassphraseSKESKVersionPolicy] -> ShowS)
-> Show PassphraseSKESKVersionPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PassphraseSKESKVersionPolicy -> ShowS
showsPrec :: Int -> PassphraseSKESKVersionPolicy -> ShowS
$cshow :: PassphraseSKESKVersionPolicy -> String
show :: PassphraseSKESKVersionPolicy -> String
$cshowList :: [PassphraseSKESKVersionPolicy] -> ShowS
showList :: [PassphraseSKESKVersionPolicy] -> ShowS
Show)

data PassphraseEncryptRequest =
  PassphraseEncryptRequest
    { PassphraseEncryptRequest -> PassphraseSKESKVersionPolicy
passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy
    , PassphraseEncryptRequest -> SymmetricAlgorithm
passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm
    , PassphraseEncryptRequest -> S2K
passphraseEncryptS2K :: S2K
    , PassphraseEncryptRequest -> ByteString
passphraseEncryptPassphrase :: BL.ByteString
    , PassphraseEncryptRequest -> ByteString
passphraseEncryptPayload :: B.ByteString
    , PassphraseEncryptRequest -> Maybe IV
passphraseEncryptSEIPDv1IVOverride :: Maybe IV
    , PassphraseEncryptRequest -> Maybe AEADAlgorithm
passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm
    , PassphraseEncryptRequest -> Maybe Word8
passphraseEncryptSEIPDv2ChunkSizeOverride :: Maybe Word8
    , PassphraseEncryptRequest -> Maybe Salt
passphraseEncryptSEIPDv2SaltOverride :: Maybe Salt
    }
  deriving (PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool
(PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool)
-> (PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool)
-> Eq PassphraseEncryptRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool
== :: PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool
$c/= :: PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool
/= :: PassphraseEncryptRequest -> PassphraseEncryptRequest -> Bool
Eq, Int -> PassphraseEncryptRequest -> ShowS
[PassphraseEncryptRequest] -> ShowS
PassphraseEncryptRequest -> String
(Int -> PassphraseEncryptRequest -> ShowS)
-> (PassphraseEncryptRequest -> String)
-> ([PassphraseEncryptRequest] -> ShowS)
-> Show PassphraseEncryptRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PassphraseEncryptRequest -> ShowS
showsPrec :: Int -> PassphraseEncryptRequest -> ShowS
$cshow :: PassphraseEncryptRequest -> String
show :: PassphraseEncryptRequest -> String
$cshowList :: [PassphraseEncryptRequest] -> ShowS
showList :: [PassphraseEncryptRequest] -> ShowS
Show)

encryptPassphraseWithPolicy ::
     MonadRandom m
  => PassphraseEncryptRequest
  -> m (Either String [Pkt])
encryptPassphraseWithPolicy :: forall (m :: * -> *).
MonadRandom m =>
PassphraseEncryptRequest -> m (Either String [Pkt])
encryptPassphraseWithPolicy PassphraseEncryptRequest
request =
  case PassphraseEncryptRequest -> PassphraseSKESKVersionPolicy
passphraseEncryptVersionPolicy PassphraseEncryptRequest
request of
    PassphraseSKESKVersionPolicy
PassphraseSKESKForceV4Interop ->
      SymmetricAlgorithm
-> S2K
-> Maybe IV
-> ByteString
-> ByteString
-> m (Either String [Pkt])
forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> S2K
-> Maybe IV
-> ByteString
-> ByteString
-> m (Either String [Pkt])
encryptSEIPDv1WithSKESK
        (PassphraseEncryptRequest -> SymmetricAlgorithm
passphraseEncryptSymmetricAlgorithm PassphraseEncryptRequest
request)
        (PassphraseEncryptRequest -> S2K
passphraseEncryptS2K PassphraseEncryptRequest
request)
        (PassphraseEncryptRequest -> Maybe IV
passphraseEncryptSEIPDv1IVOverride PassphraseEncryptRequest
request)
        (PassphraseEncryptRequest -> ByteString
passphraseEncryptPassphrase PassphraseEncryptRequest
request)
        (PassphraseEncryptRequest -> ByteString
passphraseEncryptPayload PassphraseEncryptRequest
request)
    PassphraseSKESKVersionPolicy
PassphraseSKESKPreferV6 -> do
      let messagePolicy :: MessageEncryptionPolicy
messagePolicy = OpenPGPPolicy -> MessageEncryptionPolicy
policyMessageEncryption (OpenPGPRFC -> OpenPGPPolicy
policyForRFC OpenPGPRFC
RFC9580)
          aead :: AEADAlgorithm
aead =
            AEADAlgorithm -> Maybe AEADAlgorithm -> AEADAlgorithm
forall a. a -> Maybe a -> a
fromMaybe
              (MessageEncryptionPolicy -> AEADAlgorithm
messageDefaultAEADAlgorithm MessageEncryptionPolicy
messagePolicy)
              (PassphraseEncryptRequest -> Maybe AEADAlgorithm
passphraseEncryptSEIPDv2AEADOverride PassphraseEncryptRequest
request)
          chunkSize :: Word8
chunkSize =
            Word8 -> Maybe Word8 -> Word8
forall a. a -> Maybe a -> a
fromMaybe
              (MessageEncryptionPolicy -> Word8
messageDefaultChunkSize MessageEncryptionPolicy
messagePolicy)
              (PassphraseEncryptRequest -> Maybe Word8
passphraseEncryptSEIPDv2ChunkSizeOverride PassphraseEncryptRequest
request)
      salt <-
        m Salt -> (Salt -> m Salt) -> Maybe Salt -> m Salt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (ByteString -> Salt
Salt (ByteString -> Salt) -> m ByteString -> m Salt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes (MessageEncryptionPolicy -> Int
messageSEIPDv2SaltOctets MessageEncryptionPolicy
messagePolicy))
          Salt -> m Salt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (PassphraseEncryptRequest -> Maybe Salt
passphraseEncryptSEIPDv2SaltOverride PassphraseEncryptRequest
request)
      pure $
        encryptSEIPDv2WithSKESK
          (passphraseEncryptSymmetricAlgorithm request)
          aead
          chunkSize
          salt
          (passphraseEncryptS2K request)
          (passphraseEncryptPassphrase request)
          (passphraseEncryptPayload request)

defaultRecipientPayloadShape :: RecipientPayloadShape
defaultRecipientPayloadShape :: RecipientPayloadShape
defaultRecipientPayloadShape =
  RecipientPayloadShape
    { recipientPayloadDataType :: DataType
recipientPayloadDataType = DataType
BinaryData
    , recipientPayloadFileName :: ByteString
recipientPayloadFileName = ByteString
BL.empty
    , recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp
recipientPayloadTimestamp = ThirtyTwoBitTimeStamp
0
    , recipientPayloadUseOnePassSignatures :: Bool
recipientPayloadUseOnePassSignatures = Bool
False
    , recipientPayloadSignatures :: [SignaturePayload]
recipientPayloadSignatures = []
    }

data RecipientEncryptResult =
  RecipientEncryptResult
    { RecipientEncryptResult -> [Pkt]
recipientEncryptPackets :: [Pkt]
    , RecipientEncryptResult -> PKESKSessionMaterial
recipientEncryptSessionMaterial :: PKESKSessionMaterial
    }
  deriving (RecipientEncryptResult -> RecipientEncryptResult -> Bool
(RecipientEncryptResult -> RecipientEncryptResult -> Bool)
-> (RecipientEncryptResult -> RecipientEncryptResult -> Bool)
-> Eq RecipientEncryptResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecipientEncryptResult -> RecipientEncryptResult -> Bool
== :: RecipientEncryptResult -> RecipientEncryptResult -> Bool
$c/= :: RecipientEncryptResult -> RecipientEncryptResult -> Bool
/= :: RecipientEncryptResult -> RecipientEncryptResult -> Bool
Eq, Int -> RecipientEncryptResult -> ShowS
[RecipientEncryptResult] -> ShowS
RecipientEncryptResult -> String
(Int -> RecipientEncryptResult -> ShowS)
-> (RecipientEncryptResult -> String)
-> ([RecipientEncryptResult] -> ShowS)
-> Show RecipientEncryptResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipientEncryptResult -> ShowS
showsPrec :: Int -> RecipientEncryptResult -> ShowS
$cshow :: RecipientEncryptResult -> String
show :: RecipientEncryptResult -> String
$cshowList :: [RecipientEncryptResult] -> ShowS
showList :: [RecipientEncryptResult] -> ShowS
Show)

data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where
  RecipientEncryptRequestSEIPDv1Overrides ::
    { RecipientEncryptRequestOverrides 'SEIPDv1 -> Maybe IV
recipientEncryptRequestIVOverride :: Maybe IV
    } -> RecipientEncryptRequestOverrides 'SEIPDv1
  -- | For SEIPDv2 requests:
  --   - when AEAD override is 'Nothing', encrypt-side capability negotiation
  --     selects a common recipient-supported AEAD algorithm (if enabled).
  --   - when AEAD override is 'Just', the explicit AEAD wins.
  RecipientEncryptRequestSEIPDv2Overrides ::
    { RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe AEADAlgorithm
recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm
    , RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe Word8
recipientEncryptRequestChunkSizeOverride :: Maybe Word8
    , RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe Salt
recipientEncryptRequestSaltOverride :: Maybe Salt
    } -> RecipientEncryptRequestOverrides 'SEIPDv2

data RecipientEncryptRequest (v :: SEIPDVersion) =
  RecipientEncryptRequest
    { -- | Recipient encryption targets. At least one target is required.
      forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> [RecipientEncryptionTarget]
recipientEncryptRequestTargets :: [RecipientEncryptionTarget]
    , forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> RecipientPayloadShape
recipientEncryptRequestPayloadShape :: RecipientPayloadShape
    , forall (v :: SEIPDVersion). RecipientEncryptRequest v -> ByteString
recipientEncryptRequestPayload :: B.ByteString
      -- | Explicit symmetric algorithm override. When 'Nothing', the selected
      --   mode (negotiated or legacy) determines algorithm selection.
    , forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> Maybe SymmetricAlgorithm
recipientEncryptRequestSymmetricOverride :: Maybe SymmetricAlgorithm
    , forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> RecipientEncryptRequestOverrides v
recipientEncryptRequestOverrides :: RecipientEncryptRequestOverrides v
    }

deriving instance Eq (RecipientEncryptRequestOverrides v)
deriving instance Show (RecipientEncryptRequestOverrides v)
deriving instance Eq (RecipientEncryptRequest v)
deriving instance Show (RecipientEncryptRequest v)

-- | Encode the RFC 9580 PKESK/SKESK session-key material:
--   one-octet algorithm ID, raw session key, then 16-bit checksum.
encodeOpenPGPSessionMaterial ::
     SymmetricAlgorithm -> SessionKey -> Either PKESKEncryptError B.ByteString
encodeOpenPGPSessionMaterial :: SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError ByteString
encodeOpenPGPSessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey =
  PKESKV3SessionMaterial -> ByteString
unPKESKV3SessionMaterial (PKESKV3SessionMaterial -> ByteString)
-> Either PKESKEncryptError PKESKV3SessionMaterial
-> Either PKESKEncryptError ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial SymmetricAlgorithm
symalgo SessionKey
sessionKey

-- | Generate a fresh session key and return both raw and encoded forms.
generateSessionKeyMaterial ::
     MonadRandom m
  => SymmetricAlgorithm
  -> m (Either PKESKEncryptError PKESKSessionMaterial)
generateSessionKeyMaterial :: forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> m (Either PKESKEncryptError PKESKSessionMaterial)
generateSessionKeyMaterial SymmetricAlgorithm
symalgo =
  case SymmetricAlgorithm -> Either CipherError Int
keySize SymmetricAlgorithm
symalgo of
    Left CipherError
err -> Either PKESKEncryptError PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKSessionMaterial)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError PKESKSessionMaterial
forall a b. a -> Either a b
Left (SymmetricAlgorithm -> String -> PKESKEncryptError
UnsupportedSessionKeyAlgorithm SymmetricAlgorithm
symalgo (CipherError -> String
renderCipherError CipherError
err)))
    Right Int
keyLen -> do
      sessionKeyBytes <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
keyLen
      let sessionKey = ByteString -> SessionKey
SessionKey ByteString
sessionKeyBytes
      pure (mkPKESKSessionMaterial symalgo sessionKey)

canonicalizePKESKRecipientId ::
     PKESKPayload -> Either PKESKEncryptError PKESKPayload
canonicalizePKESKRecipientId :: PKESKPayload -> Either PKESKEncryptError PKESKPayload
canonicalizePKESKRecipientId PKESKPayload
payload =
  case PKESKPayload
payload of
    PKESKPayloadV6Packet PKESKPayloadV6
payloadV6 ->
      PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet (PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6
canonicalizePKESKRecipientIdV6 PKESKPayloadV6
payloadV6
    PKESKPayload
_ -> PKESKPayload -> Either PKESKEncryptError PKESKPayload
forall a b. b -> Either a b
Right PKESKPayload
payload

canonicalizePKESKRecipientIdV6 ::
     PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6
canonicalizePKESKRecipientIdV6 :: PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6
canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 ByteString
rid PubKeyAlgorithm
pka ByteString
esk) =
  (\ByteString
normalizedRid -> ByteString -> PubKeyAlgorithm -> ByteString -> PKESKPayloadV6
PKESKPayloadV6 ByteString
normalizedRid PubKeyAlgorithm
pka ByteString
esk) (ByteString -> PKESKPayloadV6)
-> Either PKESKEncryptError ByteString
-> Either PKESKEncryptError PKESKPayloadV6
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  ByteString -> Either PKESKEncryptError ByteString
canonicalizeRecipientKeyIdentifier ByteString
rid

canonicalizeRecipientKeyIdentifier ::
     BL.ByteString -> Either PKESKEncryptError BL.ByteString
canonicalizeRecipientKeyIdentifier :: ByteString -> Either PKESKEncryptError ByteString
canonicalizeRecipientKeyIdentifier ByteString
rid
  | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
20 Bool -> Bool -> Bool
|| ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
32 = ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right ByteString
rid
  | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
21 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x04 = ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid)
  | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
33 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x06 = ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid)
  | Bool
otherwise =
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left
        (String -> PKESKEncryptError
InvalidRecipientIdentifier
           (String
"unsupported PKESK recipient identifier length/prefix: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
            Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
rid)))

canonicalizePKESKPacketRecipientIds ::
     [Pkt] -> Either PKESKEncryptError [Pkt]
canonicalizePKESKPacketRecipientIds :: [Pkt] -> Either PKESKEncryptError [Pkt]
canonicalizePKESKPacketRecipientIds =
  (Pkt -> Either PKESKEncryptError Pkt)
-> [Pkt] -> Either PKESKEncryptError [Pkt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
    (\Pkt
pkt ->
       case Pkt
pkt of
         PKESKPkt PKESKPayload
payload -> (PKESKPayload -> Pkt)
-> Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayload -> Pkt
PKESKPkt (PKESKPayload -> Either PKESKEncryptError PKESKPayload
canonicalizePKESKRecipientId PKESKPayload
payload)
         Pkt
_ -> Pkt -> Either PKESKEncryptError Pkt
forall a b. b -> Either a b
Right Pkt
pkt)

-- | Build a v6 PKESK payload for one recipient key according to the selected version policy.
buildPKESKPayloadForRecipient ::
     MonadRandom m
  => PKESKVersionPolicy
  -> SomePKPayload
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError PKESKPayload)
buildPKESKPayloadForRecipient :: forall (m :: * -> *).
MonadRandom m =>
PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKPayloadForRecipient PKESKVersionPolicy
policy SomePKPayload
recipient PKESKSessionMaterial
material =
  case PKESKVersionPolicy
policy of
    PKESKVersionPolicy
ForceV3Interop ->
      SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient SomePKPayload
recipient (PKESKSessionMaterial -> PKESKV3SessionMaterial
pkeskV3SessionMaterial PKESKSessionMaterial
material)
    PKESKVersionPolicy
PreferV6 ->
      case SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient of
        PubKeyAlgorithm
RSA -> (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet) (SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material)
        PubKeyAlgorithm
ECDH -> (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet) (SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material)
        PubKeyAlgorithm
X25519 ->
          (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet)
            (SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 SomePKPayload
recipient (PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial PKESKSessionMaterial
material))
        PubKeyAlgorithm
X448 ->
          (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet)
            (SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 SomePKPayload
recipient (PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial PKESKSessionMaterial
material))
        PubKeyAlgorithm
pka -> Either PKESKEncryptError PKESKPayload
-> m (Either PKESKEncryptError PKESKPayload)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError PKESKPayload
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> PKESKEncryptError
UnsupportedRecipientAlgorithm PubKeyAlgorithm
pka))


-- | Build a PKESK packet for one recipient key according to the selected version policy.
buildPKESKPktForRecipient ::
     MonadRandom m
  => PKESKVersionPolicy
  -> SomePKPayload
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipient :: forall (m :: * -> *).
MonadRandom m =>
PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipient PKESKVersionPolicy
policy SomePKPayload
recipient PKESKSessionMaterial
material =
  (Either PKESKEncryptError PKESKPayload
 -> Either PKESKEncryptError Pkt)
-> m (Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError Pkt)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ((PKESKPayload -> Pkt)
-> Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayload -> Pkt
PKESKPkt)
    (PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
forall (m :: * -> *).
MonadRandom m =>
PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKPayloadForRecipient PKESKVersionPolicy
policy SomePKPayload
recipient PKESKSessionMaterial
material)


-- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop.
buildPKESKv3PayloadForRecipient ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV3SessionMaterial
  -> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient SomePKPayload
recipient PKESKV3SessionMaterial
material =
  (Either PKESKEncryptError PKESKPayloadV3
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV3)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayloadV3 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV3
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV3 -> PKESKPayload
PKESKPayloadV3Packet) (SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildPKESKv3PayloadForRecipientTyped SomePKPayload
recipient PKESKV3SessionMaterial
material)

buildPKESKv3PayloadForRecipientTyped ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV3SessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV3)
buildPKESKv3PayloadForRecipientTyped :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildPKESKv3PayloadForRecipientTyped SomePKPayload
recipient PKESKV3SessionMaterial
material =
  case SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient of
    PubKeyAlgorithm
RSA -> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 SomePKPayload
recipient PKESKV3SessionMaterial
material
    PubKeyAlgorithm
DeprecatedRSAEncryptOnly -> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 SomePKPayload
recipient PKESKV3SessionMaterial
material
    PubKeyAlgorithm
ECDH -> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildECDHPKESKv3 SomePKPayload
recipient PKESKV3SessionMaterial
material
    PubKeyAlgorithm
pka -> Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> PKESKEncryptError
UnsupportedRecipientAlgorithm PubKeyAlgorithm
pka))

-- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop.
buildPKESKv3PktForRecipient ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV3SessionMaterial
  -> m (Either PKESKEncryptError Pkt)
buildPKESKv3PktForRecipient :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial -> m (Either PKESKEncryptError Pkt)
buildPKESKv3PktForRecipient SomePKPayload
recipient PKESKV3SessionMaterial
material =
  (Either PKESKEncryptError PKESKPayload
 -> Either PKESKEncryptError Pkt)
-> m (Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError Pkt)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayload -> Pkt)
-> Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayload -> Pkt
PKESKPkt) (SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient SomePKPayload
recipient PKESKV3SessionMaterial
material)

-- | Build PKESK packets for all recipients with a single shared session key.

buildPKESKPktsForRecipientTargetsWithSelector ::
     MonadRandom m
  => (RecipientEncryptionTarget -> Either PKESKEncryptError RecipientPKESKVersionStrategy)
  -> [RecipientEncryptionTarget]
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelector :: forall (m :: * -> *).
MonadRandom m =>
(RecipientEncryptionTarget
 -> Either PKESKEncryptError RecipientPKESKVersionStrategy)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelector RecipientEncryptionTarget
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
selector [RecipientEncryptionTarget]
targets PKESKSessionMaterial
material
  = (RecipientEncryptionTarget
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
forall (m :: * -> *).
MonadRandom m =>
(RecipientEncryptionTarget
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped
      (\RecipientEncryptionTarget
target ->
         RecipientPKESKVersionStrategy -> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy (RecipientPKESKVersionStrategy
 -> SomeRecipientPKESKVersionStrategyW)
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecipientEncryptionTarget
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
selector RecipientEncryptionTarget
target)
      [RecipientEncryptionTarget]
targets
      PKESKSessionMaterial
material

buildPKESKPktsForRecipientTargetsWithSelectorTyped ::
     MonadRandom m
  => (RecipientEncryptionTarget -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
  -> [RecipientEncryptionTarget]
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped :: forall (m :: * -> *).
MonadRandom m =>
(RecipientEncryptionTarget
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
selector [RecipientEncryptionTarget]
targets PKESKSessionMaterial
material
  | [RecipientEncryptionTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RecipientEncryptionTarget]
targets = Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left PKESKEncryptError
NoRecipientsProvided)
  | Bool
otherwise =
      case PKESKSessionMaterial
-> Either
     PKESKEncryptError
     (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial)
preparePKESKVersionedMaterial PKESKSessionMaterial
material of
        Left PKESKEncryptError
err -> Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left PKESKEncryptError
err)
        Right (PKESKV3SessionMaterial
v3Material, PKESKV6RawSessionMaterial
v6RawMaterial) -> do
          pkeskResults <-
            (RecipientEncryptionTarget -> m (Either PKESKEncryptError Pkt))
-> [RecipientEncryptionTarget] -> m [Either PKESKEncryptError Pkt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
              (\RecipientEncryptionTarget
target ->
                 case RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
selector RecipientEncryptionTarget
target of
                   Left PKESKEncryptError
err -> Either PKESKEncryptError Pkt -> m (Either PKESKEncryptError Pkt)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError Pkt
forall a b. a -> Either a b
Left PKESKEncryptError
err)
                   Right (SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW strategy
RecipientPreferV6W) ->
                     RecipientPKESKVersionStrategyW 'RecipientPreferV6
-> SomePKPayload
-> RecipientPKESKRequestPayload 'RecipientPreferV6
-> m (Either PKESKEncryptError Pkt)
forall (m :: * -> *) (strategy :: RecipientPKESKVersionStrategy).
MonadRandom m =>
RecipientPKESKVersionStrategyW strategy
-> SomePKPayload
-> RecipientPKESKRequestPayload strategy
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload
                       RecipientPKESKVersionStrategyW 'RecipientPreferV6
RecipientPreferV6W
                       (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
target)
                       (PKESKSessionMaterial
-> PKESKV6RawSessionMaterial
-> RecipientPKESKRequestPayload 'RecipientPreferV6
RecipientPreferV6Payload PKESKSessionMaterial
material PKESKV6RawSessionMaterial
v6RawMaterial)
                   Right (SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW strategy
RecipientForceV3InteropW) ->
                     RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
-> SomePKPayload
-> RecipientPKESKRequestPayload 'RecipientForceV3Interop
-> m (Either PKESKEncryptError Pkt)
forall (m :: * -> *) (strategy :: RecipientPKESKVersionStrategy).
MonadRandom m =>
RecipientPKESKVersionStrategyW strategy
-> SomePKPayload
-> RecipientPKESKRequestPayload strategy
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload
                       RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
RecipientForceV3InteropW
                       (RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey RecipientEncryptionTarget
target)
                       (PKESKV3SessionMaterial
-> RecipientPKESKRequestPayload 'RecipientForceV3Interop
RecipientForceV3Payload PKESKV3SessionMaterial
v3Material))
              [RecipientEncryptionTarget]
targets
          pure (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds)

preparePKESKVersionedMaterial ::
     PKESKSessionMaterial
  -> Either PKESKEncryptError (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial)
preparePKESKVersionedMaterial :: PKESKSessionMaterial
-> Either
     PKESKEncryptError
     (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial)
preparePKESKVersionedMaterial PKESKSessionMaterial
material = do
  v3Material <-
    SymmetricAlgorithm
-> SessionKey -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial
      (PKESKSessionMaterial -> SymmetricAlgorithm
pkeskSessionAlgorithm PKESKSessionMaterial
material)
      (PKESKSessionMaterial -> SessionKey
pkeskSessionKey PKESKSessionMaterial
material)
  v6RawMaterial <-
    mkPKESKV6RawSessionMaterial
      (pkeskSessionAlgorithm material)
      (pkeskSessionKey material)
  pure (v3Material, v6RawMaterial)

data RecipientPKESKRequestPayload (strategy :: RecipientPKESKVersionStrategy) where
  RecipientForceV3Payload ::
       PKESKV3SessionMaterial
    -> RecipientPKESKRequestPayload 'RecipientForceV3Interop
  RecipientPreferV6Payload ::
       PKESKSessionMaterial
    -> PKESKV6RawSessionMaterial
    -> RecipientPKESKRequestPayload 'RecipientPreferV6

buildPKESKPktForRecipientWithPreparedPayload ::
     MonadRandom m
  => RecipientPKESKVersionStrategyW strategy
  -> SomePKPayload
  -> RecipientPKESKRequestPayload strategy
  -> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload :: forall (m :: * -> *) (strategy :: RecipientPKESKVersionStrategy).
MonadRandom m =>
RecipientPKESKVersionStrategyW strategy
-> SomePKPayload
-> RecipientPKESKRequestPayload strategy
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload RecipientPKESKVersionStrategyW strategy
strategy SomePKPayload
recipient RecipientPKESKRequestPayload strategy
payload =
  (Either PKESKEncryptError PKESKPayload
 -> Either PKESKEncryptError Pkt)
-> m (Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError Pkt)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
fmapPKESKPkt m (Either PKESKEncryptError PKESKPayload)
payloadResult
  where
    fmapPKESKPkt :: Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
fmapPKESKPkt = (PKESKPayload -> Pkt)
-> Either PKESKEncryptError PKESKPayload
-> Either PKESKEncryptError Pkt
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayload -> Pkt
PKESKPkt
    payloadResult :: m (Either PKESKEncryptError PKESKPayload)
payloadResult =
      case (RecipientPKESKVersionStrategyW strategy
strategy, RecipientPKESKRequestPayload strategy
payload) of
        (RecipientPKESKVersionStrategyW strategy
RecipientForceV3InteropW, RecipientForceV3Payload PKESKV3SessionMaterial
v3Material) ->
          SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient SomePKPayload
recipient PKESKV3SessionMaterial
v3Material
        (RecipientPKESKVersionStrategyW strategy
RecipientPreferV6W, RecipientPreferV6Payload PKESKSessionMaterial
material PKESKV6RawSessionMaterial
v6RawMaterial) ->
          case SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient of
            PubKeyAlgorithm
RSA ->
              (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet) (SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material)
            PubKeyAlgorithm
ECDH ->
              (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet) (SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material)
            PubKeyAlgorithm
X25519 ->
              (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet)
                (SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 SomePKPayload
recipient PKESKV6RawSessionMaterial
v6RawMaterial)
            PubKeyAlgorithm
X448 ->
              (Either PKESKEncryptError PKESKPayloadV6
 -> Either PKESKEncryptError PKESKPayload)
-> m (Either PKESKEncryptError PKESKPayloadV6)
-> m (Either PKESKEncryptError PKESKPayload)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ((PKESKPayloadV6 -> PKESKPayload)
-> Either PKESKEncryptError PKESKPayloadV6
-> Either PKESKEncryptError PKESKPayload
forall a b.
(a -> b)
-> Either PKESKEncryptError a -> Either PKESKEncryptError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet)
                (SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 SomePKPayload
recipient PKESKV6RawSessionMaterial
v6RawMaterial)
            PubKeyAlgorithm
pka ->
              Either PKESKEncryptError PKESKPayload
-> m (Either PKESKEncryptError PKESKPayload)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError PKESKPayload
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> PKESKEncryptError
UnsupportedRecipientAlgorithm PubKeyAlgorithm
pka))

-- | Encrypt for recipient targets with capability negotiation enabled.
--
-- By default this negotiates a common symmetric and (for SEIPDv2) AEAD
-- algorithm from recipient capabilities when available. Explicit request
-- overrides still take precedence.
encryptForRecipients ::
     MonadRandom m
  => RecipientEncryptRequest v
  -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipients :: forall (m :: * -> *) (v :: SEIPDVersion).
MonadRandom m =>
RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipients =
  RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall (m :: * -> *) (v :: SEIPDVersion).
MonadRandom m =>
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOn

-- | Encrypt for recipient targets without recipient capability negotiation.
--
-- This preserves legacy behavior by using policy defaults unless request
-- overrides are provided.
encryptForRecipientsLegacy ::
     MonadRandom m
  => RecipientEncryptRequest v
  -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsLegacy :: forall (m :: * -> *) (v :: SEIPDVersion).
MonadRandom m =>
RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsLegacy =
  RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall (m :: * -> *) (v :: SEIPDVersion).
MonadRandom m =>
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOff

-- | Encrypt for recipient targets with an explicit capability-negotiation mode.
--
-- When negotiation is on, symmetric and AEAD selection use the common
-- intersection of recipient preferences constrained by the active policy.
-- When off, policy defaults are used.
encryptForRecipientsWithCapabilityNegotiation ::
     MonadRandom m
  => RecipientCapabilityNegotiationMode
  -> RecipientEncryptRequest v
  -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation :: forall (m :: * -> *) (v :: SEIPDVersion).
MonadRandom m =>
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationMode
negotiationMode RecipientEncryptRequest v
request
  | [RecipientEncryptionTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RecipientEncryptionTarget]
targets = Either PKESKEncryptError RecipientEncryptResult
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError
-> Either PKESKEncryptError RecipientEncryptResult
forall a b. a -> Either a b
Left PKESKEncryptError
NoRecipientsProvided)
  | Bool
otherwise =
      case RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
forall (v :: SEIPDVersion).
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
selectSymmetricAlgorithm RecipientCapabilityNegotiationMode
negotiationMode RecipientEncryptRequest v
request MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets of
        Left PKESKEncryptError
err -> Either PKESKEncryptError RecipientEncryptResult
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError
-> Either PKESKEncryptError RecipientEncryptResult
forall a b. a -> Either a b
Left PKESKEncryptError
err)
        Right SymmetricAlgorithm
symalgo -> do
          sessionMaterialResult <- SymmetricAlgorithm
-> m (Either PKESKEncryptError PKESKSessionMaterial)
forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> m (Either PKESKEncryptError PKESKSessionMaterial)
generateSessionKeyMaterial SymmetricAlgorithm
symalgo
          case sessionMaterialResult of
            Left PKESKEncryptError
err -> Either PKESKEncryptError RecipientEncryptResult
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError
-> Either PKESKEncryptError RecipientEncryptResult
forall a b. a -> Either a b
Left PKESKEncryptError
err)
            Right PKESKSessionMaterial
sessionMaterial -> do
              pkeskResult <-
                (RecipientEncryptionTarget
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
forall (m :: * -> *).
MonadRandom m =>
(RecipientEncryptionTarget
 -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped
                  (EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
forall (profile :: EncryptCompatibilityProfile).
EncryptCompatibilityProfileW profile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
profileW)
                  [RecipientEncryptionTarget]
targets
                  PKESKSessionMaterial
sessionMaterial
              case pkeskResult of
                Left PKESKEncryptError
err -> Either PKESKEncryptError RecipientEncryptResult
-> m (Either PKESKEncryptError RecipientEncryptResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError
-> Either PKESKEncryptError RecipientEncryptResult
forall a b. a -> Either a b
Left PKESKEncryptError
err)
                Right [Pkt]
pkeskPkts -> do
                  payloadResult <- case RecipientEncryptRequest v -> RecipientEncryptRequestOverrides v
forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> RecipientEncryptRequestOverrides v
recipientEncryptRequestOverrides RecipientEncryptRequest v
request of
                    RecipientEncryptRequestSEIPDv2Overrides
                      { recipientEncryptRequestAEADOverride :: RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe AEADAlgorithm
recipientEncryptRequestAEADOverride = Maybe AEADAlgorithm
aeadOverride
                      , recipientEncryptRequestChunkSizeOverride :: RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe Word8
recipientEncryptRequestChunkSizeOverride = Maybe Word8
chunkSizeOverride
                      , recipientEncryptRequestSaltOverride :: RecipientEncryptRequestOverrides 'SEIPDv2 -> Maybe Salt
recipientEncryptRequestSaltOverride = Maybe Salt
saltOverride
                      } ->
                        case [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv2Support [RecipientEncryptionTarget]
targets of
                          [] -> do
                            case RecipientCapabilityNegotiationMode
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Maybe AEADAlgorithm
-> Either PKESKEncryptError AEADAlgorithm
selectAEADAlgorithm RecipientCapabilityNegotiationMode
negotiationMode MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets Maybe AEADAlgorithm
aeadOverride of
                              Left PKESKEncryptError
err -> Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left PKESKEncryptError
err)
                              Right AEADAlgorithm
aead -> do
                                salt <- m Salt -> (Salt -> m Salt) -> Maybe Salt -> m Salt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Salt
Salt (ByteString -> Salt) -> m ByteString -> m Salt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32) Salt -> m Salt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Salt
saltOverride
                                let chunkSize =
                                      Word8 -> (Word8 -> Word8) -> Maybe Word8 -> Word8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                                        (MessageEncryptionPolicy -> Word8
messageDefaultChunkSize MessageEncryptionPolicy
messagePolicy)
                                        Word8 -> Word8
forall a. a -> a
id
                                        Maybe Word8
chunkSizeOverride
                                pure $
                                  buildEncryptedPacketSequenceWithShape
                                    symalgo
                                    aead
                                    chunkSize
                                    (recipientEncryptRequestPayloadShape request)
                                    salt
                                    (pkeskSessionKey sessionMaterial)
                                    pkeskPkts
                                    (recipientEncryptRequestPayload request)
                          [SomePKPayload]
_missingSEIPDv2 ->
                            case [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv1Support [RecipientEncryptionTarget]
targets of
                              [] ->
                                SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
buildSEIPDv1PayloadWithIV
                                  SymmetricAlgorithm
symalgo
                                  PKESKSessionMaterial
sessionMaterial
                                  [Pkt]
pkeskPkts
                                  Maybe IV
forall a. Maybe a
Nothing
                              [SomePKPayload]
missingSEIPDv1 ->
                                Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                  (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left
                                     (RecipientCapabilityError -> PKESKEncryptError
RecipientCapabilitySelectionFailure
                                        ([SomePKPayload] -> RecipientCapabilityError
RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
missingSEIPDv1)))
                    RecipientEncryptRequestSEIPDv1Overrides
                      { recipientEncryptRequestIVOverride :: RecipientEncryptRequestOverrides 'SEIPDv1 -> Maybe IV
recipientEncryptRequestIVOverride = Maybe IV
ivOverride } ->
                        case [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv1Support [RecipientEncryptionTarget]
targets of
                          [] ->
                            SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
buildSEIPDv1PayloadWithIV
                              SymmetricAlgorithm
symalgo
                              PKESKSessionMaterial
sessionMaterial
                              [Pkt]
pkeskPkts
                              Maybe IV
ivOverride
                          [SomePKPayload]
missingSEIPDv1 ->
                            Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                              (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left
                                 (RecipientCapabilityError -> PKESKEncryptError
RecipientCapabilitySelectionFailure
                                    ([SomePKPayload] -> RecipientCapabilityError
RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
missingSEIPDv1)))
                  pure $
                    fmap
                      (\[Pkt]
pkts ->
                         RecipientEncryptResult
                           { recipientEncryptPackets :: [Pkt]
recipientEncryptPackets = [Pkt]
pkts
                           , recipientEncryptSessionMaterial :: PKESKSessionMaterial
recipientEncryptSessionMaterial = PKESKSessionMaterial
sessionMaterial
                           })
                      payloadResult
  where
    targets :: [RecipientEncryptionTarget]
targets = RecipientEncryptRequest v -> [RecipientEncryptionTarget]
forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> [RecipientEncryptionTarget]
recipientEncryptRequestTargets RecipientEncryptRequest v
request
    profileW :: EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
profileW =
      RecipientEncryptRequestOverrides v
-> EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
forall (version :: SEIPDVersion).
RecipientEncryptRequestOverrides version
-> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
profileForPayloadVersionW (RecipientEncryptRequest v -> RecipientEncryptRequestOverrides v
forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> RecipientEncryptRequestOverrides v
recipientEncryptRequestOverrides RecipientEncryptRequest v
request)
    messagePolicy :: MessageEncryptionPolicy
messagePolicy =
      case EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
profileW of
        EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
EncryptStrictDefaultW ->
          OpenPGPPolicy -> MessageEncryptionPolicy
policyMessageEncryption (OpenPGPRFC -> OpenPGPPolicy
policyForRFC OpenPGPRFC
RFC9580)
        EncryptCompatibilityProfileW (ProfileForPayloadVersion v)
EncryptInteropLegacyW ->
          OpenPGPPolicy -> MessageEncryptionPolicy
policyMessageEncryption (OpenPGPRFC -> OpenPGPPolicy
policyForRFC OpenPGPRFC
RFC4880)

    buildSEIPDv1PayloadWithIV ::
         MonadRandom m
      => SymmetricAlgorithm
      -> PKESKSessionMaterial
      -> [Pkt]
      -> Maybe IV
      -> m (Either PKESKEncryptError [Pkt])
    buildSEIPDv1PayloadWithIV :: forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
buildSEIPDv1PayloadWithIV SymmetricAlgorithm
symalgo PKESKSessionMaterial
sessionMaterial [Pkt]
pkeskPkts Maybe IV
ivOverride = do
      ivResult <-
        case Maybe IV
ivOverride of
          Just IV
iv -> Either PKESKEncryptError IV -> m (Either PKESKEncryptError IV)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IV -> Either PKESKEncryptError IV
forall a b. b -> Either a b
Right IV
iv)
          Maybe IV
Nothing ->
            let keyBytes :: ByteString
keyBytes = SessionKey -> ByteString
unSessionKey (PKESKSessionMaterial -> SessionKey
pkeskSessionKey PKESKSessionMaterial
sessionMaterial)
             in case SymmetricAlgorithm
-> ByteString -> HOCipher Int -> Either CipherError Int
forall a.
SymmetricAlgorithm
-> ByteString -> HOCipher a -> Either CipherError a
withSymmetricCipher SymmetricAlgorithm
symalgo ByteString
keyBytes (\cipher
c -> Int -> Either String Int
forall a b. b -> Either a b
Right (cipher -> Int
forall cipher. HOBlockCipher cipher => cipher -> Int
blockSize cipher
c)) of
                  Left CipherError
err -> Either PKESKEncryptError IV -> m (Either PKESKEncryptError IV)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError IV
forall a b. a -> Either a b
Left (String -> PKESKEncryptError
PayloadBuildFailure (CipherError -> String
renderCipherError CipherError
err)))
                  Right Int
n -> (ByteString -> Either PKESKEncryptError IV)
-> m ByteString -> m (Either PKESKEncryptError IV)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IV -> Either PKESKEncryptError IV
forall a b. b -> Either a b
Right (IV -> Either PKESKEncryptError IV)
-> (ByteString -> IV) -> ByteString -> Either PKESKEncryptError IV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IV
IV) (Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
n)
      case ivResult of
        Left PKESKEncryptError
err -> Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKEncryptError -> Either PKESKEncryptError [Pkt]
forall a b. a -> Either a b
Left PKESKEncryptError
err)
        Right IV
iv ->
          Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PKESKEncryptError [Pkt]
 -> m (Either PKESKEncryptError [Pkt]))
-> Either PKESKEncryptError [Pkt]
-> m (Either PKESKEncryptError [Pkt])
forall a b. (a -> b) -> a -> b
$
            SymmetricAlgorithm
-> IV
-> RecipientPayloadShape
-> SessionKey
-> [Pkt]
-> ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShapeSEIPDv1
              SymmetricAlgorithm
symalgo
              IV
iv
              (RecipientEncryptRequest v -> RecipientPayloadShape
forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> RecipientPayloadShape
recipientEncryptRequestPayloadShape RecipientEncryptRequest v
request)
              (PKESKSessionMaterial -> SessionKey
pkeskSessionKey PKESKSessionMaterial
sessionMaterial)
              [Pkt]
pkeskPkts
              (RecipientEncryptRequest v -> ByteString
forall (v :: SEIPDVersion). RecipientEncryptRequest v -> ByteString
recipientEncryptRequestPayload RecipientEncryptRequest v
request)

    recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
    recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv1Support =
      (RecipientEncryptionTarget -> SomePKPayload)
-> [RecipientEncryptionTarget] -> [SomePKPayload]
forall a b. (a -> b) -> [a] -> [b]
map RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey ([RecipientEncryptionTarget] -> [SomePKPayload])
-> ([RecipientEncryptionTarget] -> [RecipientEncryptionTarget])
-> [RecipientEncryptionTarget]
-> [SomePKPayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (RecipientEncryptionTarget -> Bool)
-> [RecipientEncryptionTarget] -> [RecipientEncryptionTarget]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (RecipientEncryptionTarget -> Bool)
-> RecipientEncryptionTarget
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv1Support)

    recipientsMissingSEIPDv2Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
    recipientsMissingSEIPDv2Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv2Support =
      (RecipientEncryptionTarget -> SomePKPayload)
-> [RecipientEncryptionTarget] -> [SomePKPayload]
forall a b. (a -> b) -> [a] -> [b]
map RecipientEncryptionTarget -> SomePKPayload
recipientEncryptionTargetKey ([RecipientEncryptionTarget] -> [SomePKPayload])
-> ([RecipientEncryptionTarget] -> [RecipientEncryptionTarget])
-> [RecipientEncryptionTarget]
-> [SomePKPayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (RecipientEncryptionTarget -> Bool)
-> [RecipientEncryptionTarget] -> [RecipientEncryptionTarget]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (RecipientEncryptionTarget -> Bool)
-> RecipientEncryptionTarget
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv2Support)

    targetAdvertisesSEIPDv1Support :: RecipientEncryptionTarget -> Bool
    targetAdvertisesSEIPDv1Support :: RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv1Support RecipientEncryptionTarget
target =
      case RecipientEncryptionTarget -> Maybe RecipientCapabilities
recipientEncryptionTargetCapabilities RecipientEncryptionTarget
target of
        Maybe RecipientCapabilities
Nothing -> Bool
True
        Just RecipientCapabilities
caps -> RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support RecipientCapabilities
caps

    targetAdvertisesSEIPDv2Support :: RecipientEncryptionTarget -> Bool
    targetAdvertisesSEIPDv2Support :: RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv2Support RecipientEncryptionTarget
target =
      case RecipientEncryptionTarget -> Maybe RecipientCapabilities
recipientEncryptionTargetCapabilities RecipientEncryptionTarget
target of
        Maybe RecipientCapabilities
Nothing -> Bool
True
        Just RecipientCapabilities
caps -> RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv2Support RecipientCapabilities
caps

selectSymmetricAlgorithm ::
     RecipientCapabilityNegotiationMode
  -> RecipientEncryptRequest v
  -> MessageEncryptionPolicy
  -> [RecipientEncryptionTarget]
  -> Either PKESKEncryptError SymmetricAlgorithm
selectSymmetricAlgorithm :: forall (v :: SEIPDVersion).
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
selectSymmetricAlgorithm RecipientCapabilityNegotiationMode
negotiationMode RecipientEncryptRequest v
request MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets =
  case RecipientEncryptRequest v -> Maybe SymmetricAlgorithm
forall (v :: SEIPDVersion).
RecipientEncryptRequest v -> Maybe SymmetricAlgorithm
recipientEncryptRequestSymmetricOverride RecipientEncryptRequest v
request of
    Just SymmetricAlgorithm
override -> SymmetricAlgorithm -> Either PKESKEncryptError SymmetricAlgorithm
forall a b. b -> Either a b
Right SymmetricAlgorithm
override
    Maybe SymmetricAlgorithm
Nothing ->
      case RecipientCapabilityNegotiationMode
negotiationMode of
        RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOff ->
          SymmetricAlgorithm -> Either PKESKEncryptError SymmetricAlgorithm
forall a b. b -> Either a b
Right (MessageEncryptionPolicy -> SymmetricAlgorithm
messageDefaultSymmetricAlgorithm MessageEncryptionPolicy
messagePolicy)
        RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOn ->
          MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
negotiateSymmetricAlgorithm MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets

selectAEADAlgorithm ::
     RecipientCapabilityNegotiationMode
  -> MessageEncryptionPolicy
  -> [RecipientEncryptionTarget]
  -> Maybe AEADAlgorithm
  -> Either PKESKEncryptError AEADAlgorithm
selectAEADAlgorithm :: RecipientCapabilityNegotiationMode
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Maybe AEADAlgorithm
-> Either PKESKEncryptError AEADAlgorithm
selectAEADAlgorithm RecipientCapabilityNegotiationMode
negotiationMode MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets Maybe AEADAlgorithm
override =
  case Maybe AEADAlgorithm
override of
    Just AEADAlgorithm
explicit -> AEADAlgorithm -> Either PKESKEncryptError AEADAlgorithm
forall a b. b -> Either a b
Right AEADAlgorithm
explicit
    Maybe AEADAlgorithm
Nothing ->
      case RecipientCapabilityNegotiationMode
negotiationMode of
        RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOff ->
          AEADAlgorithm -> Either PKESKEncryptError AEADAlgorithm
forall a b. b -> Either a b
Right (MessageEncryptionPolicy -> AEADAlgorithm
messageDefaultAEADAlgorithm MessageEncryptionPolicy
messagePolicy)
        RecipientCapabilityNegotiationMode
RecipientCapabilityNegotiationOn ->
          MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError AEADAlgorithm
negotiateAEADAlgorithm MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets

negotiateSymmetricAlgorithm ::
     MessageEncryptionPolicy
  -> [RecipientEncryptionTarget]
  -> Either PKESKEncryptError SymmetricAlgorithm
negotiateSymmetricAlgorithm :: MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
negotiateSymmetricAlgorithm MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets =
  [SymmetricAlgorithm]
-> [[SymmetricAlgorithm]]
-> RecipientCapabilityError
-> Either PKESKEncryptError SymmetricAlgorithm
forall a.
Eq a =>
[a]
-> [[a]] -> RecipientCapabilityError -> Either PKESKEncryptError a
chooseCommonAlgorithm
    [SymmetricAlgorithm]
policyOrder
    [[SymmetricAlgorithm]]
recipientChoices
    ([SymmetricAlgorithm] -> RecipientCapabilityError
RecipientCapabilityNoCommonSymmetricAlgorithms ([[SymmetricAlgorithm]] -> [SymmetricAlgorithm]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SymmetricAlgorithm]]
recipientChoices))
  where
    policyOrder :: [SymmetricAlgorithm]
policyOrder =
      case MessageEncryptionPolicy -> [SymmetricAlgorithm]
messageSEIPDv2SymmetricAlgorithms MessageEncryptionPolicy
messagePolicy of
        [] -> [MessageEncryptionPolicy -> SymmetricAlgorithm
messageDefaultSymmetricAlgorithm MessageEncryptionPolicy
messagePolicy]
        [SymmetricAlgorithm]
syms -> [SymmetricAlgorithm]
syms
    recipientChoices :: [[SymmetricAlgorithm]]
recipientChoices = (RecipientEncryptionTarget -> [SymmetricAlgorithm])
-> [RecipientEncryptionTarget] -> [[SymmetricAlgorithm]]
forall a b. (a -> b) -> [a] -> [b]
map RecipientEncryptionTarget -> [SymmetricAlgorithm]
choicesForTarget [RecipientEncryptionTarget]
targets
    choicesForTarget :: RecipientEncryptionTarget -> [SymmetricAlgorithm]
choicesForTarget RecipientEncryptionTarget
target =
      case RecipientEncryptionTarget -> Maybe RecipientCapabilities
recipientEncryptionTargetCapabilities RecipientEncryptionTarget
target of
        Just RecipientCapabilities
caps ->
          let preferred :: [SymmetricAlgorithm]
preferred = RecipientCapabilities -> [SymmetricAlgorithm]
recipientCapabilityPreferredSymmetricAlgorithms RecipientCapabilities
caps
              allowed :: [SymmetricAlgorithm]
allowed = [SymmetricAlgorithm
alg | SymmetricAlgorithm
alg <- [SymmetricAlgorithm]
policyOrder, SymmetricAlgorithm
alg SymmetricAlgorithm -> [SymmetricAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SymmetricAlgorithm]
preferred]
           in if [SymmetricAlgorithm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SymmetricAlgorithm]
allowed
                then [SymmetricAlgorithm]
policyOrder
                else [SymmetricAlgorithm]
allowed
        Maybe RecipientCapabilities
Nothing -> [SymmetricAlgorithm]
policyOrder

negotiateAEADAlgorithm ::
     MessageEncryptionPolicy
  -> [RecipientEncryptionTarget]
  -> Either PKESKEncryptError AEADAlgorithm
negotiateAEADAlgorithm :: MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError AEADAlgorithm
negotiateAEADAlgorithm MessageEncryptionPolicy
messagePolicy [RecipientEncryptionTarget]
targets =
  [AEADAlgorithm]
-> [[AEADAlgorithm]]
-> RecipientCapabilityError
-> Either PKESKEncryptError AEADAlgorithm
forall a.
Eq a =>
[a]
-> [[a]] -> RecipientCapabilityError -> Either PKESKEncryptError a
chooseCommonAlgorithm
    [AEADAlgorithm]
policyOrder
    [[AEADAlgorithm]]
recipientChoices
    ([AEADAlgorithm] -> RecipientCapabilityError
RecipientCapabilityNoCommonAEADAlgorithms ([[AEADAlgorithm]] -> [AEADAlgorithm]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AEADAlgorithm]]
recipientChoices))
  where
    policyOrder :: [AEADAlgorithm]
policyOrder = ([AEADAlgorithm] -> AEADAlgorithm -> [AEADAlgorithm])
-> [AEADAlgorithm] -> [AEADAlgorithm] -> [AEADAlgorithm]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [AEADAlgorithm] -> AEADAlgorithm -> [AEADAlgorithm]
forall {a}. Eq a => [a] -> a -> [a]
addIfMissing [] (MessageEncryptionPolicy -> AEADAlgorithm
messageDefaultAEADAlgorithm MessageEncryptionPolicy
messagePolicy AEADAlgorithm -> [AEADAlgorithm] -> [AEADAlgorithm]
forall a. a -> [a] -> [a]
: [AEADAlgorithm
OCB, AEADAlgorithm
EAX, AEADAlgorithm
GCM])
    recipientChoices :: [[AEADAlgorithm]]
recipientChoices = (RecipientEncryptionTarget -> [AEADAlgorithm])
-> [RecipientEncryptionTarget] -> [[AEADAlgorithm]]
forall a b. (a -> b) -> [a] -> [b]
map RecipientEncryptionTarget -> [AEADAlgorithm]
choicesForTarget [RecipientEncryptionTarget]
targets
    choicesForTarget :: RecipientEncryptionTarget -> [AEADAlgorithm]
choicesForTarget RecipientEncryptionTarget
target =
      case RecipientEncryptionTarget -> Maybe RecipientCapabilities
recipientEncryptionTargetCapabilities RecipientEncryptionTarget
target of
        Just RecipientCapabilities
caps ->
          let preferred :: [AEADAlgorithm]
preferred = RecipientCapabilities -> [AEADAlgorithm]
recipientCapabilityPreferredAEADAlgorithms RecipientCapabilities
caps
              allowed :: [AEADAlgorithm]
allowed = [AEADAlgorithm
alg | AEADAlgorithm
alg <- [AEADAlgorithm]
policyOrder, AEADAlgorithm
alg AEADAlgorithm -> [AEADAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AEADAlgorithm]
preferred]
           in if [AEADAlgorithm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AEADAlgorithm]
allowed
                then [AEADAlgorithm]
policyOrder
                else [AEADAlgorithm]
allowed
        Maybe RecipientCapabilities
Nothing -> [AEADAlgorithm]
policyOrder
    addIfMissing :: [a] -> a -> [a]
addIfMissing [a]
acc a
x
      | a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
acc = [a]
acc
      | Bool
otherwise = [a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]

chooseCommonAlgorithm ::
     Eq a
  => [a]
  -> [[a]]
  -> RecipientCapabilityError
  -> Either PKESKEncryptError a
chooseCommonAlgorithm :: forall a.
Eq a =>
[a]
-> [[a]] -> RecipientCapabilityError -> Either PKESKEncryptError a
chooseCommonAlgorithm [a]
policyOrder [[a]]
recipientChoices RecipientCapabilityError
err =
  case [[a]]
recipientChoices of
    [] -> PKESKEncryptError -> Either PKESKEncryptError a
forall a b. a -> Either a b
Left (RecipientCapabilityError -> PKESKEncryptError
RecipientCapabilitySelectionFailure RecipientCapabilityError
err)
    ([a]
firstChoices:[[a]]
restChoices) ->
      let common :: [a]
common = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [a] -> [a] -> [a]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
intersectOrdered [a]
firstChoices [[a]]
restChoices
          orderedCommon :: [a]
orderedCommon = [a
alg | a
alg <- [a]
policyOrder, a
alg a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
common]
       in case [a]
orderedCommon of
            (a
selected:[a]
_) -> a -> Either PKESKEncryptError a
forall a b. b -> Either a b
Right a
selected
            [] -> PKESKEncryptError -> Either PKESKEncryptError a
forall a b. a -> Either a b
Left (RecipientCapabilityError -> PKESKEncryptError
RecipientCapabilitySelectionFailure RecipientCapabilityError
err)
  where
    intersectOrdered :: [a] -> t a -> [a]
intersectOrdered [a]
as t a
bs = [a
a | a
a <- [a]
as, a
a a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
bs]

promoteRecipientStrategy ::
     RecipientPKESKVersionStrategy
  -> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy :: RecipientPKESKVersionStrategy -> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy RecipientPKESKVersionStrategy
RecipientPreferV6 =
  RecipientPKESKVersionStrategyW 'RecipientPreferV6
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientPreferV6
RecipientPreferV6W
promoteRecipientStrategy RecipientPKESKVersionStrategy
RecipientForceV3Interop =
  RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
-> SomeRecipientPKESKVersionStrategyW
forall (profile :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW profile
-> SomeRecipientPKESKVersionStrategyW
SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
RecipientForceV3InteropW

demoteRecipientStrategy ::
     RecipientPKESKVersionStrategyW strategy
  -> RecipientPKESKVersionStrategy
demoteRecipientStrategy :: forall (strategy :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
demoteRecipientStrategy RecipientPKESKVersionStrategyW strategy
RecipientPreferV6W = RecipientPKESKVersionStrategy
RecipientPreferV6
demoteRecipientStrategy RecipientPKESKVersionStrategyW strategy
RecipientForceV3InteropW = RecipientPKESKVersionStrategy
RecipientForceV3Interop

demoteSomeRecipientStrategy ::
     SomeRecipientPKESKVersionStrategyW
  -> RecipientPKESKVersionStrategy
demoteSomeRecipientStrategy :: SomeRecipientPKESKVersionStrategyW -> RecipientPKESKVersionStrategy
demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW RecipientPKESKVersionStrategyW strategy
strategyW) =
  RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
forall (strategy :: RecipientPKESKVersionStrategy).
RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
demoteRecipientStrategy RecipientPKESKVersionStrategyW strategy
strategyW

promoteEncryptCompatibilityProfile ::
     EncryptCompatibilityProfile
  -> SomeEncryptCompatibilityProfileW
promoteEncryptCompatibilityProfile :: EncryptCompatibilityProfile -> SomeEncryptCompatibilityProfileW
promoteEncryptCompatibilityProfile EncryptCompatibilityProfile
EncryptStrictDefault =
  EncryptCompatibilityProfileW 'EncryptStrictDefault
-> SomeEncryptCompatibilityProfileW
forall (profile :: EncryptCompatibilityProfile).
EncryptCompatibilityProfileW profile
-> SomeEncryptCompatibilityProfileW
SomeEncryptCompatibilityProfileW EncryptCompatibilityProfileW 'EncryptStrictDefault
EncryptStrictDefaultW
promoteEncryptCompatibilityProfile EncryptCompatibilityProfile
EncryptInteropLegacy =
  EncryptCompatibilityProfileW 'EncryptInteropLegacy
-> SomeEncryptCompatibilityProfileW
forall (profile :: EncryptCompatibilityProfile).
EncryptCompatibilityProfileW profile
-> SomeEncryptCompatibilityProfileW
SomeEncryptCompatibilityProfileW EncryptCompatibilityProfileW 'EncryptInteropLegacy
EncryptInteropLegacyW

-- | High-level encrypt-side helper for public-key recipient encryption.
--
-- Returns a complete packet sequence:
-- @[PKESK ..., SEIPD2 ...]@.









buildEncryptedPacketSequence ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> RecipientPayloadShape
  -> Salt
  -> SessionKey
  -> [Pkt]
  -> B.ByteString
  -> Either String [Pkt]
buildEncryptedPacketSequence :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> RecipientPayloadShape
-> Salt
-> SessionKey
-> [Pkt]
-> ByteString
-> Either String [Pkt]
buildEncryptedPacketSequence SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize RecipientPayloadShape
payloadShape Salt
salt SessionKey
sessionKey [Pkt]
pkesks ByteString
payload =
  (PKESKEncryptError -> String)
-> Either PKESKEncryptError [Pkt] -> Either String [Pkt]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PKESKEncryptError -> String
renderPKESKEncryptError
    (SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> RecipientPayloadShape
-> Salt
-> SessionKey
-> [Pkt]
-> ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShape SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize RecipientPayloadShape
payloadShape Salt
salt SessionKey
sessionKey [Pkt]
pkesks ByteString
payload)

buildEncryptedPacketSequenceWithShape ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> RecipientPayloadShape
  -> Salt
  -> SessionKey
  -> [Pkt]
  -> B.ByteString
  -> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShape :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> RecipientPayloadShape
-> Salt
-> SessionKey
-> [Pkt]
-> ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShape SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize RecipientPayloadShape
payloadShape Salt
salt SessionKey
sessionKey [Pkt]
pkesks ByteString
payload = do
  onePassSignatures <- (OPSBuildError -> PKESKEncryptError)
-> Either OPSBuildError [Pkt] -> Either PKESKEncryptError [Pkt]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> PKESKEncryptError
PayloadBuildFailure (String -> PKESKEncryptError)
-> (OPSBuildError -> String) -> OPSBuildError -> PKESKEncryptError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OPSBuildError -> String
renderOPSBuildError) (RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets RecipientPayloadShape
payloadShape)
  let signatures = RecipientPayloadShape -> [SignaturePayload]
recipientPayloadSignatures RecipientPayloadShape
payloadShape
      literalBlock =
        [Pkt] -> Block Pkt
forall a. [a] -> Block a
Block
          ([Pkt]
onePassSignatures [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
           [ DataType
-> ByteString -> ThirtyTwoBitTimeStamp -> ByteString -> Pkt
LiteralDataPkt
               (RecipientPayloadShape -> DataType
recipientPayloadDataType RecipientPayloadShape
payloadShape)
               (RecipientPayloadShape -> ByteString
recipientPayloadFileName RecipientPayloadShape
payloadShape)
               (RecipientPayloadShape -> ThirtyTwoBitTimeStamp
recipientPayloadTimestamp RecipientPayloadShape
payloadShape)
               (ByteString -> ByteString
BL.fromStrict ByteString
payload)
           ] [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
           (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt [SignaturePayload]
signatures)
  ciphertext <-
    first PayloadBuildFailure $
    encryptSEIPDv2Payload
      symalgo
      aead
      chunkSize
      salt
      sessionKey
      (BL.toStrict (runPut (put literalBlock)))
  Right
    (pkesks ++
     [SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext))])

-- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext.
encryptSEIPDv1Payload ::
     SymmetricAlgorithm
  -> IV
  -> SessionKey
  -> B.ByteString  -- ^ inner packet block plaintext
  -> Either String B.ByteString
encryptSEIPDv1Payload :: SymmetricAlgorithm
-> IV -> SessionKey -> ByteString -> Either String ByteString
encryptSEIPDv1Payload SymmetricAlgorithm
symalgo IV
iv (SessionKey ByteString
keyBytes) ByteString
plaintext =
  let cleartextWithMDC :: ByteString
cleartextWithMDC = ByteString
plaintext ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> IV -> ByteString -> ByteString
mdcTrailerForSEIPDv1 IV
iv ByteString
plaintext
  in (CipherError -> String)
-> Either CipherError ByteString -> Either String ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
       CipherError -> String
renderCipherError
       (OpenPGPCFBModeW 'OpenPGPCFBNoResync
-> SymmetricAlgorithm
-> IV
-> ByteString
-> ByteString
-> Either CipherError ByteString
forall (mode :: OpenPGPCFBMode).
OpenPGPCFBModeW mode
-> SymmetricAlgorithm
-> IV
-> ByteString
-> ByteString
-> Either CipherError ByteString
encryptOpenPGPCfbRaw OpenPGPCFBModeW 'OpenPGPCFBNoResync
OpenPGPCFBNoResyncW SymmetricAlgorithm
symalgo IV
iv ByteString
cleartextWithMDC ByteString
keyBytes)

-- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC).
buildEncryptedPacketSequenceWithShapeSEIPDv1 ::
     SymmetricAlgorithm
  -> IV
  -> RecipientPayloadShape
  -> SessionKey
  -> [Pkt]
  -> B.ByteString
  -> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShapeSEIPDv1 :: SymmetricAlgorithm
-> IV
-> RecipientPayloadShape
-> SessionKey
-> [Pkt]
-> ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShapeSEIPDv1 SymmetricAlgorithm
symalgo IV
iv RecipientPayloadShape
payloadShape SessionKey
sessionKey [Pkt]
pkesks ByteString
payload = do
  onePassSignatures <- (OPSBuildError -> PKESKEncryptError)
-> Either OPSBuildError [Pkt] -> Either PKESKEncryptError [Pkt]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> PKESKEncryptError
PayloadBuildFailure (String -> PKESKEncryptError)
-> (OPSBuildError -> String) -> OPSBuildError -> PKESKEncryptError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OPSBuildError -> String
renderOPSBuildError) (RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets RecipientPayloadShape
payloadShape)
  let signatures = RecipientPayloadShape -> [SignaturePayload]
recipientPayloadSignatures RecipientPayloadShape
payloadShape
      literalBlock =
        [Pkt] -> Block Pkt
forall a. [a] -> Block a
Block
          ([Pkt]
onePassSignatures [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
           [ DataType
-> ByteString -> ThirtyTwoBitTimeStamp -> ByteString -> Pkt
LiteralDataPkt
               (RecipientPayloadShape -> DataType
recipientPayloadDataType RecipientPayloadShape
payloadShape)
               (RecipientPayloadShape -> ByteString
recipientPayloadFileName RecipientPayloadShape
payloadShape)
               (RecipientPayloadShape -> ThirtyTwoBitTimeStamp
recipientPayloadTimestamp RecipientPayloadShape
payloadShape)
               (ByteString -> ByteString
BL.fromStrict ByteString
payload)
           ] [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
           (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt [SignaturePayload]
signatures)
  ciphertext <-
    first PayloadBuildFailure $
    encryptSEIPDv1Payload symalgo iv sessionKey (BL.toStrict (runPut (put literalBlock)))
  Right
    (pkesks ++
     [SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))])

buildOnePassSignaturePackets :: RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets :: RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets RecipientPayloadShape
payloadShape
  | Bool -> Bool
not (RecipientPayloadShape -> Bool
recipientPayloadUseOnePassSignatures RecipientPayloadShape
payloadShape) = [Pkt] -> Either OPSBuildError [Pkt]
forall a b. b -> Either a b
Right []
  | [SignaturePayload] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignaturePayload]
signatures = [Pkt] -> Either OPSBuildError [Pkt]
forall a b. b -> Either a b
Right []
  | Bool
otherwise =
      ([OnePassSignaturePayload] -> [Pkt])
-> Either OPSBuildError [OnePassSignaturePayload]
-> Either OPSBuildError [Pkt]
forall a b.
(a -> b) -> Either OPSBuildError a -> Either OPSBuildError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OnePassSignaturePayload -> Pkt)
-> [OnePassSignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map OnePassSignaturePayload -> Pkt
OnePassSignaturePkt) (Either OPSBuildError [OnePassSignaturePayload]
 -> Either OPSBuildError [Pkt])
-> Either OPSBuildError [OnePassSignaturePayload]
-> Either OPSBuildError [Pkt]
forall a b. (a -> b) -> a -> b
$
      [Either OPSBuildError OnePassSignaturePayload]
-> Either OPSBuildError [OnePassSignaturePayload]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Bool
 -> SignaturePayload
 -> Either OPSBuildError OnePassSignaturePayload)
-> [Bool]
-> [SignaturePayload]
-> [Either OPSBuildError OnePassSignaturePayload]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool
-> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload
buildOnePassSignature [Bool]
nestedFlags ([SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a]
reverse [SignaturePayload]
signatures))
  where
    signatures :: [SignaturePayload]
signatures = RecipientPayloadShape -> [SignaturePayload]
recipientPayloadSignatures RecipientPayloadShape
payloadShape
    nestedFlags :: [Bool]
nestedFlags = Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate ([SignaturePayload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignaturePayload]
signatures Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool
True [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool
False]

data OnePassSignatureBuildCase where
  OnePassSignatureBuildCaseV3 ::
       SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase
  OnePassSignatureBuildCaseV4 ::
       SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase
  OnePassSignatureBuildCaseV6 ::
       SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase
  OnePassSignatureBuildCaseOther ::
       PacketVersion -> OnePassSignatureBuildCase

onePassSignatureBuildCase :: SignaturePayload -> OnePassSignatureBuildCase
onePassSignatureBuildCase :: SignaturePayload -> OnePassSignatureBuildCase
onePassSignatureBuildCase SignaturePayload
sig =
  case SignaturePayload -> SomeSignaturePayload
toSomeSignaturePayload SignaturePayload
sig of
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV3Data {}) ->
      SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseV3 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV3
payload
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV4Data {}) ->
      SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseV4 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV4
payload
    SomeSignaturePayload (payload :: SignaturePayloadV v
payload@SigPayloadV6Data {}) ->
      SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseV6 SignaturePayloadV v
SignaturePayloadV 'SigPayloadV6
payload
    SomeSignaturePayload (SigPayloadOtherData Word8
version ByteString
_) ->
      Word8 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseOther Word8
version

buildOnePassSignature :: NestedFlag -> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload
buildOnePassSignature :: Bool
-> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload
buildOnePassSignature Bool
nestedFlag SignaturePayload
sig =
  case SignaturePayload -> OnePassSignatureBuildCase
onePassSignatureBuildCase SignaturePayload
sig of
    OnePassSignatureBuildCaseV3 (SigPayloadV3Data SigType
sigType ThirtyTwoBitTimeStamp
_ EightOctetKeyId
issuerKeyId PubKeyAlgorithm
pubkeyAlgo HashAlgorithm
hashAlgo Word16
_ NonEmpty MPI
_) ->
      OnePassSignaturePayload
-> Either OPSBuildError OnePassSignaturePayload
forall a b. b -> Either a b
Right
        (OPSPayloadV3 -> OnePassSignaturePayload
OPSPayloadV3Packet
           (Word8
-> SigType
-> HashAlgorithm
-> PubKeyAlgorithm
-> EightOctetKeyId
-> Bool
-> OPSPayloadV3
OPSPayloadV3 Word8
3 SigType
sigType HashAlgorithm
hashAlgo PubKeyAlgorithm
pubkeyAlgo EightOctetKeyId
issuerKeyId Bool
nestedFlag))
    OnePassSignatureBuildCaseV4 (SigPayloadV4Data SigType
sigType PubKeyAlgorithm
pubkeyAlgo HashAlgorithm
hashAlgo [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets Word16
_ NonEmpty MPI
_) ->
      case [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId
signatureIssuerKeyId [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets of
        Just EightOctetKeyId
issuerKeyId ->
          OnePassSignaturePayload
-> Either OPSBuildError OnePassSignaturePayload
forall a b. b -> Either a b
Right
            (OPSPayloadV3 -> OnePassSignaturePayload
OPSPayloadV3Packet
               (Word8
-> SigType
-> HashAlgorithm
-> PubKeyAlgorithm
-> EightOctetKeyId
-> Bool
-> OPSPayloadV3
OPSPayloadV3 Word8
3 SigType
sigType HashAlgorithm
hashAlgo PubKeyAlgorithm
pubkeyAlgo EightOctetKeyId
issuerKeyId Bool
nestedFlag))
        Maybe EightOctetKeyId
Nothing ->
          OPSBuildError -> Either OPSBuildError OnePassSignaturePayload
forall a b. a -> Either a b
Left OPSBuildError
OPSBuildMissingIssuerKeyId
    OnePassSignatureBuildCaseV6 (SigPayloadV6Data SigType
sigType PubKeyAlgorithm
pubkeyAlgo HashAlgorithm
hashAlgo SignatureSalt
salt [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets Word16
_ NonEmpty MPI
_) ->
      case Word8 -> [SigSubPacket] -> [SigSubPacket] -> Maybe ByteString
signatureIssuerFingerprint (IssuerFingerprintVersion -> Word8
BTypes.issuerFingerprintVersionToPacketVersion IssuerFingerprintVersion
BTypes.IssuerFingerprintV6) [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets of
        Just ByteString
signerFingerprint
          | ByteString -> Int64
BL.length ByteString
signerFingerprint Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
32 ->
              OnePassSignaturePayload
-> Either OPSBuildError OnePassSignaturePayload
forall a b. b -> Either a b
Right
                (OPSPayloadV6 -> OnePassSignaturePayload
OPSPayloadV6Packet
                   (SigType
-> HashAlgorithm
-> PubKeyAlgorithm
-> SignatureSalt
-> ByteString
-> Bool
-> OPSPayloadV6
OPSPayloadV6 SigType
sigType HashAlgorithm
hashAlgo PubKeyAlgorithm
pubkeyAlgo SignatureSalt
salt ByteString
signerFingerprint Bool
nestedFlag))
          | Bool
otherwise ->
              OPSBuildError -> Either OPSBuildError OnePassSignaturePayload
forall a b. a -> Either a b
Left (Int64 -> OPSBuildError
OPSBuildFingerprintWrongLength (ByteString -> Int64
BL.length ByteString
signerFingerprint))
        Maybe ByteString
Nothing ->
          OPSBuildError -> Either OPSBuildError OnePassSignaturePayload
forall a b. a -> Either a b
Left OPSBuildError
OPSBuildMissingIssuerFingerprint
    OnePassSignatureBuildCaseOther Word8
version ->
      OPSBuildError -> Either OPSBuildError OnePassSignaturePayload
forall a b. a -> Either a b
Left (Word8 -> OPSBuildError
OPSBuildUnsupportedSigVersion Word8
version)

signatureIssuerKeyId :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId
signatureIssuerKeyId :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId
signatureIssuerKeyId [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets =
  case [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId [SigSubPacket]
hashedSubpackets of
    Just EightOctetKeyId
issuerKeyId -> EightOctetKeyId -> Maybe EightOctetKeyId
forall a. a -> Maybe a
Just EightOctetKeyId
issuerKeyId
    Maybe EightOctetKeyId
Nothing ->
      case [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId [SigSubPacket]
unhashedSubpackets of
        Just EightOctetKeyId
issuerKeyId -> EightOctetKeyId -> Maybe EightOctetKeyId
forall a. a -> Maybe a
Just EightOctetKeyId
issuerKeyId
        Maybe EightOctetKeyId
Nothing ->
          case Word8 -> [SigSubPacket] -> [SigSubPacket] -> Maybe ByteString
signatureIssuerFingerprint (IssuerFingerprintVersion -> Word8
BTypes.issuerFingerprintVersionToPacketVersion IssuerFingerprintVersion
BTypes.IssuerFingerprintV4) [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets of
            Just ByteString
issuerFingerprintBytes ->
              if ByteString -> Int64
BL.length ByteString
issuerFingerprintBytes Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
8
                    then
                      EightOctetKeyId -> Maybe EightOctetKeyId
forall a. a -> Maybe a
Just
                        (ByteString -> EightOctetKeyId
EightOctetKeyId
                           (Int64 -> ByteString -> ByteString
BL.drop (ByteString -> Int64
BL.length ByteString
issuerFingerprintBytes Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
8) ByteString
issuerFingerprintBytes))
                    else Maybe EightOctetKeyId
forall a. Maybe a
Nothing
            Maybe ByteString
Nothing -> Maybe EightOctetKeyId
forall a. Maybe a
Nothing

signatureIssuerFingerprint ::
     PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe BL.ByteString
signatureIssuerFingerprint :: Word8 -> [SigSubPacket] -> [SigSubPacket] -> Maybe ByteString
signatureIssuerFingerprint Word8
expectedVersion [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets =
  Fingerprint -> ByteString
unFingerprint (Fingerprint -> ByteString)
-> Maybe Fingerprint -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprint Word8
expectedVersion [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets

findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId [SigSubPacket]
subpackets =
  case (SigSubPacket -> Bool) -> [SigSubPacket] -> Maybe SigSubPacket
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find SigSubPacket -> Bool
isIssuerKeyIdSubpacket [SigSubPacket]
subpackets of
    Just (SigSubPacket Bool
_ (Issuer EightOctetKeyId
issuerKeyId)) -> EightOctetKeyId -> Maybe EightOctetKeyId
forall a. a -> Maybe a
Just EightOctetKeyId
issuerKeyId
    Maybe SigSubPacket
_ -> Maybe EightOctetKeyId
forall a. Maybe a
Nothing

findIssuerFingerprint ::
     PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprint :: Word8 -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprint Word8
expectedVersion [SigSubPacket]
hashedSubpackets [SigSubPacket]
unhashedSubpackets =
  case Word8 -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn Word8
expectedVersion [SigSubPacket]
hashedSubpackets of
    Just Fingerprint
issuerFingerprint -> Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just Fingerprint
issuerFingerprint
    Maybe Fingerprint
Nothing -> Word8 -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn Word8
expectedVersion [SigSubPacket]
unhashedSubpackets

findIssuerFingerprintIn :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn :: Word8 -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn Word8
expectedVersion [SigSubPacket]
subpackets =
  case (SigSubPacket -> Bool) -> [SigSubPacket] -> Maybe SigSubPacket
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word8 -> SigSubPacket -> Bool
isIssuerFingerprintSubpacket Word8
expectedVersion) [SigSubPacket]
subpackets of
    Just (SigSubPacket Bool
_ (IssuerFingerprint IssuerFingerprintVersion
_ Fingerprint
issuerFingerprint)) -> Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just Fingerprint
issuerFingerprint
    Maybe SigSubPacket
_ -> Maybe Fingerprint
forall a. Maybe a
Nothing

isIssuerKeyIdSubpacket :: SigSubPacket -> Bool
isIssuerKeyIdSubpacket :: SigSubPacket -> Bool
isIssuerKeyIdSubpacket (SigSubPacket Bool
_ (Issuer EightOctetKeyId
_)) = Bool
True
isIssuerKeyIdSubpacket SigSubPacket
_ = Bool
False

isIssuerFingerprintSubpacket :: PacketVersion -> SigSubPacket -> Bool
isIssuerFingerprintSubpacket :: Word8 -> SigSubPacket -> Bool
isIssuerFingerprintSubpacket Word8
expectedVersion (SigSubPacket Bool
_ (IssuerFingerprint IssuerFingerprintVersion
version Fingerprint
_)) =
  IssuerFingerprintVersion -> Word8
BTypes.issuerFingerprintVersionToPacketVersion IssuerFingerprintVersion
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
expectedVersion
isIssuerFingerprintSubpacket Word8
_ SigSubPacket
_ = Bool
False

buildRsaPKESKv6 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    RSAPubKey (RSA_PublicKey PublicKey
publicKey) -> do
      encrypted <- PublicKey -> ByteString -> m (Either Error ByteString)
forall (m :: * -> *).
MonadRandom m =>
PublicKey -> ByteString -> m (Either Error ByteString)
RSA15.encrypt PublicKey
publicKey (PKESKSessionMaterial -> ByteString
pkeskEncodedSessionMaterial PKESKSessionMaterial
material)
      pure $
        fmap
          (\ByteString
esk ->
             let mpiEsk :: ByteString
mpiEsk = Put -> ByteString
runPut (MPI -> Put
forall t. Binary t => t -> Put
put (Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
esk)))
              in ByteString -> PubKeyAlgorithm -> ByteString -> PKESKPayloadV6
PKESKPayloadV6 (SomePKPayload -> ByteString
recipientKeyIdentifier SomePKPayload
recipient) PubKeyAlgorithm
RSA ByteString
mpiEsk)
          (first (RecipientKeyWrapFailure RSA . show) encrypted)
    PKey
_ ->
      Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV6
forall a b. a -> Either a b
Left
           (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
              PubKeyAlgorithm
RSA
              String
"recipient PKPayload does not contain an RSA public key"))

buildRsaPKESKv3 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV3SessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 SomePKPayload
recipient PKESKV3SessionMaterial
material =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    RSAPubKey (RSA_PublicKey PublicKey
publicKey) ->
      case SomePKPayload -> Either String EightOctetKeyId
eightOctetKeyID SomePKPayload
recipient of
        Left String
err ->
          Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
              (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                 (SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient)
                 (String
"failed to derive PKESKv3 recipient key ID: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)))
        Right EightOctetKeyId
eoki -> do
          encrypted <- PublicKey -> ByteString -> m (Either Error ByteString)
forall (m :: * -> *).
MonadRandom m =>
PublicKey -> ByteString -> m (Either Error ByteString)
RSA15.encrypt PublicKey
publicKey (PKESKV3SessionMaterial -> ByteString
unPKESKV3SessionMaterial PKESKV3SessionMaterial
material)
          pure $
            fmap
              (\ByteString
esk ->
                Word8
-> EightOctetKeyId
-> PubKeyAlgorithm
-> NonEmpty MPI
-> PKESKPayloadV3
PKESKPayloadV3
                  Word8
3
                  EightOctetKeyId
eoki
                  (SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient)
                  (Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
esk) MPI -> [MPI] -> NonEmpty MPI
forall a. a -> [a] -> NonEmpty a
:| []))
              (first (RecipientKeyWrapFailure (_pkalgo recipient) . show) encrypted)
    PKey
_ ->
      Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
           (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
              (SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
recipient)
              String
"recipient PKPayload does not contain an RSA public key"))

buildECDHPKESKv3 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV3SessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV3)
buildECDHPKESKv3 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildECDHPKESKv3 SomePKPayload
recipient PKESKV3SessionMaterial
material =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    ECDHPubKey PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ->
      case SomePKPayload -> Either String EightOctetKeyId
eightOctetKeyID SomePKPayload
recipient of
        Left String
err ->
          Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
           (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
              (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                 PubKeyAlgorithm
ECDH
                 (String
"failed to derive PKESKv3 recipient key ID: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)))
        Right EightOctetKeyId
eoki ->
          case PKey
ecdhPub of
           ECDSAPubKey (ECDSA_PublicKey PublicKey
recipientPub) -> do
             (ephemeralPub, ephemeralPriv) <- Curve -> m (PublicKey, PrivateKey)
forall (m :: * -> *).
MonadRandom m =>
Curve -> m (PublicKey, PrivateKey)
ECCGen.generate (PublicKey -> Curve
ECDSA.public_curve PublicKey
recipientPub)
             case point2MBS (ECDSA.public_q ephemeralPub) of
               Maybe ByteString
Nothing ->
                 Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                   (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
                      (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                         PubKeyAlgorithm
ECDH
                         String
"failed to serialize ECDH ephemeral point"))
               Just ByteString
ephemeralBytes ->
                 Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PKESKEncryptError PKESKPayloadV3
 -> m (Either PKESKEncryptError PKESKPayloadV3))
-> Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a b. (a -> b) -> a -> b
$
                 SomePKPayload
-> EightOctetKeyId
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> PKESKV3SessionMaterial
-> Either PKESKEncryptError PKESKPayloadV3
buildEcdhV3Payload
                   SomePKPayload
recipient
                   EightOctetKeyId
eoki
                   PubKeyAlgorithm
ECDH
                   PKey
ecdhPub
                   HashAlgorithm
kdfHA
                   SymmetricAlgorithm
kdfSA
                   ByteString
ephemeralBytes
                   (SharedKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
                      (Curve -> Integer -> PublicPoint -> SharedKey
ECCDH.getShared
                         (PublicKey -> Curve
ECDSA.public_curve PublicKey
recipientPub)
                         (PrivateKey -> Integer
ECDSA.private_d PrivateKey
ephemeralPriv)
                         (PublicKey -> PublicPoint
ECDSA.public_q PublicKey
recipientPub)) ::
                    B.ByteString)
                   PKESKV3SessionMaterial
material
           EdDSAPubKey EdSigningCurve
Ed25519 EdPoint
recipientPoint -> do
             ephSecretRaw <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32
             pure $
               do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)
                  ephSecret <-
                    first (RecipientKeyWrapFailure ECDH . show) .
                    CE.eitherCryptoError $
                    C25519.secretKey (leftPadTo 32 ephSecretRaw)
                  recipientPub <-
                    first (RecipientKeyWrapFailure ECDH . show) .
                    CE.eitherCryptoError $
                    C25519.publicKey recipientPublicBytes
                  let ephPublicBytes =
                        Word8 -> ByteString -> ByteString
B.cons Word8
0x40 (PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C25519.toPublic SecretKey
ephSecret) :: B.ByteString)
                      sharedSecret = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
recipientPub SecretKey
ephSecret) :: B.ByteString
                  buildEcdhV3Payload
                    recipient
                    eoki
                    ECDH
                    ecdhPub
                    kdfHA
                    kdfSA
                    ephPublicBytes
                    sharedSecret
                    material
           PKey
_ ->
             Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
               (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
                  (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                     PubKeyAlgorithm
ECDH
                     String
"recipient ECDH public key is not RFC6637-compatible"))
    PKey
_ ->
      Either PKESKEncryptError PKESKPayloadV3
-> m (Either PKESKEncryptError PKESKPayloadV3)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV3
forall a b. a -> Either a b
Left
           (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
             PubKeyAlgorithm
ECDH
             String
"recipient PKPayload does not contain ECDH public key material"))

buildECDHPKESKv6 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKSessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 SomePKPayload
recipient PKESKSessionMaterial
material =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    ECDHPubKey PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ->
      case PKey
ecdhPub of
        ECDSAPubKey (ECDSA_PublicKey PublicKey
recipientPub) -> do
          (ephemeralPub, ephemeralPriv) <- Curve -> m (PublicKey, PrivateKey)
forall (m :: * -> *).
MonadRandom m =>
Curve -> m (PublicKey, PrivateKey)
ECCGen.generate (PublicKey -> Curve
ECDSA.public_curve PublicKey
recipientPub)
          case point2MBS (ECDSA.public_q ephemeralPub) of
            Maybe ByteString
Nothing ->
              Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV6
forall a b. a -> Either a b
Left
                   (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                      PubKeyAlgorithm
ECDH
                      String
"failed to serialize ECDH ephemeral point"))
            Just ByteString
ephemeralBytes ->
              Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PKESKEncryptError PKESKPayloadV6
 -> m (Either PKESKEncryptError PKESKPayloadV6))
-> Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a b. (a -> b) -> a -> b
$
              SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> PKESKSessionMaterial
-> Either PKESKEncryptError PKESKPayloadV6
buildEcdhV6Esk
                SomePKPayload
recipient
                PubKeyAlgorithm
ECDH
                PKey
ecdhPub
                HashAlgorithm
kdfHA
                SymmetricAlgorithm
kdfSA
                ByteString
ephemeralBytes
                (SharedKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
                   (Curve -> Integer -> PublicPoint -> SharedKey
ECCDH.getShared
                      (PublicKey -> Curve
ECDSA.public_curve PublicKey
recipientPub)
                      (PrivateKey -> Integer
ECDSA.private_d PrivateKey
ephemeralPriv)
                      (PublicKey -> PublicPoint
ECDSA.public_q PublicKey
recipientPub)) ::
                 B.ByteString)
                PKESKSessionMaterial
material
        EdDSAPubKey EdSigningCurve
Ed25519 EdPoint
recipientPoint -> do
          ephSecretRaw <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32
          pure $
            do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)
               ephSecret <-
                 first (RecipientKeyWrapFailure ECDH . show) .
                 CE.eitherCryptoError $
                 C25519.secretKey (leftPadTo 32 ephSecretRaw)
               recipientPub <-
                 first (RecipientKeyWrapFailure ECDH . show) .
                 CE.eitherCryptoError $
                 C25519.publicKey recipientPublicBytes
               let ephPublicBytes = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C25519.toPublic SecretKey
ephSecret) :: B.ByteString
                   sharedSecret = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
recipientPub SecretKey
ephSecret) :: B.ByteString
               buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material
        EdDSAPubKey EdSigningCurve
Ed448 EdPoint
recipientPoint -> do
          ephSecretRaw <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
56
          pure $
            do recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint)
               ephSecret <-
                 first (RecipientKeyWrapFailure ECDH . show) .
                 CE.eitherCryptoError $
                 C448.secretKey (leftPadTo 56 ephSecretRaw)
               recipientPub <-
                 first (RecipientKeyWrapFailure ECDH . show) .
                 CE.eitherCryptoError $
                 C448.publicKey recipientPublicBytes
               let ephPublicBytes = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C448.toPublic SecretKey
ephSecret) :: B.ByteString
                   sharedSecret = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C448.dh PublicKey
recipientPub SecretKey
ephSecret) :: B.ByteString
               buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material
        PKey
_ ->
          Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV6
forall a b. a -> Either a b
Left
               (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
                  PubKeyAlgorithm
ECDH
                  String
"recipient ECDH public key is not ECDSA/X25519/X448-compatible"))
    PKey
_ ->
      Either PKESKEncryptError PKESKPayloadV6
-> m (Either PKESKEncryptError PKESKPayloadV6)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (PKESKEncryptError -> Either PKESKEncryptError PKESKPayloadV6
forall a b. a -> Either a b
Left
           (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
              PubKeyAlgorithm
ECDH
              String
"recipient PKPayload does not contain ECDH public key material"))

buildX25519PKESKv6 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV6RawSessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 SomePKPayload
recipient PKESKV6RawSessionMaterial
material = do
  ephSecretRaw <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32
  pure $
    do recipientPublic <- extractX25519RecipientPublic recipient
       ephSecret <-
         first (RecipientKeyWrapFailure X25519 . show) .
         CE.eitherCryptoError $
         C25519.secretKey (leftPadTo 32 ephSecretRaw)
       recipientPub <-
         first (RecipientKeyWrapFailure X25519 . show) .
         CE.eitherCryptoError $
         C25519.publicKey recipientPublic
       let ephPublicBytes = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C25519.toPublic SecretKey
ephSecret) :: B.ByteString
           sharedSecret = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
recipientPub SecretKey
ephSecret) :: B.ByteString
           kek = ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephPublicBytes ByteString
recipientPublic ByteString
sharedSecret
       wrapped <-
         first (RecipientKeyWrapFailure X25519) .
         aesKeyWrapRFC3394 AES128 kek $
         unPKESKV6RawSessionMaterial material
       esk <- encodeV6X25519Esk ephPublicBytes wrapped
       Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X25519 (BL.fromStrict esk))

buildX448PKESKv6 ::
     MonadRandom m
  => SomePKPayload
  -> PKESKV6RawSessionMaterial
  -> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 :: forall (m :: * -> *).
MonadRandom m =>
SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 SomePKPayload
recipient PKESKV6RawSessionMaterial
material = do
  ephSecretRaw <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
56
  pure $
    do recipientPublic <- extractX448RecipientPublic recipient
       ephSecret <-
         first (RecipientKeyWrapFailure X448 . show) .
         CE.eitherCryptoError $
         C448.secretKey (leftPadTo 56 ephSecretRaw)
       recipientPub <-
         first (RecipientKeyWrapFailure X448 . show) .
         CE.eitherCryptoError $
         C448.publicKey recipientPublic
       let ephPublicBytes = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C448.toPublic SecretKey
ephSecret) :: B.ByteString
           sharedSecret = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C448.dh PublicKey
recipientPub SecretKey
ephSecret) :: B.ByteString
           kek = ByteString -> ByteString -> ByteString -> ByteString
deriveX448Kek ByteString
ephPublicBytes ByteString
recipientPublic ByteString
sharedSecret
       wrapped <-
         first (RecipientKeyWrapFailure X448) .
         aesKeyWrapRFC3394 AES256 kek $
         unPKESKV6RawSessionMaterial material
       esk <- encodeV6X448Esk ephPublicBytes wrapped
       Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X448 (BL.fromStrict esk))

buildEcdhV6Esk :: SomePKPayload
  -> PubKeyAlgorithm
  -> PKey
  -> HashAlgorithm
  -> SymmetricAlgorithm
  -> B.ByteString
  -> B.ByteString
  -> PKESKSessionMaterial
  -> Either PKESKEncryptError PKESKPayloadV6
buildEcdhV6Esk :: SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> PKESKSessionMaterial
-> Either PKESKEncryptError PKESKPayloadV6
buildEcdhV6Esk SomePKPayload
recipient PubKeyAlgorithm
pka PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ByteString
ephemeralBytes ByteString
sharedSecret PKESKSessionMaterial
material = do
  kdfParam <-
    (String -> PKESKEncryptError)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKdfFailure PubKeyAlgorithm
pka) (Either String ByteString -> Either PKESKEncryptError ByteString)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b. (a -> b) -> a -> b
$
    SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> Either String ByteString
buildECDHKDFParam SomePKPayload
recipient PubKeyAlgorithm
pka PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA
  kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
  wrapped <-
    first (RecipientKeyWrapFailure pka) .
    aesKeyWrapRFC3394 kdfSA kek $
    padToMultipleOf8 (pkeskEncodedSessionMaterial material)
  esk <- encodeV6EcdhEsk ephemeralBytes wrapped
  Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) pka (BL.fromStrict esk))

buildEcdhV3Payload :: SomePKPayload
  -> EightOctetKeyId
  -> PubKeyAlgorithm
  -> PKey
  -> HashAlgorithm
  -> SymmetricAlgorithm
  -> B.ByteString
  -> B.ByteString
  -> PKESKV3SessionMaterial
  -> Either PKESKEncryptError PKESKPayloadV3
buildEcdhV3Payload :: SomePKPayload
-> EightOctetKeyId
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> PKESKV3SessionMaterial
-> Either PKESKEncryptError PKESKPayloadV3
buildEcdhV3Payload SomePKPayload
recipient EightOctetKeyId
eoki PubKeyAlgorithm
pka PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ByteString
ephemeralBytes ByteString
sharedSecret PKESKV3SessionMaterial
material = do
  kdfParam <-
    (String -> PKESKEncryptError)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKdfFailure PubKeyAlgorithm
pka) (Either String ByteString -> Either PKESKEncryptError ByteString)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b. (a -> b) -> a -> b
$
    SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> Either String ByteString
buildECDHKDFParam SomePKPayload
recipient PubKeyAlgorithm
pka PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA
  kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
  wrapped <-
    first (RecipientKeyWrapFailure pka) .
    aesKeyWrapRFC3394 kdfSA kek $
    padToMultipleOf8 (unPKESKV3SessionMaterial material)
  Right
    (PKESKPayloadV3
       3
       eoki
       pka
       (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)]))

recipientKeyIdentifier :: SomePKPayload -> BL.ByteString
recipientKeyIdentifier :: SomePKPayload -> ByteString
recipientKeyIdentifier = Fingerprint -> ByteString
unFingerprint (Fingerprint -> ByteString)
-> (SomePKPayload -> Fingerprint) -> SomePKPayload -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomePKPayload -> Fingerprint
fingerprint

encodeV6EcdhEsk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6EcdhEsk :: ByteString -> ByteString -> Either PKESKEncryptError ByteString
encodeV6EcdhEsk ByteString
ephemeral ByteString
wrapped = do
  let ephLen :: Int
ephLen = ByteString -> Int
B.length ByteString
ephemeral
  if Int
ephLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255
    then PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKeyWrapFailure PubKeyAlgorithm
ECDH String
"ephemeral key encoding is too large")
    else ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString
B.singleton (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ephLen) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ephemeral ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wrapped)

encodeV6X25519Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6X25519Esk :: ByteString -> ByteString -> Either PKESKEncryptError ByteString
encodeV6X25519Esk ByteString
ephemeral ByteString
wrapped
  | ByteString -> Int
B.length ByteString
ephemeral Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
32 =
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKeyWrapFailure PubKeyAlgorithm
X25519 String
"X25519 ephemeral key must be exactly 32 octets")
  | ByteString -> Int
B.length ByteString
wrapped Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255 =
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKeyWrapFailure PubKeyAlgorithm
X25519 String
"wrapped session key encoding is too large")
  | Bool
otherwise =
      ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right (ByteString
ephemeral ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
wrapped)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wrapped)

encodeV6X448Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6X448Esk :: ByteString -> ByteString -> Either PKESKEncryptError ByteString
encodeV6X448Esk ByteString
ephemeral ByteString
wrapped
  | ByteString -> Int
B.length ByteString
ephemeral Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
56 =
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKeyWrapFailure PubKeyAlgorithm
X448 String
"X448 ephemeral key must be exactly 56 octets")
  | ByteString -> Int
B.length ByteString
wrapped Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255 =
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left (PubKeyAlgorithm -> String -> PKESKEncryptError
RecipientKeyWrapFailure PubKeyAlgorithm
X448 String
"wrapped session key encoding is too large")
  | Bool
otherwise =
      ByteString -> Either PKESKEncryptError ByteString
forall a b. b -> Either a b
Right (ByteString
ephemeral ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
wrapped)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wrapped)

extractX25519RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX25519RecipientPublic :: SomePKPayload -> Either PKESKEncryptError ByteString
extractX25519RecipientPublic SomePKPayload
recipient =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    EdDSAPubKey EdSigningCurve
Ed25519 EdPoint
point ->
      ByteString -> Either PKESKEncryptError ByteString
normalizeX25519Public (EdPoint -> ByteString
edPointBytes EdPoint
point)
    ECDHPubKey (EdDSAPubKey EdSigningCurve
Ed25519 EdPoint
point) HashAlgorithm
_ SymmetricAlgorithm
_ ->
      ByteString -> Either PKESKEncryptError ByteString
normalizeX25519Public (EdPoint -> ByteString
edPointBytes EdPoint
point)
    PKey
other ->
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left
        (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
           PubKeyAlgorithm
X25519
           (String
"expected X25519-compatible recipient key, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PKey -> String
forall a. Show a => a -> String
show PKey
other))

extractX448RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX448RecipientPublic :: SomePKPayload -> Either PKESKEncryptError ByteString
extractX448RecipientPublic SomePKPayload
recipient =
  case SomePKPayload -> PKey
_pubkey SomePKPayload
recipient of
    EdDSAPubKey EdSigningCurve
Ed448 EdPoint
point ->
      ByteString -> Either PKESKEncryptError ByteString
normalizeX448Public (EdPoint -> ByteString
edPointBytes EdPoint
point)
    ECDHPubKey (EdDSAPubKey EdSigningCurve
Ed448 EdPoint
point) HashAlgorithm
_ SymmetricAlgorithm
_ ->
      ByteString -> Either PKESKEncryptError ByteString
normalizeX448Public (EdPoint -> ByteString
edPointBytes EdPoint
point)
    PKey
other ->
      PKESKEncryptError -> Either PKESKEncryptError ByteString
forall a b. a -> Either a b
Left
        (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial
           PubKeyAlgorithm
X448
           (String
"expected X448-compatible recipient key, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PKey -> String
forall a. Show a => a -> String
show PKey
other))

normalizeX25519Public :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX25519Public :: ByteString -> Either PKESKEncryptError ByteString
normalizeX25519Public =
  (String -> PKESKEncryptError)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial PubKeyAlgorithm
X25519) (Either String ByteString -> Either PKESKEncryptError ByteString)
-> (ByteString -> Either String ByteString)
-> ByteString
-> Either PKESKEncryptError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> String -> ByteString -> Either String ByteString
normalizeMontgomeryPublic
    Int
32
    String
"invalid X25519 public key length/prefix: "

normalizeX448Public :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX448Public :: ByteString -> Either PKESKEncryptError ByteString
normalizeX448Public =
  (String -> PKESKEncryptError)
-> Either String ByteString -> Either PKESKEncryptError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PubKeyAlgorithm -> String -> PKESKEncryptError
InvalidRecipientKeyMaterial PubKeyAlgorithm
X448) (Either String ByteString -> Either PKESKEncryptError ByteString)
-> (ByteString -> Either String ByteString)
-> ByteString
-> Either PKESKEncryptError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> String -> ByteString -> Either String ByteString
normalizeMontgomeryPublic
    Int
56
    String
"invalid X448 public key length/prefix: "

edPointBytes :: EdPoint -> B.ByteString
edPointBytes :: EdPoint -> ByteString
edPointBytes (PrefixedNativeEPoint (EPoint Integer
x)) = Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
x
edPointBytes (NativeEPoint (EPoint Integer
x)) = Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
x

deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX25519Kek :: ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephemeralPublic ByteString
recipientPublic ByteString
sharedSecret =
  let ikm :: ByteString
ikm = ByteString
ephemeralPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
recipientPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sharedSecret
      prk :: PRK SHA256
prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHAlg.SHA256 ByteString
B.empty ByteString
ikm
      info :: ByteString
info = ByteString
"OpenPGP X25519" :: B.ByteString
   in forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHAlg.SHA256 PRK SHA256
prk ByteString
info Int
16

deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX448Kek :: ByteString -> ByteString -> ByteString -> ByteString
deriveX448Kek ByteString
ephemeralPublic ByteString
recipientPublic ByteString
sharedSecret =
  let ikm :: ByteString
ikm = ByteString
ephemeralPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
recipientPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sharedSecret
      prk :: PRK SHA512
prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHAlg.SHA512 ByteString
B.empty ByteString
ikm
      info :: ByteString
info = ByteString
"OpenPGP X448" :: B.ByteString
   in forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHAlg.SHA512 PRK SHA512
prk ByteString
info Int
32

padToMultipleOf8 :: B.ByteString -> B.ByteString
padToMultipleOf8 :: ByteString -> ByteString
padToMultipleOf8 ByteString
bs
  | Int
padLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ByteString
bs
  | Bool
otherwise = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
B.replicate Int
padLen (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
padLen)
  where
    rem8 :: Int
rem8 = ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
    padLen :: Int
padLen = if Int
rem8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rem8

checksum16 :: B.ByteString -> Word16
checksum16 :: ByteString -> Word16
checksum16 =
  Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16)
-> (ByteString -> Integer) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' (\Integer
acc Word8
octet -> (Integer
acc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
octet) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` (Integer
65536 :: Integer)) Integer
0

checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes :: ByteString -> ByteString
checksum16Bytes ByteString
bs =
  [Word8] -> ByteString
B.pack
    [ Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word16
chk Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xff)
    , Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
chk Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xff)
    ]
  where
    chk :: Word16
chk = ByteString -> Word16
checksum16 ByteString
bs

aesKeyWrapRFC3394 ::
     SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString
aesKeyWrapRFC3394 :: SymmetricAlgorithm
-> ByteString -> ByteString -> Either String ByteString
aesKeyWrapRFC3394 SymmetricAlgorithm
sa ByteString
kek ByteString
plain =
  String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher.
    BlockCipher cipher =>
    cipher -> Either String ByteString)
-> Either String ByteString
forall a.
String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher. BlockCipher cipher => cipher -> Either String a)
-> Either String a
withAESCipher String
"ECDH PKESK currently supports AES KEK algorithms only" SymmetricAlgorithm
sa ByteString
kek cipher -> Either String ByteString
forall cipher.
BlockCipher cipher =>
cipher -> Either String ByteString
wrapWithCipher
  where
    wrapWithCipher :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString
    wrapWithCipher :: forall cipher.
BlockCipher cipher =>
cipher -> Either String ByteString
wrapWithCipher cipher
cipher = do
      if ByteString -> Int
B.length ByteString
plain Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Bool -> Bool -> Bool
|| ByteString -> Int
B.length ByteString
plain Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        then String -> Either String ()
forall a b. a -> Either a b
Left String
"ECDH key wrap input must be at least 16 octets and a multiple of 8"
        else () -> Either String ()
forall a b. b -> Either a b
Right ()
      let rs :: [ByteString]
rs = ByteString -> [ByteString]
chunksOf8 ByteString
plain
      if [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
rs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
        then String -> Either String ()
forall a b. a -> Either a b
Left String
"ECDH key wrap input must contain at least two 64-bit blocks"
        else () -> Either String ()
forall a b. b -> Either a b
Right ()
      (aFinal, rFinal) <- cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
forall cipher.
BlockCipher cipher =>
cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
wrapRounds cipher
cipher (Int -> Word8 -> ByteString
B.replicate Int
8 Word8
0xA6) [ByteString]
rs
      Right (aFinal <> B.concat rFinal)
    wrapRounds :: CCT.BlockCipher cipher => cipher -> B.ByteString -> [B.ByteString] -> Either String (B.ByteString, [B.ByteString])
    wrapRounds :: forall cipher.
BlockCipher cipher =>
cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
wrapRounds cipher
cipher ByteString
aInit [ByteString]
rsInit = Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goJ Int
0 ByteString
aInit [ByteString]
rsInit
      where
        n :: Int
n = [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
rsInit
        goJ :: Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goJ Int
j ByteString
a [ByteString]
rs
          | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5 = (ByteString, [ByteString])
-> Either String (ByteString, [ByteString])
forall a b. b -> Either a b
Right (ByteString
a, [ByteString]
rs)
          | Bool
otherwise = do
              (a', rs') <- Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI Int
1 ByteString
a [ByteString]
rs
              goJ (j + 1) a' rs'
          where
            goI :: Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI Int
i ByteString
curA [ByteString]
curRs
              | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = (ByteString, [ByteString])
-> Either String (ByteString, [ByteString])
forall a b. b -> Either a b
Right (ByteString
curA, [ByteString]
curRs)
              | Bool
otherwise = do
                  let t :: Word64
t = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) :: Word64
                      rI :: ByteString
rI = [ByteString]
curRs [ByteString] -> Int -> ByteString
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                      block :: ByteString
block = cipher -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
forall ba. ByteArray ba => cipher -> ba -> ba
CCT.ecbEncrypt cipher
cipher (ByteString
curA ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
rI)
                      (ByteString
msb, ByteString
lsb) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
block
                      aNext :: ByteString
aNext = ByteString -> ByteString -> ByteString
xorBS ByteString
msb (Word64 -> ByteString
encodeWord64be Word64
t)
                      rsNext :: [ByteString]
rsNext = (Index [ByteString]
-> Traversal' [ByteString] (IxValue [ByteString])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((ByteString -> Identity ByteString)
 -> [ByteString] -> Identity [ByteString])
-> ByteString -> [ByteString] -> [ByteString]
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
lsb) [ByteString]
curRs
                  Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
aNext [ByteString]
rsNext

chunksOf8 :: B.ByteString -> [B.ByteString]
chunksOf8 :: ByteString -> [ByteString]
chunksOf8 ByteString
bs
  | ByteString -> Bool
B.null ByteString
bs = []
  | Bool
otherwise =
      let (ByteString
h, ByteString
t) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
bs
       in ByteString
h ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
chunksOf8 ByteString
t

xorBS :: B.ByteString -> B.ByteString -> B.ByteString
xorBS :: ByteString -> ByteString -> ByteString
xorBS ByteString
a ByteString
b = [Word8] -> ByteString
B.pack ((Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> [Word8]
forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
B.zipWith Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
xor ByteString
a ByteString
b)

encryptSEIPDv1WithSKESK ::
     MonadRandom m
  => SymmetricAlgorithm
  -> S2K
  -> Maybe IV
  -> BL.ByteString
  -> B.ByteString
  -> m (Either String [Pkt])
encryptSEIPDv1WithSKESK :: forall (m :: * -> *).
MonadRandom m =>
SymmetricAlgorithm
-> S2K
-> Maybe IV
-> ByteString
-> ByteString
-> m (Either String [Pkt])
encryptSEIPDv1WithSKESK SymmetricAlgorithm
symalgo S2K
s2k Maybe IV
ivOverride ByteString
passphrase ByteString
literalPayload = do
  let eSessionKey :: Either String ByteString
eSessionKey = do
        keyLen <- SymmetricAlgorithm -> Either String Int
symKeySize SymmetricAlgorithm
symalgo
        first renderS2KError (string2Key s2k keyLen passphrase)
  case Either String ByteString
eSessionKey of
    Left String
err -> Either String [Pkt] -> m (Either String [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String [Pkt]
forall a b. a -> Either a b
Left String
err)
    Right ByteString
sessionKeyMaterial ->
      case
        (CipherError -> String)
-> Either CipherError Int -> Either String Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
          CipherError -> String
renderCipherError
          (SymmetricAlgorithm
-> ByteString -> HOCipher Int -> Either CipherError Int
forall a.
SymmetricAlgorithm
-> ByteString -> HOCipher a -> Either CipherError a
withSymmetricCipher SymmetricAlgorithm
symalgo ByteString
sessionKeyMaterial (Int -> Either String Int
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either String Int)
-> (cipher -> Int) -> cipher -> Either String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cipher -> Int
forall cipher. HOBlockCipher cipher => cipher -> Int
blockSize)) of
        Left String
err -> Either String [Pkt] -> m (Either String [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String [Pkt]
forall a b. a -> Either a b
Left String
err)
        Right Int
ivLength -> do
          ivBytes <-
            m ByteString -> (IV -> m ByteString) -> Maybe IV -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              (Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
ivLength)
              (ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString)
-> (IV -> ByteString) -> IV -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV -> ByteString
unIV)
              Maybe IV
ivOverride
          let iv = ByteString -> IV
IV ByteString
ivBytes
          let sessionKey = ByteString -> SessionKey
SessionKey ByteString
sessionKeyMaterial
          case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of
            Left String
err -> Either String [Pkt] -> m (Either String [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String [Pkt]
forall a b. a -> Either a b
Left String
err)
            Right ByteString
encrypted ->
              Either String [Pkt] -> m (Either String [Pkt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ([Pkt] -> Either String [Pkt]
forall a b. b -> Either a b
Right
                   [ SKESKPayload -> Pkt
SKESKPkt
                       (SKESKPayloadV4 -> SKESKPayload
SKESKPayloadV4Packet
                          (SymmetricAlgorithm -> S2K -> Maybe ByteString -> SKESKPayloadV4
SKESKPayloadV4 SymmetricAlgorithm
symalgo S2K
s2k Maybe ByteString
forall a. Maybe a
Nothing))
                   , SEIPDPayload -> Pkt
SymEncIntegrityProtectedDataPkt
                       (Word8 -> ByteString -> SEIPDPayload
SEIPD1 Word8
1 (ByteString -> ByteString
BL.fromStrict ByteString
encrypted))
                   ])

encryptSEIPDv2WithSKESK ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> S2K
  -> BL.ByteString
  -> B.ByteString
  -> Either String [Pkt]
encryptSEIPDv2WithSKESK :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> ByteString
-> Either String [Pkt]
encryptSEIPDv2WithSKESK SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt S2K
s2k ByteString
passphrase ByteString
literalPayload = do
  keyLen <- SymmetricAlgorithm -> Either String Int
symKeySize SymmetricAlgorithm
symalgo
  sessionKeyMaterial <- first renderS2KError (string2Key s2k keyLen passphrase)
  (_, nonceSize) <-
    aeadModeAndNonceSizeForSEIPDv2
      "unsupported AEAD algorithm for SKESK v6 encrypt"
      aead
  when (B.length (unSalt salt) < nonceSize) $
    Left "SEIPD v2 salt is too short to derive the SKESK v6 IV"
  let skeskIV = Int -> ByteString -> ByteString
B.take Int
nonceSize (Salt -> ByteString
unSalt Salt
salt)
  kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial
  (wrappedSessionKey, skeskTag) <-
    encryptSKESK6SessionKey symalgo aead kek skeskIV sessionKeyMaterial
  let sessionKey = ByteString -> SessionKey
SessionKey ByteString
sessionKeyMaterial
  encrypted <- encryptSEIPDv2Payload symalgo aead chunkSize salt sessionKey literalPayload
  return
    [ SKESKPkt
        (SKESKPayloadV6Packet
           (SKESKPayloadV6
           symalgo
           aead
           s2k
           (BL.fromStrict skeskIV)
           (BL.fromStrict wrappedSessionKey)
           (BL.fromStrict skeskTag)))
    , SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted))
    ]

encryptSEIPDv2WithSKESKBlock ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> S2K
  -> BL.ByteString
  -> Block Pkt
  -> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> Block Pkt
-> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt S2K
s2k ByteString
passphrase Block Pkt
packetBlock =
  SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> ByteString
-> Either String [Pkt]
encryptSEIPDv2WithSKESK
    SymmetricAlgorithm
symalgo
    AEADAlgorithm
aead
    Word8
chunkSize
    Salt
salt
    S2K
s2k
    ByteString
passphrase
    (ByteString -> ByteString
BL.toStrict (Put -> ByteString
runPut (Block Pkt -> Put
forall t. Binary t => t -> Put
put Block Pkt
packetBlock)))

encryptSEIPDv2LiteralDataWithSKESK ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> S2K
  -> BL.ByteString
  -> B.ByteString
  -> Either String [Pkt]
encryptSEIPDv2LiteralDataWithSKESK :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> ByteString
-> Either String [Pkt]
encryptSEIPDv2LiteralDataWithSKESK SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt S2K
s2k ByteString
passphrase ByteString
payload =
  SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> Block Pkt
-> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock
    SymmetricAlgorithm
symalgo
    AEADAlgorithm
aead
    Word8
chunkSize
    Salt
salt
    S2K
s2k
    ByteString
passphrase
    ([Pkt] -> Block Pkt
forall a. [a] -> Block a
Block [DataType
-> ByteString -> ThirtyTwoBitTimeStamp -> ByteString -> Pkt
LiteralDataPkt DataType
BinaryData ByteString
BL.empty (Word32 -> ThirtyTwoBitTimeStamp
ThirtyTwoBitTimeStamp Word32
0) (ByteString -> ByteString
BL.fromStrict ByteString
payload)])

encryptSEIPDv2Payload ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> SessionKey
  -> B.ByteString
  -> Either String B.ByteString
encryptSEIPDv2Payload :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> SessionKey
-> ByteString
-> Either String ByteString
encryptSEIPDv2Payload SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt (SessionKey ByteString
sessionKey) ByteString
plaintext = do
  (mode, nonceSize) <- AEADAlgorithm -> Either String (AEADMode, Int)
aeadModeAndNonceSize AEADAlgorithm
aead
  keyLen <- symKeySize symalgo
  let outputLen = Int
keyLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nonceSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8
      info = [Word8] -> ByteString
B.pack [Word8
0xd2, Word8
2, SymmetricAlgorithm -> Word8
forall a. FutureVal a => a -> Word8
fromFVal SymmetricAlgorithm
symalgo, AEADAlgorithm -> Word8
forall a. FutureVal a => a -> Word8
fromFVal AEADAlgorithm
aead, Word8
chunkSize]
      prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHAlg.SHA256 (Salt -> ByteString
unSalt Salt
salt) ByteString
sessionKey
      okm = forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHAlg.SHA256 PRK SHA256
prk ByteString
info Int
outputLen :: B.ByteString
      messageKey = Int -> ByteString -> ByteString
B.take Int
keyLen ByteString
okm
      noncePrefix = Int -> ByteString -> ByteString
B.take (Int
nonceSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8) (Int -> ByteString -> ByteString
B.drop Int
keyLen ByteString
okm)
  withAESCipher
    "SEIPD v2 encrypt currently supports AES-128/192/256 only"
    symalgo
    messageKey
    (encryptChunks mode info chunkSize noncePrefix plaintext)

encryptChunks ::
     CCT.BlockCipher cipher
  => CCT.AEADMode
  -> B.ByteString
  -> Word8
  -> B.ByteString
  -> B.ByteString
  -> cipher
  -> Either String B.ByteString
encryptChunks :: forall cipher.
BlockCipher cipher =>
AEADMode
-> ByteString
-> Word8
-> ByteString
-> ByteString
-> cipher
-> Either String ByteString
encryptChunks AEADMode
mode ByteString
info Word8
chunkSize ByteString
noncePrefix ByteString
plaintext cipher
cipher = Word64
-> ByteString -> [ByteString] -> Int -> Either String ByteString
go Word64
0 ByteString
plaintext [] Int
0
  where
    chunkLen :: Int
chunkLen = Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
chunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6)
    go :: Word64
-> ByteString -> [ByteString] -> Int -> Either String ByteString
go Word64
idx ByteString
remaining [ByteString]
acc Int
totalPlain
      | ByteString -> Bool
B.null ByteString
remaining = do
        (finalTag, finalCipher) <-
          if AEADMode
mode AEADMode -> AEADMode -> Bool
forall a. Eq a => a -> a -> Bool
== AEADMode
CCT.AEAD_OCB
            then
              cipher
-> ByteString
-> ByteString
-> ByteString
-> Either String (AuthTag, ByteString)
forall c.
BlockCipher c =>
c
-> ByteString
-> ByteString
-> ByteString
-> Either String (AuthTag, ByteString)
encryptWithOCBRFC7253
                cipher
cipher
                (ByteString
noncePrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
encodeWord64be Word64
idx)
                (ByteString
info ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
encodeWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalPlain))
                ByteString
B.empty
            else do
              aead <- Word64 -> Either String (AEAD cipher)
initAEAD Word64
idx
              let (tag, out) =
                    CCT.aeadSimpleEncrypt
                      aead
                      (info <> encodeWord64be (fromIntegral totalPlain))
                      B.empty
                      16
              Right (tag, out)
        if B.null finalCipher
          then return (B.concat (reverse acc) <> authTagToBS finalTag)
          else Left "expected empty ciphertext for final SEIPD v2 tag"
      | Bool
otherwise = do
        let (ByteString
chunkPlain, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
chunkLen ByteString
remaining
        (tag, chunkCipher) <-
          if AEADMode
mode AEADMode -> AEADMode -> Bool
forall a. Eq a => a -> a -> Bool
== AEADMode
CCT.AEAD_OCB
            then
              cipher
-> ByteString
-> ByteString
-> ByteString
-> Either String (AuthTag, ByteString)
forall c.
BlockCipher c =>
c
-> ByteString
-> ByteString
-> ByteString
-> Either String (AuthTag, ByteString)
encryptWithOCBRFC7253
                cipher
cipher
                (ByteString
noncePrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
encodeWord64be Word64
idx)
                ByteString
info
                ByteString
chunkPlain
            else do
              aead <- Word64 -> Either String (AEAD cipher)
initAEAD Word64
idx
              pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16)
        let chunkOut = ByteString
chunkCipher ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> AuthTag -> ByteString
authTagToBS AuthTag
tag
        go
          (idx + 1)
          rest
          (chunkOut : acc)
          (totalPlain + B.length chunkPlain)

    initAEAD :: Word64 -> Either String (AEAD cipher)
initAEAD Word64
idx =
      (CryptoError -> String)
-> Either CryptoError (AEAD cipher) -> Either String (AEAD cipher)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> String
forall a. Show a => a -> String
show (Either CryptoError (AEAD cipher) -> Either String (AEAD cipher))
-> (CryptoFailable (AEAD cipher)
    -> Either CryptoError (AEAD cipher))
-> CryptoFailable (AEAD cipher)
-> Either String (AEAD cipher)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable (AEAD cipher) -> Either CryptoError (AEAD cipher)
forall a. CryptoFailable a -> Either CryptoError a
CE.eitherCryptoError (CryptoFailable (AEAD cipher) -> Either String (AEAD cipher))
-> CryptoFailable (AEAD cipher) -> Either String (AEAD cipher)
forall a b. (a -> b) -> a -> b
$
      AEADMode -> cipher -> ByteString -> CryptoFailable (AEAD cipher)
forall cipher iv.
(BlockCipher cipher, ByteArrayAccess iv) =>
AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher)
forall iv.
ByteArrayAccess iv =>
AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher)
CCT.aeadInit AEADMode
mode cipher
cipher (ByteString
noncePrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
encodeWord64be Word64
idx)

aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)
aeadModeAndNonceSize :: AEADAlgorithm -> Either String (AEADMode, Int)
aeadModeAndNonceSize =
  String -> AEADAlgorithm -> Either String (AEADMode, Int)
aeadModeAndNonceSizeForSEIPDv2
    String
"unsupported AEAD algorithm for SEIPD v2 encrypt"

symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize =
  String -> SymmetricAlgorithm -> Either String Int
seipdv2SymmetricKeySize
    String
"unsupported symmetric algorithm for SEIPD v2 encrypt"

authTagToBS :: CCT.AuthTag -> B.ByteString
authTagToBS :: AuthTag -> ByteString
authTagToBS = Bytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Bytes -> ByteString)
-> (AuthTag -> Bytes) -> AuthTag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthTag -> Bytes
CCT.unAuthTag

encodeWord64be :: Word64 -> B.ByteString
encodeWord64be :: Word64 -> ByteString
encodeWord64be = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Word64 -> ByteString) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (Word64 -> Put) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Put
putWord64be

-- | Compose a complete AEAD-encrypted message with optional literal data and signature.
-- Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization.
--
-- Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes)
--            (SimpleS2K SHA256) passphrase payload Nothing@
-- returns @[SKESK v6, SEIPD v2, <ciphertext>]@
--
-- If the signature is provided, it will be included in the encrypted payload.
composeMessageWithSEIPDv2 ::
     SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> S2K
  -> BL.ByteString
  -> B.ByteString
  -> Maybe [Pkt]
  -> Either String [Pkt]
composeMessageWithSEIPDv2 :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> ByteString
-> Maybe [Pkt]
-> Either String [Pkt]
composeMessageWithSEIPDv2 SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt S2K
s2k ByteString
passphrase ByteString
payload Maybe [Pkt]
mSigs = do
  let packets :: [Pkt]
packets = case Maybe [Pkt]
mSigs of
        Maybe [Pkt]
Nothing -> [DataType
-> ByteString -> ThirtyTwoBitTimeStamp -> ByteString -> Pkt
LiteralDataPkt DataType
BinaryData ByteString
BL.empty (Word32 -> ThirtyTwoBitTimeStamp
ThirtyTwoBitTimeStamp Word32
0) (ByteString -> ByteString
BL.fromStrict ByteString
payload)]
        Just [Pkt]
sigs -> DataType
-> ByteString -> ThirtyTwoBitTimeStamp -> ByteString -> Pkt
LiteralDataPkt DataType
BinaryData ByteString
BL.empty (Word32 -> ThirtyTwoBitTimeStamp
ThirtyTwoBitTimeStamp Word32
0) (ByteString -> ByteString
BL.fromStrict ByteString
payload) Pkt -> [Pkt] -> [Pkt]
forall a. a -> [a] -> [a]
: [Pkt]
sigs
      blockPayload :: Block Pkt
blockPayload = [Pkt] -> Block Pkt
forall a. [a] -> Block a
Block [Pkt]
packets
  SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> ByteString
-> Block Pkt
-> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock SymmetricAlgorithm
symalgo AEADAlgorithm
aead Word8
chunkSize Salt
salt S2K
s2k ByteString
passphrase Block Pkt
blockPayload