module Network.TLS.Sending (writePacket) where
import Control.Monad.State.Strict
import Control.Concurrent.MVar
import Data.IORef
import qualified Data.ByteString as B
import Network.TLS.Types (Role(..))
import Network.TLS.Cap
import Network.TLS.Struct
import Network.TLS.Record
import Network.TLS.Packet
import Network.TLS.Context.Internal
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Handshake.State
import Network.TLS.Cipher
import Network.TLS.Util
import Network.TLS.Imports
makeRecord :: Packet -> RecordM (Record Plaintext)
makeRecord pkt = do
ver <- getRecordVersion
return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt)
where writePacketContent (Handshake hss) = encodeHandshakes hss
writePacketContent (Alert a) = encodeAlerts a
writePacketContent ChangeCipherSpec = encodeChangeCipherSpec
writePacketContent (AppData x) = x
encodeRecord :: Record Ciphertext -> RecordM ByteString
encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]
where (hdr, content) = recordToRaw record
writePacket :: Context -> Packet -> IO (Either TLSError ByteString)
writePacket ctx pkt@(Handshake hss) = do
forM_ hss $ \hs -> do
case hs of
Finished fdata -> usingState_ ctx $ updateVerifiedData ClientRole fdata
_ -> return ()
let encoded = encodeHandshake hs
usingHState ctx $ do
when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded
prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)
writePacket ctx pkt = do
d <- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)
when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx
return d
prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)
prepareRecord ctx f = do
ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)
txState <- readMVar $ ctxTxState ctx
let sz = case stCipher txState of
Nothing -> 0
Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher
then bulkIVSize $ cipherBulk cipher
else 0
if hasExplicitBlockIV ver && sz > 0
then do newIV <- getStateRNG ctx sz
runTxState ctx (modify (setRecordIV newIV) >> f)
else runTxState ctx f
switchTxEncryption :: Context -> IO ()
switchTxEncryption ctx = do
tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState)
(ver, cc) <- usingState_ ctx $ do v <- getVersion
c <- isClientContext
return (v, c)
liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx)
when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True
where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)