    -- |
    -- Module      : Network.TLS.Sending
    -- License     : BSD-style
    -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
    -- Stability   : experimental
    -- Portability : unknown
    --
    -- the Sending module contains calls related to marshalling packets according
    -- to the TLS state
    --
    module Network.TLS.Sending (
        encodePacket
      , encodePacket13
      , updateHandshake
      , updateHandshake13
      ) where

    import Network.TLS.Cipher
    import Network.TLS.Context.Internal
    import Network.TLS.Handshake.Random
    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.Record.Layer
    import Network.TLS.State
    import Network.TLS.Struct
    import Network.TLS.Struct13
    import Network.TLS.Types (Role(..))
    import Network.TLS.Util

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

    -- | encodePacket transform a packet into marshalled data related to current state
    -- and updating state on the go
    encodePacket :: Monoid bytes
                 => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
    encodePacket :: forall bytes.
    Monoid bytes =>
    Context
    -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
    encodePacket Context
    ctx RecordLayer bytes
    recordLayer Packet
    pkt = do
        (Version
    ver, Bool
    _) <- Context -> IO (Version, Bool)
    decideRecordVersion Context
    ctx
        let pt :: ProtocolType
    pt = Packet -> ProtocolType
    packetType Packet
    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
    ver (ByteString -> Fragment Plaintext
    fragmentPlaintext ByteString
    bs)
            len :: Maybe Int
    len = Context -> Maybe Int
    ctxFragmentSize Context
    ctx
        [Record Plaintext]
    records <- (ByteString -> Record Plaintext)
    -> [ByteString] -> [Record Plaintext]
    forall a b. (a -> b) -> [a] -> [b]
    map ByteString -> Record Plaintext
    mkRecord ([ByteString] -> [Record Plaintext])
    -> IO [ByteString] -> IO [Record Plaintext]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Context -> Maybe Int -> Packet -> IO [ByteString]
    packetToFragments Context
    ctx Maybe Int
    len Packet
    pkt
        Either TLSError bytes
    bs <- ([bytes] -> bytes)
    -> Either TLSError [bytes] -> Either TLSError bytes
    forall a b. (a -> b) -> Either TLSError a -> Either TLSError b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [bytes] -> bytes
    forall a. Monoid a => [a] -> a
    mconcat (Either TLSError [bytes] -> Either TLSError bytes)
    -> IO (Either TLSError [bytes]) -> IO (Either TLSError bytes)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Record Plaintext]
    -> (Record Plaintext -> IO (Either TLSError bytes))
    -> IO (Either TLSError [bytes])
    forall (m :: * -> *) a l b.
    Monad m =>
    [a] -> (a -> m (Either l b)) -> m (Either l [b])
    forEitherM [Record Plaintext]
    records (RecordLayer bytes -> Record Plaintext -> IO (Either TLSError bytes)
    forall bytes.
    RecordLayer bytes -> Record Plaintext -> IO (Either TLSError bytes)
    recordEncode RecordLayer bytes
    recordLayer)
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Packet
    pkt Packet -> Packet -> Bool
    forall a. Eq a => a -> a -> Bool
    == Packet
    ChangeCipherSpec) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context -> IO ()
    switchTxEncryption Context
    ctx
        Either TLSError bytes -> IO (Either TLSError bytes)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Either TLSError bytes
    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.
    packetToFragments :: Context -> Maybe Int -> Packet -> IO [ByteString]
    packetToFragments :: Context -> Maybe Int -> Packet -> IO [ByteString]
    packetToFragments Context
    ctx Maybe Int
    len (Handshake [Handshake]
    hss)  =
        Maybe Int -> ByteString -> [ByteString]
    getChunks Maybe Int
    len (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 -> Role -> Handshake -> IO ByteString
    updateHandshake Context
    ctx Role
    ClientRole) [Handshake]
    hss
    packetToFragments 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]
    packetToFragments Context
    _   Maybe Int
    _   Packet
    ChangeCipherSpec = [ByteString] -> IO [ByteString]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ByteString
    encodeChangeCipherSpec]
    packetToFragments 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
        RecordState
    tx  <- Context -> HandshakeM RecordState -> IO RecordState
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (String -> Maybe RecordState -> RecordState
    forall a. String -> Maybe a -> a
    fromJust String
    "tx-state" (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)
        (Version
    ver, Role
    cc) <- Context -> TLSSt (Version, Role) -> IO (Version, Role)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt (Version, Role) -> IO (Version, Role))
    -> TLSSt (Version, Role) -> IO (Version, Role)
    forall a b. (a -> b) -> a -> b
    $ do Version
    v <- TLSSt Version
    getVersion
                                          Role
    c <- TLSSt Role
    isClientContext
                                          (Version, Role) -> TLSSt (Version, Role)
    forall a. a -> TLSSt a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Version
    v, Role
    c)
        IO () -> IO ()
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ MVar RecordState -> (RecordState -> IO RecordState) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ (Context -> MVar RecordState
    ctxTxState Context
    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
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Version
    ver Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Version
    TLS10 Bool -> Bool -> Bool
    && Role
    cc Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    ClientRole Bool -> Bool -> Bool
    && RecordState -> Bool
    isCBC RecordState
    tx Bool -> Bool -> Bool
    && Supported -> Bool
    supportedEmptyPacket (Context -> Supported
    ctxSupported Context
    ctx)) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO ()
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef (Context -> IORef Bool
    ctxNeedEmptyPacket Context
    ctx) Bool
    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)

    updateHandshake :: Context -> Role -> Handshake -> IO ByteString
    updateHandshake :: Context -> Role -> Handshake -> IO ByteString
    updateHandshake Context
    ctx Role
    role Handshake
    hs = do
        case Handshake
    hs of
            Finished ByteString
    fdata -> Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Role -> ByteString -> TLSSt ()
    updateVerifiedData Role
    role ByteString
    fdata
            Handshake
    _              -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        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 (HandshakeType -> Bool
    finishHandshakeTypeMaterial (HandshakeType -> Bool) -> HandshakeType -> Bool
    forall a b. (a -> b) -> a -> b
    $ Handshake -> HandshakeType
    typeOfHandshake 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)
            len :: Maybe Int
    len = Context -> Maybe Int
    ctxFragmentSize Context
    ctx
        [Record Plaintext]
    records <- (ByteString -> Record Plaintext)
    -> [ByteString] -> [Record Plaintext]
    forall a b. (a -> b) -> [a] -> [b]
    map ByteString -> Record Plaintext
    mkRecord ([ByteString] -> [Record Plaintext])
    -> IO [ByteString] -> IO [Record Plaintext]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Context -> Maybe Int -> Packet13 -> IO [ByteString]
    packetToFragments13 Context
    ctx Maybe Int
    len Packet13
    pkt
        ([bytes] -> bytes)
    -> Either TLSError [bytes] -> Either TLSError bytes
    forall a b. (a -> b) -> Either TLSError a -> Either TLSError b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [bytes] -> bytes
    forall a. Monoid a => [a] -> a
    mconcat (Either TLSError [bytes] -> Either TLSError bytes)
    -> IO (Either TLSError [bytes]) -> IO (Either TLSError bytes)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Record Plaintext]
    -> (Record Plaintext -> IO (Either TLSError bytes))
    -> IO (Either TLSError [bytes])
    forall (m :: * -> *) a l b.
    Monad m =>
    [a] -> (a -> m (Either l b)) -> m (Either l [b])
    forEitherM [Record Plaintext]
    records (RecordLayer bytes -> Record Plaintext -> IO (Either TLSError bytes)
    forall bytes.
    RecordLayer bytes -> Record Plaintext -> IO (Either TLSError bytes)
    recordEncode13 RecordLayer bytes
    recordLayer)

    packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]
    packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]
    packetToFragments13 Context
    ctx Maybe Int
    len (Handshake13 [Handshake13]
    hss)  =
        Maybe Int -> ByteString -> [ByteString]
    getChunks Maybe Int
    len (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