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
|
|
|
|
--
|
2011-12-01 08:41:01 +00:00
|
|
|
module Network.TLS.Sending (writePacket, encryptRSA) where
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
import Control.Applicative ((<$>))
|
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
|
|
|
|
|
2010-09-26 17:51:23 +00:00
|
|
|
import Network.TLS.Util
|
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
|
|
|
|
import Network.TLS.Crypto
|
|
|
|
|
|
|
|
{-
|
|
|
|
- 'makePacketData' create a Header and a content bytestring related to a packet
|
|
|
|
- this doesn't change any state
|
|
|
|
-}
|
2011-08-12 17:41:49 +00:00
|
|
|
makeRecord :: Packet -> TLSSt (Record Plaintext)
|
|
|
|
makeRecord pkt = do
|
2012-03-27 07:57:51 +00:00
|
|
|
ver <- stVersion <$> get
|
|
|
|
content <- writePacketContent pkt
|
|
|
|
return $ Record (packetType pkt) ver (fragmentPlaintext content)
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
{-
|
|
|
|
- Handshake data need to update a digest
|
|
|
|
-}
|
2011-08-12 17:41:49 +00:00
|
|
|
processRecord :: Record Plaintext -> TLSSt (Record Plaintext)
|
|
|
|
processRecord record@(Record ty _ fragment) = do
|
2012-03-27 07:57:51 +00:00
|
|
|
when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment)
|
|
|
|
return record
|
2011-08-12 17:41:49 +00:00
|
|
|
|
2010-09-09 21:47:19 +00:00
|
|
|
{-
|
|
|
|
- ChangeCipherSpec state change need to be handled after encryption otherwise
|
|
|
|
- its own packet would be encrypted with the new context, instead of beeing sent
|
|
|
|
- under the current context
|
|
|
|
-}
|
2011-08-12 17:41:49 +00:00
|
|
|
postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext)
|
|
|
|
postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) =
|
2012-03-27 07:57:51 +00:00
|
|
|
switchTxEncryption >> return record
|
2011-08-12 17:41:49 +00:00
|
|
|
postprocessRecord record = return record
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
{-
|
|
|
|
- marshall packet data
|
|
|
|
-}
|
2011-08-12 17:41:49 +00:00
|
|
|
encodeRecord :: Record Ciphertext -> TLSSt ByteString
|
|
|
|
encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]
|
2012-03-27 07:57:51 +00:00
|
|
|
where (hdr, content) = recordToRaw record
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-10-02 21:02:37 +00:00
|
|
|
{-
|
|
|
|
- just update TLS state machine
|
|
|
|
-}
|
2011-06-10 20:24:46 +00:00
|
|
|
preProcessPacket :: Packet -> TLSSt ()
|
|
|
|
preProcessPacket (Alert _) = return ()
|
|
|
|
preProcessPacket (AppData _) = return ()
|
2011-11-29 08:59:41 +00:00
|
|
|
preProcessPacket (ChangeCipherSpec) = return ()
|
2011-06-10 20:24:46 +00:00
|
|
|
preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do
|
2012-03-27 07:57:51 +00:00
|
|
|
case hs of
|
|
|
|
Finished fdata -> updateVerifiedData True fdata
|
|
|
|
_ -> return ()
|
2010-09-09 21:47:19 +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
|
2011-08-12 17:41:49 +00:00
|
|
|
writePacket pkt = do
|
2012-03-27 07:57:51 +00:00
|
|
|
preProcessPacket pkt
|
|
|
|
makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- SENDING Helpers -}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
|
|
|
{- if the RSA encryption fails we just return an empty bytestring, and let the protocol
|
|
|
|
- fail by itself; however it would be probably better to just report it since it's an internal problem.
|
|
|
|
-}
|
2011-03-01 20:01:40 +00:00
|
|
|
encryptRSA :: ByteString -> TLSSt ByteString
|
2010-09-09 21:47:19 +00:00
|
|
|
encryptRSA content = do
|
2012-03-27 07:57:51 +00:00
|
|
|
st <- get
|
|
|
|
let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st
|
|
|
|
case withTLSRNG (stRandomGen st) (\g -> kxEncrypt g rsakey content) of
|
|
|
|
Left err -> fail ("rsa encrypt failed: " ++ show err)
|
|
|
|
Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
writePacketContent :: Packet -> TLSSt ByteString
|
2011-12-01 08:41:01 +00:00
|
|
|
writePacketContent (Handshake hss) = return $ encodeHandshakes hss
|
2011-06-10 20:24:46 +00:00
|
|
|
writePacketContent (Alert a) = return $ encodeAlerts a
|
|
|
|
writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec
|
|
|
|
writePacketContent (AppData x) = return x
|