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

-- |
-- Module      : Network.TLS.Context
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
-- only needed because of some GHC bug relative to insufficient polymorphic field
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Context
        (
        -- * Context configuration
          Params(..)
        , RoleParams(..)
        , ClientParams(..)
        , ServerParams(..)
        , updateClientParams
        , updateServerParams
        , Logging(..)
        , SessionID
        , SessionData(..)
        , MaxFragmentEnum(..)
        , Measurement(..)
        , CertificateUsage(..)
        , CertificateRejectReason(..)
        , defaultLogging
        , defaultParamsClient
        , defaultParamsServer
        , withSessionManager
        , setSessionManager

        -- * Context object and accessor
        , Backend(..)
        , Context
        , ctxParams
        , ctxConnection
        , ctxEOF
        , ctxHasSSLv2ClientHello
        , ctxDisableSSLv2ClientHello
        , ctxEstablished
        , ctxLogging
        , setEOF
        , setEstablished
        , contextFlush
        , contextClose
        , contextSend
        , contextRecv
        , updateMeasure
        , withMeasure

        -- * deprecated types
        , TLSParams
        , TLSLogging
        , TLSCertificateUsage
        , TLSCertificateRejectReason
        , TLSCtx

        -- * deprecated values
        , defaultParams

        -- * New contexts
        , contextNew
        , contextNewOnHandle

        -- * Using context states
        , throwCore
        , usingState
        , usingState_
        , getStateRNG
        ) where

import Network.BSD (HostName)
import Network.TLS.Extension
import Network.TLS.Struct
import qualified Network.TLS.Struct as Struct
import Network.TLS.Session
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Crypto
import Network.TLS.State
import Network.TLS.Measurement
import Data.Certificate.X509
import Data.List (intercalate)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B

import Crypto.Random.API

import Control.Concurrent.MVar
import Control.Monad.State
import Control.Exception (throwIO, Exception())
import Data.IORef
import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose)

data Logging = Logging
        { loggingPacketSent :: String -> IO ()
        , loggingPacketRecv :: String -> IO ()
        , loggingIOSent     :: B.ByteString -> IO ()
        , loggingIORecv     :: Header -> B.ByteString -> IO ()
        }

data ClientParams = ClientParams
        { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
        , clientUseServerName        :: Maybe HostName
        , clientWantSessionResume    :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session.

          -- | This action is called when the server sends a
          -- certificate request.  The parameter is the information
          -- from the request.  The action should select a certificate
          -- chain of one of the given certificate types where the
          -- last certificate in the chain should be signed by one of
          -- the given distinguished names.  Each certificate should
          -- be signed by the following one, except for the last.  At
          -- least the first of the certificates in the chain must
          -- have a corresponding private key, because that is used
          -- for signing the certificate verify message.
          --
          -- Note that is is the responsibility of this action to
          -- select a certificate matching one of the requested
          -- certificate types.  Returning a non-matching one will
          -- lead to handshake failure later.
          --
          -- Returning a certificate chain not matching the
          -- distinguished names may lead to problems or not,
          -- depending whether the server accepts it.
        , onCertificateRequest :: ([CertificateType],
                                   Maybe [HashAndSignatureAlgorithm],
                                   [DistinguishedName]) -> IO [(X509, Maybe PrivateKey)]
        }

data ServerParams = ServerParams
        { serverWantClientCert    :: Bool  -- ^ request a certificate from client.

          -- | This is a list of certificates from which the
          -- disinguished names are sent in certificate request
          -- messages.  For TLS1.0, it should not be empty.
        , serverCACertificates :: [X509]

          -- | This action is called when a client certificate chain
          -- is received from the client.  When it returns a
          -- CertificateUsageReject value, the handshake is aborted.
        , onClientCertificate :: [X509] -> IO CertificateUsage

          -- | This action is called when the client certificate
          -- cannot be verified.  A 'Nothing' argument indicates a
          -- wrong signature, a 'Just e' message signals a crypto
          -- error.
        , onUnverifiedClientCert :: IO Bool

        , onCipherChoosing        :: Version -> [Cipher] -> Cipher -- ^ callback on server to modify the cipher chosen.
        }

data RoleParams = Client ClientParams | Server ServerParams

