module Network.TLS.IO.Encode (
    encodePacket12,
    encodePacket13,
    updateHandshake12,
    updateHandshake13,
) where

import Control.Concurrent.MVar
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Data.IORef

import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.Imports
import Network.TLS.Packet
import Network.TLS.Packet13
import Network.TLS.Parameters
import Network.TLS.Record
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types (Role (..))
import Network.TLS.Util

-- | encodePacket transform a packet into marshalled data related to current state
-- and updating state on the go
encodePacket12
    :: Monoid bytes
    => Context
    -> RecordLayer bytes
    -> Packet
    -> IO (Either TLSError bytes)
encodePacket12 :: forall bytes.
Monoid bytes =>
Context
-> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
encodePacket12 Context
ctx RecordLayer bytes
recordLayer Packet
pkt = do
    (ver, _) <- Context -> IO (Version, Bool)
decideRecordVersion Context
ctx
    let pt = Packet -> ProtocolType
packetType Packet
pkt
        mkRecord ByteString
bs = ProtocolType -> Version -> Fragment Plaintext -> Record Plaintext
forall a. ProtocolType -> Version -> Fragment a -> Record a
Record ProtocolType
pt Version
ver (ByteString -> Fragment Plaintext
fragmentPlaintext ByteString
bs)
    mlen <- getPeerRecordLimit ctx
    records <- map mkRecord <$> packetToFragments12 ctx mlen pkt
    bs <- fmap mconcat <$> forEitherM records (recordEncode12 recordLayer ctx)
    when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx
    return bs

-- Decompose handshake packets into fragments of the specified length.  AppData
-- packets are not fragmented here but by callers of sendPacket, so that the
-- empty-packet countermeasure may be applied to each fragment independently.
packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]
packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]
packetToFragments12 Context
ctx Maybe Int
mlen (Handshake [Handshake]
hss) =
    Maybe Int -> ByteString -> [ByteString]
getChunks Maybe Int
mlen (ByteString -> [ByteString])
-> ([ByteString] -> ByteString) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handshake -> IO ByteString) -> [Handshake] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Context -> Handshake -> IO ByteString
updateHandshake12 Context
ctx) [Handshake]
hss
packetToFragments12 Context
_ Maybe Int
_ (Alert [(AlertLevel, AlertDescription)]
a) = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[(AlertLevel, AlertDescription)] -> ByteString
encodeAlerts [(AlertLevel, AlertDescription)]
a]
packetToFragments12 Context
_ Maybe Int
_ Packet
ChangeCipherSpec = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
encodeChangeCipherSpec]
packetToFragments12 Context
_ Maybe Int
_ (AppData ByteString
x) = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
x]

switchTxEncryption :: Context -> IO ()
switchTxEncryption :: Context -> IO ()
switchTxEncryption Context
ctx = do
    tx <- Context -> HandshakeM RecordState -> IO RecordState
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (Maybe RecordState -> RecordState
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe RecordState -> RecordState)
-> HandshakeM (Maybe RecordState) -> HandshakeM RecordState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HandshakeState -> Maybe RecordState)
-> HandshakeM (Maybe RecordState)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Maybe RecordState
hstPendingTxState)
    (ver, role) <- usingState_ ctx $ do
        v <- getVersion
        r <- getRole
        return (v, r)
    liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\RecordState
_ -> RecordState -> IO RecordState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecordState
tx)
    -- set empty packet counter measure if condition are met
    when
        ( ver <= TLS10
            && role == ClientRole
            && isCBC tx
            && supportedEmptyPacket (ctxSupported ctx)
        )
        $ liftIO
        $ writeIORef (ctxNeedEmptyPacket ctx) True
  where
    isCBC :: RecordState -> Bool
isCBC RecordState
tx = Bool -> (Cipher -> Bool) -> Maybe Cipher -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Cipher
c -> Bulk -> Int
bulkBlockSize (Cipher -> Bulk
cipherBulk Cipher
c) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (RecordState -> Maybe Cipher
stCipher RecordState
tx)

