{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Simplex.Messaging.Crypto.Ratchet
  ( Ratchet (..),
    RatchetX448,
    MsgEncryptKey (..),
    MsgEncryptKeyX448,
    SkippedMsgDiff (..),
    SkippedMsgKeys,
    InitialKeys (..),
    pattern IKPQOn,
    pattern IKPQOff,
    PQEncryption (..),
    pattern PQEncOn,
    pattern PQEncOff,
    PQSupport (..),
    pattern PQSupportOn,
    pattern PQSupportOff,
    AUseKEM (..),
    RatchetKEMState (..),
    SRatchetKEMState (..),
    RcvPrivRKEMParams,
    APrivRKEMParams (..),
    RcvE2ERatchetParamsUri,
    RcvE2ERatchetParams,
    SndE2ERatchetParams,
    AE2ERatchetParams (..),
    E2ERatchetParamsUri (..),
    E2ERatchetParams (..),
    VersionE2E,
    VersionRangeE2E,
    pattern VersionE2E,
    RatchetVersions (..),
    kdfX3DHE2EEncryptVersion,
    pqRatchetE2EEncryptVersion,
    currentE2EEncryptVersion,
    supportedE2EEncryptVRange,
    generateRcvE2EParams,
    generateSndE2EParams,
    mkRcvE2ERatchetParams,
    initialPQEncryption,
    connPQEncryption,
    joinContactInitialKeys,
    replyKEM_,
    pqSupportToEnc,
    pqEncToSupport,
    pqSupportAnd,
    pqEnableSupport,
    pqX3dhSnd,
    pqX3dhRcv,
    initSndRatchet,
    initRcvRatchet,
    rcCheckCanPad,
    rcEncryptHeader,
    rcEncryptMsg,
    rcDecrypt,
    -- used in tests
    MsgHeader (..),
    RatchetInitParams (..),
    UseKEM (..),
    RKEMParams (..),
    ARKEMParams (..),
    SndRatchet (..),
    RcvRatchet (..),
    RatchetKEM (..),
    RatchetKEMAccepted (..),
    RatchetKey (..),
    fullHeaderLen,
    applySMDiff,
    encodeMsgHeader,
    msgHeaderP,
  )
where

import Control.Applicative ((<|>))
import Control.Monad (unless)
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Crypto.Cipher.AES (AES256)
import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Attoparsec.ByteString (Parser, peekWord8')
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Composition ((.:), (.:.))
import Data.Functor (($>))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Simplex.Messaging.Agent.QueryString
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder)
import Simplex.Messaging.Crypto
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, parseE, parseE')
import Simplex.Messaging.Util (($>>=), (<$?>))
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import UnliftIO.STM

-- e2e encryption headers version history:
-- 1 - binary protocol encoding (1/1/2022)
-- 2 - use KDF in x3dh (10/20/2022)

data E2EVersion

instance VersionScope E2EVersion

type VersionE2E = Version E2EVersion

type VersionRangeE2E = VersionRange E2EVersion

pattern VersionE2E :: Word16 -> VersionE2E
pattern $mVersionE2E :: forall {r}. VersionE2E -> (Word16 -> r) -> ((# #) -> r) -> r
$bVersionE2E :: Word16 -> VersionE2E
VersionE2E v = Version v

kdfX3DHE2EEncryptVersion :: VersionE2E
kdfX3DHE2EEncryptVersion :: VersionE2E
kdfX3DHE2EEncryptVersion = Word16 -> VersionE2E
VersionE2E Word16
2

pqRatchetE2EEncryptVersion :: VersionE2E
pqRatchetE2EEncryptVersion :: VersionE2E
pqRatchetE2EEncryptVersion = Word16 -> VersionE2E
VersionE2E Word16
3

currentE2EEncryptVersion :: VersionE2E
currentE2EEncryptVersion :: VersionE2E
currentE2EEncryptVersion = Word16 -> VersionE2E
VersionE2E Word16
3

supportedE2EEncryptVRange :: VersionRangeE2E
supportedE2EEncryptVRange :: VersionRangeE2E
supportedE2EEncryptVRange = VersionE2E -> VersionE2E -> VersionRangeE2E
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionE2E
kdfX3DHE2EEncryptVersion VersionE2E
currentE2EEncryptVersion

data RatchetKEMState
  = RKSProposed -- only KEM encapsulation key
  | RKSAccepted -- KEM ciphertext and the next encapsulation key

data SRatchetKEMState (s :: RatchetKEMState) where
  SRKSProposed :: SRatchetKEMState 'RKSProposed
  SRKSAccepted :: SRatchetKEMState 'RKSAccepted

deriving instance Show (SRatchetKEMState s)

instance TestEquality SRatchetKEMState where
  testEquality :: forall (a :: RatchetKEMState) (b :: RatchetKEMState).
SRatchetKEMState a -> SRatchetKEMState b -> Maybe (a :~: b)
testEquality SRatchetKEMState a
SRKSProposed SRatchetKEMState b
SRKSProposed = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SRatchetKEMState a
SRKSAccepted SRatchetKEMState b
SRKSAccepted = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SRatchetKEMState a
_ SRatchetKEMState b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s

instance RatchetKEMStateI 'RKSProposed where sRatchetKEMState :: SRatchetKEMState 'RKSProposed
sRatchetKEMState = SRatchetKEMState 'RKSProposed
SRKSProposed

instance RatchetKEMStateI 'RKSAccepted where sRatchetKEMState :: SRatchetKEMState 'RKSAccepted
sRatchetKEMState = SRatchetKEMState 'RKSAccepted
SRKSAccepted

checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a)
checkRatchetKEMState :: forall {k} (t :: RatchetKEMState -> k -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState) (a :: k).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' a -> Either String (t s a)
checkRatchetKEMState t s' a
x = case SRatchetKEMState s -> SRatchetKEMState s' -> Maybe (s :~: s')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: RatchetKEMState) (b :: RatchetKEMState).
SRatchetKEMState a -> SRatchetKEMState b -> Maybe (a :~: b)
testEquality (forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
sRatchetKEMState @s) (forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
sRatchetKEMState @s') of
  Just s :~: s'
Refl -> t s a -> Either String (t s a)
forall a b. b -> Either a b
Right t s a
t s' a
x
  Maybe (s :~: s')
Nothing -> String -> Either String (t s a)
forall a b. a -> Either a b
Left String
"bad ratchet KEM state"

checkRatchetKEMState' :: forall t s s'. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' -> Either String (t s)
checkRatchetKEMState' :: forall (t :: RatchetKEMState -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' -> Either String (t s)
checkRatchetKEMState' t s'
x = case SRatchetKEMState s -> SRatchetKEMState s' -> Maybe (s :~: s')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: RatchetKEMState) (b :: RatchetKEMState).
SRatchetKEMState a -> SRatchetKEMState b -> Maybe (a :~: b)
testEquality (forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
sRatchetKEMState @s) (forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
sRatchetKEMState @s') of
  Just s :~: s'
Refl -> t s -> Either String (t s)
forall a b. b -> Either a b
Right t s
t s'
x
  Maybe (s :~: s')
Nothing -> String -> Either String (t s)
forall a b. a -> Either a b
Left String
"bad ratchet KEM state"

data RKEMParams (s :: RatchetKEMState) where
  RKParamsProposed :: KEMPublicKey -> RKEMParams 'RKSProposed
  RKParamsAccepted :: KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted

deriving instance Eq (RKEMParams s)

deriving instance Show (RKEMParams s)

data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RKEMParams s)

deriving instance Show ARKEMParams

type RcvRKEMParams = RKEMParams 'RKSProposed

instance RatchetKEMStateI s => Encoding (RKEMParams s) where
  smpEncode :: RKEMParams s -> ByteString
smpEncode = \case
    RKParamsProposed KEMPublicKey
k -> (Char, KEMPublicKey) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'P', KEMPublicKey
k)
    RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k -> (Char, KEMCiphertext, KEMPublicKey) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'A', KEMCiphertext
ct, KEMPublicKey
k)
  smpP :: Parser (RKEMParams s)