data Params = forall s . SessionManager s => Params
        { pConnectVersion    :: Version             -- ^ version to use on client connection.
        , pAllowedVersions   :: [Version]           -- ^ allowed versions that we can use.
        , pCiphers           :: [Cipher]            -- ^ all ciphers supported ordered by priority.
        , pCompressions      :: [Compression]       -- ^ all compression supported ordered by priority.
        , pHashSignatures    :: [HashAndSignatureAlgorithm] -- ^ All supported hash/signature algorithms pair for client certificate verification, ordered by decreasing priority.
        , pUseSecureRenegotiation :: Bool           -- ^ notify that we want to use secure renegotation
        , pUseSession             :: Bool           -- ^ generate new session if specified
        , pCertificates      :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any.
        , pLogging           :: Logging             -- ^ callback for logging
        , onHandshake        :: Measurement -> IO Bool -- ^ callback on a beggining of handshake
        , onCertificatesRecv :: [X509] -> IO CertificateUsage -- ^ callback to verify received cert chain.
        , pSessionManager    :: s
        , onSuggestNextProtocols :: IO (Maybe [B.ByteString])       -- ^ suggested next protocols accoring to the next protocol negotiation extension.
        , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)
        , roleParams          :: RoleParams
        }

-- | Set a new session manager in a parameters structure.
setSessionManager :: SessionManager s => s -> Params -> Params
setSessionManager manager (Params {..}) = Params { pSessionManager = manager, .. }

withSessionManager :: Params -> (forall s . SessionManager s => s -> a) -> a
withSessionManager (Params { pSessionManager = man }) f = f man

defaultLogging :: Logging
defaultLogging = Logging
        { loggingPacketSent = (\_ -> return ())
        , loggingPacketRecv = (\_ -> return ())
        , loggingIOSent     = (\_ -> return ())
        , loggingIORecv     = (\_ _ -> return ())
        }

defaultParamsClient :: Params
defaultParamsClient = Params
        { pConnectVersion         = TLS10
        , pAllowedVersions        = [TLS10,TLS11,TLS12]
        , pCiphers                = []
        , pCompressions           = [nullCompression]
        , pHashSignatures         = [ (Struct.HashSHA512, SignatureRSA)
                                    , (Struct.HashSHA384, SignatureRSA)
                                    , (Struct.HashSHA256, SignatureRSA)
                                    , (Struct.HashSHA224, SignatureRSA)
                                    ]
        , pUseSecureRenegotiation = True
        , pUseSession             = True
        , pCertificates           = []
        , pLogging                = defaultLogging
        , onHandshake             = (\_ -> return True)
        , onCertificatesRecv      = (\_ -> return CertificateUsageAccept)
        , pSessionManager         = NoSessionManager
        , onSuggestNextProtocols  = return Nothing
        , onNPNServerSuggest      = Nothing
        , roleParams              = Client $ ClientParams
                                        { clientWantSessionResume    = Nothing
                                        , clientUseMaxFragmentLength = Nothing
                                        , clientUseServerName        = Nothing
                                        , onCertificateRequest       = \ _ -> return []
                                        }
        }

defaultParamsServer :: Params
defaultParamsServer = defaultParamsClient { roleParams = Server role }
    where role = ServerParams
                   { serverWantClientCert   = False
                   , onCipherChoosing       = \_ -> head
                   , serverCACertificates   = []
                   , onClientCertificate    = \ _ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected"
                   , onUnverifiedClientCert = return False
                   }

updateRoleParams :: (ClientParams -> ClientParams) -> (ServerParams -> ServerParams) -> Params -> Params
updateRoleParams fc fs params = case roleParams params of
                                     Client c -> params { roleParams = Client (fc c) }
                                     Server s -> params { roleParams = Server (fs s) }

updateClientParams :: (ClientParams -> ClientParams) -> Params -> Params
updateClientParams f = updateRoleParams f id

updateServerParams :: (ServerParams -> ServerParams) -> Params -> Params
updateServerParams f = updateRoleParams id f

