2010-09-09 21:47:19 +00:00
|
|
|
-- |
|
|
|
|
-- 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
|
|
|
|
--
|
2013-07-28 08:19:28 +00:00
|
|
|
module Network.TLS.Sending (writePacket) where
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
import Control.Monad.State
|
|
|
|
|
2010-09-26 09:34:47 +00:00
|
|
|
import Data.ByteString (ByteString)
|
2010-09-09 21:47:19 +00:00
|
|
|
import qualified Data.ByteString as B
|
|
|
|
|
2013-07-21 09:16:01 +00:00
|
|
|
import Network.TLS.Types (Role(..))
|
2013-07-24 07:19:13 +00:00
|
|
|
import Network.TLS.Cap
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Struct
|
2011-08-12 17:41:49 +00:00
|
|
|
import Network.TLS.Record
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Packet
|
|
|
|
import Network.TLS.State
|
2013-07-20 07:21:15 +00:00
|
|
|
import Network.TLS.Handshake.State
|
2013-07-24 07:19:13 +00:00
|
|
|
import Network.TLS.Cipher
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-21 05:54:01 +00:00
|
|
|
-- | 'makePacketData' create a Header and a content bytestring related to a packet
|
|
|
|
-- this doesn't change any state
|
2013-07-11 08:03:33 +00:00
|
|
|
makeRecord :: Packet -> RecordM (Record Plaintext)
|
2011-08-12 17:41:49 +00:00
|
|
|
makeRecord pkt = do
|
2013-07-25 20:53:32 +00:00
|
|
|
ver <- getRecordVersion
|
2013-07-21 05:54:01 +00:00
|
|
|
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
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-21 05:54:01 +00:00
|
|
|
-- | marshall packet data
|
2013-07-11 08:03:33 +00:00
|
|
|
encodeRecord :: Record Ciphertext -> RecordM ByteString
|
2011-08-12 17:41:49 +00:00
|
|
|
encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]
|
2013-07-12 06:27:28 +00:00
|
|
|
where (hdr, content) = recordToRaw record
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-21 05:54:01 +00:00
|
|
|
-- | writePacket transform a packet into marshalled data related to current state
|
|
|
|
-- and updating state on the go
|
2011-03-01 20:01:40 +00:00
|
|
|
writePacket :: Packet -> TLSSt ByteString
|
2013-07-20 15:07:07 +00:00
|
|
|
writePacket pkt@(Handshake hss) = do
|
|
|
|
forM_ hss $ \hs -> do
|
|
|
|
case hs of
|
2013-07-21 09:16:01 +00:00
|
|
|
Finished fdata -> updateVerifiedData ClientRole fdata
|
2013-07-20 15:07:07 +00:00
|
|
|
_ -> return ()
|
|
|
|
let encoded = encodeHandshake hs
|
|
|
|
when (certVerifyHandshakeMaterial hs) $ withHandshakeM $ addHandshakeMessage encoded
|
|
|
|
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ withHandshakeM $ updateHandshakeDigest encoded
|
2013-07-24 07:19:13 +00:00
|
|
|
prepareRecord (makeRecord pkt >>= engageRecord >>= encodeRecord)
|
2013-07-20 15:09:16 +00:00
|
|
|
writePacket pkt = do
|
2013-07-24 07:19:13 +00:00
|
|
|
d <- prepareRecord (makeRecord pkt >>= engageRecord >>= encodeRecord)
|
2013-07-22 07:35:53 +00:00
|
|
|
when (pkt == ChangeCipherSpec) $ switchTxEncryption
|
2013-07-20 15:09:16 +00:00
|
|
|
return d
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-24 07:19:13 +00:00
|
|
|
-- before TLS 1.1, the block cipher IV is made of the residual of the previous block,
|
|
|
|
-- so we use cstIV as is, however in other case we generate an explicit IV
|
|
|
|
prepareRecord :: RecordM a -> TLSSt a
|
|
|
|
prepareRecord f = do
|
|
|
|
st <- get
|
|
|
|
ver <- getVersion
|
2013-07-25 20:53:32 +00:00
|
|
|
let sz = case stCipher $ stTxState st of
|
2013-07-24 07:19:13 +00:00
|
|
|
Nothing -> 0
|
|
|
|
Just cipher -> bulkIVSize $ cipherBulk cipher
|
|
|
|
if hasExplicitBlockIV ver && sz > 0
|
|
|
|
then do newIV <- genRandom sz
|
2013-07-27 07:32:27 +00:00
|
|
|
runTxState (modify $ setRecordIV newIV)
|
2013-07-25 20:53:32 +00:00
|
|
|
runTxState f
|
|
|
|
else runTxState f
|