1-- |
2-- Module      : Network.TLS.Sending
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- the Sending module contains calls related to marshalling packets according
9-- to the TLS state
10--
11module Network.TLS.Sending (
12    encodePacket
13  , encodePacket13
14  , updateHandshake
15  , updateHandshake13
16  ) where
17
18import Network.TLS.Cipher
19import Network.TLS.Context.Internal
20import Network.TLS.Handshake.Random
21import Network.TLS.Handshake.State
22import Network.TLS.Handshake.State13
23import Network.TLS.Imports
24import Network.TLS.Packet
25import Network.TLS.Packet13
26import Network.TLS.Parameters
27import Network.TLS.Record
28import Network.TLS.Record.Layer
29import Network.TLS.State
30import Network.TLS.Struct
31import Network.TLS.Struct13
32import Network.TLS.Types (Role(..))
33import Network.TLS.Util
34
35import Control.Concurrent.MVar
36import Control.Monad.State.Strict
37import qualified Data.ByteString as B
38import Data.IORef
39
40-- | encodePacket transform a packet into marshalled data related to current state
41-- and updating state on the go
42encodePacket :: Monoid bytes
43             => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
44encodePacket ctx recordLayer pkt = do
45    (ver, _) <- decideRecordVersion ctx
46    let pt = packetType pkt
47        mkRecord bs = Record pt ver (fragmentPlaintext bs)
48        len = ctxFragmentSize ctx
49    records <- map mkRecord <$> packetToFragments ctx len pkt
50    bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer)
51    when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx
52    return bs
53
54-- Decompose handshake packets into fragments of the specified length.  AppData
55-- packets are not fragmented here but by callers of sendPacket, so that the
56-- empty-packet countermeasure may be applied to each fragment independently.
57packetToFragments :: Context -> Maybe Int -> Packet -> IO [ByteString]
58packetToFragments ctx len (Handshake hss)  =
59    getChunks len . B.concat <$> mapM (updateHandshake ctx ClientRole) hss
60packetToFragments _   _   (Alert a)        = return [encodeAlerts a]
61packetToFragments _   _   ChangeCipherSpec = return [encodeChangeCipherSpec]
62packetToFragments _   _   (AppData x)      = return [x]
63
64switchTxEncryption :: Context -> IO ()
65switchTxEncryption ctx = do
66    tx  <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState)
67    (ver, cc) <- usingState_ ctx $ do v <- getVersion
68                                      c <- isClientContext
69                                      return (v, c)
70    liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx)
71    -- set empty packet counter measure if condition are met
72    when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True
73  where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)
74
75updateHandshake :: Context -> Role -> Handshake -> IO ByteString
76updateHandshake ctx role hs = do
77    case hs of
78        Finished fdata -> usingState_ ctx $ updateVerifiedData role fdata
79        _              -> return ()
80    usingHState ctx $ do
81        when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded
82        when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded
83    return encoded
84  where
85    encoded = encodeHandshake hs
86
87----------------------------------------------------------------
88
89encodePacket13 :: Monoid bytes
90               => Context -> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes)
91encodePacket13 ctx recordLayer pkt = do
92    let pt = contentType pkt
93        mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)
94        len = ctxFragmentSize ctx
95    records <- map mkRecord <$> packetToFragments13 ctx len pkt
96    fmap mconcat <$> forEitherM records (recordEncode13 recordLayer)
97
98packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]
99packetToFragments13 ctx len (Handshake13 hss)  =
100    getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss
101packetToFragments13 _   _   (Alert13 a)        = return [encodeAlerts a]
102packetToFragments13 _   _   (AppData13 x)      = return [x]
103packetToFragments13 _   _   ChangeCipherSpec13 = return [encodeChangeCipherSpec]
104
105updateHandshake13 :: Context -> Handshake13 -> IO ByteString
106updateHandshake13 ctx hs
107    | isIgnored hs = return encoded
108    | otherwise    = usingHState ctx $ do
109        when (isHRR hs) wrapAsMessageHash13
110        updateHandshakeDigest encoded
111        addHandshakeMessage encoded
112        return encoded
113  where
114    encoded = encodeHandshake13 hs
115
116    isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand
117    isHRR _                           = False
118
119    isIgnored NewSessionTicket13{} = True
120    isIgnored KeyUpdate13{}        = True
121    isIgnored _                    = False
122