updateHandshake12 :: Context -> Handshake -> IO ByteString
updateHandshake12 :: Context -> Handshake -> IO ByteString
updateHandshake12 Context
ctx Handshake
hs = do
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> HandshakeM () -> HandshakeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Handshake -> Bool
certVerifyHandshakeMaterial Handshake
hs) (HandshakeM () -> HandshakeM ()) -> HandshakeM () -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> HandshakeM ()
addHandshakeMessage ByteString
encoded
        Bool -> HandshakeM () -> HandshakeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Handshake -> Bool
finishedHandshakeMaterial Handshake
hs) (HandshakeM () -> HandshakeM ()) -> HandshakeM () -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> HandshakeM ()
updateHandshakeDigest ByteString
encoded
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
encoded
  where
    encoded :: ByteString
encoded = Handshake -> ByteString
encodeHandshake Handshake
hs

----------------------------------------------------------------

encodePacket13
    :: Monoid bytes
    => Context
    -> RecordLayer bytes
    -> Packet13
    -> IO (Either TLSError bytes)
encodePacket13 :: forall bytes.
Monoid bytes =>
Context
-> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes)
encodePacket13 Context
ctx RecordLayer bytes
recordLayer Packet13
pkt = do
    let pt :: ProtocolType
pt = Packet13 -> ProtocolType
contentType Packet13
pkt
        mkRecord :: ByteString -> Record Plaintext
mkRecord ByteString
bs = ProtocolType -> Version -> Fragment Plaintext -> Record Plaintext
forall a. ProtocolType -> Version -> Fragment a -> Record a
Record ProtocolType
pt Version
TLS12 (ByteString -> Fragment Plaintext
fragmentPlaintext ByteString
bs)
    mlen <- Context -> IO (Maybe Int)
getPeerRecordLimit Context
ctx
    records <- map mkRecord <$> packetToFragments13 ctx mlen pkt
    fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)

packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]
packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]
packetToFragments13 Context
ctx Maybe Int
mlen (Handshake13 [Handshake13]
hss) =
    Maybe Int -> ByteString -> [ByteString]
getChunks Maybe Int
mlen (ByteString -> [ByteString])
-> ([ByteString] -> ByteString) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handshake13 -> IO ByteString) -> [Handshake13] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Context -> Handshake13 -> IO ByteString
updateHandshake13 Context
ctx) [Handshake13]
hss
packetToFragments13 Context
_ Maybe Int
_ (Alert13 [(AlertLevel, AlertDescription)]
a) = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[(AlertLevel, AlertDescription)] -> ByteString
encodeAlerts [(AlertLevel, AlertDescription)]
a]
packetToFragments13 Context
_ Maybe Int
_ (AppData13 ByteString
x) = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
x]
packetToFragments13 Context
_ Maybe Int
_ Packet13
ChangeCipherSpec13 = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
encodeChangeCipherSpec]

updateHandshake13 :: Context -> Handshake13 -> IO ByteString
updateHandshake13 :: Context -> Handshake13 -> IO ByteString
updateHandshake13 Context
ctx Handshake13
hs
    | Handshake13 -> Bool
isIgnored Handshake13
hs = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
encoded
    | Bool
otherwise = Context -> HandshakeM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM ByteString -> IO ByteString)
-> HandshakeM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        Bool -> HandshakeM () -> HandshakeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Handshake13 -> Bool
isHRR Handshake13
hs) HandshakeM ()
wrapAsMessageHash13
        ByteString -> HandshakeM ()
updateHandshakeDigest ByteString
encoded
        ByteString -> HandshakeM ()
addHandshakeMessage ByteString
encoded
        ByteString -> HandshakeM ByteString
forall a. a -> HandshakeM a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
encoded
  where
    encoded :: ByteString
encoded = Handshake13 -> ByteString
encodeHandshake13 Handshake13
hs

    isHRR :: Handshake13 -> Bool
isHRR (ServerHello13 ServerRandom
srand Session
_ CipherId
_ [ExtensionRaw]
_) = ServerRandom -> Bool
isHelloRetryRequest ServerRandom
srand
    isHRR Handshake13
_ = Bool
False

    isIgnored :: Handshake13 -> Bool
isIgnored NewSessionTicket13{} = Bool
True
    isIgnored KeyUpdate13{} = Bool
True
    isIgnored Handshake13
_ = Bool
False