smpP = (\(ARKP SRatchetKEMState s
_ RKEMParams s
ps) -> RKEMParams s -> Either String (RKEMParams s)
forall (t :: RatchetKEMState -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' -> Either String (t s)
checkRatchetKEMState' RKEMParams s
ps) (ARKEMParams -> Either String (RKEMParams s))
-> Parser ByteString ARKEMParams -> Parser (RKEMParams s)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString ARKEMParams
forall a. Encoding a => Parser a
smpP

instance Encoding ARKEMParams where
  smpEncode :: ARKEMParams -> ByteString
smpEncode (ARKP SRatchetKEMState s
_ RKEMParams s
ps) = RKEMParams s -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode RKEMParams s
ps
  smpP :: Parser ByteString ARKEMParams
smpP =
    Parser Char
forall a. Encoding a => Parser a
smpP Parser Char
-> (Char -> Parser ByteString ARKEMParams)
-> Parser ByteString ARKEMParams
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'P' -> SRatchetKEMState 'RKSProposed
-> RKEMParams 'RKSProposed -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSProposed
SRKSProposed (RKEMParams 'RKSProposed -> ARKEMParams)
-> (KEMPublicKey -> RKEMParams 'RKSProposed)
-> KEMPublicKey
-> ARKEMParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsProposed (KEMPublicKey -> ARKEMParams)
-> Parser ByteString KEMPublicKey -> Parser ByteString ARKEMParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString KEMPublicKey
forall a. Encoding a => Parser a
smpP
      Char
'A' -> SRatchetKEMState 'RKSAccepted
-> RKEMParams 'RKSAccepted -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSAccepted
SRKSAccepted (RKEMParams 'RKSAccepted -> ARKEMParams)
-> (KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted)
-> KEMCiphertext
-> KEMPublicKey
-> ARKEMParams
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted
RKParamsAccepted (KEMCiphertext -> KEMPublicKey -> ARKEMParams)
-> Parser ByteString KEMCiphertext
-> Parser ByteString (KEMPublicKey -> ARKEMParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString KEMCiphertext
forall a. Encoding a => Parser a
smpP Parser ByteString (KEMPublicKey -> ARKEMParams)
-> Parser ByteString KEMPublicKey -> Parser ByteString ARKEMParams
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString KEMPublicKey
forall a. Encoding a => Parser a
smpP
      Char
_ -> String -> Parser ByteString ARKEMParams
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ratchet KEM params"

instance ToField ARKEMParams where toField :: ARKEMParams -> SQLData
toField = Binary ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (Binary ByteString -> SQLData)
-> (ARKEMParams -> Binary ByteString) -> ARKEMParams -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary ByteString
forall a. a -> Binary a
Binary (ByteString -> Binary ByteString)
-> (ARKEMParams -> ByteString) -> ARKEMParams -> Binary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ARKEMParams -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance FromField ARKEMParams where fromField :: FieldParser ARKEMParams
fromField = (ByteString -> Either String ARKEMParams)
-> FieldParser ARKEMParams
forall k.
Typeable k =>
(ByteString -> Either String k) -> FieldParser k
blobFieldDecoder ByteString -> Either String ARKEMParams
forall a. Encoding a => ByteString -> Either String a
smpDecode

data E2ERatchetParams (s :: RatchetKEMState) (a :: Algorithm)
  = E2ERatchetParams VersionE2E (PublicKey a) (PublicKey a) (Maybe (RKEMParams s))
  deriving (Int -> E2ERatchetParams s a -> ShowS
[E2ERatchetParams s a] -> ShowS
E2ERatchetParams s a -> String
(Int -> E2ERatchetParams s a -> ShowS)
-> (E2ERatchetParams s a -> String)
-> ([E2ERatchetParams s a] -> ShowS)
-> Show (E2ERatchetParams s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: RatchetKEMState) (a :: Algorithm).
Int -> E2ERatchetParams s a -> ShowS
forall (s :: RatchetKEMState) (a :: Algorithm).
[E2ERatchetParams s a] -> ShowS
forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParams s a -> String
$cshowsPrec :: forall (s :: RatchetKEMState) (a :: Algorithm).
Int -> E2ERatchetParams s a -> ShowS
showsPrec :: Int -> E2ERatchetParams s a -> ShowS
$cshow :: forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParams s a -> String
show :: E2ERatchetParams s a -> String
$cshowList :: forall (s :: RatchetKEMState) (a :: Algorithm).
[E2ERatchetParams s a] -> ShowS
showList :: [E2ERatchetParams s a] -> ShowS
Show)

data AE2ERatchetParams (a :: Algorithm)
  = forall s.
    RatchetKEMStateI s =>
    AE2ERatchetParams (SRatchetKEMState s) (E2ERatchetParams s a)

deriving instance Show (AE2ERatchetParams a)

data AnyE2ERatchetParams
  = forall s a.
    (RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
    AnyE2ERatchetParams (SRatchetKEMState s) (SAlgorithm a) (E2ERatchetParams s a)

deriving instance Show AnyE2ERatchetParams

instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParams s a) where
  smpEncode :: E2ERatchetParams s a -> ByteString
smpEncode (E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_)
    | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion = (VersionE2E, PublicKey a, PublicKey a, Maybe (RKEMParams s))
-> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
v, PublicKey a
k1, PublicKey a
k2, Maybe (RKEMParams s)
kem_)
    | Bool
otherwise = (VersionE2E, PublicKey a, PublicKey a) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
v, PublicKey a
k1, PublicKey a
k2)
  smpP :: Parser (E2ERatchetParams s a)
smpP = AE2ERatchetParams a -> Either String (E2ERatchetParams s a)
toParams (AE2ERatchetParams a -> Either String (E2ERatchetParams s a))
-> Parser ByteString (AE2ERatchetParams a)
-> Parser (E2ERatchetParams s a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString (AE2ERatchetParams a)
forall a. Encoding a => Parser a
smpP
    where
      toParams :: AE2ERatchetParams a -> Either String (E2ERatchetParams s a)
      toParams :: AE2ERatchetParams a -> Either String (E2ERatchetParams s a)
toParams = \case
        AE2ERatchetParams SRatchetKEMState s
_ (E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
Nothing) -> E2ERatchetParams s a -> Either String (E2ERatchetParams s a)
forall a b. b -> Either a b
Right (E2ERatchetParams s a -> Either String (E2ERatchetParams s a))
-> E2ERatchetParams s a -> Either String (E2ERatchetParams s a)
forall a b. (a -> b) -> a -> b
$ VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
forall a. Maybe a
Nothing
        AE2ERatchetParams SRatchetKEMState s
_ E2ERatchetParams s a
ps -> E2ERatchetParams s a -> Either String (E2ERatchetParams s a)
forall {k} (t :: RatchetKEMState -> k -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState) (a :: k).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' a -> Either String (t s a)
checkRatchetKEMState E2ERatchetParams s a
ps

instance AlgorithmI a => Encoding (AE2ERatchetParams a) where
  smpEncode :: AE2ERatchetParams a -> ByteString
smpEncode (AE2ERatchetParams SRatchetKEMState s
_ E2ERatchetParams s a
ps) = E2ERatchetParams s a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode E2ERatchetParams s a
ps
  smpP :: Parser (AE2ERatchetParams a)
smpP = (\(AnyE2ERatchetParams SRatchetKEMState s
s SAlgorithm a
_ E2ERatchetParams s a
ps) -> SRatchetKEMState s -> E2ERatchetParams s a -> AE2ERatchetParams a
forall (a :: Algorithm) (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> E2ERatchetParams s a -> AE2ERatchetParams a
AE2ERatchetParams SRatchetKEMState s
s (E2ERatchetParams s a -> AE2ERatchetParams a)
-> Either String (E2ERatchetParams s a)
-> Either String (AE2ERatchetParams a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> E2ERatchetParams s a -> Either String (E2ERatchetParams s a)
forall (t :: Algorithm -> *) (a :: Algorithm) (a' :: Algorithm).
(AlgorithmI a, AlgorithmI a') =>
t a' -> Either String (t a)
checkAlgorithm E2ERatchetParams s a
ps) (AnyE2ERatchetParams -> Either String (AE2ERatchetParams a))
-> Parser ByteString AnyE2ERatchetParams
-> Parser (AE2ERatchetParams a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString AnyE2ERatchetParams
forall a. Encoding a => Parser a
smpP

instance Encoding AnyE2ERatchetParams where
  smpEncode :: AnyE2ERatchetParams -> ByteString
smpEncode (AnyE2ERatchetParams SRatchetKEMState s
_ SAlgorithm a
_ E2ERatchetParams s a
ps) = E2ERatchetParams s a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode E2ERatchetParams s a
ps
  smpP :: Parser ByteString AnyE2ERatchetParams
smpP = do
    VersionE2E
v :: VersionE2E <- Parser VersionE2E
forall a. Encoding a => Parser a
smpP
    APublicDhKey SAlgorithm a
a PublicKey a
k1 <- Parser APublicDhKey
forall a. Encoding a => Parser a
smpP
    APublicDhKey SAlgorithm a
a' PublicKey a
k2 <- Parser APublicDhKey
forall a. Encoding a => Parser a
smpP
    case SAlgorithm a -> SAlgorithm a -> Maybe (a :~: a)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Algorithm) (b :: Algorithm).
SAlgorithm a -> SAlgorithm b -> Maybe (a :~: b)
testEquality SAlgorithm a
a SAlgorithm a
a' of
      Maybe (a :~: a)
Nothing -> String -> Parser ByteString AnyE2ERatchetParams
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad e2e params: different key algorithms"
      Just a :~: a
Refl ->
        VersionE2E -> Parser (Maybe ARKEMParams)
kemP VersionE2E
v Parser (Maybe ARKEMParams)
-> (Maybe ARKEMParams -> Parser ByteString AnyE2ERatchetParams)
-> Parser ByteString AnyE2ERatchetParams
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (ARKP SRatchetKEMState s
s RKEMParams s
kem) -> AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams)
-> AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams
forall a b. (a -> b) -> a -> b
$ SRatchetKEMState s
-> SAlgorithm a -> E2ERatchetParams s a -> AnyE2ERatchetParams
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a -> E2ERatchetParams s a -> AnyE2ERatchetParams
AnyE2ERatchetParams SRatchetKEMState s
s SAlgorithm a
a (E2ERatchetParams s a -> AnyE2ERatchetParams)
-> E2ERatchetParams s a -> AnyE2ERatchetParams
forall a b. (a -> b) -> a -> b
$ VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
PublicKey a
k2 (RKEMParams s -> Maybe (RKEMParams s)
forall a. a -> Maybe a
Just RKEMParams s
kem)
          Maybe ARKEMParams
Nothing -> AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams)
-> AnyE2ERatchetParams -> Parser ByteString AnyE2ERatchetParams
forall a b. (a -> b) -> a -> b
$ SRatchetKEMState 'RKSProposed
-> SAlgorithm a
-> E2ERatchetParams 'RKSProposed a
-> AnyE2ERatchetParams
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a -> E2ERatchetParams s a -> AnyE2ERatchetParams
AnyE2ERatchetParams SRatchetKEMState 'RKSProposed
SRKSProposed SAlgorithm a
a (E2ERatchetParams 'RKSProposed a -> AnyE2ERatchetParams)
-> E2ERatchetParams 'RKSProposed a -> AnyE2ERatchetParams
forall a b. (a -> b) -> a -> b
$ VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams 'RKSProposed)
-> E2ERatchetParams 'RKSProposed a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
PublicKey a
k2 Maybe (RKEMParams 'RKSProposed)
forall a. Maybe a
Nothing
    where
      kemP :: VersionE2E -> Parser (Maybe ARKEMParams)
      kemP :: VersionE2E -> Parser (Maybe ARKEMParams)
kemP VersionE2E
v
        | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion = Parser (Maybe ARKEMParams)
forall a. Encoding a => Parser a
smpP
        | Bool
otherwise = Maybe ARKEMParams -> Parser (Maybe ARKEMParams)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ARKEMParams
forall a. Maybe a
Nothing

instance VersionI E2EVersion (E2ERatchetParams s a) where
  type VersionRangeT E2EVersion (E2ERatchetParams s a) = E2ERatchetParamsUri s a
  version :: E2ERatchetParams s a -> VersionE2E
version (E2ERatchetParams VersionE2E
v PublicKey a
_ PublicKey a
_ Maybe (RKEMParams s)
_) = VersionE2E
v
  toVersionRangeT :: E2ERatchetParams s a
-> VersionRangeE2E
-> VersionRangeT E2EVersion (E2ERatchetParams s a)
toVersionRangeT (E2ERatchetParams VersionE2E
_ PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_) VersionRangeE2E
vr = VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_

instance VersionRangeI E2EVersion (E2ERatchetParamsUri s a) where
  type VersionT E2EVersion (E2ERatchetParamsUri s a) = (E2ERatchetParams s a)
  versionRange :: E2ERatchetParamsUri s a -> VersionRangeE2E
versionRange (E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
_ PublicKey a
_ Maybe (RKEMParams s)
_) = VersionRangeE2E
vr
  toVersionT :: E2ERatchetParamsUri s a
-> VersionE2E -> VersionT E2EVersion (E2ERatchetParamsUri s a)
toVersionT (E2ERatchetParamsUri VersionRangeE2E
_ PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_) VersionE2E
v = VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_
  toVersionRange :: E2ERatchetParamsUri s a
-> VersionRangeE2E -> E2ERatchetParamsUri s a
toVersionRange (E2ERatchetParamsUri VersionRangeE2E
_ PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_) VersionRangeE2E
vr = VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_

type RcvE2ERatchetParamsUri a = E2ERatchetParamsUri 'RKSProposed a

data E2ERatchetParamsUri (s :: RatchetKEMState) (a :: Algorithm)
  = E2ERatchetParamsUri VersionRangeE2E (PublicKey a) (PublicKey a) (Maybe (RKEMParams s))
  deriving (E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
(E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool)
-> (E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool)
-> Eq (E2ERatchetParamsUri s a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
$c== :: forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
== :: E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
$c/= :: forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
/= :: E2ERatchetParamsUri s a -> E2ERatchetParamsUri s a -> Bool
Eq, Int -> E2ERatchetParamsUri s a -> ShowS
[E2ERatchetParamsUri s a] -> ShowS
E2ERatchetParamsUri s a -> String
(Int -> E2ERatchetParamsUri s a -> ShowS)
-> (E2ERatchetParamsUri s a -> String)
-> ([E2ERatchetParamsUri s a] -> ShowS)
-> Show (E2ERatchetParamsUri s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: RatchetKEMState) (a :: Algorithm).
Int -> E2ERatchetParamsUri s a -> ShowS
forall (s :: RatchetKEMState) (a :: Algorithm).
[E2ERatchetParamsUri s a] -> ShowS
forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParamsUri s a -> String
$cshowsPrec :: forall (s :: RatchetKEMState) (a :: Algorithm).
Int -> E2ERatchetParamsUri s a -> ShowS
showsPrec :: Int -> E2ERatchetParamsUri s a -> ShowS
$cshow :: forall (s :: RatchetKEMState) (a :: Algorithm).
E2ERatchetParamsUri s a -> String
show :: E2ERatchetParamsUri s a -> String
$cshowList :: forall (s :: RatchetKEMState) (a :: Algorithm).
[E2ERatchetParamsUri s a] -> ShowS
showList :: [E2ERatchetParamsUri s a] -> ShowS
Show)

data AE2ERatchetParamsUri (a :: Algorithm)
  = forall s.
    RatchetKEMStateI s =>
    AE2ERatchetParamsUri (SRatchetKEMState s) (E2ERatchetParamsUri s a)

deriving instance Show (AE2ERatchetParamsUri a)

data AnyE2ERatchetParamsUri
  = forall s a.
    (RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
    AnyE2ERatchetParamsUri (SRatchetKEMState s) (SAlgorithm a) (E2ERatchetParamsUri s a)

deriving instance Show AnyE2ERatchetParamsUri

instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri s a) where
  strEncode :: E2ERatchetParamsUri s a -> ByteString
strEncode (E2ERatchetParamsUri VersionRangeE2E
vs PublicKey a
key1 PublicKey a
key2 Maybe (RKEMParams s)
kem_) =
    QueryStringParams -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (QueryStringParams -> ByteString)
-> (SimpleQuery -> QueryStringParams) -> SimpleQuery -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QSPEscaping -> SimpleQuery -> QueryStringParams
QSP QSPEscaping
QNoEscaping (SimpleQuery -> ByteString) -> SimpleQuery -> ByteString
forall a b. (a -> b) -> a -> b
$
      [(ByteString
"v", VersionRangeE2E -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode VersionRangeE2E
vs), (ByteString
"x3dh", [PublicKey a] -> ByteString
forall a. StrEncoding a => [a] -> ByteString
strEncodeList [PublicKey a
key1, PublicKey a
key2])]
        SimpleQuery -> SimpleQuery -> SimpleQuery
forall a. Semigroup a => a -> a -> a
<> SimpleQuery
-> (RKEMParams s -> SimpleQuery)
-> Maybe (RKEMParams s)
-> SimpleQuery
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] RKEMParams s -> SimpleQuery
encodeKem Maybe (RKEMParams s)
kem_
    where
      encodeKem :: RKEMParams s -> SimpleQuery
encodeKem RKEMParams s
kem
        | VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
vs VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
< VersionE2E
pqRatchetE2EEncryptVersion = []
        | Bool
otherwise = case RKEMParams s
kem of
            RKParamsProposed KEMPublicKey
k -> [(ByteString
"kem_key", KEMPublicKey -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode KEMPublicKey
k)]
            RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k -> [(ByteString
"kem_ct", KEMCiphertext -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode KEMCiphertext
ct), (ByteString
"kem_key", KEMPublicKey -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode KEMPublicKey
k)]
  strP :: Parser (E2ERatchetParamsUri s a)
strP = AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
forall (s :: RatchetKEMState) (a :: Algorithm).
RatchetKEMStateI s =>
AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
toE2ERatchetParamsUri (AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a))
-> Parser ByteString (AE2ERatchetParamsUri a)
-> Parser (E2ERatchetParamsUri s a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString (AE2ERatchetParamsUri a)
forall a. StrEncoding a => Parser a
strP
  {-# INLINE strP #-}

toE2ERatchetParamsUri :: RatchetKEMStateI s => AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
toE2ERatchetParamsUri :: forall (s :: RatchetKEMState) (a :: Algorithm).
RatchetKEMStateI s =>
AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
toE2ERatchetParamsUri = \case
  AE2ERatchetParamsUri SRatchetKEMState s
_ (E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
Nothing) -> E2ERatchetParamsUri s a -> Either String (E2ERatchetParamsUri s a)
forall a b. b -> Either a b
Right (E2ERatchetParamsUri s a
 -> Either String (E2ERatchetParamsUri s a))
-> E2ERatchetParamsUri s a
-> Either String (E2ERatchetParamsUri s a)
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
forall a. Maybe a
Nothing
  AE2ERatchetParamsUri SRatchetKEMState s
_ E2ERatchetParamsUri s a
ps -> E2ERatchetParamsUri s a -> Either String (E2ERatchetParamsUri s a)
forall {k} (t :: RatchetKEMState -> k -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState) (a :: k).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' a -> Either String (t s a)
checkRatchetKEMState E2ERatchetParamsUri s a
ps

instance AlgorithmI a => StrEncoding (AE2ERatchetParamsUri a) where
  strEncode :: AE2ERatchetParamsUri a -> ByteString
strEncode (AE2ERatchetParamsUri SRatchetKEMState s
_ E2ERatchetParamsUri s a
ps) = E2ERatchetParamsUri s a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode E2ERatchetParamsUri s a
ps
  strP :: Parser (AE2ERatchetParamsUri a)
strP = (\(AnyE2ERatchetParamsUri SRatchetKEMState s
s SAlgorithm a
_ E2ERatchetParamsUri s a
ps) -> SRatchetKEMState s
-> E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a
forall (a :: Algorithm) (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
-> E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a
AE2ERatchetParamsUri SRatchetKEMState s
s (E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a)
-> Either String (E2ERatchetParamsUri s a)
-> Either String (AE2ERatchetParamsUri a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> E2ERatchetParamsUri s a -> Either String (E2ERatchetParamsUri s a)
forall (t :: Algorithm -> *) (a :: Algorithm) (a' :: Algorithm).
(AlgorithmI a, AlgorithmI a') =>
t a' -> Either String (t a)
checkAlgorithm E2ERatchetParamsUri s a
ps) (AnyE2ERatchetParamsUri -> Either String (AE2ERatchetParamsUri a))
-> Parser ByteString AnyE2ERatchetParamsUri
-> Parser (AE2ERatchetParamsUri a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString AnyE2ERatchetParamsUri
forall a. StrEncoding a => Parser a
strP

instance StrEncoding AnyE2ERatchetParamsUri where
  strEncode :: AnyE2ERatchetParamsUri -> ByteString
strEncode (AnyE2ERatchetParamsUri SRatchetKEMState s
_ SAlgorithm a
_ E2ERatchetParamsUri s a
ps) = E2ERatchetParamsUri s a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode E2ERatchetParamsUri s a
ps
  strP :: Parser ByteString AnyE2ERatchetParamsUri
strP = do
    QueryStringParams
query <- Parser QueryStringParams
forall a. StrEncoding a => Parser a
strP
    VersionRangeE2E
vr :: VersionRangeE2E <- ByteString -> QueryStringParams -> Parser VersionRangeE2E
forall a.
StrEncoding a =>
ByteString -> QueryStringParams -> Parser a
queryParam ByteString
"v" QueryStringParams
query
    [APublicDhKey]
keys <- NonEmpty APublicDhKey -> [APublicDhKey]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty APublicDhKey -> [APublicDhKey])
-> Parser ByteString (NonEmpty APublicDhKey)
-> Parser ByteString [APublicDhKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> QueryStringParams -> Parser ByteString (NonEmpty APublicDhKey)
forall a.
StrEncoding a =>
ByteString -> QueryStringParams -> Parser a
queryParam ByteString
"x3dh" QueryStringParams
query
    case [APublicDhKey]
keys of
      [APublicDhKey SAlgorithm a
a PublicKey a
k1, APublicDhKey SAlgorithm a
a' PublicKey a
k2] -> case SAlgorithm a -> SAlgorithm a -> Maybe (a :~: a)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Algorithm) (b :: Algorithm).
SAlgorithm a -> SAlgorithm b -> Maybe (a :~: b)
testEquality SAlgorithm a
a SAlgorithm a
a' of
        Maybe (a :~: a)
Nothing -> String -> Parser ByteString AnyE2ERatchetParamsUri
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad e2e params: different key algorithms"
        Just a :~: a
Refl ->
          VersionRangeE2E -> QueryStringParams -> Parser (Maybe ARKEMParams)
kemP VersionRangeE2E
vr QueryStringParams
query Parser (Maybe ARKEMParams)
-> (Maybe ARKEMParams -> Parser ByteString AnyE2ERatchetParamsUri)
-> Parser ByteString AnyE2ERatchetParamsUri
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (ARKP SRatchetKEMState s
s RKEMParams s
kem) -> AnyE2ERatchetParamsUri -> Parser ByteString AnyE2ERatchetParamsUri
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyE2ERatchetParamsUri
 -> Parser ByteString AnyE2ERatchetParamsUri)
-> AnyE2ERatchetParamsUri
-> Parser ByteString AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
AnyE2ERatchetParamsUri SRatchetKEMState s
s SAlgorithm a
a (E2ERatchetParamsUri s a -> AnyE2ERatchetParamsUri)
-> E2ERatchetParamsUri s a -> AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
PublicKey a
k2 (RKEMParams s -> Maybe (RKEMParams s)
forall a. a -> Maybe a
Just RKEMParams s
kem)
            Maybe ARKEMParams
Nothing -> AnyE2ERatchetParamsUri -> Parser ByteString AnyE2ERatchetParamsUri
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyE2ERatchetParamsUri
 -> Parser ByteString AnyE2ERatchetParamsUri)
-> AnyE2ERatchetParamsUri
-> Parser ByteString AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ SRatchetKEMState 'RKSProposed
-> SAlgorithm a
-> E2ERatchetParamsUri 'RKSProposed a
-> AnyE2ERatchetParamsUri
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
AnyE2ERatchetParamsUri SRatchetKEMState 'RKSProposed
SRKSProposed SAlgorithm a
a (E2ERatchetParamsUri 'RKSProposed a -> AnyE2ERatchetParamsUri)
-> E2ERatchetParamsUri 'RKSProposed a -> AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams 'RKSProposed)
-> E2ERatchetParamsUri 'RKSProposed a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
PublicKey a
k2 Maybe (RKEMParams 'RKSProposed)
forall a. Maybe a
Nothing
      [APublicDhKey]
_ -> String -> Parser ByteString AnyE2ERatchetParamsUri
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad e2e params"
    where
      kemP :: VersionRangeE2E -> QueryStringParams -> Parser (Maybe ARKEMParams)
kemP VersionRangeE2E
vr QueryStringParams
query
        | VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
vr VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion =
            ByteString -> QueryStringParams -> Parser (Maybe KEMPublicKey)
forall a.
StrEncoding a =>
ByteString -> QueryStringParams -> Parser (Maybe a)
queryParam_ ByteString
"kem_key" QueryStringParams
query
              Parser (Maybe KEMPublicKey)
-> (KEMPublicKey -> Parser (Maybe ARKEMParams))
-> Parser (Maybe ARKEMParams)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \KEMPublicKey
k -> ARKEMParams -> Maybe ARKEMParams
forall a. a -> Maybe a
Just (ARKEMParams -> Maybe ARKEMParams)
-> (Maybe KEMCiphertext -> ARKEMParams)
-> Maybe KEMCiphertext
-> Maybe ARKEMParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KEMPublicKey -> Maybe KEMCiphertext -> ARKEMParams
kemParams KEMPublicKey
k (Maybe KEMCiphertext -> Maybe ARKEMParams)
-> Parser ByteString (Maybe KEMCiphertext)
-> Parser (Maybe ARKEMParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> QueryStringParams -> Parser ByteString (Maybe KEMCiphertext)
forall a.
StrEncoding a =>
ByteString -> QueryStringParams -> Parser (Maybe a)
queryParam_ ByteString
"kem_ct" QueryStringParams
query
        | Bool
otherwise = Maybe ARKEMParams -> Parser (Maybe ARKEMParams)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ARKEMParams
forall a. Maybe a
Nothing
      kemParams :: KEMPublicKey -> Maybe KEMCiphertext -> ARKEMParams
kemParams KEMPublicKey
k = \case
        Maybe KEMCiphertext
Nothing -> SRatchetKEMState 'RKSProposed
-> RKEMParams 'RKSProposed -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSProposed
SRKSProposed (RKEMParams 'RKSProposed -> ARKEMParams)
-> RKEMParams 'RKSProposed -> ARKEMParams
forall a b. (a -> b) -> a -> b
$ KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsProposed KEMPublicKey
k
        Just KEMCiphertext
ct -> SRatchetKEMState 'RKSAccepted
-> RKEMParams 'RKSAccepted -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSAccepted
SRKSAccepted (RKEMParams 'RKSAccepted -> ARKEMParams)
-> RKEMParams 'RKSAccepted -> ARKEMParams
forall a b. (a -> b) -> a -> b
$ KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted
RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k

instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParamsUri s a) where
  smpEncode :: E2ERatchetParamsUri s a -> ByteString
smpEncode (E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
k2 Maybe (RKEMParams s)
kem_) = (VersionRangeE2E, PublicKey a, PublicKey a, Maybe (RKEMParams s))
-> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionRangeE2E
vr, PublicKey a
k1, PublicKey a
k2, Maybe (RKEMParams s)
kem_)
  {-# INLINE smpEncode #-}
  smpP :: Parser (E2ERatchetParamsUri s a)
smpP = AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
forall (s :: RatchetKEMState) (a :: Algorithm).
RatchetKEMStateI s =>
AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
toE2ERatchetParamsUri (AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a))
-> Parser ByteString (AE2ERatchetParamsUri a)
-> Parser (E2ERatchetParamsUri s a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString (AE2ERatchetParamsUri a)
forall a. Encoding a => Parser a
smpP
  {-# INLINE smpP #-}

instance AlgorithmI a => Encoding (AE2ERatchetParamsUri a) where
  smpEncode :: AE2ERatchetParamsUri a -> ByteString
smpEncode (AE2ERatchetParamsUri SRatchetKEMState s
_ E2ERatchetParamsUri s a
ps) = E2ERatchetParamsUri s a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode E2ERatchetParamsUri s a
ps
  {-# INLINE smpEncode #-}
  smpP :: Parser (AE2ERatchetParamsUri a)
smpP = (\(AnyE2ERatchetParamsUri SRatchetKEMState s
s SAlgorithm a
_ E2ERatchetParamsUri s a
ps) -> SRatchetKEMState s
-> E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a
forall (a :: Algorithm) (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s
-> E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a
AE2ERatchetParamsUri SRatchetKEMState s
s (E2ERatchetParamsUri s a -> AE2ERatchetParamsUri a)
-> Either String (E2ERatchetParamsUri s a)
-> Either String (AE2ERatchetParamsUri a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> E2ERatchetParamsUri s a -> Either String (E2ERatchetParamsUri s a)
forall (t :: Algorithm -> *) (a :: Algorithm) (a' :: Algorithm).
(AlgorithmI a, AlgorithmI a') =>
t a' -> Either String (t a)
checkAlgorithm E2ERatchetParamsUri s a
ps) (AnyE2ERatchetParamsUri -> Either String (AE2ERatchetParamsUri a))
-> Parser ByteString AnyE2ERatchetParamsUri
-> Parser (AE2ERatchetParamsUri a)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString AnyE2ERatchetParamsUri
forall a. Encoding a => Parser a
smpP
  {-# INLINE smpP #-}

instance Encoding AnyE2ERatchetParamsUri where
  smpEncode :: AnyE2ERatchetParamsUri -> ByteString
smpEncode (AnyE2ERatchetParamsUri SRatchetKEMState s
_ SAlgorithm a
_ E2ERatchetParamsUri s a
ps) = E2ERatchetParamsUri s a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode E2ERatchetParamsUri s a
ps
  {-# INLINE smpEncode #-}
  smpP :: Parser ByteString AnyE2ERatchetParamsUri
smpP = do
    VersionRangeE2E
vr <- forall a. Encoding a => Parser a
smpP @VersionRangeE2E
    APublicDhKey SAlgorithm a
a PublicKey a
k1 <- Parser APublicDhKey
forall a. Encoding a => Parser a
smpP
    APublicDhKey SAlgorithm a
a' PublicKey a
k2 <- Parser APublicDhKey
forall a. Encoding a => Parser a
smpP
    case SAlgorithm a -> SAlgorithm a -> Maybe (a :~: a)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Algorithm) (b :: Algorithm).
SAlgorithm a -> SAlgorithm b -> Maybe (a :~: b)
testEquality SAlgorithm a
a SAlgorithm a
a' of
      Maybe (a :~: a)
Nothing -> String -> Parser ByteString AnyE2ERatchetParamsUri
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad e2e params: different key algorithms"
      Just a :~: a
Refl ->
        let result :: Maybe ARKEMParams -> AnyE2ERatchetParamsUri
result = \case
              Just (ARKP SRatchetKEMState s
s RKEMParams s
kem) -> SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
AnyE2ERatchetParamsUri SRatchetKEMState s
s SAlgorithm a
a (E2ERatchetParamsUri s a -> AnyE2ERatchetParamsUri)
-> E2ERatchetParamsUri s a -> AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
PublicKey a
k2 (RKEMParams s -> Maybe (RKEMParams s)
forall a. a -> Maybe a
Just RKEMParams s
kem)
              Maybe ARKEMParams
Nothing -> SRatchetKEMState 'RKSProposed
-> SAlgorithm a
-> E2ERatchetParamsUri 'RKSProposed a
-> AnyE2ERatchetParamsUri
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
SRatchetKEMState s
-> SAlgorithm a
-> E2ERatchetParamsUri s a
-> AnyE2ERatchetParamsUri
AnyE2ERatchetParamsUri SRatchetKEMState 'RKSProposed
SRKSProposed SAlgorithm a
a (E2ERatchetParamsUri 'RKSProposed a -> AnyE2ERatchetParamsUri)
-> E2ERatchetParamsUri 'RKSProposed a -> AnyE2ERatchetParamsUri
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams 'RKSProposed)
-> E2ERatchetParamsUri 'RKSProposed a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
E2ERatchetParamsUri VersionRangeE2E
vr PublicKey a
k1 PublicKey a
PublicKey a
k2 Maybe (RKEMParams 'RKSProposed)
forall a. Maybe a
Nothing
         in Maybe ARKEMParams -> AnyE2ERatchetParamsUri
result (Maybe ARKEMParams -> AnyE2ERatchetParamsUri)
-> Parser (Maybe ARKEMParams)
-> Parser ByteString AnyE2ERatchetParamsUri
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe ARKEMParams)
forall a. Encoding a => Parser a
smpP

type RcvE2ERatchetParams a = E2ERatchetParams 'RKSProposed a

type SndE2ERatchetParams a = AE2ERatchetParams a

data PrivRKEMParams (s :: RatchetKEMState) where
  PrivateRKParamsProposed :: KEMKeyPair -> PrivRKEMParams 'RKSProposed
  PrivateRKParamsAccepted :: KEMCiphertext -> KEMSharedKey -> KEMKeyPair -> PrivRKEMParams 'RKSAccepted

data APrivRKEMParams = forall s. RatchetKEMStateI s => APRKP (SRatchetKEMState s) (PrivRKEMParams s)

type RcvPrivRKEMParams = PrivRKEMParams 'RKSProposed

instance RatchetKEMStateI s => Encoding (PrivRKEMParams s) where
  smpEncode :: PrivRKEMParams s -> ByteString
smpEncode = \case
    PrivateRKParamsProposed KEMKeyPair
k -> (Char, KEMKeyPair) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'P', KEMKeyPair
k)
    PrivateRKParamsAccepted KEMCiphertext
ct KEMSharedKey
shared KEMKeyPair
k -> (Char, KEMCiphertext, KEMSharedKey, KEMKeyPair) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'A', KEMCiphertext
ct, KEMSharedKey
shared, KEMKeyPair
k)
  smpP :: Parser (PrivRKEMParams s)
smpP = (\(APRKP SRatchetKEMState s
_ PrivRKEMParams s
ps) -> PrivRKEMParams s -> Either String (PrivRKEMParams s)
forall (t :: RatchetKEMState -> *) (s :: RatchetKEMState)
       (s' :: RatchetKEMState).
(RatchetKEMStateI s, RatchetKEMStateI s') =>
t s' -> Either String (t s)
checkRatchetKEMState' PrivRKEMParams s
ps) (APrivRKEMParams -> Either String (PrivRKEMParams s))
-> Parser ByteString APrivRKEMParams -> Parser (PrivRKEMParams s)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString APrivRKEMParams
forall a. Encoding a => Parser a
smpP

instance Encoding APrivRKEMParams where
  smpEncode :: APrivRKEMParams -> ByteString
smpEncode (APRKP SRatchetKEMState s
_ PrivRKEMParams s
ps) = PrivRKEMParams s -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode PrivRKEMParams s
ps
  smpP :: Parser ByteString APrivRKEMParams
smpP =
    Parser Char
forall a. Encoding a => Parser a
smpP Parser Char
-> (Char -> Parser ByteString APrivRKEMParams)
-> Parser ByteString APrivRKEMParams
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'P' -> SRatchetKEMState 'RKSProposed
-> PrivRKEMParams 'RKSProposed -> APrivRKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> PrivRKEMParams s -> APrivRKEMParams
APRKP SRatchetKEMState 'RKSProposed
SRKSProposed (PrivRKEMParams 'RKSProposed -> APrivRKEMParams)
-> (KEMKeyPair -> PrivRKEMParams 'RKSProposed)
-> KEMKeyPair
-> APrivRKEMParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KEMKeyPair -> PrivRKEMParams 'RKSProposed
PrivateRKParamsProposed (KEMKeyPair -> APrivRKEMParams)
-> Parser ByteString KEMKeyPair
-> Parser ByteString APrivRKEMParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString KEMKeyPair
forall a. Encoding a => Parser a
smpP
      Char
'A' -> SRatchetKEMState 'RKSAccepted
-> PrivRKEMParams 'RKSAccepted -> APrivRKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> PrivRKEMParams s -> APrivRKEMParams
APRKP SRatchetKEMState 'RKSAccepted
SRKSAccepted (PrivRKEMParams 'RKSAccepted -> APrivRKEMParams)
-> (KEMCiphertext
    -> KEMSharedKey -> KEMKeyPair -> PrivRKEMParams 'RKSAccepted)
-> KEMCiphertext
-> KEMSharedKey
-> KEMKeyPair
-> APrivRKEMParams
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. KEMCiphertext
-> KEMSharedKey -> KEMKeyPair -> PrivRKEMParams 'RKSAccepted
PrivateRKParamsAccepted (KEMCiphertext -> KEMSharedKey -> KEMKeyPair -> APrivRKEMParams)
-> Parser ByteString KEMCiphertext
-> Parser
     ByteString (KEMSharedKey -> KEMKeyPair -> APrivRKEMParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString KEMCiphertext
forall a. Encoding a => Parser a
smpP Parser ByteString (KEMSharedKey -> KEMKeyPair -> APrivRKEMParams)
-> Parser ByteString KEMSharedKey
-> Parser ByteString (KEMKeyPair -> APrivRKEMParams)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString KEMSharedKey
forall a. Encoding a => Parser a
smpP Parser ByteString (KEMKeyPair -> APrivRKEMParams)
-> Parser ByteString KEMKeyPair
-> Parser ByteString APrivRKEMParams
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString KEMKeyPair
forall a. Encoding a => Parser a
smpP
      Char
_ -> String -> Parser ByteString APrivRKEMParams
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad APrivRKEMParams"

instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField :: PrivRKEMParams s -> SQLData
toField = Binary ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (Binary ByteString -> SQLData)
-> (PrivRKEMParams s -> Binary ByteString)
-> PrivRKEMParams s
-> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary ByteString
forall a. a -> Binary a
Binary (ByteString -> Binary ByteString)
-> (PrivRKEMParams s -> ByteString)
-> PrivRKEMParams s
-> Binary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivRKEMParams s -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance (Typeable s, RatchetKEMStateI s) => FromField (PrivRKEMParams s) where fromField :: FieldParser (PrivRKEMParams s)
fromField = (ByteString -> Either String (PrivRKEMParams s))
-> FieldParser (PrivRKEMParams s)
forall k.
Typeable k =>
(ByteString -> Either String k) -> FieldParser k
blobFieldDecoder ByteString -> Either String (PrivRKEMParams s)
forall a. Encoding a => ByteString -> Either String a
smpDecode

data UseKEM (s :: RatchetKEMState) where
  ProposeKEM :: UseKEM 'RKSProposed
  AcceptKEM :: KEMPublicKey -> UseKEM 'RKSAccepted

data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)

mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
mkRcvE2ERatchetParams :: forall (a :: Algorithm).
VersionE2E
-> (PrivateKey a, PrivateKey a,
    Maybe (PrivRKEMParams 'RKSProposed))
-> RcvE2ERatchetParams a
mkRcvE2ERatchetParams VersionE2E
v (PrivateKey a
pk1, PrivateKey a
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem) = VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams 'RKSProposed)
-> E2ERatchetParams 'RKSProposed a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v (PrivateKey a -> PublicKey a
forall (a :: Algorithm). PrivateKey a -> PublicKey a
publicKey PrivateKey a
pk1) (PrivateKey a -> PublicKey a
forall (a :: Algorithm). PrivateKey a -> PublicKey a
publicKey PrivateKey a
pk2) (PrivRKEMParams 'RKSProposed -> RKEMParams 'RKSProposed
mkKem (PrivRKEMParams 'RKSProposed -> RKEMParams 'RKSProposed)
-> Maybe (PrivRKEMParams 'RKSProposed)
-> Maybe (RKEMParams 'RKSProposed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PrivRKEMParams 'RKSProposed)
pKem)
  where
    mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
    mkKem :: PrivRKEMParams 'RKSProposed -> RKEMParams 'RKSProposed
mkKem (PrivateRKParamsProposed (KEMPublicKey
k, KEMSecretKey
_)) = KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsProposed KEMPublicKey
k

generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
generateE2EParams :: forall (s :: RatchetKEMState) (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM s)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
generateE2EParams TVar ChaChaDRG
g VersionE2E
v Maybe (UseKEM s)
useKEM_ = do
  (PublicKey a
k1, PrivateKey a
pk1) <- STM (PublicKey a, PrivateKey a) -> IO (PublicKey a, PrivateKey a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey a, PrivateKey a) -> IO (PublicKey a, PrivateKey a))
-> STM (PublicKey a, PrivateKey a)
-> IO (PublicKey a, PrivateKey a)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair a)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
generateKeyPair TVar ChaChaDRG
g
  (PublicKey a
k2, PrivateKey a
pk2) <- STM (PublicKey a, PrivateKey a) -> IO (PublicKey a, PrivateKey a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey a, PrivateKey a) -> IO (PublicKey a, PrivateKey a))
-> STM (PublicKey a, PrivateKey a)
-> IO (PublicKey a, PrivateKey a)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair a)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
generateKeyPair TVar ChaChaDRG
g
  Maybe (RKEMParams s, PrivRKEMParams s)
kems <- IO (Maybe (RKEMParams s, PrivRKEMParams s))
kemParams
  (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
 E2ERatchetParams s a)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey a
pk1, PrivateKey a
pk2, (RKEMParams s, PrivRKEMParams s) -> PrivRKEMParams s
forall a b. (a, b) -> b
snd ((RKEMParams s, PrivRKEMParams s) -> PrivRKEMParams s)
-> Maybe (RKEMParams s, PrivRKEMParams s)
-> Maybe (PrivRKEMParams s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RKEMParams s, PrivRKEMParams s)
kems, VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParams s a
E2ERatchetParams VersionE2E
v PublicKey a
k1 PublicKey a
k2 ((RKEMParams s, PrivRKEMParams s) -> RKEMParams s
forall a b. (a, b) -> a
fst ((RKEMParams s, PrivRKEMParams s) -> RKEMParams s)
-> Maybe (RKEMParams s, PrivRKEMParams s) -> Maybe (RKEMParams s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RKEMParams s, PrivRKEMParams s)
kems))
  where
    kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
    kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
kemParams = case Maybe (UseKEM s)
useKEM_ of
      Just UseKEM s
useKem
        | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion ->
            (RKEMParams s, PrivRKEMParams s)
-> Maybe (RKEMParams s, PrivRKEMParams s)
forall a. a -> Maybe a
Just ((RKEMParams s, PrivRKEMParams s)
 -> Maybe (RKEMParams s, PrivRKEMParams s))
-> IO (RKEMParams s, PrivRKEMParams s)
-> IO (Maybe (RKEMParams s, PrivRKEMParams s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              ks :: KEMKeyPair
ks@(KEMPublicKey
k, KEMSecretKey
_) <- TVar ChaChaDRG -> IO KEMKeyPair
sntrup761Keypair TVar ChaChaDRG
g
              case UseKEM s
useKem of
                UseKEM s
ProposeKEM -> (RKEMParams s, PrivRKEMParams s)
-> IO (RKEMParams s, PrivRKEMParams s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsProposed KEMPublicKey
k, KEMKeyPair -> PrivRKEMParams 'RKSProposed
PrivateRKParamsProposed KEMKeyPair
ks)
                AcceptKEM KEMPublicKey
k' -> do
                  (KEMCiphertext
ct, KEMSharedKey
shared) <- TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
sntrup761Enc TVar ChaChaDRG
g KEMPublicKey
k'
                  (RKEMParams s, PrivRKEMParams s)
-> IO (RKEMParams s, PrivRKEMParams s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted
RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k, KEMCiphertext
-> KEMSharedKey -> KEMKeyPair -> PrivRKEMParams 'RKSAccepted
PrivateRKParamsAccepted KEMCiphertext
ct KEMSharedKey
shared KEMKeyPair
ks)
      Maybe (UseKEM s)
_ -> Maybe (RKEMParams s, PrivRKEMParams s)
-> IO (Maybe (RKEMParams s, PrivRKEMParams s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RKEMParams s, PrivRKEMParams s)
forall a. Maybe a
Nothing

-- used by party initiating connection, Bob in double-ratchet spec
generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> PQSupport -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed), E2ERatchetParams 'RKSProposed a)
generateRcvE2EParams :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
generateRcvE2EParams TVar ChaChaDRG
g VersionE2E
v = TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM 'RKSProposed)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
forall (s :: RatchetKEMState) (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM s)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
generateE2EParams TVar ChaChaDRG
g VersionE2E
v (Maybe (UseKEM 'RKSProposed)
 -> IO
      (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
       E2ERatchetParams 'RKSProposed a))
-> (PQSupport -> Maybe (UseKEM 'RKSProposed))
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PQSupport -> Maybe (UseKEM 'RKSProposed)
proposeKEM_
  where
    proposeKEM_ :: PQSupport -> Maybe (UseKEM 'RKSProposed)
    proposeKEM_ :: PQSupport -> Maybe (UseKEM 'RKSProposed)
proposeKEM_ = \case
      PQSupport
PQSupportOn -> UseKEM 'RKSProposed -> Maybe (UseKEM 'RKSProposed)
forall a. a -> Maybe a
Just UseKEM 'RKSProposed
ProposeKEM
      PQSupport
PQSupportOff -> Maybe (UseKEM 'RKSProposed)
forall a. Maybe a
Nothing

-- used by party accepting connection, Alice in double-ratchet spec
generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe AUseKEM -> IO (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams, AE2ERatchetParams a)
generateSndE2EParams :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe AUseKEM
-> IO
     (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
      AE2ERatchetParams a)
generateSndE2EParams TVar ChaChaDRG
g VersionE2E
v = \case
  Maybe AUseKEM
Nothing -> do
    (PrivateKey a
pk1, PrivateKey a
pk2, Maybe (PrivRKEMParams 'RKSProposed)
_, E2ERatchetParams 'RKSProposed a
e2eParams) <- TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM 'RKSProposed)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
forall (s :: RatchetKEMState) (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM s)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
generateE2EParams TVar ChaChaDRG
g VersionE2E
v Maybe (UseKEM 'RKSProposed)
forall a. Maybe a
Nothing
    (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
 AE2ERatchetParams a)
-> IO
     (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
      AE2ERatchetParams a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey a
pk1, PrivateKey a
pk2, Maybe APrivRKEMParams
forall a. Maybe a
Nothing, SRatchetKEMState 'RKSProposed
-> E2ERatchetParams 'RKSProposed a -> AE2ERatchetParams a
forall (a :: Algorithm) (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> E2ERatchetParams s a -> AE2ERatchetParams a
AE2ERatchetParams SRatchetKEMState 'RKSProposed
SRKSProposed E2ERatchetParams 'RKSProposed a
e2eParams)
  Just (AUseKEM SRatchetKEMState s
s UseKEM s
useKEM) -> do
    (PrivateKey a
pk1, PrivateKey a
pk2, Maybe (PrivRKEMParams s)
pKem, E2ERatchetParams s a
e2eParams) <- TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM s)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
forall (s :: RatchetKEMState) (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe (UseKEM s)
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s),
      E2ERatchetParams s a)
generateE2EParams TVar ChaChaDRG
g VersionE2E
v (UseKEM s -> Maybe (UseKEM s)
forall a. a -> Maybe a
Just UseKEM s
useKEM)
    (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
 AE2ERatchetParams a)
-> IO
     (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
      AE2ERatchetParams a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey a
pk1, PrivateKey a
pk2, SRatchetKEMState s -> PrivRKEMParams s -> APrivRKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> PrivRKEMParams s -> APrivRKEMParams
APRKP SRatchetKEMState s
s (PrivRKEMParams s -> APrivRKEMParams)
-> Maybe (PrivRKEMParams s) -> Maybe APrivRKEMParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PrivRKEMParams s)
pKem, SRatchetKEMState s -> E2ERatchetParams s a -> AE2ERatchetParams a
forall (a :: Algorithm) (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> E2ERatchetParams s a -> AE2ERatchetParams a
AE2ERatchetParams SRatchetKEMState s
s E2ERatchetParams s a
e2eParams)

data RatchetInitParams = RatchetInitParams
  { RatchetInitParams -> Str
assocData :: Str,
    RatchetInitParams -> RatchetKey
ratchetKey :: RatchetKey,
    RatchetInitParams -> HeaderKey
sndHK :: HeaderKey,
    RatchetInitParams -> HeaderKey
rcvNextHK :: HeaderKey,
    RatchetInitParams -> Maybe RatchetKEMAccepted
kemAccepted :: Maybe RatchetKEMAccepted
  }
  deriving (Int -> RatchetInitParams -> ShowS
[RatchetInitParams] -> ShowS
RatchetInitParams -> String
(Int -> RatchetInitParams -> ShowS)
-> (RatchetInitParams -> String)
-> ([RatchetInitParams] -> ShowS)
-> Show RatchetInitParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RatchetInitParams -> ShowS
showsPrec :: Int -> RatchetInitParams -> ShowS
$cshow :: RatchetInitParams -> String
show :: RatchetInitParams -> String
$cshowList :: [RatchetInitParams] -> ShowS
showList :: [RatchetInitParams] -> ShowS
Show)

-- this is used by the peer joining the connection
pqX3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> Maybe APrivRKEMParams -> E2ERatchetParams 'RKSProposed a -> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
--        3. replied       2. received
pqX3dhSnd :: forall (a :: Algorithm).
DhAlgorithm a =>
PrivateKey a
-> PrivateKey a
-> Maybe APrivRKEMParams
-> E2ERatchetParams 'RKSProposed a
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
pqX3dhSnd PrivateKey a
spk1 PrivateKey a
spk2 Maybe APrivRKEMParams
spKem_ (E2ERatchetParams VersionE2E
v PublicKey a
rk1 PublicKey a
rk2 Maybe (RKEMParams 'RKSProposed)
rKem_) = do
  (Maybe KEMKeyPair
ks_, Maybe RatchetKEMAccepted
kem_) <- Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
sndPq
  let initParams :: RatchetInitParams
initParams = (PublicKey a, PublicKey a)
-> DhSecret a
-> DhSecret a
-> DhSecret a
-> Maybe RatchetKEMAccepted
-> RatchetInitParams
forall (a :: Algorithm).
DhAlgorithm a =>
(PublicKey a, PublicKey a)
-> DhSecret a
-> DhSecret a
-> DhSecret a
-> Maybe RatchetKEMAccepted
-> RatchetInitParams
pqX3dh (PrivateKey a -> PublicKey a
forall (a :: Algorithm). PrivateKey a -> PublicKey a
publicKey PrivateKey a
spk1, PublicKey a
rk1) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
rk1 PrivateKey a
spk2) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
rk2 PrivateKey a
spk1) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
rk2 PrivateKey a
spk2) Maybe RatchetKEMAccepted
kem_
  (RatchetInitParams, Maybe KEMKeyPair)
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
forall a. a -> Either CryptoError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RatchetInitParams
initParams, Maybe KEMKeyPair
ks_)
  where
    sndPq :: Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
    sndPq :: Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
sndPq = case Maybe APrivRKEMParams
spKem_ of
      Just (APRKP SRatchetKEMState s
_ PrivRKEMParams s
ps) | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> case (PrivRKEMParams s
ps, Maybe (RKEMParams 'RKSProposed)
rKem_) of
        (PrivateRKParamsAccepted KEMCiphertext
ct KEMSharedKey
shared KEMKeyPair
ks, Just (RKParamsProposed KEMPublicKey
k)) -> (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
-> Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
forall a b. b -> Either a b
Right (KEMKeyPair -> Maybe KEMKeyPair
forall a. a -> Maybe a
Just KEMKeyPair
ks, RatchetKEMAccepted -> Maybe RatchetKEMAccepted
forall a. a -> Maybe a
Just (RatchetKEMAccepted -> Maybe RatchetKEMAccepted)
-> RatchetKEMAccepted -> Maybe RatchetKEMAccepted
forall a b. (a -> b) -> a -> b
$ KEMPublicKey -> KEMSharedKey -> KEMCiphertext -> RatchetKEMAccepted
RatchetKEMAccepted KEMPublicKey
k KEMSharedKey
shared KEMCiphertext
ct)
        (PrivateRKParamsProposed KEMKeyPair
ks, Maybe (RKEMParams 'RKSProposed)
_) -> (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
-> Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
forall a b. b -> Either a b
Right (KEMKeyPair -> Maybe KEMKeyPair
forall a. a -> Maybe a
Just KEMKeyPair
ks, Maybe RatchetKEMAccepted
forall a. Maybe a
Nothing) -- both parties can send "proposal" in case of ratchet renegotiation
        (PrivRKEMParams s, Maybe (RKEMParams 'RKSProposed))
_ -> CryptoError
-> Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
forall a b. a -> Either a b
Left CryptoError
CERatchetKEMState
      Maybe APrivRKEMParams
_ -> (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
-> Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
forall a b. b -> Either a b
Right (Maybe KEMKeyPair
forall a. Maybe a
Nothing, Maybe RatchetKEMAccepted
forall a. Maybe a
Nothing)

-- this is used by the peer that created new connection, after receiving the reply
pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => PrivateKey a -> PrivateKey a -> Maybe (PrivRKEMParams 'RKSProposed) -> E2ERatchetParams s a -> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
--        1. sent          4. received in reply
pqX3dhRcv :: forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a) =>
PrivateKey a
-> PrivateKey a
-> Maybe (PrivRKEMParams 'RKSProposed)
-> E2ERatchetParams s a
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
pqX3dhRcv PrivateKey a
rpk1 PrivateKey a
rpk2 Maybe (PrivRKEMParams 'RKSProposed)
rpKem_ (E2ERatchetParams VersionE2E
v PublicKey a
sk1 PublicKey a
sk2 Maybe (RKEMParams s)
sKem_) = do
  Maybe (KEMKeyPair, RatchetKEMAccepted)
kem_ <- ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
rcvPq
  let initParams :: RatchetInitParams
initParams = (PublicKey a, PublicKey a)
-> DhSecret a
-> DhSecret a
-> DhSecret a
-> Maybe RatchetKEMAccepted
-> RatchetInitParams
forall (a :: Algorithm).
DhAlgorithm a =>
(PublicKey a, PublicKey a)
-> DhSecret a
-> DhSecret a
-> DhSecret a
-> Maybe RatchetKEMAccepted
-> RatchetInitParams
pqX3dh (PublicKey a
sk1, PrivateKey a -> PublicKey a
forall (a :: Algorithm). PrivateKey a -> PublicKey a
publicKey PrivateKey a
rpk1) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
sk2 PrivateKey a
rpk1) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
sk1 PrivateKey a
rpk2) (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
sk2 PrivateKey a
rpk2) ((KEMKeyPair, RatchetKEMAccepted) -> RatchetKEMAccepted
forall a b. (a, b) -> b
snd ((KEMKeyPair, RatchetKEMAccepted) -> RatchetKEMAccepted)
-> Maybe (KEMKeyPair, RatchetKEMAccepted)
-> Maybe RatchetKEMAccepted
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (KEMKeyPair, RatchetKEMAccepted)
kem_)
  (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RatchetInitParams
initParams, (KEMKeyPair, RatchetKEMAccepted) -> KEMKeyPair
forall a b. (a, b) -> a
fst ((KEMKeyPair, RatchetKEMAccepted) -> KEMKeyPair)
-> Maybe (KEMKeyPair, RatchetKEMAccepted) -> Maybe KEMKeyPair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (KEMKeyPair, RatchetKEMAccepted)
kem_)
  where
    rcvPq :: ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
    rcvPq :: ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
rcvPq = case Maybe (RKEMParams s)
sKem_ of
      Just (RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k') | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> case Maybe (PrivRKEMParams 'RKSProposed)
rpKem_ of
        Just (PrivateRKParamsProposed ks :: KEMKeyPair
ks@(KEMPublicKey
_, KEMSecretKey
pk)) -> do
          KEMSharedKey
shared <- IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey
forall a. IO a -> ExceptT CryptoError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey)
-> IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey
forall a b. (a -> b) -> a -> b
$ KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey
sntrup761Dec KEMCiphertext
ct KEMSecretKey
pk
          Maybe (KEMKeyPair, RatchetKEMAccepted)
-> ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (KEMKeyPair, RatchetKEMAccepted)
 -> ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted)))
-> Maybe (KEMKeyPair, RatchetKEMAccepted)
-> ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
forall a b. (a -> b) -> a -> b
$ (KEMKeyPair, RatchetKEMAccepted)
-> Maybe (KEMKeyPair, RatchetKEMAccepted)
forall a. a -> Maybe a
Just (KEMKeyPair
ks, KEMPublicKey -> KEMSharedKey -> KEMCiphertext -> RatchetKEMAccepted
RatchetKEMAccepted KEMPublicKey
k' KEMSharedKey
shared KEMCiphertext
ct)
        Maybe (PrivRKEMParams 'RKSProposed)
Nothing -> CryptoError
-> ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CERatchetKEMState
      Maybe (RKEMParams s)
_ -> Maybe (KEMKeyPair, RatchetKEMAccepted)
-> ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (KEMKeyPair, RatchetKEMAccepted)
forall a. Maybe a
Nothing -- both parties can send "proposal" in case of ratchet renegotiation

pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> RatchetInitParams
pqX3dh :: forall (a :: Algorithm).
DhAlgorithm a =>
(PublicKey a, PublicKey a)
-> DhSecret a
-> DhSecret a
-> DhSecret a
-> Maybe RatchetKEMAccepted
-> RatchetInitParams
pqX3dh (PublicKey a
sk1, PublicKey a
rk1) DhSecret a
dh1 DhSecret a
dh2 DhSecret a
dh3 Maybe RatchetKEMAccepted
kemAccepted =
  RatchetInitParams {Str
$sel:assocData:RatchetInitParams :: Str
assocData :: Str
assocData, $sel:ratchetKey:RatchetInitParams :: RatchetKey
ratchetKey = ByteString -> RatchetKey
RatchetKey ByteString
sk, $sel:sndHK:RatchetInitParams :: HeaderKey
sndHK = ByteString -> HeaderKey
Key ByteString
hk, $sel:rcvNextHK:RatchetInitParams :: HeaderKey
rcvNextHK = ByteString -> HeaderKey
Key ByteString
nhk, Maybe RatchetKEMAccepted
$sel:kemAccepted:RatchetInitParams :: Maybe RatchetKEMAccepted
kemAccepted :: Maybe RatchetKEMAccepted
kemAccepted}
  where
    assocData :: Str
assocData = ByteString -> Str
Str (ByteString -> Str) -> ByteString -> Str
forall a b. (a -> b) -> a -> b
$ PublicKey a -> ByteString
forall (a :: Algorithm). PublicKey a -> ByteString
pubKeyBytes PublicKey a
sk1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PublicKey a -> ByteString
forall (a :: Algorithm). PublicKey a -> ByteString
pubKeyBytes PublicKey a
rk1
    dhs :: ByteString
dhs = DhSecret a -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
dhBytes' DhSecret a
dh1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DhSecret a -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
dhBytes' DhSecret a
dh2 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DhSecret a -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
dhBytes' DhSecret a
dh3 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pq
    pq :: ByteString
pq = ByteString
-> (RatchetKEMAccepted -> ByteString)
-> Maybe RatchetKEMAccepted
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (\RatchetKEMAccepted {$sel:rcPQRss:RatchetKEMAccepted :: RatchetKEMAccepted -> KEMSharedKey
rcPQRss = KEMSharedKey ScrubbedBytes
ss} -> ScrubbedBytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ScrubbedBytes
ss) Maybe RatchetKEMAccepted
kemAccepted
    (ByteString
hk, ByteString
nhk, ByteString
sk) =
      let salt :: ByteString
salt = Int -> Char -> ByteString
B.replicate Int
64 Char
'\0'
       in ByteString
-> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
hkdf3 ByteString
salt ByteString
dhs ByteString
"SimpleXX3DH"

type RatchetX448 = Ratchet 'X448

data Ratchet a = Ratchet
  { -- ratchet version range sent in messages (current .. max supported ratchet version)
    forall (a :: Algorithm). Ratchet a -> RatchetVersions
rcVersion :: RatchetVersions,
    -- associated data - must be the same in both parties ratchets
    forall (a :: Algorithm). Ratchet a -> Str
rcAD :: Str,
    forall (a :: Algorithm). Ratchet a -> PrivateKey a
rcDHRs :: PrivateKey a,
    forall (a :: Algorithm). Ratchet a -> Maybe RatchetKEM
rcKEM :: Maybe RatchetKEM,
    forall (a :: Algorithm). Ratchet a -> PQSupport
rcSupportKEM :: PQSupport, -- defines header size, can only be enabled once
    forall (a :: Algorithm). Ratchet a -> PQEncryption
rcEnableKEM :: PQEncryption, -- will enable KEM on the next ratchet step
    forall (a :: Algorithm). Ratchet a -> PQEncryption
rcSndKEM :: PQEncryption, -- used KEM hybrid secret for sending ratchet
    forall (a :: Algorithm). Ratchet a -> PQEncryption
rcRcvKEM :: PQEncryption, -- used KEM hybrid secret for receiving ratchet
    forall (a :: Algorithm). Ratchet a -> RatchetKey
rcRK :: RatchetKey,
    forall (a :: Algorithm). Ratchet a -> Maybe (SndRatchet a)
rcSnd :: Maybe (SndRatchet a),
    forall (a :: Algorithm). Ratchet a -> Maybe RcvRatchet
rcRcv :: Maybe RcvRatchet,
    forall (a :: Algorithm). Ratchet a -> Word32
rcNs :: Word32,
    forall (a :: Algorithm). Ratchet a -> Word32
rcNr :: Word32,
    forall (a :: Algorithm). Ratchet a -> Word32
rcPN :: Word32,
    forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKs :: HeaderKey,
    forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKr :: HeaderKey
  }
  deriving (Int -> Ratchet a -> ShowS
[Ratchet a] -> ShowS
Ratchet a -> String
(Int -> Ratchet a -> ShowS)
-> (Ratchet a -> String)
-> ([Ratchet a] -> ShowS)
-> Show (Ratchet a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: Algorithm). Int -> Ratchet a -> ShowS
forall (a :: Algorithm). [Ratchet a] -> ShowS
forall (a :: Algorithm). Ratchet a -> String
$cshowsPrec :: forall (a :: Algorithm). Int -> Ratchet a -> ShowS
showsPrec :: Int -> Ratchet a -> ShowS
$cshow :: forall (a :: Algorithm). Ratchet a -> String
show :: Ratchet a -> String
$cshowList :: forall (a :: Algorithm). [Ratchet a] -> ShowS
showList :: [Ratchet a] -> ShowS
Show)

data RatchetVersions = RatchetVersions
  { RatchetVersions -> VersionE2E
current :: VersionE2E,
    RatchetVersions -> VersionE2E
maxSupported :: VersionE2E
  }
  deriving (RatchetVersions -> RatchetVersions -> Bool
(RatchetVersions -> RatchetVersions -> Bool)
-> (RatchetVersions -> RatchetVersions -> Bool)
-> Eq RatchetVersions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RatchetVersions -> RatchetVersions -> Bool
== :: RatchetVersions -> RatchetVersions -> Bool
$c/= :: RatchetVersions -> RatchetVersions -> Bool
/= :: RatchetVersions -> RatchetVersions -> Bool
Eq, Int -> RatchetVersions -> ShowS
[RatchetVersions] -> ShowS
RatchetVersions -> String
(Int -> RatchetVersions -> ShowS)
-> (RatchetVersions -> String)
-> ([RatchetVersions] -> ShowS)
-> Show RatchetVersions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RatchetVersions -> ShowS
showsPrec :: Int -> RatchetVersions -> ShowS
$cshow :: RatchetVersions -> String
show :: RatchetVersions -> String
$cshowList :: [RatchetVersions] -> ShowS
showList :: [RatchetVersions] -> ShowS
Show)

instance ToJSON RatchetVersions where
  -- TODO v5.7 or v5.8 change to the default record encoding
  toJSON :: RatchetVersions -> Value
toJSON RatchetVersions {VersionE2E
$sel:current:RatchetVersions :: RatchetVersions -> VersionE2E
current :: VersionE2E
current, VersionE2E
$sel:maxSupported:RatchetVersions :: RatchetVersions -> VersionE2E
maxSupported :: VersionE2E
maxSupported} = (VersionE2E, VersionE2E) -> Value
forall a. ToJSON a => a -> Value
toJSON (VersionE2E
current, VersionE2E
maxSupported)
  toEncoding :: RatchetVersions -> Encoding
toEncoding RatchetVersions {VersionE2E
$sel:current:RatchetVersions :: RatchetVersions -> VersionE2E
current :: VersionE2E
current, VersionE2E
$sel:maxSupported:RatchetVersions :: RatchetVersions -> VersionE2E
maxSupported :: VersionE2E
maxSupported} = (VersionE2E, VersionE2E) -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (VersionE2E
current, VersionE2E
maxSupported)

instance FromJSON RatchetVersions where
  -- TODO v5.7 or v5.8 replace comment below with "tuple for backward"
  -- this parser supports JSON record encoding for forward compatibility
  parseJSON :: Value -> Parser RatchetVersions
parseJSON Value
v = (VersionE2E, VersionE2E) -> RatchetVersions
toRV ((VersionE2E, VersionE2E) -> RatchetVersions)
-> Parser (VersionE2E, VersionE2E) -> Parser RatchetVersions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (VersionE2E, VersionE2E)
tupleP Parser (VersionE2E, VersionE2E)
-> Parser (VersionE2E, VersionE2E)
-> Parser (VersionE2E, VersionE2E)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (VersionE2E, VersionE2E)
recordP Value
v)
    where
      tupleP :: Parser (VersionE2E, VersionE2E)
tupleP = Value -> Parser (VersionE2E, VersionE2E)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      recordP :: Value -> Parser (VersionE2E, VersionE2E)
recordP = String
-> (Object -> Parser (VersionE2E, VersionE2E))
-> Value
-> Parser (VersionE2E, VersionE2E)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"RatchetVersions" ((Object -> Parser (VersionE2E, VersionE2E))
 -> Value -> Parser (VersionE2E, VersionE2E))
-> (Object -> Parser (VersionE2E, VersionE2E))
-> Value
-> Parser (VersionE2E, VersionE2E)
forall a b. (a -> b) -> a -> b
$ \Object
o -> (,) (VersionE2E -> VersionE2E -> (VersionE2E, VersionE2E))
-> Parser VersionE2E
-> Parser (VersionE2E -> (VersionE2E, VersionE2E))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser VersionE2E
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"current" Parser (VersionE2E -> (VersionE2E, VersionE2E))
-> Parser VersionE2E -> Parser (VersionE2E, VersionE2E)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser VersionE2E
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"maxSupported"
      toRV :: (VersionE2E, VersionE2E) -> RatchetVersions
toRV (VersionE2E
current, VersionE2E
maxSupported) = RatchetVersions {VersionE2E
$sel:current:RatchetVersions :: VersionE2E
current :: VersionE2E
current, VersionE2E
$sel:maxSupported:RatchetVersions :: VersionE2E
maxSupported :: VersionE2E
maxSupported}

data SndRatchet a = SndRatchet
  { forall (a :: Algorithm). SndRatchet a -> PublicKey a
rcDHRr :: PublicKey a,
    forall (a :: Algorithm). SndRatchet a -> RatchetKey
rcCKs :: RatchetKey,
    forall (a :: Algorithm). SndRatchet a -> HeaderKey
rcHKs :: HeaderKey
  }
  deriving (Int -> SndRatchet a -> ShowS
[SndRatchet a] -> ShowS
SndRatchet a -> String
(Int -> SndRatchet a -> ShowS)
-> (SndRatchet a -> String)
-> ([SndRatchet a] -> ShowS)
-> Show (SndRatchet a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: Algorithm). Int -> SndRatchet a -> ShowS
forall (a :: Algorithm). [SndRatchet a] -> ShowS
forall (a :: Algorithm). SndRatchet a -> String
$cshowsPrec :: forall (a :: Algorithm). Int -> SndRatchet a -> ShowS
showsPrec :: Int -> SndRatchet a -> ShowS
$cshow :: forall (a :: Algorithm). SndRatchet a -> String
show :: SndRatchet a -> String
$cshowList :: forall (a :: Algorithm). [SndRatchet a] -> ShowS
showList :: [SndRatchet a] -> ShowS
Show)

data RcvRatchet = RcvRatchet
  { RcvRatchet -> RatchetKey
rcCKr :: RatchetKey,
    RcvRatchet -> HeaderKey
rcHKr :: HeaderKey
  }
  deriving (Int -> RcvRatchet -> ShowS
[RcvRatchet] -> ShowS
RcvRatchet -> String
(Int -> RcvRatchet -> ShowS)
-> (RcvRatchet -> String)
-> ([RcvRatchet] -> ShowS)
-> Show RcvRatchet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RcvRatchet -> ShowS
showsPrec :: Int -> RcvRatchet -> ShowS
$cshow :: RcvRatchet -> String
show :: RcvRatchet -> String
$cshowList :: [RcvRatchet] -> ShowS
showList :: [RcvRatchet] -> ShowS
Show)

data RatchetKEM = RatchetKEM
  { RatchetKEM -> KEMKeyPair
rcPQRs :: KEMKeyPair,
    RatchetKEM -> Maybe RatchetKEMAccepted
rcKEMs :: Maybe RatchetKEMAccepted
  }
  deriving (Int -> RatchetKEM -> ShowS
[RatchetKEM] -> ShowS
RatchetKEM -> String
(Int -> RatchetKEM -> ShowS)
-> (RatchetKEM -> String)
-> ([RatchetKEM] -> ShowS)
-> Show RatchetKEM
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RatchetKEM -> ShowS
showsPrec :: Int -> RatchetKEM -> ShowS
$cshow :: RatchetKEM -> String
show :: RatchetKEM -> String
$cshowList :: [RatchetKEM] -> ShowS
showList :: [RatchetKEM] -> ShowS
Show)

data RatchetKEMAccepted = RatchetKEMAccepted
  { RatchetKEMAccepted -> KEMPublicKey
rcPQRr :: KEMPublicKey, -- received key
    RatchetKEMAccepted -> KEMSharedKey
rcPQRss :: KEMSharedKey, -- computed shared secret
    RatchetKEMAccepted -> KEMCiphertext
rcPQRct :: KEMCiphertext -- sent encaps(rcPQRr, rcPQRss)
  }
  deriving (Int -> RatchetKEMAccepted -> ShowS
[RatchetKEMAccepted] -> ShowS
RatchetKEMAccepted -> String
(Int -> RatchetKEMAccepted -> ShowS)
-> (RatchetKEMAccepted -> String)
-> ([RatchetKEMAccepted] -> ShowS)
-> Show RatchetKEMAccepted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RatchetKEMAccepted -> ShowS
showsPrec :: Int -> RatchetKEMAccepted -> ShowS
$cshow :: RatchetKEMAccepted -> String
show :: RatchetKEMAccepted -> String
$cshowList :: [RatchetKEMAccepted] -> ShowS
showList :: [RatchetKEMAccepted] -> ShowS
Show)

type SkippedMsgKeys = Map HeaderKey SkippedHdrMsgKeys

type SkippedHdrMsgKeys = Map Word32 MessageKey

data SkippedMsgDiff
  = SMDNoChange
  | SMDRemove HeaderKey Word32
  | SMDAdd SkippedMsgKeys

-- | this function is only used in tests to apply changes in skipped messages,
-- in the agent the diff is persisted, and the whole state is loaded for the next message.
applySMDiff :: SkippedMsgKeys -> SkippedMsgDiff -> SkippedMsgKeys
applySMDiff :: SkippedMsgKeys -> SkippedMsgDiff -> SkippedMsgKeys
applySMDiff SkippedMsgKeys
smks = \case
  SkippedMsgDiff
SMDNoChange -> SkippedMsgKeys
smks
  SMDRemove HeaderKey
hk Word32
msgN -> SkippedMsgKeys -> Maybe SkippedMsgKeys -> SkippedMsgKeys
forall a. a -> Maybe a -> a
fromMaybe SkippedMsgKeys
smks (Maybe SkippedMsgKeys -> SkippedMsgKeys)
-> Maybe SkippedMsgKeys -> SkippedMsgKeys
forall a b. (a -> b) -> a -> b
$ do
    SkippedHdrMsgKeys
mks <- HeaderKey -> SkippedMsgKeys -> Maybe SkippedHdrMsgKeys
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HeaderKey
hk SkippedMsgKeys
smks
    MessageKey
_ <- Word32 -> SkippedHdrMsgKeys -> Maybe MessageKey
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word32
msgN SkippedHdrMsgKeys
mks
    let mks' :: SkippedHdrMsgKeys
mks' = Word32 -> SkippedHdrMsgKeys -> SkippedHdrMsgKeys
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Word32
msgN SkippedHdrMsgKeys
mks
    SkippedMsgKeys -> Maybe SkippedMsgKeys
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SkippedMsgKeys -> Maybe SkippedMsgKeys)
-> SkippedMsgKeys -> Maybe SkippedMsgKeys
forall a b. (a -> b) -> a -> b
$
      if SkippedHdrMsgKeys -> Bool
forall k a. Map k a -> Bool
M.null SkippedHdrMsgKeys
mks'
        then HeaderKey -> SkippedMsgKeys -> SkippedMsgKeys
forall k a. Ord k => k -> Map k a -> Map k a
M.delete HeaderKey
hk SkippedMsgKeys
smks
        else HeaderKey -> SkippedHdrMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert HeaderKey
hk SkippedHdrMsgKeys
mks' SkippedMsgKeys
smks
  SMDAdd SkippedMsgKeys
smks' ->
    let merge :: k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
merge k
hk Map k a
mks = (Maybe (Map k a) -> Maybe (Map k a))
-> k -> Map k (Map k a) -> Map k (Map k a)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (Map k a -> Maybe (Map k a))
-> (Maybe (Map k a) -> Map k a)
-> Maybe (Map k a)
-> Maybe (Map k a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k a -> (Map k a -> Map k a) -> Maybe (Map k a) -> Map k a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map k a
mks (Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k a
mks)) k
hk
     in (HeaderKey
 -> SkippedHdrMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys)
-> SkippedMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey HeaderKey -> SkippedHdrMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys
forall {k} {k} {a}.
(Ord k, Ord k) =>
k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
merge SkippedMsgKeys
smks SkippedMsgKeys
smks'

type HeaderKey = Key

data MessageKey = MessageKey Key IV
  deriving (Int -> MessageKey -> ShowS
[MessageKey] -> ShowS
MessageKey -> String
(Int -> MessageKey -> ShowS)
-> (MessageKey -> String)
-> ([MessageKey] -> ShowS)
-> Show MessageKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageKey -> ShowS
showsPrec :: Int -> MessageKey -> ShowS
$cshow :: MessageKey -> String
show :: MessageKey -> String
$cshowList :: [MessageKey] -> ShowS
showList :: [MessageKey] -> ShowS
Show)

instance Encoding MessageKey where
  smpEncode :: MessageKey -> ByteString
smpEncode (MessageKey (Key ByteString
key) (IV ByteString
iv)) = (ByteString, ByteString) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (ByteString
key, ByteString
iv)
  smpP :: Parser MessageKey
smpP = HeaderKey -> IV -> MessageKey
MessageKey (HeaderKey -> IV -> MessageKey)
-> Parser ByteString HeaderKey
-> Parser ByteString (IV -> MessageKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> HeaderKey
Key (ByteString -> HeaderKey)
-> Parser ByteString ByteString -> Parser ByteString HeaderKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP) Parser ByteString (IV -> MessageKey)
-> Parser ByteString IV -> Parser MessageKey
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> IV
IV (ByteString -> IV)
-> Parser ByteString ByteString -> Parser ByteString IV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP)

-- | Input key material for double ratchet HKDF functions
newtype RatchetKey = RatchetKey ByteString
  deriving (Int -> RatchetKey -> ShowS
[RatchetKey] -> ShowS
RatchetKey -> String
(Int -> RatchetKey -> ShowS)
-> (RatchetKey -> String)
-> ([RatchetKey] -> ShowS)
-> Show RatchetKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RatchetKey -> ShowS
showsPrec :: Int -> RatchetKey -> ShowS
$cshow :: RatchetKey -> String
show :: RatchetKey -> String
$cshowList :: [RatchetKey] -> ShowS
showList :: [RatchetKey] -> ShowS
Show)

instance ToJSON RatchetKey where
  toJSON :: RatchetKey -> Value
toJSON (RatchetKey ByteString
k) = ByteString -> Value
forall a. StrEncoding a => a -> Value
strToJSON ByteString
k
  toEncoding :: RatchetKey -> Encoding
toEncoding (RatchetKey ByteString
k) = ByteString -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding ByteString
k

instance FromJSON RatchetKey where
  parseJSON :: Value -> Parser RatchetKey
parseJSON = (ByteString -> RatchetKey)
-> Parser ByteString -> Parser RatchetKey
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> RatchetKey
RatchetKey (Parser ByteString -> Parser RatchetKey)
-> (Value -> Parser ByteString) -> Value -> Parser RatchetKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value -> Parser ByteString
forall a. StrEncoding a => String -> Value -> Parser a
strParseJSON String
"Key"

instance ToField MessageKey where toField :: MessageKey -> SQLData
toField = Binary ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (Binary ByteString -> SQLData)
-> (MessageKey -> Binary ByteString) -> MessageKey -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary ByteString
forall a. a -> Binary a
Binary (ByteString -> Binary ByteString)
-> (MessageKey -> ByteString) -> MessageKey -> Binary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageKey -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance FromField MessageKey where fromField :: FieldParser MessageKey
fromField = (ByteString -> Either String MessageKey) -> FieldParser MessageKey
forall k.
Typeable k =>
(ByteString -> Either String k) -> FieldParser k
blobFieldDecoder ByteString -> Either String MessageKey
forall a. Encoding a => ByteString -> Either String a
smpDecode

-- | Sending ratchet initialization
--
-- Please note that sPKey is not stored, and its public part together with random salt
-- is sent to the recipient.
-- @
-- RatchetInitAlicePQ2HE(state, SK, bob_dh_public_key, shared_hka, shared_nhkb, bob_pq_kem_encapsulation_key)
-- // below added for post-quantum KEM
-- state.PQRs = GENERATE_PQKEM()
-- state.PQRr = bob_pq_kem_encapsulation_key
-- state.PQRss = random // shared secret for KEM
-- state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret
-- // above added for KEM
-- @
initSndRatchet ::
  forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Ratchet a
initSndRatchet :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PublicKey a
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> Ratchet a
initSndRatchet RatchetVersions
rcVersion PublicKey a
rcDHRr PrivateKey a
rcDHRs (RatchetInitParams {Str
$sel:assocData:RatchetInitParams :: RatchetInitParams -> Str
assocData :: Str
assocData, RatchetKey
$sel:ratchetKey:RatchetInitParams :: RatchetInitParams -> RatchetKey
ratchetKey :: RatchetKey
ratchetKey, HeaderKey
$sel:sndHK:RatchetInitParams :: RatchetInitParams -> HeaderKey
sndHK :: HeaderKey
sndHK, HeaderKey
$sel:rcvNextHK:RatchetInitParams :: RatchetInitParams -> HeaderKey
rcvNextHK :: HeaderKey
rcvNextHK, Maybe RatchetKEMAccepted
$sel:kemAccepted:RatchetInitParams :: RatchetInitParams -> Maybe RatchetKEMAccepted
kemAccepted :: Maybe RatchetKEMAccepted
kemAccepted}, Maybe KEMKeyPair
rcPQRs_) = do
  -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss)
  let (RatchetKey
rcRK, RatchetKey
rcCKs, HeaderKey
rcNHKs) = RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
rootKdf RatchetKey
ratchetKey PublicKey a
rcDHRr PrivateKey a
rcDHRs (RatchetKEMAccepted -> KEMSharedKey
rcPQRss (RatchetKEMAccepted -> KEMSharedKey)
-> Maybe RatchetKEMAccepted -> Maybe KEMSharedKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RatchetKEMAccepted
kemAccepted)
      pqOn :: Bool
pqOn = Maybe KEMKeyPair -> Bool
forall a. Maybe a -> Bool
isJust Maybe KEMKeyPair
rcPQRs_
   in Ratchet
        { RatchetVersions
$sel:rcVersion:Ratchet :: RatchetVersions
rcVersion :: RatchetVersions
rcVersion,
          $sel:rcAD:Ratchet :: Str
rcAD = Str
assocData,
          PrivateKey a
$sel:rcDHRs:Ratchet :: PrivateKey a
rcDHRs :: PrivateKey a
rcDHRs,
          $sel:rcKEM:Ratchet :: Maybe RatchetKEM
rcKEM = (KEMKeyPair -> Maybe RatchetKEMAccepted -> RatchetKEM
`RatchetKEM` Maybe RatchetKEMAccepted
kemAccepted) (KEMKeyPair -> RatchetKEM) -> Maybe KEMKeyPair -> Maybe RatchetKEM
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KEMKeyPair
rcPQRs_,
          $sel:rcSupportKEM:Ratchet :: PQSupport
rcSupportKEM = Bool -> PQSupport
PQSupport Bool
pqOn,
          $sel:rcEnableKEM:Ratchet :: PQEncryption
rcEnableKEM = Bool -> PQEncryption
PQEncryption Bool
pqOn,
          $sel:rcSndKEM:Ratchet :: PQEncryption
rcSndKEM = Bool -> PQEncryption
PQEncryption (Bool -> PQEncryption) -> Bool -> PQEncryption
forall a b. (a -> b) -> a -> b
$ Maybe RatchetKEMAccepted -> Bool
forall a. Maybe a -> Bool
isJust Maybe RatchetKEMAccepted
kemAccepted,
          $sel:rcRcvKEM:Ratchet :: PQEncryption
rcRcvKEM = PQEncryption
PQEncOff,
          RatchetKey
$sel:rcRK:Ratchet :: RatchetKey
rcRK :: RatchetKey
rcRK,
          $sel:rcSnd:Ratchet :: Maybe (SndRatchet a)
rcSnd = SndRatchet a -> Maybe (SndRatchet a)
forall a. a -> Maybe a
Just SndRatchet {PublicKey a
$sel:rcDHRr:SndRatchet :: PublicKey a
rcDHRr :: PublicKey a
rcDHRr, RatchetKey
$sel:rcCKs:SndRatchet :: RatchetKey
rcCKs :: RatchetKey
rcCKs, $sel:rcHKs:SndRatchet :: HeaderKey
rcHKs = HeaderKey
sndHK},
          $sel:rcRcv:Ratchet :: Maybe RcvRatchet
rcRcv = Maybe RcvRatchet
forall a. Maybe a
Nothing,
          $sel:rcPN:Ratchet :: Word32
rcPN = Word32
0,
          $sel:rcNs:Ratchet :: Word32
rcNs = Word32
0,
          $sel:rcNr:Ratchet :: Word32
rcNr = Word32
0,
          HeaderKey
$sel:rcNHKs:Ratchet :: HeaderKey
rcNHKs :: HeaderKey
rcNHKs,
          $sel:rcNHKr:Ratchet :: HeaderKey
rcNHKr = HeaderKey
rcvNextHK
        }

-- | Receiving ratchet initialization, equivalent to RatchetInitBobPQ2HE in double ratchet spec
--
-- def RatchetInitBobPQ2HE(state, SK, bob_dh_key_pair, shared_hka, shared_nhkb, bob_pq_kem_key_pair)
--
-- Please note that the public part of rcDHRs was sent to the sender
-- as part of the connection request and random salt was received from the sender.
initRcvRatchet ::
  forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> PQSupport -> Ratchet a
initRcvRatchet :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> PQSupport
-> Ratchet a
initRcvRatchet RatchetVersions
rcVersion PrivateKey a
rcDHRs (RatchetInitParams {Str
$sel:assocData:RatchetInitParams :: RatchetInitParams -> Str
assocData :: Str
assocData, RatchetKey
$sel:ratchetKey:RatchetInitParams :: RatchetInitParams -> RatchetKey
ratchetKey :: RatchetKey
ratchetKey, HeaderKey
$sel:sndHK:RatchetInitParams :: RatchetInitParams -> HeaderKey
sndHK :: HeaderKey
sndHK, HeaderKey
$sel:rcvNextHK:RatchetInitParams :: RatchetInitParams -> HeaderKey
rcvNextHK :: HeaderKey
rcvNextHK, Maybe RatchetKEMAccepted
$sel:kemAccepted:RatchetInitParams :: RatchetInitParams -> Maybe RatchetKEMAccepted
kemAccepted :: Maybe RatchetKEMAccepted
kemAccepted}, Maybe KEMKeyPair
rcPQRs_) PQSupport
pqSupport =
  Ratchet
    { RatchetVersions
$sel:rcVersion:Ratchet :: RatchetVersions
rcVersion :: RatchetVersions
rcVersion,
      $sel:rcAD:Ratchet :: Str
rcAD = Str
assocData,
      PrivateKey a
$sel:rcDHRs:Ratchet :: PrivateKey a
rcDHRs :: PrivateKey a
rcDHRs,
      -- rcKEM:
      -- state.PQRs = bob_pq_kem_key_pair
      -- state.PQRr = None
      -- state.PQRss = None
      -- state.PQRct = None
      $sel:rcKEM:Ratchet :: Maybe RatchetKEM
rcKEM = (KEMKeyPair -> Maybe RatchetKEMAccepted -> RatchetKEM
`RatchetKEM` Maybe RatchetKEMAccepted
kemAccepted) (KEMKeyPair -> RatchetKEM) -> Maybe KEMKeyPair -> Maybe RatchetKEM
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KEMKeyPair
rcPQRs_,
      $sel:rcSupportKEM:Ratchet :: PQSupport
rcSupportKEM = PQSupport
pqSupport,
      $sel:rcEnableKEM:Ratchet :: PQEncryption
rcEnableKEM = PQSupport -> PQEncryption
pqSupportToEnc PQSupport
pqSupport,
      $sel:rcSndKEM:Ratchet :: PQEncryption
rcSndKEM = PQEncryption
PQEncOff,
      $sel:rcRcvKEM:Ratchet :: PQEncryption
rcRcvKEM = PQEncryption
PQEncOff,
      $sel:rcRK:Ratchet :: RatchetKey
rcRK = RatchetKey
ratchetKey,
      $sel:rcSnd:Ratchet :: Maybe (SndRatchet a)
rcSnd = Maybe (SndRatchet a)
forall a. Maybe a
Nothing,
      $sel:rcRcv:Ratchet :: Maybe RcvRatchet
rcRcv = Maybe RcvRatchet
forall a. Maybe a
Nothing,
      $sel:rcPN:Ratchet :: Word32
rcPN = Word32
0,
      $sel:rcNs:Ratchet :: Word32
rcNs = Word32
0,
      $sel:rcNr:Ratchet :: Word32
rcNr = Word32
0,
      $sel:rcNHKs:Ratchet :: HeaderKey
rcNHKs = HeaderKey
rcvNextHK,
      $sel:rcNHKr:Ratchet :: HeaderKey
rcNHKr = HeaderKey
sndHK
    }

-- encaps = state.PQRs.encaps, // added for KEM #2
-- ct = state.PQRct // added for KEM #1
data MsgHeader a = MsgHeader
  { -- | max supported ratchet version
    forall (a :: Algorithm). MsgHeader a -> VersionE2E
msgMaxVersion :: VersionE2E,
    forall (a :: Algorithm). MsgHeader a -> PublicKey a
msgDHRs :: PublicKey a,
    forall (a :: Algorithm). MsgHeader a -> Maybe ARKEMParams
msgKEM :: Maybe ARKEMParams,
    forall (a :: Algorithm). MsgHeader a -> Word32
msgPN :: Word32,
    forall (a :: Algorithm). MsgHeader a -> Word32
msgNs :: Word32
  }
  deriving (Int -> MsgHeader a -> ShowS
[MsgHeader a] -> ShowS
MsgHeader a -> String
(Int -> MsgHeader a -> ShowS)
-> (MsgHeader a -> String)
-> ([MsgHeader a] -> ShowS)
-> Show (MsgHeader a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: Algorithm). Int -> MsgHeader a -> ShowS
forall (a :: Algorithm). [MsgHeader a] -> ShowS
forall (a :: Algorithm). MsgHeader a -> String
$cshowsPrec :: forall (a :: Algorithm). Int -> MsgHeader a -> ShowS
showsPrec :: Int -> MsgHeader a -> ShowS
$cshow :: forall (a :: Algorithm). MsgHeader a -> String
show :: MsgHeader a -> String
$cshowList :: forall (a :: Algorithm). [MsgHeader a] -> ShowS
showList :: [MsgHeader a] -> ShowS
Show)

-- to allow extension without increasing the size, the actual header length is:
-- 69 = 2 (original size) + 2 + 1+56 (Curve448) + 4 + 4
-- The exact size is 2288, added reserve
paddedHeaderLen :: VersionE2E -> PQSupport -> Int
paddedHeaderLen :: VersionE2E -> PQSupport -> Int
paddedHeaderLen VersionE2E
v = \case
  PQSupport
PQSupportOn | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> Int
2310
  PQSupport
_ -> Int
88

-- only used in tests to validate correct padding
-- (2 bytes - version size, 1 byte - header size)
fullHeaderLen :: VersionE2E -> PQSupport -> Int
fullHeaderLen :: VersionE2E -> PQSupport -> Int
fullHeaderLen VersionE2E
v PQSupport
pq = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionE2E -> PQSupport -> Int
paddedHeaderLen VersionE2E
v PQSupport
pq Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
authTagSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall c. BlockCipher c => Int
ivSize @AES256

-- pass the current version, as MsgHeader only includes the max supported version that can be different from the current
encodeMsgHeader :: AlgorithmI a => VersionE2E -> MsgHeader a -> ByteString
encodeMsgHeader :: forall (a :: Algorithm).
AlgorithmI a =>
VersionE2E -> MsgHeader a -> ByteString
encodeMsgHeader VersionE2E
v MsgHeader {VersionE2E
$sel:msgMaxVersion:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> VersionE2E
msgMaxVersion :: VersionE2E
msgMaxVersion, PublicKey a
$sel:msgDHRs:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> PublicKey a
msgDHRs :: PublicKey a
msgDHRs, Maybe ARKEMParams
$sel:msgKEM:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Maybe ARKEMParams
msgKEM :: Maybe ARKEMParams
msgKEM, Word32
$sel:msgPN:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Word32
msgPN :: Word32
msgPN, Word32
$sel:msgNs:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Word32
msgNs :: Word32
msgNs}
  | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion = (VersionE2E, PublicKey a, Maybe ARKEMParams, Word32, Word32)
-> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
msgMaxVersion, PublicKey a
msgDHRs, Maybe ARKEMParams
msgKEM, Word32
msgPN, Word32
msgNs)
  | Bool
otherwise = (VersionE2E, PublicKey a, Word32, Word32) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
msgMaxVersion, PublicKey a
msgDHRs, Word32
msgPN, Word32
msgNs)

-- pass the current version, as MsgHeader only includes the max supported version that can be different from the current
msgHeaderP :: AlgorithmI a => VersionE2E -> Parser (MsgHeader a)
msgHeaderP :: forall (a :: Algorithm).
AlgorithmI a =>
VersionE2E -> Parser (MsgHeader a)
msgHeaderP VersionE2E
v = do
  VersionE2E
msgMaxVersion <- Parser VersionE2E
forall a. Encoding a => Parser a
smpP
  PublicKey a
msgDHRs <- Parser (PublicKey a)
forall a. Encoding a => Parser a
smpP
  Maybe ARKEMParams
msgKEM <- if VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion then Parser (Maybe ARKEMParams)
forall a. Encoding a => Parser a
smpP else Maybe ARKEMParams -> Parser (Maybe ARKEMParams)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ARKEMParams
forall a. Maybe a
Nothing
  Word32
msgPN <- Parser Word32
forall a. Encoding a => Parser a
smpP
  Word32
msgNs <- Parser Word32
forall a. Encoding a => Parser a
smpP
  MsgHeader a -> Parser (MsgHeader a)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgHeader {VersionE2E
$sel:msgMaxVersion:MsgHeader :: VersionE2E
msgMaxVersion :: VersionE2E
msgMaxVersion, PublicKey a
$sel:msgDHRs:MsgHeader :: PublicKey a
msgDHRs :: PublicKey a
msgDHRs, Maybe ARKEMParams
$sel:msgKEM:MsgHeader :: Maybe ARKEMParams
msgKEM :: Maybe ARKEMParams
msgKEM, Word32
$sel:msgPN:MsgHeader :: Word32
msgPN :: Word32
msgPN, Word32
$sel:msgNs:MsgHeader :: Word32
msgNs :: Word32
msgNs}

data EncMessageHeader = EncMessageHeader
  { EncMessageHeader -> VersionE2E
ehVersion :: VersionE2E, -- this is current ratchet version
    EncMessageHeader -> IV
ehIV :: IV,
    EncMessageHeader -> AuthTag
ehAuthTag :: AuthTag,
    EncMessageHeader -> ByteString
ehBody :: ByteString
  }

-- this encoding depends on version in EncMessageHeader because it is "current" ratchet version
instance Encoding EncMessageHeader where
  smpEncode :: EncMessageHeader -> ByteString
smpEncode EncMessageHeader {VersionE2E
$sel:ehVersion:EncMessageHeader :: EncMessageHeader -> VersionE2E
ehVersion :: VersionE2E
ehVersion, IV
$sel:ehIV:EncMessageHeader :: EncMessageHeader -> IV
ehIV :: IV
ehIV, AuthTag
$sel:ehAuthTag:EncMessageHeader :: EncMessageHeader -> AuthTag
ehAuthTag :: AuthTag
ehAuthTag, ByteString
$sel:ehBody:EncMessageHeader :: EncMessageHeader -> ByteString
ehBody :: ByteString
ehBody} =
    (VersionE2E, IV, AuthTag) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
ehVersion, IV
ehIV, AuthTag
ehAuthTag) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> VersionE2E -> ByteString -> ByteString
encodeLarge VersionE2E
ehVersion ByteString
ehBody
  smpP :: Parser EncMessageHeader
smpP = do
    (VersionE2E
ehVersion, IV
ehIV, AuthTag
ehAuthTag) <- Parser (VersionE2E, IV, AuthTag)
forall a. Encoding a => Parser a
smpP
    ByteString
ehBody <- Parser ByteString ByteString
largeP
    EncMessageHeader -> Parser EncMessageHeader
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncMessageHeader {VersionE2E
$sel:ehVersion:EncMessageHeader :: VersionE2E
ehVersion :: VersionE2E
ehVersion, IV
$sel:ehIV:EncMessageHeader :: IV
ehIV :: IV
ehIV, AuthTag
$sel:ehAuthTag:EncMessageHeader :: AuthTag
ehAuthTag :: AuthTag
ehAuthTag, ByteString
$sel:ehBody:EncMessageHeader :: ByteString
ehBody :: ByteString
ehBody}

-- the encoder always uses 2-byte lengths for the new version, even for short headers without PQ keys.
encodeLarge :: VersionE2E -> ByteString -> ByteString
encodeLarge :: VersionE2E -> ByteString -> ByteString
encodeLarge VersionE2E
v ByteString
s
  | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion = Large -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Large -> ByteString) -> Large -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Large
Large ByteString
s
  | Bool
otherwise = ByteString -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode ByteString
s

-- This parser relies on the fact that header cannot be shorter than 32 bytes (it is ~69 bytes without PQ KEM),
-- therefore if the first byte is less or equal to 31 (x1F), then we have 2 byte-length limited to 8191.
-- This allows upgrading the current version in one message.
largeP :: Parser ByteString
largeP :: Parser ByteString ByteString
largeP = do
  Word8
len1 <- Parser Word8
peekWord8'
  if Word8
len1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
32 then Large -> ByteString
unLarge (Large -> ByteString)
-> Parser ByteString Large -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Large
forall a. Encoding a => Parser a
smpP else Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP

-- the header is length-prefixed to parse it as string and use as part of associated data for authenticated encryption
data EncRatchetMessage = EncRatchetMessage
  { EncRatchetMessage -> ByteString
emHeader :: ByteString,
    EncRatchetMessage -> AuthTag
emAuthTag :: AuthTag,
    EncRatchetMessage -> ByteString
emBody :: ByteString
  }

encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage VersionE2E
v EncRatchetMessage {ByteString
$sel:emHeader:EncRatchetMessage :: EncRatchetMessage -> ByteString
emHeader :: ByteString
emHeader, ByteString
$sel:emBody:EncRatchetMessage :: EncRatchetMessage -> ByteString
emBody :: ByteString
emBody, AuthTag
$sel:emAuthTag:EncRatchetMessage :: EncRatchetMessage -> AuthTag
emAuthTag :: AuthTag
emAuthTag} =
  VersionE2E -> ByteString -> ByteString
encodeLarge VersionE2E
v ByteString
emHeader ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (AuthTag, Tail) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (AuthTag
emAuthTag, ByteString -> Tail
Tail ByteString
emBody)

encRatchetMessageP :: Parser EncRatchetMessage
encRatchetMessageP :: Parser EncRatchetMessage
encRatchetMessageP = do
  ByteString
emHeader <- Parser ByteString ByteString
largeP
  (AuthTag
emAuthTag, Tail ByteString
emBody) <- Parser (AuthTag, Tail)
forall a. Encoding a => Parser a
smpP
  EncRatchetMessage -> Parser EncRatchetMessage
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncRatchetMessage {ByteString
$sel:emHeader:EncRatchetMessage :: ByteString
emHeader :: ByteString
emHeader, ByteString
$sel:emBody:EncRatchetMessage :: ByteString
emBody :: ByteString
emBody, AuthTag
$sel:emAuthTag:EncRatchetMessage :: AuthTag
emAuthTag :: AuthTag
emAuthTag}

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

pattern PQEncOn :: PQEncryption
pattern $mPQEncOn :: forall {r}. PQEncryption -> ((# #) -> r) -> ((# #) -> r) -> r
$bPQEncOn :: PQEncryption
PQEncOn = PQEncryption True

pattern PQEncOff :: PQEncryption
pattern $mPQEncOff :: forall {r}. PQEncryption -> ((# #) -> r) -> ((# #) -> r) -> r
$bPQEncOff :: PQEncryption
PQEncOff = PQEncryption False

{-# COMPLETE PQEncOn, PQEncOff #-}

instance ToJSON PQEncryption where
  toEncoding :: PQEncryption -> Encoding
toEncoding (PQEncryption Bool
pq) = Bool -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Bool
pq
  toJSON :: PQEncryption -> Value
toJSON (PQEncryption Bool
pq) = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
pq

instance FromJSON PQEncryption where
  parseJSON :: Value -> Parser PQEncryption
parseJSON Value
v = Bool -> PQEncryption
PQEncryption (Bool -> PQEncryption) -> Parser Bool -> Parser PQEncryption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  omittedField :: Maybe PQEncryption
omittedField = PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
PQEncOff

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

pattern PQSupportOn :: PQSupport
pattern $mPQSupportOn :: forall {r}. PQSupport -> ((# #) -> r) -> ((# #) -> r) -> r
$bPQSupportOn :: PQSupport
PQSupportOn = PQSupport True

pattern PQSupportOff :: PQSupport
pattern $mPQSupportOff :: forall {r}. PQSupport -> ((# #) -> r) -> ((# #) -> r) -> r
$bPQSupportOff :: PQSupport
PQSupportOff = PQSupport False

{-# COMPLETE PQSupportOn, PQSupportOff #-}

instance ToJSON PQSupport where
  toEncoding :: PQSupport -> Encoding
toEncoding (PQSupport Bool
pq) = Bool -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Bool
pq
  toJSON :: PQSupport -> Value
toJSON (PQSupport Bool
pq) = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
pq

instance FromJSON PQSupport where
  parseJSON :: Value -> Parser PQSupport
parseJSON Value
v = Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> Parser Bool -> Parser PQSupport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  omittedField :: Maybe PQSupport
omittedField = PQSupport -> Maybe PQSupport
forall a. a -> Maybe a
Just PQSupport
PQSupportOff

pqSupportToEnc :: PQSupport -> PQEncryption
pqSupportToEnc :: PQSupport -> PQEncryption
pqSupportToEnc (PQSupport Bool
pq) = Bool -> PQEncryption
PQEncryption Bool
pq

pqEncToSupport :: PQEncryption -> PQSupport
pqEncToSupport :: PQEncryption -> PQSupport
pqEncToSupport (PQEncryption Bool
pq) = Bool -> PQSupport
PQSupport Bool
pq

pqSupportAnd :: PQSupport -> PQSupport -> PQSupport
pqSupportAnd :: PQSupport -> PQSupport -> PQSupport
pqSupportAnd (PQSupport Bool
s1) (PQSupport Bool
s2) = Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> Bool -> PQSupport
forall a b. (a -> b) -> a -> b
$ Bool
s1 Bool -> Bool -> Bool
&& Bool
s2

pqEnableSupport :: VersionE2E -> PQSupport -> PQEncryption -> PQSupport
pqEnableSupport :: VersionE2E -> PQSupport -> PQEncryption -> PQSupport
pqEnableSupport VersionE2E
v (PQSupport Bool
sup) (PQEncryption Bool
enc) = Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> Bool -> PQSupport
forall a b. (a -> b) -> a -> b
$ Bool
sup Bool -> Bool -> Bool
|| (VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion Bool -> Bool -> Bool
&& Bool
enc)

replyKEM_ :: VersionE2E -> Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM
replyKEM_ :: VersionE2E
-> Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM
replyKEM_ VersionE2E
v Maybe (RKEMParams 'RKSProposed)
kem_ = \case
  PQSupport
PQSupportOn | VersionE2E
v VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> AUseKEM -> Maybe AUseKEM
forall a. a -> Maybe a
Just (AUseKEM -> Maybe AUseKEM) -> AUseKEM -> Maybe AUseKEM
forall a b. (a -> b) -> a -> b
$ case Maybe (RKEMParams 'RKSProposed)
kem_ of
    Just (RKParamsProposed KEMPublicKey
k) -> SRatchetKEMState 'RKSAccepted -> UseKEM 'RKSAccepted -> AUseKEM
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> UseKEM s -> AUseKEM
AUseKEM SRatchetKEMState 'RKSAccepted
SRKSAccepted (UseKEM 'RKSAccepted -> AUseKEM) -> UseKEM 'RKSAccepted -> AUseKEM
forall a b. (a -> b) -> a -> b
$ KEMPublicKey -> UseKEM 'RKSAccepted
AcceptKEM KEMPublicKey
k
    Maybe (RKEMParams 'RKSProposed)
Nothing -> SRatchetKEMState 'RKSProposed -> UseKEM 'RKSProposed -> AUseKEM
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> UseKEM s -> AUseKEM
AUseKEM SRatchetKEMState 'RKSProposed
SRKSProposed UseKEM 'RKSProposed
ProposeKEM
  PQSupport
_ -> Maybe AUseKEM
forall a. Maybe a
Nothing

instance StrEncoding PQEncryption where
  strEncode :: PQEncryption -> ByteString
strEncode PQEncryption
pqMode
    | PQEncryption -> Bool
enablePQ PQEncryption
pqMode = ByteString
"pq=enable"
    | Bool
otherwise = ByteString
"pq=disable"
  strP :: Parser PQEncryption
strP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser PQEncryption) -> Parser PQEncryption
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"pq=enable" -> Bool -> Parser PQEncryption
pq Bool
True
      ByteString
"pq=disable" -> Bool -> Parser PQEncryption
pq Bool
False
      ByteString
_ -> String -> Parser PQEncryption
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad PQEncryption"
    where
      pq :: Bool -> Parser PQEncryption
pq = PQEncryption -> Parser PQEncryption
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PQEncryption -> Parser PQEncryption)
-> (Bool -> PQEncryption) -> Bool -> Parser PQEncryption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PQEncryption
PQEncryption

instance StrEncoding PQSupport where
  strEncode :: PQSupport -> ByteString
strEncode = PQEncryption -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (PQEncryption -> ByteString)
-> (PQSupport -> PQEncryption) -> PQSupport -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PQSupport -> PQEncryption
pqSupportToEnc
  {-# INLINE strEncode #-}
  strP :: Parser PQSupport
strP = PQEncryption -> PQSupport
pqEncToSupport (PQEncryption -> PQSupport)
-> Parser PQEncryption -> Parser PQSupport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PQEncryption
forall a. StrEncoding a => Parser a
strP
  {-# INLINE strP #-}

data InitialKeys
  = IKUsePQ -- use PQ keys in contact request and short link data
  | IKLinkPQ PQSupport -- use PQ keys in short link data only, if PQSupport enabled
  deriving (InitialKeys -> InitialKeys -> Bool
(InitialKeys -> InitialKeys -> Bool)
-> (InitialKeys -> InitialKeys -> Bool) -> Eq InitialKeys
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitialKeys -> InitialKeys -> Bool
== :: InitialKeys -> InitialKeys -> Bool
$c/= :: InitialKeys -> InitialKeys -> Bool
/= :: InitialKeys -> InitialKeys -> Bool
Eq, Int -> InitialKeys -> ShowS
[InitialKeys] -> ShowS
InitialKeys -> String
(Int -> InitialKeys -> ShowS)
-> (InitialKeys -> String)
-> ([InitialKeys] -> ShowS)
-> Show InitialKeys
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialKeys -> ShowS
showsPrec :: Int -> InitialKeys -> ShowS
$cshow :: InitialKeys -> String
show :: InitialKeys -> String
$cshowList :: [InitialKeys] -> ShowS
showList :: [InitialKeys] -> ShowS
Show)

pattern IKPQOn :: InitialKeys
pattern $mIKPQOn :: forall {r}. InitialKeys -> ((# #) -> r) -> ((# #) -> r) -> r
$bIKPQOn :: InitialKeys
IKPQOn = IKLinkPQ PQSupportOn

pattern IKPQOff :: InitialKeys
pattern $mIKPQOff :: forall {r}. InitialKeys -> ((# #) -> r) -> ((# #) -> r) -> r
$bIKPQOff :: InitialKeys
IKPQOff = IKLinkPQ PQSupportOff

instance StrEncoding InitialKeys where
  strEncode :: InitialKeys -> ByteString
strEncode = \case
    InitialKeys
IKUsePQ -> ByteString
"pq=invitation"
    IKLinkPQ PQSupport
pq -> PQSupport -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode PQSupport
pq
  strP :: Parser InitialKeys
strP = PQSupport -> InitialKeys
IKLinkPQ (PQSupport -> InitialKeys)
-> Parser PQSupport -> Parser InitialKeys
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PQSupport
forall a. StrEncoding a => Parser a
strP Parser InitialKeys -> Parser InitialKeys -> Parser InitialKeys
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"pq=invitation" Parser ByteString ByteString -> InitialKeys -> Parser InitialKeys
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> InitialKeys
IKUsePQ

-- determines whether PQ key should be included in invitation link
initialPQEncryption :: Bool -> InitialKeys -> PQSupport
initialPQEncryption :: Bool -> InitialKeys -> PQSupport
initialPQEncryption Bool
shortLink = \case
  InitialKeys
IKUsePQ -> PQSupport
PQSupportOn
  IKLinkPQ (PQSupport Bool
enable) -> Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> Bool -> PQSupport
forall a b. (a -> b) -> a -> b
$ Bool
enable Bool -> Bool -> Bool
&& Bool
shortLink

-- determines whether PQ encryption should be used in connection
connPQEncryption :: InitialKeys -> PQSupport
connPQEncryption :: InitialKeys -> PQSupport
connPQEncryption = \case
  InitialKeys
IKUsePQ -> PQSupport
PQSupportOn
  IKLinkPQ PQSupport
pq -> PQSupport
pq -- default for creating connection is IKLinkPQ PQEncOn

joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
joinContactInitialKeys Bool
pqCompatible = \case
  PQSupport
PQSupportOn | Bool
pqCompatible -> InitialKeys
IKUsePQ
  PQSupport
pqEnc -> PQSupport -> InitialKeys
IKLinkPQ PQSupport
pqEnc

rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
rcCheckCanPad Int
paddedMsgLen ByteString
msg =
  Bool -> ExceptT CryptoError IO () -> ExceptT CryptoError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Int -> Bool
canPad (ByteString -> Int
B.length ByteString
msg) Int
paddedMsgLen) (ExceptT CryptoError IO () -> ExceptT CryptoError IO ())
-> ExceptT CryptoError IO () -> ExceptT CryptoError IO ()
forall a b. (a -> b) -> a -> b
$ CryptoError -> ExceptT CryptoError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CryptoLargeMsgError

rcEncryptHeader :: AlgorithmI a => Ratchet a -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
rcEncryptHeader :: forall (a :: Algorithm).
AlgorithmI a =>
Ratchet a
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
rcEncryptHeader Ratchet {$sel:rcSnd:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe (SndRatchet a)
rcSnd = Maybe (SndRatchet a)
Nothing} Maybe PQEncryption
_ VersionE2E
_ = CryptoError -> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CERatchetState
rcEncryptHeader rc :: Ratchet a
rc@Ratchet {$sel:rcSnd:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe (SndRatchet a)
rcSnd = Just sr :: SndRatchet a
sr@SndRatchet {RatchetKey
$sel:rcCKs:SndRatchet :: forall (a :: Algorithm). SndRatchet a -> RatchetKey
rcCKs :: RatchetKey
rcCKs, HeaderKey
$sel:rcHKs:SndRatchet :: forall (a :: Algorithm). SndRatchet a -> HeaderKey
rcHKs :: HeaderKey
rcHKs}, PrivateKey a
$sel:rcDHRs:Ratchet :: forall (a :: Algorithm). Ratchet a -> PrivateKey a
rcDHRs :: PrivateKey a
rcDHRs, Maybe RatchetKEM
$sel:rcKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RatchetKEM
rcKEM :: Maybe RatchetKEM
rcKEM, Word32
$sel:rcNs:Ratchet :: forall (a :: Algorithm). Ratchet a -> Word32
rcNs :: Word32
rcNs, Word32
$sel:rcPN:Ratchet :: forall (a :: Algorithm). Ratchet a -> Word32
rcPN :: Word32
rcPN, $sel:rcAD:Ratchet :: forall (a :: Algorithm). Ratchet a -> Str
rcAD = Str ByteString
rcAD, PQSupport
$sel:rcSupportKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> PQSupport
rcSupportKEM :: PQSupport
rcSupportKEM, PQEncryption
$sel:rcEnableKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> PQEncryption
rcEnableKEM :: PQEncryption
rcEnableKEM, RatchetVersions
$sel:rcVersion:Ratchet :: forall (a :: Algorithm). Ratchet a -> RatchetVersions
rcVersion :: RatchetVersions
rcVersion} Maybe PQEncryption
pqEnc_ VersionE2E
supportedE2EVersion = do
  -- state.CKs, mk = KDF_CK(state.CKs)
  let (RatchetKey
ck', HeaderKey
mk, IV
iv, IV
ehIV) = RatchetKey -> (RatchetKey, HeaderKey, IV, IV)
chainKdf RatchetKey
rcCKs
      v :: VersionE2E
v = RatchetVersions -> VersionE2E
current RatchetVersions
rcVersion
      -- PQ encryption can be enabled or disabled
      rcEnableKEM' :: PQEncryption
rcEnableKEM' = PQEncryption -> Maybe PQEncryption -> PQEncryption
forall a. a -> Maybe a -> a
fromMaybe PQEncryption
rcEnableKEM Maybe PQEncryption
pqEnc_
      -- support for PQ encryption (and therefore large headers/small envelopes) can only be enabled, it cannot be disabled
      rcSupportKEM' :: PQSupport
rcSupportKEM' = VersionE2E -> PQSupport -> PQEncryption -> PQSupport
pqEnableSupport VersionE2E
v PQSupport
rcSupportKEM PQEncryption
rcEnableKEM'
      -- This sets max version to support PQ encryption.
      -- Current version upgrade happens when peer decrypts the message.
      -- TODO note that maxSupported will not downgrade here below current (v).
      maxSupported' :: VersionE2E
maxSupported' = VersionE2E -> VersionE2E -> VersionE2E
forall a. Ord a => a -> a -> a
max VersionE2E
supportedE2EVersion (VersionE2E -> VersionE2E) -> VersionE2E -> VersionE2E
forall a b. (a -> b) -> a -> b
$ if Maybe PQEncryption
pqEnc_ Maybe PQEncryption -> Maybe PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
== PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
PQEncOn then VersionE2E
pqRatchetE2EEncryptVersion else VersionE2E
v
      rcVersion' :: RatchetVersions
rcVersion' = RatchetVersions
rcVersion {maxSupported = maxSupported'}
  -- enc_header = HENCRYPT(state.HKs, header)
  (AuthTag
ehAuthTag, ByteString
ehBody) <- HeaderKey
-> IV
-> Int
-> ByteString
-> ByteString
-> ExceptT CryptoError IO (AuthTag, ByteString)
encryptAEAD HeaderKey
rcHKs IV
ehIV (VersionE2E -> PQSupport -> Int
paddedHeaderLen VersionE2E
v PQSupport
rcSupportKEM') ByteString
rcAD (VersionE2E -> VersionE2E -> ByteString
msgHeader VersionE2E
v VersionE2E
maxSupported')
  -- return enc_header
  let emHeader :: ByteString
emHeader = EncMessageHeader -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode EncMessageHeader {$sel:ehVersion:EncMessageHeader :: VersionE2E
ehVersion = VersionE2E
v, ByteString
$sel:ehBody:EncMessageHeader :: ByteString
ehBody :: ByteString
ehBody, AuthTag
$sel:ehAuthTag:EncMessageHeader :: AuthTag
ehAuthTag :: AuthTag
ehAuthTag, IV
$sel:ehIV:EncMessageHeader :: IV
ehIV :: IV
ehIV}
      msgEncryptKey :: MsgEncryptKey a
msgEncryptKey =
        MsgEncryptKey
          { $sel:msgRcVersion:MsgEncryptKey :: VersionE2E
msgRcVersion = VersionE2E
v,
            $sel:msgKey:MsgEncryptKey :: MessageKey
msgKey = HeaderKey -> IV -> MessageKey
MessageKey HeaderKey
mk IV
iv,
            $sel:msgRcAD:MsgEncryptKey :: ByteString
msgRcAD = ByteString
rcAD,
            $sel:msgEncHeader:MsgEncryptKey :: ByteString
msgEncHeader = ByteString
emHeader
          }
      rc' :: Ratchet a
rc' =
        Ratchet a
rc
          { rcSnd = Just sr {rcCKs = ck'},
            rcNs = rcNs + 1,
            rcSupportKEM = rcSupportKEM',
            rcEnableKEM = rcEnableKEM',
            rcVersion = rcVersion',
            rcKEM = if pqEnc_ == Just PQEncOff then (\RatchetKEM
rck -> RatchetKEM
rck {rcKEMs = Nothing}) <$> rcKEM else rcKEM
          }
  (MsgEncryptKey a, Ratchet a)
-> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgEncryptKey a
msgEncryptKey, Ratchet a
rc')
  where
    -- header = HEADER_PQ2(
    --   dh = state.DHRs.public,
    --   kem = state.PQRs.public, // added for KEM #2
    --   ct = state.PQRct, // added for KEM #1
    --   pn = state.PN,
    --   n = state.Ns
    -- )
    msgHeader :: VersionE2E -> VersionE2E -> ByteString
msgHeader VersionE2E
v VersionE2E
maxSupported' =
      VersionE2E -> MsgHeader a -> ByteString
forall (a :: Algorithm).
AlgorithmI a =>
VersionE2E -> MsgHeader a -> ByteString
encodeMsgHeader
        VersionE2E
v
        MsgHeader
          { $sel:msgMaxVersion:MsgHeader :: VersionE2E
msgMaxVersion = VersionE2E
maxSupported',
            $sel:msgDHRs:MsgHeader :: PublicKey a
msgDHRs = PrivateKey a -> PublicKey a
forall (a :: Algorithm). PrivateKey a -> PublicKey a
publicKey PrivateKey a
rcDHRs,
            $sel:msgKEM:MsgHeader :: Maybe ARKEMParams
msgKEM = RatchetKEM -> ARKEMParams
msgKEMParams (RatchetKEM -> ARKEMParams)
-> Maybe RatchetKEM -> Maybe ARKEMParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RatchetKEM
rcKEM,
            $sel:msgPN:MsgHeader :: Word32
msgPN = Word32
rcPN,
            $sel:msgNs:MsgHeader :: Word32
msgNs = Word32
rcNs
          }
    msgKEMParams :: RatchetKEM -> ARKEMParams
msgKEMParams RatchetKEM {$sel:rcPQRs:RatchetKEM :: RatchetKEM -> KEMKeyPair
rcPQRs = (KEMPublicKey
k, KEMSecretKey
_), Maybe RatchetKEMAccepted
$sel:rcKEMs:RatchetKEM :: RatchetKEM -> Maybe RatchetKEMAccepted
rcKEMs :: Maybe RatchetKEMAccepted
rcKEMs} = case Maybe RatchetKEMAccepted
rcKEMs of
      Maybe RatchetKEMAccepted
Nothing -> SRatchetKEMState 'RKSProposed
-> RKEMParams 'RKSProposed -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSProposed
SRKSProposed (RKEMParams 'RKSProposed -> ARKEMParams)
-> RKEMParams 'RKSProposed -> ARKEMParams
forall a b. (a -> b) -> a -> b
$ KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsProposed KEMPublicKey
k
      Just RatchetKEMAccepted {KEMCiphertext
$sel:rcPQRct:RatchetKEMAccepted :: RatchetKEMAccepted -> KEMCiphertext
rcPQRct :: KEMCiphertext
rcPQRct} -> SRatchetKEMState 'RKSAccepted
-> RKEMParams 'RKSAccepted -> ARKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> RKEMParams s -> ARKEMParams
ARKP SRatchetKEMState 'RKSAccepted
SRKSAccepted (RKEMParams 'RKSAccepted -> ARKEMParams)
-> RKEMParams 'RKSAccepted -> ARKEMParams
forall a b. (a -> b) -> a -> b
$ KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted
RKParamsAccepted KEMCiphertext
rcPQRct KEMPublicKey
k

type MsgEncryptKeyX448 = MsgEncryptKey 'X448

data MsgEncryptKey a = MsgEncryptKey
  { forall {k} (a :: k). MsgEncryptKey a -> VersionE2E
msgRcVersion :: VersionE2E,
    forall {k} (a :: k). MsgEncryptKey a -> MessageKey
msgKey :: MessageKey,
    forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgRcAD :: ByteString,
    forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgEncHeader :: ByteString
  }
  deriving (Int -> MsgEncryptKey a -> ShowS
[MsgEncryptKey a] -> ShowS
MsgEncryptKey a -> String
(Int -> MsgEncryptKey a -> ShowS)
-> (MsgEncryptKey a -> String)
-> ([MsgEncryptKey a] -> ShowS)
-> Show (MsgEncryptKey a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> MsgEncryptKey a -> ShowS
forall k (a :: k). [MsgEncryptKey a] -> ShowS
forall k (a :: k). MsgEncryptKey a -> String
$cshowsPrec :: forall k (a :: k). Int -> MsgEncryptKey a -> ShowS
showsPrec :: Int -> MsgEncryptKey a -> ShowS
$cshow :: forall k (a :: k). MsgEncryptKey a -> String
show :: MsgEncryptKey a -> String
$cshowList :: forall k (a :: k). [MsgEncryptKey a] -> ShowS
showList :: [MsgEncryptKey a] -> ShowS
Show)

rcEncryptMsg :: AlgorithmI a => MsgEncryptKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString
rcEncryptMsg :: forall (a :: Algorithm).
AlgorithmI a =>
MsgEncryptKey a
-> Int -> ByteString -> ExceptT CryptoError IO ByteString
rcEncryptMsg MsgEncryptKey {$sel:msgKey:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> MessageKey
msgKey = MessageKey HeaderKey
mk IV
iv, ByteString
$sel:msgRcAD:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgRcAD :: ByteString
msgRcAD, ByteString
$sel:msgEncHeader:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgEncHeader :: ByteString
msgEncHeader, $sel:msgRcVersion:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> VersionE2E
msgRcVersion = VersionE2E
v} Int
paddedMsgLen ByteString
msg = do
  -- return ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
  (AuthTag
emAuthTag, ByteString
emBody) <- HeaderKey
-> IV
-> Int
-> ByteString
-> ByteString
-> ExceptT CryptoError IO (AuthTag, ByteString)
encryptAEAD HeaderKey
mk IV
iv Int
paddedMsgLen (ByteString
msgRcAD ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
msgEncHeader) ByteString
msg
  let msg' :: ByteString
msg' = VersionE2E -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage VersionE2E
v EncRatchetMessage {$sel:emHeader:EncRatchetMessage :: ByteString
emHeader = ByteString
msgEncHeader, ByteString
$sel:emBody:EncRatchetMessage :: ByteString
emBody :: ByteString
emBody, AuthTag
$sel:emAuthTag:EncRatchetMessage :: AuthTag
emAuthTag :: AuthTag
emAuthTag}
  ByteString -> ExceptT CryptoError IO ByteString
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
msg'

data SkippedMessage a
  = SMMessage (DecryptResult a)
  | SMHeader (Maybe RatchetStep) (MsgHeader a)
  | SMNone

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

type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)

maxSkip :: Word32
maxSkip :: Word32
maxSkip = Word32
512

rcDecrypt ::
  forall a.
  (AlgorithmI a, DhAlgorithm a) =>
  TVar ChaChaDRG ->
  Ratchet a ->
  SkippedMsgKeys ->
  ByteString ->
  ExceptT CryptoError IO (DecryptResult a)
rcDecrypt :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> Ratchet a
-> SkippedMsgKeys
-> ByteString
-> ExceptT CryptoError IO (DecryptResult a)
rcDecrypt TVar ChaChaDRG
g rc :: Ratchet a
rc@Ratchet {Maybe RcvRatchet
$sel:rcRcv:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RcvRatchet
rcRcv :: Maybe RcvRatchet
rcRcv, $sel:rcAD:Ratchet :: forall (a :: Algorithm). Ratchet a -> Str
rcAD = Str ByteString
rcAD, RatchetVersions
$sel:rcVersion:Ratchet :: forall (a :: Algorithm). Ratchet a -> RatchetVersions
rcVersion :: RatchetVersions
rcVersion} SkippedMsgKeys
rcMKSkipped ByteString
msg' = do
  encMsg :: EncRatchetMessage
encMsg@EncRatchetMessage {ByteString
$sel:emHeader:EncRatchetMessage :: EncRatchetMessage -> ByteString
emHeader :: ByteString
emHeader} <- (String -> CryptoError)
-> Parser EncRatchetMessage
-> ByteString
-> ExceptT CryptoError IO EncRatchetMessage
forall e a.
(String -> e) -> Parser a -> ByteString -> ExceptT e IO a
parseE String -> CryptoError
CryptoHeaderError Parser EncRatchetMessage
encRatchetMessageP ByteString
msg'
  EncMessageHeader
encHdr <- (String -> CryptoError)
-> Parser EncMessageHeader
-> ByteString
-> ExceptT CryptoError IO EncMessageHeader
forall e a.
(String -> e) -> Parser a -> ByteString -> ExceptT e IO a
parseE String -> CryptoError
CryptoHeaderError Parser EncMessageHeader
forall a. Encoding a => Parser a
smpP ByteString
emHeader
  -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)
  EncMessageHeader
-> EncRatchetMessage -> ExceptT CryptoError IO (SkippedMessage a)
decryptSkipped EncMessageHeader
encHdr EncRatchetMessage
encMsg ExceptT CryptoError IO (SkippedMessage a)
-> (SkippedMessage a -> ExceptT CryptoError IO (DecryptResult a))
-> ExceptT CryptoError IO (DecryptResult a)
forall a b.
ExceptT CryptoError IO a
-> (a -> ExceptT CryptoError IO b) -> ExceptT CryptoError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SkippedMessage a
SMNone -> do
      (RatchetStep
rcStep, MsgHeader a
hdr) <- Maybe RcvRatchet
-> EncMessageHeader
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
decryptRcHeader Maybe RcvRatchet
rcRcv EncMessageHeader
encHdr
      RatchetStep
-> MsgHeader a
-> EncRatchetMessage
-> ExceptT CryptoError IO (DecryptResult a)
decryptRcMessage RatchetStep
rcStep MsgHeader a
hdr EncRatchetMessage
encMsg
    SMHeader Maybe RatchetStep
rcStep_ MsgHeader a
hdr ->
      case Maybe RatchetStep
rcStep_ of
        Just RatchetStep
rcStep -> RatchetStep
-> MsgHeader a
-> EncRatchetMessage
-> ExceptT CryptoError IO (DecryptResult a)
decryptRcMessage RatchetStep
rcStep MsgHeader a
hdr EncRatchetMessage
encMsg
        Maybe RatchetStep
Nothing -> CryptoError -> ExceptT CryptoError IO (DecryptResult a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CERatchetHeader
    SMMessage DecryptResult a
r -> DecryptResult a -> ExceptT CryptoError IO (DecryptResult a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DecryptResult a
r
  where
    decryptRcMessage :: RatchetStep -> MsgHeader a -> EncRatchetMessage -> ExceptT CryptoError IO (DecryptResult a)
    decryptRcMessage :: RatchetStep
-> MsgHeader a
-> EncRatchetMessage
-> ExceptT CryptoError IO (DecryptResult a)
decryptRcMessage RatchetStep
rcStep hdr :: MsgHeader a
hdr@MsgHeader {VersionE2E
$sel:msgMaxVersion:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> VersionE2E
msgMaxVersion :: VersionE2E
msgMaxVersion, Word32
$sel:msgPN:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Word32
msgPN :: Word32
msgPN, Word32
$sel:msgNs:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Word32
msgNs :: Word32
msgNs} EncRatchetMessage
encMsg = do
      -- if dh_ratchet:
      (Ratchet a
rc', SkippedMsgKeys
smks1) <- case RatchetStep
rcStep of
        RatchetStep
SameRatchet -> (Ratchet a, SkippedMsgKeys)
-> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratchet a
upgradedRatchet, SkippedMsgKeys
forall k a. Map k a
M.empty)
        RatchetStep
AdvanceRatchet -> do
          -- SkipMessageKeysHE(state, header.pn)
          (Ratchet a
rc', SkippedMsgKeys
hmks) <- Either CryptoError (Ratchet a, SkippedMsgKeys)
-> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either CryptoError (Ratchet a, SkippedMsgKeys)
 -> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys))
-> Either CryptoError (Ratchet a, SkippedMsgKeys)
-> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)
forall a b. (a -> b) -> a -> b
$ Word32
-> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys Word32
msgPN Ratchet a
upgradedRatchet
          -- DHRatchetPQ2HE(state, header)
          (,SkippedMsgKeys
hmks) (Ratchet a -> (Ratchet a, SkippedMsgKeys))
-> ExceptT CryptoError IO (Ratchet a)
-> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ratchet a -> MsgHeader a -> ExceptT CryptoError IO (Ratchet a)
ratchetStep Ratchet a
rc' MsgHeader a
hdr
      -- SkipMessageKeysHE(state, header.n)
      case Word32
-> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys Word32
msgNs Ratchet a
rc' of
        Left CryptoError
e -> DecryptResult a -> ExceptT CryptoError IO (DecryptResult a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CryptoError -> Either CryptoError ByteString
forall a b. a -> Either a b
Left CryptoError
e, Ratchet a
rc', SkippedMsgKeys -> SkippedMsgDiff
smkDiff SkippedMsgKeys
smks1)
        Right (rc'' :: Ratchet a
rc''@Ratchet {$sel:rcRcv:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RcvRatchet
rcRcv = Just rr :: RcvRatchet
rr@RcvRatchet {RatchetKey
$sel:rcCKr:RcvRatchet :: RcvRatchet -> RatchetKey
rcCKr :: RatchetKey
rcCKr}, Word32
$sel:rcNr:Ratchet :: forall (a :: Algorithm). Ratchet a -> Word32
rcNr :: Word32
rcNr}, SkippedMsgKeys
smks2) -> do
          -- state.CKr, mk = KDF_CK(state.CKr)
          let (RatchetKey
rcCKr', HeaderKey
mk, IV
iv, IV
_) = RatchetKey -> (RatchetKey, HeaderKey, IV, IV)
chainKdf RatchetKey
rcCKr
          -- return DECRYPT (mk, cipher-text, CONCAT (AD, enc_header))
          Either CryptoError ByteString
msg <- MessageKey
-> EncRatchetMessage
-> ExceptT CryptoError IO (Either CryptoError ByteString)
decryptMessage (HeaderKey -> IV -> MessageKey
MessageKey HeaderKey
mk IV
iv) EncRatchetMessage
encMsg
          -- state . Nr += 1
          DecryptResult a -> ExceptT CryptoError IO (DecryptResult a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CryptoError ByteString
msg, Ratchet a
rc'' {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr + 1}, SkippedMsgKeys -> SkippedMsgDiff
smkDiff (SkippedMsgKeys -> SkippedMsgDiff)
-> SkippedMsgKeys -> SkippedMsgDiff
forall a b. (a -> b) -> a -> b
$ SkippedMsgKeys
smks1 SkippedMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys
forall a. Semigroup a => a -> a -> a
<> SkippedMsgKeys
smks2)
        Right (Ratchet a
rc'', SkippedMsgKeys
smks2) ->
          DecryptResult a -> ExceptT CryptoError IO (DecryptResult a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CryptoError -> Either CryptoError ByteString
forall a b. a -> Either a b
Left CryptoError
CERatchetState, Ratchet a
rc'', SkippedMsgKeys -> SkippedMsgDiff
smkDiff (SkippedMsgKeys -> SkippedMsgDiff)
-> SkippedMsgKeys -> SkippedMsgDiff
forall a b. (a -> b) -> a -> b
$ SkippedMsgKeys
smks1 SkippedMsgKeys -> SkippedMsgKeys -> SkippedMsgKeys
forall a. Semigroup a => a -> a -> a
<> SkippedMsgKeys
smks2)
      where
        upgradedRatchet :: Ratchet a
        upgradedRatchet :: Ratchet a
upgradedRatchet
          | VersionE2E
msgMaxVersion VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
> VersionE2E
current = Ratchet a
rc {rcVersion = rcVersion {current = max current $ min msgMaxVersion maxSupported}}
          | Bool
otherwise = Ratchet a
rc
          where
            RatchetVersions {VersionE2E
$sel:current:RatchetVersions :: RatchetVersions -> VersionE2E
current :: VersionE2E
current, VersionE2E
$sel:maxSupported:RatchetVersions :: RatchetVersions -> VersionE2E
maxSupported :: VersionE2E
maxSupported} = RatchetVersions
rcVersion
        smkDiff :: SkippedMsgKeys -> SkippedMsgDiff
        smkDiff :: SkippedMsgKeys -> SkippedMsgDiff
smkDiff SkippedMsgKeys
smks = if SkippedMsgKeys -> Bool
forall k a. Map k a -> Bool
M.null SkippedMsgKeys
smks then SkippedMsgDiff
SMDNoChange else SkippedMsgKeys -> SkippedMsgDiff
SMDAdd SkippedMsgKeys
smks
        ratchetStep :: Ratchet a -> MsgHeader a -> ExceptT CryptoError IO (Ratchet a)
        ratchetStep :: Ratchet a -> MsgHeader a -> ExceptT CryptoError IO (Ratchet a)
ratchetStep rc' :: Ratchet a
rc'@Ratchet {PrivateKey a
$sel:rcDHRs:Ratchet :: forall (a :: Algorithm). Ratchet a -> PrivateKey a
rcDHRs :: PrivateKey a
rcDHRs, RatchetKey
$sel:rcRK:Ratchet :: forall (a :: Algorithm). Ratchet a -> RatchetKey
rcRK :: RatchetKey
rcRK, HeaderKey
$sel:rcNHKs:Ratchet :: forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKs :: HeaderKey
rcNHKs, HeaderKey
$sel:rcNHKr:Ratchet :: forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKr :: HeaderKey
rcNHKr, PQSupport
$sel:rcSupportKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> PQSupport
rcSupportKEM :: PQSupport
rcSupportKEM, $sel:rcVersion:Ratchet :: forall (a :: Algorithm). Ratchet a -> RatchetVersions
rcVersion = RatchetVersions
rv} MsgHeader {PublicKey a
$sel:msgDHRs:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> PublicKey a
msgDHRs :: PublicKey a
msgDHRs, Maybe ARKEMParams
$sel:msgKEM:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Maybe ARKEMParams
msgKEM :: Maybe ARKEMParams
msgKEM} = do
          (Maybe KEMSharedKey
kemSS, Maybe KEMSharedKey
kemSS', Maybe RatchetKEM
rcKEM') <- Ratchet a
-> Maybe ARKEMParams
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
pqRatchetStep Ratchet a
rc' Maybe ARKEMParams
msgKEM
          -- state.DHRs = GENERATE_DH()
          (PublicKey a
_, PrivateKey a
rcDHRs') <- STM (KeyPair a) -> ExceptT CryptoError IO (KeyPair a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (KeyPair a) -> ExceptT CryptoError IO (KeyPair a))
-> STM (KeyPair a) -> ExceptT CryptoError IO (KeyPair a)
forall a b. (a -> b) -> a -> b
$ forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
generateKeyPair @a TVar ChaChaDRG
g
          -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss)
          let (RatchetKey
rcRK', RatchetKey
rcCKr', HeaderKey
rcNHKr') = RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
rootKdf RatchetKey
rcRK PublicKey a
msgDHRs PrivateKey a
rcDHRs Maybe KEMSharedKey
kemSS
              -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss)
              (RatchetKey
rcRK'', RatchetKey
rcCKs', HeaderKey
rcNHKs') = RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
rootKdf RatchetKey
rcRK' PublicKey a
msgDHRs PrivateKey a
rcDHRs' Maybe KEMSharedKey
kemSS'
              sndKEM :: Bool
sndKEM = Maybe KEMSharedKey -> Bool
forall a. Maybe a -> Bool
isJust Maybe KEMSharedKey
kemSS'
              rcvKEM :: Bool
rcvKEM = Maybe KEMSharedKey -> Bool
forall a. Maybe a -> Bool
isJust Maybe KEMSharedKey
kemSS
              rcEnableKEM' :: PQEncryption
rcEnableKEM' = Bool -> PQEncryption
PQEncryption (Bool -> PQEncryption) -> Bool -> PQEncryption
forall a b. (a -> b) -> a -> b
$ Bool
sndKEM Bool -> Bool -> Bool
|| Bool
rcvKEM Bool -> Bool -> Bool
|| Maybe RatchetKEM -> Bool
forall a. Maybe a -> Bool
isJust Maybe RatchetKEM
rcKEM'
          Ratchet a -> ExceptT CryptoError IO (Ratchet a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Ratchet a
rc'
              { rcDHRs = rcDHRs',
                rcKEM = rcKEM',
                rcSupportKEM = pqEnableSupport (current rv) rcSupportKEM rcEnableKEM',
                rcEnableKEM = rcEnableKEM',
                rcSndKEM = PQEncryption sndKEM,
                rcRcvKEM = PQEncryption rcvKEM,
                rcRK = rcRK'',
                rcSnd = Just SndRatchet {rcDHRr = msgDHRs, rcCKs = rcCKs', rcHKs = rcNHKs},
                rcRcv = Just RcvRatchet {rcCKr = rcCKr', rcHKr = rcNHKr},
                rcPN = rcNs rc,
                rcNs = 0,
                rcNr = 0,
                rcNHKs = rcNHKs',
                rcNHKr = rcNHKr'
              }
        pqRatchetStep :: Ratchet a -> Maybe ARKEMParams -> ExceptT CryptoError IO (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
        pqRatchetStep :: Ratchet a
-> Maybe ARKEMParams
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
pqRatchetStep Ratchet {Maybe RatchetKEM
$sel:rcKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RatchetKEM
rcKEM :: Maybe RatchetKEM
rcKEM, $sel:rcEnableKEM:Ratchet :: forall (a :: Algorithm). Ratchet a -> PQEncryption
rcEnableKEM = PQEncryption Bool
pqEnc, $sel:rcVersion:Ratchet :: forall (a :: Algorithm). Ratchet a -> RatchetVersions
rcVersion = RatchetVersions
rv} = \case
          -- received message does not have KEM in header,
          -- but the user enabled KEM when sending previous message
          Maybe ARKEMParams
Nothing -> case Maybe RatchetKEM
rcKEM of
            Maybe RatchetKEM
Nothing | Bool
pqEnc Bool -> Bool -> Bool
&& RatchetVersions -> VersionE2E
current RatchetVersions
rv VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> do
              KEMKeyPair
rcPQRs <- IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair
forall a. IO a -> ExceptT CryptoError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair)
-> IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> IO KEMKeyPair
sntrup761Keypair TVar ChaChaDRG
g
              (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KEMSharedKey
forall a. Maybe a
Nothing, Maybe KEMSharedKey
forall a. Maybe a
Nothing, RatchetKEM -> Maybe RatchetKEM
forall a. a -> Maybe a
Just RatchetKEM {KEMKeyPair
$sel:rcPQRs:RatchetKEM :: KEMKeyPair
rcPQRs :: KEMKeyPair
rcPQRs, $sel:rcKEMs:RatchetKEM :: Maybe RatchetKEMAccepted
rcKEMs = Maybe RatchetKEMAccepted
forall a. Maybe a
Nothing})
            Maybe RatchetKEM
_ -> (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KEMSharedKey
forall a. Maybe a
Nothing, Maybe KEMSharedKey
forall a. Maybe a
Nothing, Maybe RatchetKEM
forall a. Maybe a
Nothing)
          -- received message has KEM in header.
          Just (ARKP SRatchetKEMState s
_ RKEMParams s
ps)
            | Bool
pqEnc Bool -> Bool -> Bool
&& RatchetVersions -> VersionE2E
current RatchetVersions
rv VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
pqRatchetE2EEncryptVersion -> do
                -- state.PQRr = header.kem
                (Maybe KEMSharedKey
ss, KEMPublicKey
rcPQRr) <- ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
sharedSecret
                -- state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret KEM #1
                (KEMCiphertext
rcPQRct, KEMSharedKey
rcPQRss) <- IO (KEMCiphertext, KEMSharedKey)
-> ExceptT CryptoError IO (KEMCiphertext, KEMSharedKey)
forall a. IO a -> ExceptT CryptoError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (KEMCiphertext, KEMSharedKey)
 -> ExceptT CryptoError IO (KEMCiphertext, KEMSharedKey))
-> IO (KEMCiphertext, KEMSharedKey)
-> ExceptT CryptoError IO (KEMCiphertext, KEMSharedKey)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
sntrup761Enc TVar ChaChaDRG
g KEMPublicKey
rcPQRr
                -- state.PQRs = GENERATE_PQKEM()
                KEMKeyPair
rcPQRs <- IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair
forall a. IO a -> ExceptT CryptoError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair)
-> IO KEMKeyPair -> ExceptT CryptoError IO KEMKeyPair
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> IO KEMKeyPair
sntrup761Keypair TVar ChaChaDRG
g
                let kem' :: RatchetKEM
kem' = RatchetKEM {KEMKeyPair
$sel:rcPQRs:RatchetKEM :: KEMKeyPair
rcPQRs :: KEMKeyPair
rcPQRs, $sel:rcKEMs:RatchetKEM :: Maybe RatchetKEMAccepted
rcKEMs = RatchetKEMAccepted -> Maybe RatchetKEMAccepted
forall a. a -> Maybe a
Just RatchetKEMAccepted {KEMPublicKey
$sel:rcPQRr:RatchetKEMAccepted :: KEMPublicKey
rcPQRr :: KEMPublicKey
rcPQRr, KEMSharedKey
$sel:rcPQRss:RatchetKEMAccepted :: KEMSharedKey
rcPQRss :: KEMSharedKey
rcPQRss, KEMCiphertext
$sel:rcPQRct:RatchetKEMAccepted :: KEMCiphertext
rcPQRct :: KEMCiphertext
rcPQRct}}
                (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KEMSharedKey
ss, KEMSharedKey -> Maybe KEMSharedKey
forall a. a -> Maybe a
Just KEMSharedKey
rcPQRss, RatchetKEM -> Maybe RatchetKEM
forall a. a -> Maybe a
Just RatchetKEM
kem')
            | Bool
otherwise -> do
                -- state.PQRr = header.kem
                (Maybe KEMSharedKey
ss, KEMPublicKey
_) <- ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
sharedSecret
                (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
-> ExceptT
     CryptoError
     IO
     (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KEMSharedKey
ss, Maybe KEMSharedKey
forall a. Maybe a
Nothing, Maybe RatchetKEM
forall a. Maybe a
Nothing)
            where
              sharedSecret :: ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
sharedSecret = case RKEMParams s
ps of
                RKParamsProposed KEMPublicKey
k -> (Maybe KEMSharedKey, KEMPublicKey)
-> ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KEMSharedKey
forall a. Maybe a
Nothing, KEMPublicKey
k)
                RKParamsAccepted KEMCiphertext
ct KEMPublicKey
k -> case Maybe RatchetKEM
rcKEM of
                  Maybe RatchetKEM
Nothing -> CryptoError
-> ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CERatchetKEMState
                  -- ss = PQKEM-DEC(state.PQRs.private, header.ct)
                  Just RatchetKEM {KEMKeyPair
$sel:rcPQRs:RatchetKEM :: RatchetKEM -> KEMKeyPair
rcPQRs :: KEMKeyPair
rcPQRs} -> do
                    KEMSharedKey
ss <- IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey
forall a. IO a -> ExceptT CryptoError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey)
-> IO KEMSharedKey -> ExceptT CryptoError IO KEMSharedKey
forall a b. (a -> b) -> a -> b
$ KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey
sntrup761Dec KEMCiphertext
ct (KEMKeyPair -> KEMSecretKey
forall a b. (a, b) -> b
snd KEMKeyPair
rcPQRs)
                    (Maybe KEMSharedKey, KEMPublicKey)
-> ExceptT CryptoError IO (Maybe KEMSharedKey, KEMPublicKey)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KEMSharedKey -> Maybe KEMSharedKey
forall a. a -> Maybe a
Just KEMSharedKey
ss, KEMPublicKey
k)
    skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
    skipMessageKeys :: Word32
-> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys Word32
_ r :: Ratchet a
r@Ratchet {$sel:rcRcv:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RcvRatchet
rcRcv = Maybe RcvRatchet
Nothing} = (Ratchet a, SkippedMsgKeys)
-> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. b -> Either a b
Right (Ratchet a
r, SkippedMsgKeys
forall k a. Map k a
M.empty)
    skipMessageKeys Word32
untilN r :: Ratchet a
r@Ratchet {$sel:rcRcv:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe RcvRatchet
rcRcv = Just rr :: RcvRatchet
rr@RcvRatchet {RatchetKey
$sel:rcCKr:RcvRatchet :: RcvRatchet -> RatchetKey
rcCKr :: RatchetKey
rcCKr, HeaderKey
$sel:rcHKr:RcvRatchet :: RcvRatchet -> HeaderKey
rcHKr :: HeaderKey
rcHKr}, Word32
$sel:rcNr:Ratchet :: forall (a :: Algorithm). Ratchet a -> Word32
rcNr :: Word32
rcNr}
      | Word32
rcNr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
untilN Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 = CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. a -> Either a b
Left (CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys))
-> CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. (a -> b) -> a -> b
$ Word32 -> CryptoError
CERatchetEarlierMessage (Word32
rcNr Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
untilN Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1)
      | Word32
rcNr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
untilN Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 = CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. a -> Either a b
Left CryptoError
CERatchetDuplicateMessage
      | Word32
rcNr Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
maxSkip Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
untilN = CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. a -> Either a b
Left (CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys))
-> CryptoError -> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. (a -> b) -> a -> b
$ Word32 -> CryptoError
CERatchetTooManySkipped (Word32
untilN Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
rcNr)
      | Word32
rcNr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
untilN = (Ratchet a, SkippedMsgKeys)
-> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. b -> Either a b
Right (Ratchet a
r, SkippedMsgKeys
forall k a. Map k a
M.empty)
      | Bool
otherwise =
          let (RatchetKey
rcCKr', Word32
rcNr', SkippedHdrMsgKeys
mks) = Word32
-> RatchetKey
-> Word32
-> SkippedHdrMsgKeys
-> (RatchetKey, Word32, SkippedHdrMsgKeys)
advanceRcvRatchet (Word32
untilN Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
rcNr) RatchetKey
rcCKr Word32
rcNr SkippedHdrMsgKeys
forall k a. Map k a
M.empty
              r' :: Ratchet a
r' = Ratchet a
r {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr'}
           in (Ratchet a, SkippedMsgKeys)
-> Either CryptoError (Ratchet a, SkippedMsgKeys)
forall a b. b -> Either a b
Right (Ratchet a
r', HeaderKey -> SkippedHdrMsgKeys -> SkippedMsgKeys
forall k a. k -> a -> Map k a
M.singleton HeaderKey
rcHKr SkippedHdrMsgKeys
mks)
    advanceRcvRatchet :: Word32 -> RatchetKey -> Word32 -> SkippedHdrMsgKeys -> (RatchetKey, Word32, SkippedHdrMsgKeys)
    advanceRcvRatchet :: Word32
-> RatchetKey
-> Word32
-> SkippedHdrMsgKeys
-> (RatchetKey, Word32, SkippedHdrMsgKeys)
advanceRcvRatchet Word32
0 RatchetKey
ck Word32
msgNs SkippedHdrMsgKeys
mks = (RatchetKey
ck, Word32
msgNs, SkippedHdrMsgKeys
mks)
    advanceRcvRatchet Word32
n RatchetKey
ck Word32
msgNs SkippedHdrMsgKeys
mks =
      let (RatchetKey
ck', HeaderKey
mk, IV
iv, IV
_) = RatchetKey -> (RatchetKey, HeaderKey, IV, IV)
chainKdf RatchetKey
ck
          mks' :: SkippedHdrMsgKeys
mks' = Word32 -> MessageKey -> SkippedHdrMsgKeys -> SkippedHdrMsgKeys
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Word32
msgNs (HeaderKey -> IV -> MessageKey
MessageKey HeaderKey
mk IV
iv) SkippedHdrMsgKeys
mks
       in Word32
-> RatchetKey
-> Word32
-> SkippedHdrMsgKeys
-> (RatchetKey, Word32, SkippedHdrMsgKeys)
advanceRcvRatchet (Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) RatchetKey
ck' (Word32
msgNs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) SkippedHdrMsgKeys
mks'
    decryptSkipped :: EncMessageHeader -> EncRatchetMessage -> ExceptT CryptoError IO (SkippedMessage a)
    decryptSkipped :: EncMessageHeader
-> EncRatchetMessage -> ExceptT CryptoError IO (SkippedMessage a)
decryptSkipped EncMessageHeader
encHdr EncRatchetMessage
encMsg = SkippedMessage a
-> [(HeaderKey, SkippedHdrMsgKeys)]
-> ExceptT CryptoError IO (SkippedMessage a)
tryDecryptSkipped SkippedMessage a
forall (a :: Algorithm). SkippedMessage a
SMNone ([(HeaderKey, SkippedHdrMsgKeys)]
 -> ExceptT CryptoError IO (SkippedMessage a))
-> [(HeaderKey, SkippedHdrMsgKeys)]
-> ExceptT CryptoError IO (SkippedMessage a)
forall a b. (a -> b) -> a -> b
$ SkippedMsgKeys -> [(HeaderKey, SkippedHdrMsgKeys)]
forall k a. Map k a -> [(k, a)]
M.assocs SkippedMsgKeys
rcMKSkipped
      where
        tryDecryptSkipped :: SkippedMessage a -> [(HeaderKey, SkippedHdrMsgKeys)] -> ExceptT CryptoError IO (SkippedMessage a)
        tryDecryptSkipped :: SkippedMessage a
-> [(HeaderKey, SkippedHdrMsgKeys)]
-> ExceptT CryptoError IO (SkippedMessage a)
tryDecryptSkipped SkippedMessage a
SMNone ((HeaderKey
hk, SkippedHdrMsgKeys
mks) : [(HeaderKey, SkippedHdrMsgKeys)]
hks) = do
          ExceptT CryptoError IO (MsgHeader a)
-> ExceptT CryptoError IO (Either CryptoError (MsgHeader a))
forall (m :: * -> *) e a.
Monad m =>
ExceptT e m a -> ExceptT e m (Either e a)
tryE (HeaderKey
-> EncMessageHeader -> ExceptT CryptoError IO (MsgHeader a)
decryptHeader HeaderKey
hk EncMessageHeader
encHdr) ExceptT CryptoError IO (Either CryptoError (MsgHeader a))
-> (Either CryptoError (MsgHeader a)
    -> ExceptT CryptoError IO (SkippedMessage a))
-> ExceptT CryptoError IO (SkippedMessage a)
forall a b.
ExceptT CryptoError IO a
-> (a -> ExceptT CryptoError IO b) -> ExceptT CryptoError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left CryptoError
CERatchetHeader -> SkippedMessage a
-> [(HeaderKey, SkippedHdrMsgKeys)]
-> ExceptT CryptoError IO (SkippedMessage a)
tryDecryptSkipped SkippedMessage a
forall (a :: Algorithm). SkippedMessage a
SMNone [(HeaderKey, SkippedHdrMsgKeys)]
hks
            Left CryptoError
e -> CryptoError -> ExceptT CryptoError IO (SkippedMessage a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
e
            Right hdr :: MsgHeader a
hdr@MsgHeader {Word32
$sel:msgNs:MsgHeader :: forall (a :: Algorithm). MsgHeader a -> Word32
msgNs :: Word32
msgNs} ->
              case Word32 -> SkippedHdrMsgKeys -> Maybe MessageKey
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word32
msgNs SkippedHdrMsgKeys
mks of
                Maybe MessageKey
Nothing ->
                  let nextRc :: Maybe RatchetStep
nextRc
                        | Bool -> (RcvRatchet -> Bool) -> Maybe RcvRatchet -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((HeaderKey -> HeaderKey -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderKey
hk) (HeaderKey -> Bool)
-> (RcvRatchet -> HeaderKey) -> RcvRatchet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvRatchet -> HeaderKey
rcHKr) Maybe RcvRatchet
rcRcv = RatchetStep -> Maybe RatchetStep
forall a. a -> Maybe a
Just RatchetStep
SameRatchet
                        | HeaderKey
hk HeaderKey -> HeaderKey -> Bool
forall a. Eq a => a -> a -> Bool
== Ratchet a -> HeaderKey
forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKr Ratchet a
rc = RatchetStep -> Maybe RatchetStep
forall a. a -> Maybe a
Just RatchetStep
AdvanceRatchet
                        | Bool
otherwise = Maybe RatchetStep
forall a. Maybe a
Nothing
                   in SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a))
-> SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a)
forall a b. (a -> b) -> a -> b
$ Maybe RatchetStep -> MsgHeader a -> SkippedMessage a
forall (a :: Algorithm).
Maybe RatchetStep -> MsgHeader a -> SkippedMessage a
SMHeader Maybe RatchetStep
nextRc MsgHeader a
hdr
                Just MessageKey
mk -> do
                  Either CryptoError ByteString
msg <- MessageKey
-> EncRatchetMessage
-> ExceptT CryptoError IO (Either CryptoError ByteString)
decryptMessage MessageKey
mk EncRatchetMessage
encMsg
                  SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a))
-> SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a)
forall a b. (a -> b) -> a -> b
$ DecryptResult a -> SkippedMessage a
forall (a :: Algorithm). DecryptResult a -> SkippedMessage a
SMMessage (Either CryptoError ByteString
msg, Ratchet a
rc, HeaderKey -> Word32 -> SkippedMsgDiff
SMDRemove HeaderKey
hk Word32
msgNs)
        tryDecryptSkipped SkippedMessage a
r [(HeaderKey, SkippedHdrMsgKeys)]
_ = SkippedMessage a -> ExceptT CryptoError IO (SkippedMessage a)
forall a. a -> ExceptT CryptoError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SkippedMessage a
r
    decryptRcHeader :: Maybe RcvRatchet -> EncMessageHeader -> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
    decryptRcHeader :: Maybe RcvRatchet
-> EncMessageHeader
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
decryptRcHeader Maybe RcvRatchet
Nothing EncMessageHeader
hdr = EncMessageHeader
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
decryptNextHeader EncMessageHeader
hdr
    decryptRcHeader (Just RcvRatchet {HeaderKey
$sel:rcHKr:RcvRatchet :: RcvRatchet -> HeaderKey
rcHKr :: HeaderKey
rcHKr}) EncMessageHeader
hdr =
      -- header = HDECRYPT(state.HKr, enc_header)
      ((RatchetStep
SameRatchet,) (MsgHeader a -> (RatchetStep, MsgHeader a))
-> ExceptT CryptoError IO (MsgHeader a)
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderKey
-> EncMessageHeader -> ExceptT CryptoError IO (MsgHeader a)
decryptHeader HeaderKey
rcHKr EncMessageHeader
hdr) ExceptT CryptoError IO (RatchetStep, MsgHeader a)
-> (CryptoError
    -> ExceptT CryptoError IO (RatchetStep, MsgHeader a))
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \case
        CryptoError
CERatchetHeader -> EncMessageHeader
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
decryptNextHeader EncMessageHeader
hdr
        CryptoError
e -> CryptoError -> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
e
    -- header = HDECRYPT(state.NHKr, enc_header)
    decryptNextHeader :: EncMessageHeader
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
decryptNextHeader EncMessageHeader
hdr = (RatchetStep
AdvanceRatchet,) (MsgHeader a -> (RatchetStep, MsgHeader a))
-> ExceptT CryptoError IO (MsgHeader a)
-> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderKey
-> EncMessageHeader -> ExceptT CryptoError IO (MsgHeader a)
decryptHeader (Ratchet a -> HeaderKey
forall (a :: Algorithm). Ratchet a -> HeaderKey
rcNHKr Ratchet a
rc) EncMessageHeader
hdr
    decryptHeader :: HeaderKey
-> EncMessageHeader -> ExceptT CryptoError IO (MsgHeader a)
decryptHeader HeaderKey
k EncMessageHeader {VersionE2E
$sel:ehVersion:EncMessageHeader :: EncMessageHeader -> VersionE2E
ehVersion :: VersionE2E
ehVersion, ByteString
$sel:ehBody:EncMessageHeader :: EncMessageHeader -> ByteString
ehBody :: ByteString
ehBody, AuthTag
$sel:ehAuthTag:EncMessageHeader :: EncMessageHeader -> AuthTag
ehAuthTag :: AuthTag
ehAuthTag, IV
$sel:ehIV:EncMessageHeader :: EncMessageHeader -> IV
ehIV :: IV
ehIV} = do
      ByteString
header <- HeaderKey
-> IV
-> ByteString
-> ByteString
-> AuthTag
-> ExceptT CryptoError IO ByteString
decryptAEAD HeaderKey
k IV
ehIV ByteString
rcAD ByteString
ehBody AuthTag
ehAuthTag ExceptT CryptoError IO ByteString
-> (CryptoError -> ExceptT CryptoError IO ByteString)
-> ExceptT CryptoError IO ByteString
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \CryptoError
_ -> CryptoError -> ExceptT CryptoError IO ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CryptoError
CERatchetHeader
      (String -> CryptoError)
-> Parser (MsgHeader a)
-> ByteString
-> ExceptT CryptoError IO (MsgHeader a)
forall e a.
(String -> e) -> Parser a -> ByteString -> ExceptT e IO a
parseE' String -> CryptoError
CryptoHeaderError (VersionE2E -> Parser (MsgHeader a)
forall (a :: Algorithm).
AlgorithmI a =>
VersionE2E -> Parser (MsgHeader a)
msgHeaderP VersionE2E
ehVersion) ByteString
header
    decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
    decryptMessage :: MessageKey
-> EncRatchetMessage
-> ExceptT CryptoError IO (Either CryptoError ByteString)
decryptMessage (MessageKey HeaderKey
mk IV
iv) EncRatchetMessage {ByteString
$sel:emHeader:EncRatchetMessage :: EncRatchetMessage -> ByteString
emHeader :: ByteString
emHeader, ByteString
$sel:emBody:EncRatchetMessage :: EncRatchetMessage -> ByteString
emBody :: ByteString
emBody, AuthTag
$sel:emAuthTag:EncRatchetMessage :: EncRatchetMessage -> AuthTag
emAuthTag :: AuthTag
emAuthTag} =
      -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
      ExceptT CryptoError IO ByteString
-> ExceptT CryptoError IO (Either CryptoError ByteString)
forall (m :: * -> *) e a.
Monad m =>
ExceptT e m a -> ExceptT e m (Either e a)
tryE (ExceptT CryptoError IO ByteString
 -> ExceptT CryptoError IO (Either CryptoError ByteString))
-> ExceptT CryptoError IO ByteString
-> ExceptT CryptoError IO (Either CryptoError ByteString)
forall a b. (a -> b) -> a -> b
$ HeaderKey
-> IV
-> ByteString
-> ByteString
-> AuthTag
-> ExceptT CryptoError IO ByteString
decryptAEAD HeaderKey
mk IV
iv (ByteString
rcAD ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
emHeader) ByteString
emBody AuthTag
emAuthTag

rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> Maybe KEMSharedKey -> (RatchetKey, RatchetKey, Key)
rootKdf :: forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetKey
-> PublicKey a
-> PrivateKey a
-> Maybe KEMSharedKey
-> (RatchetKey, RatchetKey, HeaderKey)
rootKdf (RatchetKey ByteString
rk) PublicKey a
k PrivateKey a
pk Maybe KEMSharedKey
kemSecret_ =
  let dhOut :: ByteString
dhOut = DhSecret a -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
dhBytes' (PublicKey a -> PrivateKey a -> DhSecret a
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
dh' PublicKey a
k PrivateKey a
pk)
      ss :: ByteString
ss = case Maybe KEMSharedKey
kemSecret_ of
        Just (KEMSharedKey ScrubbedBytes
s) -> ByteString
dhOut ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ScrubbedBytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ScrubbedBytes
s
        Maybe KEMSharedKey
Nothing -> ByteString
dhOut
      (ByteString
rk', ByteString
ck, ByteString
nhk) = ByteString
-> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
hkdf3 ByteString
rk ByteString
ss ByteString
"SimpleXRootRatchet"
   in (ByteString -> RatchetKey
RatchetKey ByteString
rk', ByteString -> RatchetKey
RatchetKey ByteString
ck, ByteString -> HeaderKey
Key ByteString
nhk)

chainKdf :: RatchetKey -> (RatchetKey, Key, IV, IV)
chainKdf :: RatchetKey -> (RatchetKey, HeaderKey, IV, IV)
chainKdf (RatchetKey ByteString
ck) =
  let (ByteString
ck', ByteString
mk, ByteString
ivs) = ByteString
-> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
hkdf3 ByteString
"" ByteString
ck ByteString
"SimpleXChainRatchet"
      (ByteString
iv1, ByteString
iv2) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
16 ByteString
ivs
   in (ByteString -> RatchetKey
RatchetKey ByteString
ck', ByteString -> HeaderKey
Key ByteString
mk, ByteString -> IV
IV ByteString
iv1, ByteString -> IV
IV ByteString
iv2)

hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
hkdf3 :: ByteString
-> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
hkdf3 ByteString
salt ByteString
ikm ByteString
info = (ByteString
s1, ByteString
s2, ByteString
s3)
  where
    out :: ByteString
out = ByteString -> ByteString -> ByteString -> Int -> ByteString
forall secret.
ByteArrayAccess secret =>
ByteString -> secret -> ByteString -> Int -> ByteString
hkdf ByteString
salt ByteString
ikm ByteString
info Int
96
    (ByteString
s1, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
32 ByteString
out
    (ByteString
s2, ByteString
s3) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
32 ByteString
rest

$(JQ.deriveJSON defaultJSON ''RcvRatchet)

$(JQ.deriveJSON defaultJSON ''RatchetKEMAccepted)

$(JQ.deriveJSON defaultJSON ''RatchetKEM)

instance AlgorithmI a => ToJSON (SndRatchet a) where
  toEncoding :: SndRatchet a -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''SndRatchet)
  toJSON :: SndRatchet a -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''SndRatchet)

instance AlgorithmI a => FromJSON (SndRatchet a) where
  parseJSON :: Value -> Parser (SndRatchet a)
parseJSON = $(JQ.mkParseJSON defaultJSON ''SndRatchet)

instance AlgorithmI a => ToJSON (Ratchet a) where
  toEncoding :: Ratchet a -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''Ratchet)
  toJSON :: Ratchet a -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''Ratchet)

instance AlgorithmI a => FromJSON (Ratchet a) where
  parseJSON :: Value -> Parser (Ratchet a)
parseJSON = $(JQ.mkParseJSON defaultJSON ''Ratchet)

instance AlgorithmI a => ToField (Ratchet a) where toField :: Ratchet a -> SQLData
toField = Binary ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (Binary ByteString -> SQLData)
-> (Ratchet a -> Binary ByteString) -> Ratchet a -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary ByteString
forall a. a -> Binary a
Binary (ByteString -> Binary ByteString)
-> (Ratchet a -> ByteString) -> Ratchet a -> Binary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (Ratchet a -> ByteString) -> Ratchet a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratchet a -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode

instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField :: FieldParser (Ratchet a)
fromField = (ByteString -> Either String (Ratchet a))
-> FieldParser (Ratchet a)
forall k.
Typeable k =>
(ByteString -> Either String k) -> FieldParser k
blobFieldDecoder ByteString -> Either String (Ratchet a)
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecodeStrict'

instance ToField PQEncryption where toField :: PQEncryption -> SQLData
toField (PQEncryption Bool
pqEnc) = BoolInt -> SQLData
forall a. ToField a => a -> SQLData
toField (Bool -> BoolInt
BI Bool
pqEnc)

instance FromField PQEncryption where
#if defined(dbPostgres)
  fromField f dat = PQEncryption . unBI <$> fromField f dat
#else
  fromField :: FieldParser PQEncryption
fromField Field
f = Bool -> PQEncryption
PQEncryption (Bool -> PQEncryption)
-> (BoolInt -> Bool) -> BoolInt -> PQEncryption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolInt -> Bool
unBI (BoolInt -> PQEncryption) -> Ok BoolInt -> Ok PQEncryption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser BoolInt
forall a. FromField a => FieldParser a
fromField Field
f
#endif

instance ToField PQSupport where toField :: PQSupport -> SQLData
toField (PQSupport Bool
pqEnc) = BoolInt -> SQLData
forall a. ToField a => a -> SQLData
toField (Bool -> BoolInt
BI Bool
pqEnc)

instance FromField PQSupport where
#if defined(dbPostgres)
  fromField f dat = PQSupport . unBI <$> fromField f dat
#else
  fromField :: FieldParser PQSupport
fromField Field
f = Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> (BoolInt -> Bool) -> BoolInt -> PQSupport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolInt -> Bool
unBI (BoolInt -> PQSupport) -> Ok BoolInt -> Ok PQSupport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser BoolInt
forall a. FromField a => FieldParser a
fromField Field
f
#endif

instance Encoding (MsgEncryptKey a) where
  smpEncode :: MsgEncryptKey a -> ByteString
smpEncode MsgEncryptKey {$sel:msgRcVersion:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> VersionE2E
msgRcVersion = VersionE2E
v, MessageKey
$sel:msgKey:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> MessageKey
msgKey :: MessageKey
msgKey, ByteString
$sel:msgRcAD:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgRcAD :: ByteString
msgRcAD, ByteString
$sel:msgEncHeader:MsgEncryptKey :: forall {k} (a :: k). MsgEncryptKey a -> ByteString
msgEncHeader :: ByteString
msgEncHeader} =
    (VersionE2E, ByteString, MessageKey, Large) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionE2E
v, ByteString
msgRcAD, MessageKey
msgKey, ByteString -> Large
Large ByteString
msgEncHeader)
  smpP :: Parser (MsgEncryptKey a)
smpP = do
    (VersionE2E
v, ByteString
msgRcAD, MessageKey
msgKey, Large ByteString
msgEncHeader) <- Parser (VersionE2E, ByteString, MessageKey, Large)
forall a. Encoding a => Parser a
smpP
    MsgEncryptKey a -> Parser (MsgEncryptKey a)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgEncryptKey {$sel:msgRcVersion:MsgEncryptKey :: VersionE2E
msgRcVersion = VersionE2E
v, ByteString
$sel:msgRcAD:MsgEncryptKey :: ByteString
msgRcAD :: ByteString
msgRcAD, MessageKey
$sel:msgKey:MsgEncryptKey :: MessageKey
msgKey :: MessageKey
msgKey, ByteString
$sel:msgEncHeader:MsgEncryptKey :: ByteString
msgEncHeader :: ByteString
msgEncHeader}

instance AlgorithmI a => ToField (MsgEncryptKey a) where toField :: MsgEncryptKey a -> SQLData
toField = Binary ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (Binary ByteString -> SQLData)
-> (MsgEncryptKey a -> Binary ByteString)
-> MsgEncryptKey a
-> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary ByteString
forall a. a -> Binary a
Binary (ByteString -> Binary ByteString)
-> (MsgEncryptKey a -> ByteString)
-> MsgEncryptKey a
-> Binary ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEncryptKey a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField :: FieldParser (MsgEncryptKey a)
fromField = (ByteString -> Either String (MsgEncryptKey a))
-> FieldParser (MsgEncryptKey a)
forall k.
Typeable k =>
(ByteString -> Either String k) -> FieldParser k
blobFieldDecoder ByteString -> Either String (MsgEncryptKey a)
forall a. Encoding a => ByteString -> Either String a
smpDecode