-- | -- Module : Network.TLS.Parameters -- License : BSD-style -- Maintainer : Vincent Hanquez <vincent@snarc.org> -- Stability : experimental -- Portability : unknown -- module Network.TLS.Parameters ( ClientParams(..) , ServerParams(..) , CommonParams , ClientHooks(..) , ServerHooks(..) , Supported(..) , Shared(..) -- * special default , defaultParamsClient -- * Parameters , MaxFragmentEnum(..) , CertificateUsage(..) , CertificateRejectReason(..) ) 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.Measurement import Network.TLS.Compression import Network.TLS.Crypto import Network.TLS.Credentials import Network.TLS.X509 import Data.Monoid import Data.Default.Class import qualified Data.ByteString as B type CommonParams = (Supported, Shared) data ClientParams = ClientParams { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- | Define the name of the server, along with an extra service identification blob. -- this is important that the hostname part is properly filled for security reason, -- as it allow to properly associate the remote side with the given certificate -- during a handshake. -- -- The extra blob is useful to differentiate services running on the same host, but that -- might have different certificates given. It's only used as part of the X509 validation -- infrastructure. , clientServerIdentification :: (HostName, Bytes) -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow -- the client to specify which host name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). , clientUseServerNameIndication :: Bool -- | try to establish a connection using this session. , clientWantSessionResume :: Maybe (SessionID, SessionData) , clientShared :: Shared , clientHooks :: ClientHooks , clientSupported :: Supported } deriving (Show) defaultParamsClient :: HostName -> Bytes -> ClientParams defaultParamsClient serverName serverId = ClientParams { clientWantSessionResume = Nothing , clientUseMaxFragmentLength = Nothing , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientShared = def , clientHooks = def , clientSupported = def } data ServerParams = ServerParams { -- | request a certificate from client. serverWantClientCert :: Bool -- | 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 :: [SignedCertificate] -- | Server Optional Diffie Hellman parameters. If this value is not -- properly set, no Diffie Hellman key exchange will take place. , serverDHEParams :: Maybe DHParams , serverShared :: Shared , serverHooks :: ServerHooks , serverSupported :: Supported } deriving (Show) defaultParamsServer :: ServerParams defaultParamsServer = ServerParams { serverWantClientCert = False , serverCACertificates = [] , serverDHEParams = Nothing , serverHooks = def , serverShared = def , serverSupported = def } instance Default ServerParams where def = defaultParamsServer -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported { -- | Supported Versions by this context -- On the client side, the highest version will be used to establish the connection. -- On the server side, the highest version that is less or equal than the client version will be chosed. supportedVersions :: [Version] -- | Supported cipher methods , supportedCiphers :: [Cipher] -- | supported compressions methods , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client -- certificate verification, ordered by decreasing priority. , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Set if we support secure renegotiation. , supportedSecureRenegotiation :: Bool -- | Set if we support session. , supportedSession :: Bool } deriving (Show,Eq) defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS12,TLS11,TLS10,SSL3] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA256, SignatureRSA) , (Struct.HashSHA224, SignatureRSA) , (Struct.HashSHA1, SignatureDSS) ] , supportedSecureRenegotiation = True , supportedSession = True } instance Default Supported where def = defaultSupported data Shared = Shared { sharedCredentials :: Credentials , sharedSessionManager :: SessionManager , sharedCAStore :: CertificateStore , sharedValidationCache :: ValidationCache } instance Show Shared where show _ = "Shared" instance Default Shared where def = Shared { sharedCAStore = mempty , sharedCredentials = mempty , sharedSessionManager = noSessionManager , sharedValidationCache = def } -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks { -- | 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 (Maybe (CertificateChain, PrivKey)) , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \ _ -> return Nothing , onNPNServerSuggest = Nothing , onServerCertificate = validateDefault } instance Show ClientHooks where show _ = "ClientHooks" instance Default ClientHooks where def = defaultClientHooks -- | A set of callbacks run by the server for various corners of the TLS establishment data ServerHooks = ServerHooks { -- | 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 :: CertificateChain -> 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 -- | Allow the server to choose the cipher relative to the -- the client version and the client list of ciphers. -- -- This could be useful with old clients and as a workaround -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1) -- -- The client cipher list cannot be empty. , onCipherChoosing :: Version -> [Cipher] -> Cipher -- | suggested next protocols accoring to the next protocol negotiation extension. , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- | at each new handshake, we call this hook to see if we allow handshake to happens. , onNewHandshake :: Measurement -> IO Bool } defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks { onCipherChoosing = \_ -> head , onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False , onSuggestNextProtocols = return Nothing , onNewHandshake = \_ -> return True } instance Show ServerHooks where show _ = "ClientHooks" instance Default ServerHooks where def = defaultServerHooks