network-simple-tls (empty) → 0.1.0.0
raw patch · 8 files changed
+750/−0 lines, 8 filesdep +basedep +bytestringdep +certificatesetup-changed
Dependencies added: base, bytestring, certificate, crypto-random-api, network, network-simple, network-simple-tls, tls, tls-extra
Files
- LICENSE +30/−0
- PEOPLE +6/−0
- README.md +14/−0
- Setup.hs +2/−0
- examples/https-client.hs +99/−0
- examples/tls-echo.hs +92/−0
- network-simple-tls.cabal +57/−0
- src/Network/Simple/TCP/TLS.hs +450/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Renzo Carbonara <renzocarbonaraλgmail.com>++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.
+ PEOPLE view
@@ -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
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/https-client.hs view
@@ -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 }+
+ examples/tls-echo.hs view
@@ -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 }+
+ network-simple-tls.cabal view
@@ -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+
+ src/Network/Simple/TCP/TLS.hs view
@@ -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