hs-tls/core/Network/TLS/Core.hs

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}
-- |
-- Module      : Network.TLS.Core
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Core
        (
        -- * Internal packet sending and receiving
          sendPacket
        , recvPacket

        -- * Initialisation and Termination of context
        , bye
        , handshake
        , HandshakeFailed(..)
        , ConnectionNotEstablished(..)

        -- * Next Protocol Negotiation
        , getNegotiatedProtocol

        -- * High level API
        , Terminated(..)
        , sendData
        , recvData
        , recvData'
        ) where

import Network.TLS.Context
import Network.TLS.Struct
import Network.TLS.IO
import Network.TLS.Handshake
import Data.Typeable
import qualified Network.TLS.State as S
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as L
import qualified Control.Exception as E

import Control.Monad.State

-- | Early termination exception with the reason and the TLS error associated
data Terminated = Terminated Bool String TLSError
                deriving (Eq,Show,Typeable)

instance E.Exception Terminated

-- | notify the context that this side wants to close connection.
-- this is important that it is called before closing the handle, otherwise
-- the session might not be resumable (for version < TLS1.2).
--
-- this doesn't actually close the handle
bye :: MonadIO m => Context -> m ()
bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]

-- | If the Next Protocol Negotiation extension has been used, this will
-- return get the protocol agreed upon.
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
getNegotiatedProtocol ctx = usingState_ ctx S.getNegotiatedProtocol

-- | sendData sends a bunch of data.
-- It will automatically chunk data to acceptable packet size
sendData :: MonadIO m => Context -> L.ByteString -> m ()
sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks dataToSend)
        where sendDataChunk d
                | B.length d > 16384 = do
                        let (sending, remain) = B.splitAt 16384 d
                        sendPacket ctx $ AppData sending
                        sendDataChunk remain
                | otherwise = sendPacket ctx $ AppData d

-- | 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)

          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"
          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"
                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

          -- 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)

{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}
-- | same as recvData but returns a lazy bytestring.
recvData' :: MonadIO m => Context -> m L.ByteString
recvData' ctx = recvData ctx >>= return . L.fromChunks . (:[])