diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for metro-transport-xor + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Lupino (c) 2020 + +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 Lupino 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# metro-transport-tls + +TLS transport for metro 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/metro-transport-tls.cabal b/metro-transport-tls.cabal new file mode 100644 --- /dev/null +++ b/metro-transport-tls.cabal @@ -0,0 +1,48 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4800ce3a672404ff6894c0407fa75e3d83ebb0d5c936fd2d651342365244eebb + +name: metro-transport-tls +version: 0.1.0.0 +synopsis: TLS transport for metro +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/Lupino/metro#readme +bug-reports: https://github.com/Lupino/metro/issues +author: Lupino +maintainer: lmjubuntu@gmail.com +copyright: MIT +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/Lupino/metro + +library + exposed-modules: + Metro.TP.TLS + Metro.TP.TLSSetting + other-modules: + Paths_metro_transport_tls + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , data-default-class + , metro + , pem + , tls + , x509 + , x509-store + , x509-validation + default-language: Haskell2010 diff --git a/src/Metro/TP/TLS.hs b/src/Metro/TP/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Metro/TP/TLS.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module provides convenience functions for interfacing @tls@. +-- +-- This module is intended to be imported @qualified@, e.g.: +-- +module Metro.TP.TLS + ( TLS + -- * re-export + , module Metro.TP.TLSSetting + , tlsConfig + ) where + +import Control.Exception (SomeException, bracketOnError, catch) +import qualified Data.ByteString.Char8 as B (append, length, null) +import qualified Data.ByteString.Lazy as BL (fromStrict) +import Metro.Class (Transport (..)) +import Metro.TP.TLSSetting +import Network.TLS (Context, TLSParams) +import qualified Network.TLS as TLS + + +newtype TLS = TLS Context + +instance Transport TLS where + data TransportConfig TLS = forall params tp. (Transport tp, TLSParams params) => TLSConfig params (TransportConfig tp) + + -- | Convenience function for initiating an TLS transport + -- + -- This operation may throw 'TLS.TLSException' on failure. + -- + newTransport (TLSConfig params config) = do + transport <- newTransport config + bracketOnError (TLS.contextNew (transportBackend transport) params) closeTLS $ \ctx -> do + TLS.handshake ctx + return $ TLS ctx + + recvData (TLS ctx) = const $ TLS.recvData ctx + sendData (TLS ctx) = TLS.sendData ctx . BL.fromStrict + closeTransport (TLS ctx) = closeTLS ctx + +transportBackend :: Transport tp => tp -> TLS.Backend +transportBackend transport = TLS.Backend + { TLS.backendFlush = return () + , TLS.backendClose = closeTransport transport + , TLS.backendSend = sendData transport + , TLS.backendRecv = recvData' + } + + where recvData' nbytes = do + s <- recvData transport nbytes + if loadMore nbytes s then do + s' <- recvData' (nbytes - B.length s) + return $ s `B.append` s' + else return s + + loadMore nbytes bs | B.null bs = False + | B.length bs < nbytes = True + | otherwise = False + + +-- | Close a TLS 'Context' and its underlying socket. +-- +closeTLS :: Context -> IO () +closeTLS ctx = (TLS.bye ctx >> TLS.contextClose ctx) -- sometimes socket was closed before 'TLS.bye' + `catch` (\(_::SomeException) -> return ()) -- so we catch the 'Broken pipe' error here + + +tlsConfig :: (Transport tp, TLSParams params) => params -> TransportConfig tp -> TransportConfig TLS +tlsConfig = TLSConfig diff --git a/src/Metro/TP/TLSSetting.hs b/src/Metro/TP/TLSSetting.hs new file mode 100644 --- /dev/null +++ b/src/Metro/TP/TLSSetting.hs @@ -0,0 +1,137 @@ +-- | Helpers for setting up a tls connection with @tls@ package, +-- for further customization, please refer to @tls@ package. +-- +-- Note, functions in this module will throw error if can't load certificates or CA store. +-- +module Metro.TP.TLSSetting + ( + -- * Make TLS settings + makeClientParams + , makeClientParams' + , makeServerParams + , makeServerParams' + ) where + +import qualified Data.ByteString as B (empty, readFile) +import Data.Default.Class (def) +import qualified Data.PEM as X509 (pemContent, pemParseBS) +import qualified Data.X509 as X509 (CertificateChain (..), + HashALG (..), + decodeSignedCertificate) +import qualified Data.X509.CertificateStore as X509 (CertificateStore, + makeCertificateStore) +import qualified Data.X509.Validation as X509 (ServiceID, checkFQHN, + validate) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS (ciphersuite_strong) + + + +makeCAStore :: FilePath -> IO X509.CertificateStore +makeCAStore fp = do + bs <- B.readFile fp + let Right pems = X509.pemParseBS bs + case mapM (X509.decodeSignedCertificate . X509.pemContent) pems of + Right cas -> return (X509.makeCertificateStore cas) + Left err -> error err + +-- | make a simple tls 'TLS.ClientParams' that will validate server and use tls connection +-- without providing client's own certificate. suitable for connecting server which don't +-- validate clients. +-- +-- we defer setting of 'TLS.clientServerIdentification' to connecting phase. +-- +-- Note, tls's default validating method require server has v3 certificate. +-- you can use openssl's V3 extension to issue such a certificate. or change 'TLS.ClientParams' +-- before connecting. +-- +makeClientParams :: FilePath -- ^ trusted certificates. + -> X509.ServiceID + -> IO TLS.ClientParams +makeClientParams tca servid = do + caStore <- makeCAStore tca + return (TLS.defaultParamsClient "" B.empty) + { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_strong } + , TLS.clientServerIdentification = servid + , TLS.clientShared = def + { TLS.sharedCAStore = caStore + , TLS.sharedValidationCache = def + } + } + +-- | make a simple tls 'TLS.ClientParams' that will validate server and use tls connection +-- while providing client's own certificate as well. suitable for connecting server which +-- validate clients. +-- +-- Also only accept v3 certificate. +-- +makeClientParams' :: FilePath -- ^ public certificate (X.509 format). + -> [FilePath] -- ^ chain certificates (X.509 format). + -- the root of your certificate chain should be + -- already trusted by server, or tls will fail. + -> FilePath -- ^ private key associated. + -> FilePath -- ^ trusted certificates. + -> X509.ServiceID + -> IO TLS.ClientParams +makeClientParams' pub certs priv tca servid = do + p <- makeClientParams tca servid + c <- TLS.credentialLoadX509Chain pub certs priv + case c of + Right c' -> + return p + { TLS.clientShared = (TLS.clientShared p) + { + TLS.sharedCredentials = TLS.Credentials [c'] + } + , TLS.clientHooks = (TLS.clientHooks p) + { + TLS.onCertificateRequest = const . return $ Just c' + } + } + Left err -> error err + +-- | make a simple tls 'TLS.ServerParams' without validating client's certificate. +-- +makeServerParams :: FilePath -- ^ public certificate (X.509 format). + -> [FilePath] -- ^ chain certificates (X.509 format). + -- the root of your certificate chain should be + -- already trusted by client, or tls will fail. + -> FilePath -- ^ private key associated. + -> IO TLS.ServerParams +makeServerParams pub certs priv = do + c <- TLS.credentialLoadX509Chain pub certs priv + case c of + Right c'@(X509.CertificateChain c'', _) -> + return def + { TLS.serverCACertificates = c'' + , TLS.serverShared = def + { + TLS.sharedCredentials = TLS.Credentials [c'] + } + , TLS.serverSupported = def { TLS.supportedCiphers = TLS.ciphersuite_strong } + } + Left err -> error err + +-- | make a tls 'TLS.ServerParams' that also validating client's certificate. +-- +makeServerParams' :: FilePath -- ^ public certificate (X.509 format). + -> [FilePath] -- ^ chain certificates (X.509 format). + -> FilePath -- ^ private key associated. + -> FilePath -- ^ server will use these certificates to validate clients. + -> IO TLS.ServerParams +makeServerParams' pub certs priv tca = do + caStore <- makeCAStore tca + p <- makeServerParams pub certs priv + return p + { TLS.serverWantClientCert = True + , TLS.serverShared = (TLS.serverShared p) + { TLS.sharedCAStore = caStore + } + , TLS.serverHooks = def + { TLS.onClientCertificate = \chain -> do + errs <- X509.validate X509.HashSHA256 def (def { X509.checkFQHN = False }) caStore def ("", B.empty) chain + case errs of + [] -> return TLS.CertificateUsageAccept + xs -> return . TLS.CertificateUsageReject . TLS.CertificateRejectOther $ show xs + } + }