defaultParams :: Params
defaultParams = defaultParamsClient
{-# DEPRECATED defaultParams "use defaultParamsClient" #-}


instance Show Params where
        show p = "Params { " ++ (intercalate "," $ map (\(k,v) -> k ++ "=" ++ v)
                [ ("connectVersion", show $ pConnectVersion p)
                , ("allowedVersions", show $ pAllowedVersions p)
                , ("ciphers", show $ pCiphers p)
                , ("compressions", show $ pCompressions p)
                , ("certificates", show $ length $ pCertificates p)
                ]) ++ " }"

-- | Certificate and Chain rejection reason
data CertificateRejectReason =
          CertificateRejectExpired
        | CertificateRejectRevoked
        | CertificateRejectUnknownCA
        | CertificateRejectOther String
        deriving (Show,Eq)

-- | Certificate Usage callback possible returns values.
data CertificateUsage =
          CertificateUsageAccept                         -- ^ usage of certificate accepted
        | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected
        deriving (Show,Eq)

-- | Connection IO backend
data Backend = Backend
        { backendFlush :: IO ()                -- ^ Flush the connection sending buffer, if any.
        , backendClose :: IO ()                -- ^ Close the connection.
        , backendSend  :: ByteString -> IO ()  -- ^ Send a bytestring through the connection.
        , backendRecv  :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection.
        }

-- | A TLS Context keep tls specific state, parameters and backend information.
data Context = Context
        { ctxConnection       :: Backend   -- ^ return the backend object associated with this context
        , ctxParams           :: Params
        , ctxState            :: MVar TLSState
        , ctxMeasurement      :: IORef Measurement
        , ctxEOF_             :: IORef Bool    -- ^ has the handle EOFed or not.
        , ctxEstablished_     :: IORef Bool    -- ^ has the handshake been done and been successful.
        , ctxSSLv2ClientHello :: IORef Bool    -- ^ enable the reception of compatibility SSLv2 client hello.
                                               -- the flag will be set to false regardless of its initial value
                                               -- after the first packet received.
        }

-- deprecated types, setup as aliases for compatibility.
type TLSParams = Params
type TLSCtx = Context
type TLSLogging = Logging
type TLSCertificateUsage = CertificateUsage
type TLSCertificateRejectReason = CertificateRejectReason

updateMeasure :: MonadIO m => Context -> (Measurement -> Measurement) -> m ()
updateMeasure ctx f = liftIO $ do
    x <- readIORef (ctxMeasurement ctx)
    writeIORef (ctxMeasurement ctx) $! f x

withMeasure :: MonadIO m => Context -> (Measurement -> IO a) -> m a
withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f)

contextFlush :: Context -> IO ()
contextFlush = backendFlush . ctxConnection

contextClose :: Context -> IO ()
contextClose = backendClose . ctxConnection

contextSend :: Context -> Bytes -> IO ()
contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b

contextRecv :: Context -> Int -> IO Bytes
contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz

ctxEOF :: MonadIO m => Context -> m Bool
ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)

ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool
ctxHasSSLv2ClientHello ctx = liftIO (readIORef $ ctxSSLv2ClientHello ctx)

ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m ()
ctxDisableSSLv2ClientHello ctx = liftIO (writeIORef (ctxSSLv2ClientHello ctx) False)

setEOF :: MonadIO m => Context -> m ()
setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True

ctxEstablished :: MonadIO m => Context -> m Bool
ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx

setEstablished :: MonadIO m => Context -> Bool -> m ()
setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v

ctxLogging :: Context -> Logging
ctxLogging = pLogging . ctxParams

-- | create a new context using the backend and parameters specified.
contextNew :: (MonadIO m, CPRG rng)
           => Backend   -- ^ Backend abstraction with specific method to interact with the connection type.
           -> Params    -- ^ Parameters of the context.
           -> rng       -- ^ Random number generator associated with this context.
           -> m Context
contextNew backend params rng = liftIO $ do
        let clientContext = case roleParams params of
                                 Client {} -> True
                                 Server {} -> False
        let st = (newTLSState rng) { stClientContext = clientContext }

        stvar <- newMVar st
        eof   <- newIORef False
        established <- newIORef False
        stats <- newIORef newMeasurement
        -- we enable the reception of SSLv2 ClientHello message only in the
        -- server context, where we might be dealing with an old/compat client.
        sslv2Compat <- newIORef (not clientContext)
        return $ Context
                { ctxConnection   = backend
                , ctxParams       = params
                , ctxState        = stvar
                , ctxMeasurement  = stats
                , ctxEOF_         = eof
                , ctxEstablished_ = established
                , ctxSSLv2ClientHello = sslv2Compat
                }

-- | create a new context on an handle.
contextNewOnHandle :: (MonadIO m, CPRG rng)
                   => Handle -- ^ Handle of the connection.
                   -> Params -- ^ Parameters of the context.
                   -> rng    -- ^ Random number generator associated with this context.
                   -> m Context
contextNewOnHandle handle params st =
        liftIO (hSetBuffering handle NoBuffering) >> contextNew backend params st
        where backend = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle)

throwCore :: (MonadIO m, Exception e) => e -> m a
throwCore = liftIO . throwIO


usingState :: MonadIO m => Context -> TLSSt a -> m (Either TLSError a)
usingState ctx f =
        liftIO $ modifyMVar (ctxState ctx) $ \st ->
                let (a, newst) = runTLSState f st
                 in newst `seq` return (newst, a)

usingState_ :: MonadIO m => Context -> TLSSt a -> m a
usingState_ ctx f = do
        ret <- usingState ctx f
        case ret of
                Left err -> throwCore err
                Right r  -> return r

getStateRNG :: MonadIO m => Context -> Int -> m Bytes
getStateRNG ctx n = usingState_ ctx (genTLSRandom n)