diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Renzo Carbonara + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Renzo Carbonara nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/PEOPLE b/PEOPLE new file mode 100644 --- /dev/null +++ b/PEOPLE @@ -0,0 +1,6 @@ +The following people have participated in creating this library at some +point, either by directly contributing code or by providing thoughtful +input in discussions about the library design. + +Renzo Carbonara +Vincent Hanquez diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# network-simple-tls + +Haskell library simplifying the useage of TLS secured network +connections. Currently, only TCP sockets are supported. This package +aims to be similar and compatible with the `network-simple` package. + +Check the source or rendered Haddocks for extensive documentation. + +This code is licensed under the terms of the so called **3-clause BSD +license**. Read the file named ``LICENSE`` found in this same directory +for details. + +See the ``PEOPLE`` file to learn about the people involved in this +effort. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/https-client.hs b/examples/https-client.hs new file mode 100644 --- /dev/null +++ b/examples/https-client.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Applicative ((<$>), (<*>), pure) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL () +import Data.Certificate.X509 (X509) +import Data.CertificateStore (CertificateStore + ,makeCertificateStore) +import Data.Maybe (maybeToList) +import Data.Monoid ((<>)) +import qualified Network.Simple.TCP.TLS as Z +import qualified Network.Socket as NS +import qualified Network.TLS as T +import Network.TLS.Extra as TE +import System.Certificate.X509 (getSystemCertificateStore) +import System.Console.GetOpt +import System.Environment (getProgName, getArgs) + +client :: CertificateStore -> [Z.Credential] -> NS.HostName + -> NS.ServiceName -> IO () +client cStore creds host port = do + Z.connect csettings host port $ \(ctx,_) -> do + T.sendData ctx "GET / HTTP/1.0\r\n\r\n" + consume ctx B.putStr >> putStrLn "" + where + csettings = Z.makeClientSettings creds (Just host) cStore + +-- | Repeatedly receive data from the given 'T.Context' until exhausted, +-- performing the given action on each received chunk. +consume :: T.Context -> (B.ByteString -> IO ()) -> IO () +consume ctx k = do + mbs <- Z.recv ctx + case mbs of + Nothing -> return () + Just bs -> k bs >> consume ctx k + + +main :: IO () +main = do + args <- getArgs + case getOpt RequireOrder options args of + (actions, [hostname,port], _) -> do + opts <- foldl (>>=) (return defaultOptions) actions + cStore <- case optCACert opts of + Nothing -> getSystemCertificateStore + Just ca -> return $ makeCertificateStore [ca] + let cred = Z.Credential <$> optClientCert opts + <*> optClientKey opts + <*> pure [] + client cStore (maybeToList cred) hostname port + (_,_,msgs) -> do + pn <- getProgName + let header = "Usage: " <> pn <> " [OPTIONS] HOSTNAME PORT" + error $ concat msgs ++ usageInfo header options + +-------------------------------------------------------------------------------- +-- The boring stuff below is related to command line parsing + +data Options = Options + { optClientCert :: Maybe X509 + , optClientKey :: Maybe T.PrivateKey + , optCACert :: Maybe X509 + } deriving (Show) + +defaultOptions :: Options +defaultOptions = Options + { optClientCert = Nothing + , optClientKey = Nothing + , optCACert = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = + [ Option [] ["cert"] (OptArg readClientCert "FILE") "Client certificate" + , Option [] ["key"] (OptArg readClientKey "FILE") "Client private key" + , Option [] ["cacert"] (OptArg readCACert "FILE") "CA certificate" + ] + + +readClientCert :: Maybe FilePath -> Options -> IO Options +readClientCert Nothing opt = return opt +readClientCert (Just arg) opt = do + cert <- TE.fileReadCertificate arg + return $ opt { optClientCert = Just cert } + +readClientKey :: Maybe FilePath -> Options -> IO Options +readClientKey Nothing opt = return opt +readClientKey (Just arg) opt = do + key <- TE.fileReadPrivateKey arg + return $ opt { optClientKey = Just key } + +readCACert :: Maybe FilePath -> Options -> IO Options +readCACert Nothing opt = return opt +readCACert (Just arg) opt = do + cert <- TE.fileReadCertificate arg + return $ opt { optCACert = Just cert } + diff --git a/examples/tls-echo.hs b/examples/tls-echo.hs new file mode 100644 --- /dev/null +++ b/examples/tls-echo.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Applicative +import qualified Data.ByteString.Char8 as B +import Data.Certificate.X509 (X509) +import Data.Char (toUpper) +import Data.Monoid ((<>)) +import qualified Network.Simple.TCP.TLS as Z +import qualified Network.Socket as NS +import qualified Network.TLS as T +import Network.TLS.Extra as TE +import System.Console.GetOpt +import System.Environment (getProgName, getArgs) +import qualified Data.CertificateStore as C + +server :: Z.Credential -> Z.HostPreference -> NS.ServiceName + -> Maybe C.CertificateStore -> IO () +server cred hp port mcs = do + let ss = Z.makeServerSettings cred mcs + Z.serve ss hp port $ \(ctx,caddr) -> do + putStrLn $ show caddr <> " joined." + consume ctx $ Z.send ctx . B.map toUpper + putStrLn $ show caddr <> " quit." + where + +-- | Repeatedly receive data from the given 'T.Context' until exhausted, +-- performing the given action on each received chunk. +consume :: T.Context -> (B.ByteString -> IO ()) -> IO () +consume ctx k = do + mbs <- Z.recv ctx + case mbs of + Nothing -> return () + Just bs -> k bs >> consume ctx k + + +main :: IO () +main = do + args <- getArgs + case getOpt RequireOrder options args of + (actions, [hostname,port], _) -> do + opts <- foldl (>>=) (return defaultOptions) actions + let !cred = Z.Credential (optServerCert opts) (optServerKey opts) [] + server cred (Z.Host hostname) port + (C.makeCertificateStore . pure <$> optCACert opts) + (_,_,msgs) -> do + pn <- getProgName + let header = "Usage: " <> pn <> " [OPTIONS] HOSTNAME PORT" + error $ concat msgs ++ usageInfo header options + +-------------------------------------------------------------------------------- +-- The boring stuff below is related to command line parsing + +data Options = Options + { optServerCert :: X509 + , optServerKey :: T.PrivateKey + , optCACert :: Maybe X509 + } deriving (Show) + +defaultOptions :: Options +defaultOptions = Options + { optServerCert = error "Missing optServerCert" + , optServerKey = error "Missing optServerKey" + , optCACert = Nothing + } + +options :: [OptDescr (Options -> IO Options)] +options = + [ Option [] ["cert"] (ReqArg readServerCert "FILE") "Server certificate" + , Option [] ["key"] (ReqArg readServerKey "FILE") "Server private key" + , Option [] ["cacert"] (OptArg readCACert "FILE") + "CA certificate to verify a client certificate, if given" + ] + +readServerCert :: FilePath -> Options -> IO Options +readServerCert arg opt = do + cert <- TE.fileReadCertificate arg + return $ opt { optServerCert = cert } + +readServerKey :: FilePath -> Options -> IO Options +readServerKey arg opt = do + key <- TE.fileReadPrivateKey arg + return $ opt { optServerKey = key } + +readCACert :: Maybe FilePath -> Options -> IO Options +readCACert Nothing opt = return opt +readCACert (Just arg) opt = do + cert <- TE.fileReadCertificate arg + return $ opt { optCACert = Just cert } + diff --git a/network-simple-tls.cabal b/network-simple-tls.cabal new file mode 100644 --- /dev/null +++ b/network-simple-tls.cabal @@ -0,0 +1,57 @@ +name: network-simple-tls +version: 0.1.0.0 +synopsis: Simple interface to TLS secured network sockets. +description: Simple interface to TLS secured network sockets. +homepage: https://github.com/k0001/network-simple-tls +bug-reports: https://github.com/k0001/network-simple-tls/issues +license: BSD3 +license-file: LICENSE +author: Renzo Carbonara +maintainer: renzocarbonaraλgmail.com +copyright: Copyright (c) Renzo Carbonara 2013 +category: Network +build-type: Simple +cabal-version: >=1.8 +extra-source-files: README.md PEOPLE + +source-repository head + type: git + location: git://github.com/k0001/network-simple-tls.git + +library + hs-source-dirs: src + exposed-modules: Network.Simple.TCP.TLS + build-depends: base (>=4.5 && <5.0) + , bytestring (>=0.9 && <0.10) + , certificate (>=1.3 && <1.4) + , crypto-random-api (>=0.2 && <0.3) + , network (>=2.3 && <2.5) + , network-simple (>=0.2 && <0.3) + , tls (>=1.1 && <1.2) + , tls-extra (>=0.6 && <0.7) + + + +------------------------------------------------------------------------ +-- Examples. All built when the 'examples' flag is given. + +flag examples + description: Build examples + default: False + +executable network-simple-tls-example-https-client + if !flag(examples) + buildable: False + hs-source-dirs: examples + main-is: https-client.hs + build-depends: base, bytestring, network-simple-tls, network, + tls-extra, tls, certificate + +executable network-simple-tls-example-echo + if !flag(examples) + buildable: False + hs-source-dirs: examples + main-is: tls-echo.hs + build-depends: base, bytestring, network-simple-tls, network, + tls-extra, tls, certificate + diff --git a/src/Network/Simple/TCP/TLS.hs b/src/Network/Simple/TCP/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Network/Simple/TCP/TLS.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE BangPatterns #-} + +-- | This module exports simple tools for establishing TLS-secured TCP +-- connections, relevant to both the client side and server side of the +-- connection. +-- +-- This module re-exports some functions from the "Network.Simple.TCP" module +-- in the @network-simple@ package. Consider using that module directly if you +-- need a similar API without TLS support. + +module Network.Simple.TCP.TLS ( + -- * Server side + serve + -- ** Listening + , S.listen + -- ** Accepting + , accept + , acceptFork + -- ** Server TLS Settings + , ServerSettings + , makeServerSettings + , updateServerParams + , serverParams + -- * Client side + , connect + -- ** Client TLS Settings + , ClientSettings + , makeClientSettings + , getDefaultClientSettings + , updateClientParams + , clientParams + -- * Credentials + , Credential(Credential) + , credentialToCertList + -- * Utils + , recv + , send + -- * Low level support + , connectTls + , acceptTls + , useTls + , useTlsThenCloseFork + -- * Exports + , S.HostPreference(..) + ) where + + +import Control.Concurrent (ThreadId, forkIO) +import qualified Control.Exception as E +import Control.Monad (forever) +import Crypto.Random.API (getSystemRandomGen) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Certificate.X509 as X +import qualified Data.CertificateStore as C +import Data.Maybe (listToMaybe) +import Data.List (intersect) +import qualified GHC.IO.Exception as Eg +import qualified Network.Simple.TCP as S +import qualified Network.Socket as NS +import qualified Network.TLS as T +import Network.TLS.Extra as TE +import System.Certificate.X509 (getSystemCertificateStore) +import System.IO (IOMode(ReadWriteMode)) + + +-------------------------------------------------------------------------------- + +-- | Primary certificate, private key and the rest of the certificate chain. +data Credential = Credential !X.X509 !T.PrivateKey [X.X509] + deriving (Show) + +-- | Convert client `Credential` to the format expected by 'T.pCertificates'. +credentialToCertList :: Credential -> [(X.X509, Maybe T.PrivateKey)] +credentialToCertList (Credential c pk xs) = + (c, Just pk) : fmap (\x -> (x, Nothing)) xs + +-------------------------------------------------------------------------------- +-- Client side TLS settings + +-- | Abstract type representing the configuration settings for a TLS client. +-- +-- Use 'makeClientSettings' or 'getDefaultClientSettings' to obtain your +-- 'ClientSettings' value. +data ClientSettings = ClientSettings { unClientSettings :: T.Params } + +-- | Get the system default 'ClientSettings'. +-- +-- See 'makeClientSettings' for the for the default TLS settings used. +getDefaultClientSettings :: IO ClientSettings +getDefaultClientSettings = + makeClientSettings [] Nothing `fmap` getSystemCertificateStore + +-- | Make defaults 'ClientSettings'. +-- +-- The following TLS settings are used by default: +-- +-- [Supported versions] 'T.TLS10', 'T.TLS11', 'T.TLS12'. +-- +-- [Version reported during /ClientHello/] 'T.TLS10'. +-- +-- [Supported cipher suites] In decreasing order of preference: +-- 'TE.cipher_AES256_SHA256', +-- 'TE.cipher_AES256_SHA1', +-- 'TE.cipher_AES128_SHA256', +-- 'TE.cipher_AES128_SHA1', +-- 'TE.cipher_RC4_128_SHA1', +-- 'TE.cipher_RC4_128_MD5'. +makeClientSettings + :: [Credential] -- ^Credentials to provide to the server, if requested. + -- The first one is used in case we can't choose one + -- based on information provided by the server. + -> Maybe NS.HostName -- ^Explicit Server Name Identification (SNI). + -> C.CertificateStore -- ^CAs used to verify the server certificate. + -- Use 'getSystemCertificateStore' to obtain + -- the operating system's defaults. + -> ClientSettings +makeClientSettings creds msni cStore = + ClientSettings . T.updateClientParams modClientParams + . modParamsCore + $ T.defaultParamsClient + where + modParamsCore p = p + { T.pConnectVersion = T.TLS10 + , T.pAllowedVersions = [T.TLS12, T.TLS11, T.TLS10] + , T.pCiphers = ciphers_AES_CBC ++ ciphers_RC4 + , T.pUseSession = True + , T.pCertificates = [] + , T.onCertificatesRecv = TE.certificateVerifyChain cStore } + modClientParams cp = cp + { T.onCertificateRequest = + return . maybe firstCerts credentialToCertList . findCredential + , T.clientUseServerName = msni } + + -- | Find the first Credential that matches the given requirements. + -- Currently, the only requirement considered is the subject DN. + findCredential (_, _, dns) = listToMaybe (filter isSubject creds) + where + isSubject (Credential c _ _) = X.certSubjectDN (X.x509Cert c) `elem` dns + + firstCerts = + case creds of + (c:_) -> credentialToCertList c + [] -> error "makeClientSettings:\ + \ no Credential given but server requested one" + + +-- | Update advanced TLS client configuration 'T.Params'. +-- See the "Network.TLS" module for details. +updateClientParams :: (T.Params -> T.Params) -> ClientSettings -> ClientSettings +updateClientParams f = ClientSettings . f . unClientSettings + +-- | A 'Control.Lens.Lens' into the TLS client configuration 'T.Params'. +-- See the "Network.TLS" and the @lens@ package for details. +clientParams :: Functor f => (T.Params -> f T.Params) + -> (ClientSettings -> f ClientSettings) +clientParams f = fmap ClientSettings . f . unClientSettings + +-------------------------------------------------------------------------------- +-- Server side TLS settings + +-- | Abstract type representing the configuration settings for a TLS server. +-- +-- Use 'makeServerSettings' to obtain your 'ServerSettings' value, and +-- 'updateServerParams' to update it. +data ServerSettings = ServerSettings { unServerSettings :: T.Params } + +-- | Make default 'ServerSettings'. +-- +-- The following TLS settings are used by default: +-- +-- [Supported versions] 'T.TLS10', 'T.TLS11', 'T.TLS12'. +-- +-- [Supported cipher suites for 'T.TLS10'] +-- In decreasing order of preference: +-- 'TE.cipher_AES256_SHA256', +-- 'TE.cipher_AES256_SHA1', +-- 'TE.cipher_AES128_SHA256', +-- 'TE.cipher_AES128_SHA1', +-- 'TE.cipher_RC4_128_SHA1', +-- 'TE.cipher_RC4_128_MD5'. +-- The cipher suite preferred by the client is used. +-- +-- [Supported cipher suites for 'T.TLS11' and 'T.TLS12'] +-- In decreasing order of preference: +-- 'TE.cipher_AES256_SHA256', +-- 'TE.cipher_AES256_SHA1', +-- 'TE.cipher_AES128_SHA256', +-- 'TE.cipher_AES128_SHA1'. +-- The cipher suite preferred by the client is used. +makeServerSettings + :: Credential -- ^Server credential. + -> Maybe C.CertificateStore -- ^CAs used to verify the client certificate. If + -- specified, then a valid client certificate will + -- be expected during on handshake. + -> ServerSettings +makeServerSettings creds mcStore = + ServerSettings . T.updateServerParams modServerParams + . modParamsCore + $ T.defaultParamsServer + where + modParamsCore p = p + { T.pConnectVersion = T.TLS10 + , T.pAllowedVersions = [T.TLS12, T.TLS11, T.TLS10] + , T.pCiphers = ciphers_AES_CBC ++ ciphers_RC4 + , T.pUseSession = True + , T.pCertificates = credentialToCertList creds } + modServerParams sp = sp + { T.serverWantClientCert = maybe False (const True) mcStore + , T.onClientCertificate = clientCertsCheck + , T.onCipherChoosing = chooseCipher + , T.serverCACertificates = maybe [] C.listCertificates mcStore } + clientCertsCheck certs = case mcStore of + Nothing -> return T.CertificateUsageAccept + Just cs -> TE.certificateVerifyChain cs certs + -- | Ciphers prefered by the client take precedence. + chooseCipher v cCiphs = head (intersect cCiphs (preferredCiphers v)) + +-- | Update advanced TLS server configuration 'T.Params'. +-- See the "Network.TLS" module for details. +updateServerParams :: (T.Params -> T.Params) -> ServerSettings -> ServerSettings +updateServerParams f = ServerSettings . f . unServerSettings + +-- | A 'Control.Lens.Lens' into the TLS server configuration 'T.Params'. +-- See the "Network.TLS" and the @lens@ package for details. +serverParams :: Functor f => (T.Params -> f T.Params) + -> (ServerSettings -> f ServerSettings) +serverParams f = fmap ServerSettings . f . unServerSettings + +-------------------------------------------------------------------------------- + +-- | Start a TLS-secured TCP server that accepts incoming connections and +-- handles each of them concurrently, in different threads. +-- +-- Any acquired network resources are properly closed and discarded when done or +-- in case of exceptions. This function binds a listening socket, accepts an +-- incoming connection, performs a TLS handshake and then safely closes the +-- connection when done or in case of exceptions. You don't need to perform any +-- of those steps manually. +serve + :: ServerSettings -- ^TLS settings. + -> S.HostPreference -- ^Preferred host to bind. + -> NS.ServiceName -- ^Service port to bind. + -> ((T.Context, NS.SockAddr) -> IO ()) + -- ^Computation to run in a different thread + -- once an incomming connection is accepted and a + -- TLS-secured communication is established. Takes the + -- TLS connection context and remote end address. + -> IO () +serve ss hp port k = + S.listen hp port $ \(lsock,_) -> do + forever $ acceptFork ss lsock k + +-------------------------------------------------------------------------------- + +-- | Accepts a single incomming TLS-secured TCP connection and use it. +-- +-- A TLS handshake is performed immediately after establishing the TCP +-- connection. +-- +-- The connection is properly closed when done or in case of exceptions. If you +-- need to manage the lifetime of the connection resources yourself, then use +-- 'acceptTls' instead. +accept + :: ServerSettings -- ^TLS settings. + -> NS.Socket -- ^Listening and bound socket. + -> ((T.Context, NS.SockAddr) -> IO b) + -- ^Computation to run in a different thread + -- once an incomming connection is accepted and a + -- TLS-secured communication is established. Takes the + -- TLS connection context and remote end address. + -> IO b +accept ss lsock k = E.bracket (acceptTls ss lsock) + (contextCloseNoVanish . fst) + (useTls k) + +-- | Like 'accept', except it uses a different thread to performs the TLS +-- handshake and run the given computation. +acceptFork + :: ServerSettings -- ^TLS settings. + -> NS.Socket -- ^Listening and bound socket. + -> ((T.Context, NS.SockAddr) -> IO ()) + -- ^Computation to run in a different thread + -- once an incomming connection is accepted and a + -- TLS-secured communication is established. Takes the + -- TLS connection context and remote end address. + -> IO ThreadId +acceptFork ss lsock k = E.bracketOnError (acceptTls ss lsock) + (contextCloseNoVanish . fst) + (useTlsThenCloseFork k) + +-------------------------------------------------------------------------------- + +-- | Connect to a TLS-secured TCP server and use the connection +-- +-- A TLS handshake is performed immediately after establishing the TCP +-- connection. +-- +-- The connection is properly closed when done or in case of exceptions. If you +-- need to manage the lifetime of the connection resources yourself, then use +-- 'connectTls' instead. +connect + :: ClientSettings -- ^TLS settings. + -> NS.HostName -- ^Server hostname. + -> NS.ServiceName -- ^Server service port. + -> ((T.Context, NS.SockAddr) -> IO r) + -- ^Computation to run after establishing TLS-secured + -- TCP connection to the remote server. Takes the TLS + -- connection context and remote end address. + -> IO r +connect cs host port k = E.bracket (connectTls cs host port) + (contextCloseNoVanish . fst) + (useTls k) + +-------------------------------------------------------------------------------- + +-- | Estalbishes a TCP connection to a remote server and returns a TLS +-- 'T.Context' configured on top of it using the given 'ClientSettings'. +-- The remote end address is also returned. +-- +-- Prefer to use 'connect' if you will be used the obtained 'T.Context' within a +-- limited scope. +-- +-- You need to call 'T.handshake' on the resulting 'T.Context' before using it +-- for communication purposes, and 'T.bye' afterwards. The 'useTls' or +-- 'useTlsThenCloseFork' functions can perform those steps for you. +connectTls :: ClientSettings -> NS.HostName -> NS.ServiceName + -> IO (T.Context, NS.SockAddr) +connectTls (ClientSettings params) host port = do + (csock, caddr) <- S.connectSock host port + (`E.onException` NS.sClose csock) $ do + h <- NS.socketToHandle csock ReadWriteMode + ctx <- T.contextNewOnHandle h params' =<< getSystemRandomGen + return (ctx, caddr) + where + params' = params { T.onCertificatesRecv = TE.certificateChecks certsCheck } + certsCheck = [T.onCertificatesRecv params, return . checkHost] + checkHost = + let T.Client cparams = T.roleParams params in + case T.clientUseServerName cparams of + Nothing -> TE.certificateVerifyDomain host + Just sni -> TE.certificateVerifyDomain sni + +-- | Accepts an incoming TCP connection and returns a TLS 'T.Context' configured +-- on top of it using the given 'ServerSettings'. The remote end address is also +-- returned. +-- +-- Prefer to use 'accept' if you will be used the obtained 'T.Context' within a +-- limited scope. +-- +-- You need to call 'T.handshake' on the resulting 'T.Context' before using it +-- for communication purposes, and 'T.bye' afterwards. The 'useTls' or +-- 'useTlsThenCloseFork' functions can perform those steps for you. +acceptTls :: ServerSettings -> NS.Socket -> IO (T.Context, NS.SockAddr) +acceptTls (ServerSettings params) lsock = do + (csock, caddr) <- NS.accept lsock + (`E.onException` NS.sClose csock) $ do + h <- NS.socketToHandle csock ReadWriteMode + ctx <- T.contextNewOnHandle h params =<< getSystemRandomGen + return (ctx, caddr) + +-- | Perform a TLS 'T.handshake' on the given 'T.Context', then perform the +-- given action and at last say 'T.bye', even in case of exceptions. +-- +-- This function discards 'Eg.ResourceVanished' exceptions that will happen when +-- trying to say 'T.bye' if the remote end has done it before. +useTls :: ((T.Context, NS.SockAddr) -> IO a) -> (T.Context, NS.SockAddr) -> IO a +useTls k conn@(ctx,_) = E.bracket_ (T.handshake ctx) (byeNoVanish ctx) (k conn) + +-- | Similar to 'useTls', except it performs the all the IO actions safely in a +-- new thread and closes the connection backend after using it. Use this instead +-- of forking `useTls` yourself. +-- +-- This function discards 'Eg.ResourceVanished' exceptions that will happen when +-- trying to close the connection backend if the remote end has done it before. +useTlsThenCloseFork :: ((T.Context, NS.SockAddr) -> IO ()) + -> (T.Context, NS.SockAddr) -> IO ThreadId +useTlsThenCloseFork k conn@(ctx,_) = do + forkFinally (E.bracket_ (T.handshake ctx) (byeNoVanish ctx) (k conn)) + (\e1 -> do + e2 <- E.try $ contextCloseNoVanish ctx + -- in case both e1 and e2 hold exceptions, we throw e1. + case (e1,e2) of + (Left e, _) -> E.throwIO e + (_, Left e) -> E.throwIO (e :: E.SomeException) + _ -> return ()) + +-------------------------------------------------------------------------------- +-- Utils + +-- | Receives decrypted bytes from the given 'T.Context'. Returns 'Nothing' +-- on EOF. +-- +-- Up to @16384@ decrypted bytes will be received at once. The TLS connection is +-- automatically renegotiated if a /ClientHello/ message is received. +recv :: T.Context -> IO (Maybe B.ByteString) +recv ctx = + E.handle (\T.Error_EOF -> return Nothing) + (do bs <- T.recvData ctx + if B.null bs + then return Nothing -- I think this never happens + else return (Just bs)) +{-# INLINABLE recv #-} + +-- | Encrypts the given strict 'B.ByteString' and sends it through the +-- 'T.Context'. +send :: T.Context -> B.ByteString -> IO () +send ctx bs = T.sendData ctx (BL.fromChunks [bs]) +{-# INLINABLE send #-} + +-------------------------------------------------------------------------------- +-- Internal: Default ciphers + +ciphers_RC4 :: [T.Cipher] +ciphers_RC4 = [ TE.cipher_RC4_128_SHA1 + , TE.cipher_RC4_128_MD5 ] + +ciphers_AES_CBC :: [T.Cipher] +ciphers_AES_CBC = [ TE.cipher_AES256_SHA256 + , TE.cipher_AES256_SHA1 + , TE.cipher_AES128_SHA256 + , TE.cipher_AES128_SHA1 ] + +preferredCiphers :: T.Version -> [T.Cipher] +preferredCiphers T.TLS12 = ciphers_AES_CBC +preferredCiphers T.TLS11 = ciphers_AES_CBC +preferredCiphers T.TLS10 = ciphers_AES_CBC ++ ciphers_RC4 +preferredCiphers v = error ("preferredCiphers: " ++ show v ++ " not supported") + +-------------------------------------------------------------------------------- +-- Internal utils + +-- | Like 'T.bye', except it ignores 'Eg.ResourceVanished' exceptions. +byeNoVanish :: T.Context -> IO () +byeNoVanish ctx = + E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ()) + (T.bye ctx) + +-- | Like 'T.contextClose', except it ignores 'Eg.ResourceVanished' exceptions. +contextCloseNoVanish :: T.Context -> IO () +contextCloseNoVanish ctx = + E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ()) + (T.contextClose ctx) + +-- | 'Control.Concurrent.forkFinally' was introduced in base==4.6.0.0. We'll use +-- our own version here for a while, until base==4.6.0.0 is widely establised. +forkFinally :: IO a -> (Either E.SomeException a -> IO ()) -> IO ThreadId +forkFinally action and_then = + E.mask $ \restore -> + forkIO $ E.try (restore action) >>= and_then