yogsototh/hs-tls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

handle early termination and bad remote side more effectively.

Browse source 
mark the session has invalid and also try to
reply to the other side that we're closing the connection.

Finally a new terminated exception is raised to userspace to notify
the failure.
This commit is contained in:
Vincent Hanquez 2012-12-31 15:49:34 +00:00
parent fd922e90d3
commit a2355f33ee
1 changed files with 27 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
core/Network/TLS/Core.hs
View file

@ -31,7 +31,9 @@ module Network.TLS.Core
import Network.TLS.Context
import Network.TLS.Struct
import Network.TLS.State (getSession)
import Network.TLS.IO
import Network.TLS.Session
import Network.TLS.Handshake
import Data.Typeable
import qualified Network.TLS.State as S
@ -75,27 +77,46 @@ sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks data
-- | recvData get data out of Data packet, and automatically renegotiate if
-- a Handshake ClientHello is received
recvData :: MonadIO m => Context -> m B.ByteString
recvData ctx = checkValid ctx >> recvPacket ctx >>= either packetError process
where packetError err = error ("error received: " ++ show err)
recvData ctx = checkValid ctx >> recvPacket ctx >>= either onError process
where onError err@(Error_Protocol (reason,fatal,desc)) =
terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason
onError err =
terminate err AlertLevel_Fatal InternalError (show err)
process (Handshake [ch@(ClientHello {})]) =
-- on server context receiving a client hello == renegotiation
case roleParams $ ctxParams ctx of
Server sparams -> handshakeServerWith sparams ctx ch >> recvData ctx
Client {} -> error "assert, unexpected client hello in client context"
Client {} -> let reason = "unexpected client hello in client context" in
terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
process (Handshake [HelloRequest]) =
-- on client context, receiving a hello request == renegotiation
case roleParams $ ctxParams ctx of
Server {} -> error "assert, unexpected hello request in server context"
Server {} -> let reason = "unexpected hello request in server context" in
terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
Client cparams -> handshakeClient cparams ctx >> recvData ctx
process (Alert [(AlertLevel_Warning, CloseNotify)]) = setEOF ctx >> return B.empty
process (Alert [(AlertLevel_Fatal, _)]) = setEOF ctx >> return B.empty
process (Alert [(AlertLevel_Fatal, desc)]) = do
setEOF ctx
liftIO $ E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))
-- when receiving empty appdata, we just retry to get some data.
process (AppData "") = recvData ctx
process (AppData x) = return x
process p = error ("error unexpected packet: " ++ show p)
process p = let reason = "unexpected message " ++ show p in
terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
terminate :: MonadIO m => TLSError -> AlertLevel -> AlertDescription -> String -> m a
terminate err level desc reason = do
session <- usingState_ ctx getSession
case session of
Session Nothing -> return ()
Session (Just sid) -> withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionInvalidate s sid)
liftIO $ E.catch (sendPacket ctx $ Alert [(level, desc)]) (\(_ :: E.SomeException) -> return ())
setEOF ctx
liftIO $ E.throwIO (Terminated False reason err)
{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}
-- | same as recvData but returns a lazy bytestring.