2011-12-06 00:15:00 +00:00
-- |
-- Module : Network.TLS.Context
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
2012-07-12 07:59:59 +00:00
{- # LANGUAGE ExistentialQuantification, Rank2Types # -}
-- only needed because of some GHC bug relative to insufficient polymorphic field
{- # LANGUAGE RecordWildCards # -}
2011-12-06 00:15:00 +00:00
module Network.TLS.Context
2012-03-27 07:57:51 +00:00
(
-- * Context configuration
Params ( .. )
2012-07-12 07:54:34 +00:00
, RoleParams ( .. )
, ClientParams ( .. )
, ServerParams ( .. )
, updateClientParams
, updateServerParams
2012-03-27 07:57:51 +00:00
, Logging ( .. )
2012-07-08 09:14:09 +00:00
, SessionID
2012-03-27 07:57:51 +00:00
, SessionData ( .. )
2012-10-20 08:00:30 +00:00
, MaxFragmentEnum ( .. )
2012-03-27 07:57:51 +00:00
, Measurement ( .. )
, CertificateUsage ( .. )
, CertificateRejectReason ( .. )
, defaultLogging
, defaultParamsClient
, defaultParamsServer
2012-07-12 07:59:59 +00:00
, withSessionManager
, setSessionManager
2012-03-27 07:57:51 +00:00
-- * Context object and accessor
, Backend ( .. )
, Context
, ctxParams
, ctxConnection
, ctxEOF
2012-12-04 08:31:22 +00:00
, ctxHasSSLv2ClientHello
, ctxDisableSSLv2ClientHello
2012-03-27 07:57:51 +00:00
, ctxEstablished
, ctxLogging
, setEOF
, setEstablished
2012-03-31 22:15:23 +00:00
, contextFlush
, contextClose
, contextSend
, contextRecv
2012-03-27 07:57:51 +00:00
, updateMeasure
, withMeasure
-- * deprecated types
, TLSParams
, TLSLogging
, TLSCertificateUsage
, TLSCertificateRejectReason
, TLSCtx
-- * deprecated values
, defaultParams
-- * New contexts
, contextNew
, contextNewOnHandle
-- * Using context states
, throwCore
, usingState
, usingState_
, getStateRNG
) where
2011-12-06 00:15:00 +00:00
2012-10-20 08:00:30 +00:00
import Network.BSD ( HostName )
import Network.TLS.Extension
2011-12-06 00:15:00 +00:00
import Network.TLS.Struct
2012-07-18 20:19:11 +00:00
import qualified Network.TLS.Struct as Struct
2012-07-12 07:59:59 +00:00
import Network.TLS.Session
2011-12-06 00:15:00 +00:00
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 )
2012-03-12 08:48:03 +00:00
import Data.ByteString ( ByteString )
2011-12-06 00:15:00 +00:00
import qualified Data.ByteString as B
2012-12-05 07:47:17 +00:00
import Crypto.Random.API
2012-03-15 08:16:48 +00:00
2011-12-06 00:15:00 +00:00
import Control.Concurrent.MVar
import Control.Monad.State
2012-03-10 19:39:55 +00:00
import Control.Exception ( throwIO , Exception ( ) )
2011-12-06 00:15:00 +00:00
import Data.IORef
2012-03-28 07:08:33 +00:00
import System.IO ( Handle , hSetBuffering , BufferMode ( .. ) , hFlush , hClose )
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
data Logging = Logging
2012-03-27 07:57:51 +00:00
{ loggingPacketSent :: String -> IO ()
, loggingPacketRecv :: String -> IO ()
, loggingIOSent :: B . ByteString -> IO ()
, loggingIORecv :: Header -> B . ByteString -> IO ()
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:04:16 +00:00
data ClientParams = ClientParams
2012-10-20 08:00:30 +00:00
{ clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
, clientUseServerName :: Maybe HostName
, clientWantSessionResume :: Maybe ( SessionID , SessionData ) -- ^ try to establish a connection using this session.
2012-07-18 19:34:18 +00:00
-- | 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.
2012-07-16 12:36:44 +00:00
, onCertificateRequest :: ( [ CertificateType ] ,
2012-10-21 17:32:07 +00:00
Maybe [ HashAndSignatureAlgorithm ] ,
2012-07-16 12:36:44 +00:00
[ DistinguishedName ] ) -> IO [ ( X509 , Maybe PrivateKey ) ]
2012-07-12 08:02:10 +00:00
}
2012-03-15 08:04:16 +00:00
data ServerParams = ServerParams
2012-07-12 08:02:10 +00:00
{ serverWantClientCert :: Bool -- ^ request a certificate from client.
2012-07-18 19:34:18 +00:00
-- | 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.
2012-07-16 12:36:44 +00:00
, serverCACertificates :: [ X509 ]
2012-07-18 19:34:18 +00:00
-- | This action is called when a client certificate chain
-- is received from the client. When it returns a
-- CertificateUsageReject value, the handshake is aborted.
2012-07-16 12:36:44 +00:00
, onClientCertificate :: [ X509 ] -> IO CertificateUsage
2012-07-18 19:34:18 +00:00
-- | 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.
2012-07-16 12:36:44 +00:00
, onUnverifiedClientCert :: Maybe KxError -> IO Bool
2012-07-26 21:17:08 +00:00
2012-07-23 20:53:59 +00:00
, onCipherChoosing :: Version -> [ Cipher ] -> Cipher -- ^ callback on server to modify the cipher chosen.
2012-07-12 08:02:10 +00:00
}
2012-03-15 08:04:16 +00:00
data RoleParams = Client ClientParams | Server ServerParams
2012-07-12 07:59:59 +00:00
data Params = forall s . SessionManager s => Params
2012-03-27 07:57:51 +00:00
{ 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.
2012-08-27 06:45:48 +00:00
, pHashSignatures :: [ HashAndSignatureAlgorithm ] -- ^ All supported hash/signature algorithms pair for client certificate verification, ordered by decreasing priority.
2012-03-27 07:57:51 +00:00
, 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.
2012-07-12 07:59:59 +00:00
, pSessionManager :: s
2012-02-12 18:59:19 +00:00
, onSuggestNextProtocols :: IO ( Maybe [ B . ByteString ] ) -- ^ suggested next protocols accoring to the next protocol negotiation extension.
2012-02-16 08:05:46 +00:00
, onNPNServerSuggest :: Maybe ( [ B . ByteString ] -> IO B . ByteString )
2012-03-27 07:57:51 +00:00
, roleParams :: RoleParams
}
2011-12-06 00:15:00 +00:00
2012-07-12 07:59:59 +00:00
-- | 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
2012-03-14 08:56:28 +00:00
defaultLogging :: Logging
defaultLogging = Logging
2012-03-27 07:57:51 +00:00
{ loggingPacketSent = ( \ _ -> return () )
, loggingPacketRecv = ( \ _ -> return () )
, loggingIOSent = ( \ _ -> return () )
, loggingIORecv = ( \ _ _ -> return () )
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:04:16 +00:00
defaultParamsClient :: Params
defaultParamsClient = Params
2012-03-27 07:57:51 +00:00
{ pConnectVersion = TLS10
, pAllowedVersions = [ TLS10 , TLS11 , TLS12 ]
, pCiphers = []
, pCompressions = [ nullCompression ]
2012-07-18 20:19:11 +00:00
, pHashSignatures = [ ( Struct . HashSHA512 , SignatureRSA )
, ( Struct . HashSHA384 , SignatureRSA )
, ( Struct . HashSHA256 , SignatureRSA )
, ( Struct . HashSHA224 , SignatureRSA )
]
2012-03-27 07:57:51 +00:00
, pUseSecureRenegotiation = True
, pUseSession = True
, pCertificates = []
, pLogging = defaultLogging
, onHandshake = ( \ _ -> return True )
, onCertificatesRecv = ( \ _ -> return CertificateUsageAccept )
2012-07-12 07:59:59 +00:00
, pSessionManager = NoSessionManager
2012-02-12 18:59:19 +00:00
, onSuggestNextProtocols = return Nothing
2012-02-16 08:05:46 +00:00
, onNPNServerSuggest = Nothing
2012-03-27 07:57:51 +00:00
, roleParams = Client $ ClientParams
2012-10-20 08:00:30 +00:00
{ clientWantSessionResume = Nothing
, clientUseMaxFragmentLength = Nothing
, clientUseServerName = Nothing
, onCertificateRequest = \ _ -> return []
2012-07-12 08:02:10 +00:00
}
2012-03-27 07:57:51 +00:00
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:04:16 +00:00
defaultParamsServer :: Params
2012-08-05 06:15:32 +00:00
defaultParamsServer = defaultParamsClient { roleParams = Server role }
2012-08-04 15:51:12 +00:00
where role = ServerParams
2012-08-05 06:12:07 +00:00
{ serverWantClientCert = False
, onCipherChoosing = \ _ -> head
, serverCACertificates = []
, onClientCertificate = \ _ -> return $ CertificateUsageReject $ CertificateRejectOther " no client certificates expected "
, onUnverifiedClientCert = \ _ -> return False
}
2012-03-15 08:04:16 +00:00
2012-07-12 07:54:34 +00:00
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
2012-03-15 08:04:16 +00:00
defaultParams :: Params
defaultParams = defaultParamsClient
{- # DEPRECATED defaultParams "use defaultParamsClient" # -}
2012-03-14 08:56:28 +00:00
instance Show Params where
2012-03-27 07:57:51 +00:00
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 )
] ) ++ " } "
2011-12-06 00:15:00 +00:00
-- | Certificate and Chain rejection reason
2012-03-14 08:56:28 +00:00
data CertificateRejectReason =
2012-03-27 07:57:51 +00:00
CertificateRejectExpired
| CertificateRejectRevoked
| CertificateRejectUnknownCA
| CertificateRejectOther String
deriving ( Show , Eq )
2011-12-06 00:15:00 +00:00
-- | Certificate Usage callback possible returns values.
2012-03-14 08:56:28 +00:00
data CertificateUsage =
2012-03-27 07:57:51 +00:00
CertificateUsageAccept -- ^ usage of certificate accepted
| CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected
deriving ( Show , Eq )
2011-12-06 00:15:00 +00:00
2012-07-12 08:02:38 +00:00
-- | Connection IO backend
2012-03-14 08:56:28 +00:00
data Backend = Backend
2012-03-27 07:57:51 +00:00
{ backendFlush :: IO () -- ^ Flush the connection sending buffer, if any.
2012-03-28 07:08:33 +00:00
, backendClose :: IO () -- ^ Close the connection.
2012-03-27 07:57:51 +00:00
, backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection.
, backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection.
}
2012-03-12 08:48:03 +00:00
-- | A TLS Context keep tls specific state, parameters and backend information.
2012-03-14 08:56:28 +00:00
data Context = Context
2012-12-04 08:31:22 +00:00
{ 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.
2012-03-27 07:57:51 +00:00
}
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
-- 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 ()
2012-03-10 16:40:59 +00:00
updateMeasure ctx f = liftIO $ do
x <- readIORef ( ctxMeasurement ctx )
writeIORef ( ctxMeasurement ctx ) $! f x
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
withMeasure :: MonadIO m => Context -> ( Measurement -> IO a ) -> m a
2011-12-06 00:15:00 +00:00
withMeasure ctx f = liftIO ( readIORef ( ctxMeasurement ctx ) >>= f )
2012-03-31 22:15:23 +00:00
contextFlush :: Context -> IO ()
contextFlush = backendFlush . ctxConnection
2011-12-06 00:15:00 +00:00
2012-03-31 22:15:23 +00:00
contextClose :: Context -> IO ()
contextClose = backendClose . ctxConnection
2012-03-28 07:08:33 +00:00
2012-03-31 22:15:23 +00:00
contextSend :: Context -> Bytes -> IO ()
contextSend c b = updateMeasure c ( addBytesSent $ B . length b ) >> ( backendSend $ ctxConnection c ) b
2011-12-06 00:15:00 +00:00
2012-03-31 22:15:23 +00:00
contextRecv :: Context -> Int -> IO Bytes
contextRecv c sz = updateMeasure c ( addBytesReceived sz ) >> ( backendRecv $ ctxConnection c ) sz
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
ctxEOF :: MonadIO m => Context -> m Bool
2011-12-06 00:15:00 +00:00
ctxEOF ctx = liftIO ( readIORef $ ctxEOF_ ctx )
2012-12-04 08:31:22 +00:00
ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool
ctxHasSSLv2ClientHello ctx = liftIO ( readIORef $ ctxSSLv2ClientHello ctx )
ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m ()
ctxDisableSSLv2ClientHello ctx = liftIO ( writeIORef ( ctxSSLv2ClientHello ctx ) False )
2012-03-14 08:56:28 +00:00
setEOF :: MonadIO m => Context -> m ()
2011-12-06 00:15:00 +00:00
setEOF ctx = liftIO $ writeIORef ( ctxEOF_ ctx ) True
2012-03-14 08:56:28 +00:00
ctxEstablished :: MonadIO m => Context -> m Bool
2012-01-25 16:01:55 +00:00
ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx
2012-03-14 08:56:28 +00:00
setEstablished :: MonadIO m => Context -> Bool -> m ()
2012-01-25 16:01:55 +00:00
setEstablished ctx v = liftIO $ writeIORef ( ctxEstablished_ ctx ) v
2012-03-14 08:56:28 +00:00
ctxLogging :: Context -> Logging
2011-12-06 00:15:00 +00:00
ctxLogging = pLogging . ctxParams
2012-03-15 08:16:48 +00:00
-- | create a new context using the backend and parameters specified.
2012-12-05 07:47:17 +00:00
contextNew :: ( MonadIO m , CPRG rng )
2012-03-15 08:16:48 +00:00
=> Backend -- ^ Backend abstraction with specific method to interacat 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
2012-03-27 07:57:51 +00:00
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
2012-12-04 08:31:22 +00:00
-- 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 )
2012-03-27 07:57:51 +00:00
return $ Context
{ ctxConnection = backend
, ctxParams = params
, ctxState = stvar
, ctxMeasurement = stats
, ctxEOF_ = eof
, ctxEstablished_ = established
2012-12-04 08:31:22 +00:00
, ctxSSLv2ClientHello = sslv2Compat
2012-03-27 07:57:51 +00:00
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:16:48 +00:00
-- | create a new context on an handle.
2012-12-05 07:47:17 +00:00
contextNewOnHandle :: ( MonadIO m , CPRG rng )
2012-03-15 08:16:48 +00:00
=> Handle -- ^ Handle of the connection.
-> Params -- ^ Parameters of the context.
-> rng -- ^ Random number generator associated with this context.
-> m Context
2012-03-15 07:55:38 +00:00
contextNewOnHandle handle params st =
2012-03-27 07:57:51 +00:00
liftIO ( hSetBuffering handle NoBuffering ) >> contextNew backend params st
2012-03-28 07:08:33 +00:00
where backend = Backend ( hFlush handle ) ( hClose handle ) ( B . hPut handle ) ( B . hGet handle )
2011-12-06 00:15:00 +00:00
throwCore :: ( MonadIO m , Exception e ) => e -> m a
throwCore = liftIO . throwIO
2012-03-14 08:56:28 +00:00
usingState :: MonadIO m => Context -> TLSSt a -> m ( Either TLSError a )
2012-03-10 19:39:55 +00:00
usingState ctx f =
2012-03-27 07:57:51 +00:00
liftIO $ modifyMVar ( ctxState ctx ) $ \ st ->
let ( a , newst ) = runTLSState f st
in newst ` seq ` return ( newst , a )
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
usingState_ :: MonadIO m => Context -> TLSSt a -> m a
2011-12-06 00:15:00 +00:00
usingState_ ctx f = do
2012-03-27 07:57:51 +00:00
ret <- usingState ctx f
case ret of
Left err -> throwCore err
Right r -> return r
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
getStateRNG :: MonadIO m => Context -> Int -> m Bytes
2011-12-06 00:15:00 +00:00
getStateRNG ctx n = usingState_ ctx ( genTLSRandom n )