diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Suite Solutions. 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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/Network/Wai/Handler/WarpTLS.hs b/Network/Wai/Handler/WarpTLS.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/WarpTLS.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Handler.WarpTLS + ( TLSSettings (..) + , runTLS + ) where + +import qualified Network.TLS as TLS +import Network.Wai.Handler.Warp +import Network.Wai +import Network.Socket +import System.IO +import Crypto.Random +import qualified Data.ByteString.Lazy as L +import Data.Conduit.Binary (sourceFileRange) +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import Control.Exception (bracket, handle, SomeException) +import qualified Network.TLS.Extra as TLSExtra +import qualified Data.Certificate.X509 as X509 +import qualified Data.Certificate.PEM as PEM +import qualified Data.ByteString as B +import Control.Monad (unless) +import qualified Data.Certificate.KeyRSA as KeyRSA +import Control.Applicative ((<$>)) + +data TLSSettings = TLSSettings + { certFile :: FilePath + , keyFile :: FilePath + } + +runTLS :: TLSSettings -> Settings -> Application -> IO () +runTLS tset set app = do + cert <- readCertificate $ certFile tset + pk <- readPrivateKey $ keyFile tset + let params = TLS.defaultParams + { TLS.pWantClientCert = False + , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] + , TLS.pCiphers = ciphers + , TLS.pCertificates = [(cert, Just pk)] + } + bracket + (bindPort (settingsPort set) (settingsHost set)) + sClose + (\sock -> runSettingsConnection set (getter params sock) app) + where + retry :: TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr) + retry a b _ = getter a b + + getter params sock = do + (s, sa) <- accept sock + handle (retry params sock) $ do + h <- socketToHandle s ReadWriteMode + hSetBuffering h NoBuffering + gen <- newGenIO + ctx <- TLS.server params (gen :: SystemRandom) h + b <- TLS.handshake ctx + unless b $ error "Invalid handshake" + let conn = Connection + { connSendMany = TLS.sendData ctx . L.fromChunks + , connSendAll = TLS.sendData ctx . L.fromChunks . return + , connSendFile = \fp offset len _th -> C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return) + , connClose = do + TLS.bye ctx + hClose h + , connRecv = B.concat . L.toChunks <$> TLS.recvData ctx + } + return (conn, sa) + +-- taken from stunnel example in tls-extra +ciphers :: [TLS.Cipher] +ciphers = + [ TLSExtra.cipher_AES128_SHA1 + , TLSExtra.cipher_AES256_SHA1 + , TLSExtra.cipher_RC4_128_MD5 + , TLSExtra.cipher_RC4_128_SHA1 + ] + +readCertificate :: FilePath -> IO X509.X509 +readCertificate filepath = do + content <- B.readFile filepath + certdata <- + case PEM.parsePEMCert content of + Nothing -> error "no valid certificate section" + Just x -> return x + case X509.decodeCertificate $ L.fromChunks [certdata] of + Left err -> error ("cannot decode certificate: " ++ err) + Right x -> return x + +readPrivateKey :: FilePath -> IO TLS.PrivateKey +readPrivateKey filepath = do + content <- B.readFile filepath + pkdata <- + case PEM.parsePEMKeyRSA content of + Nothing -> error "no valid RSA key section" + Just x -> return (L.fromChunks [x]) + case KeyRSA.decodePrivate pkdata of + Left err -> error ("cannot decode key: " ++ err) + Right (_pub, x) -> return $ TLS.PrivRSA x diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/warp-tls.cabal b/warp-tls.cabal new file mode 100644 --- /dev/null +++ b/warp-tls.cabal @@ -0,0 +1,33 @@ +Name: warp-tls +Version: 1.0.0 +Synopsis: SSL support for Warp via the TLS package +License: BSD3 +License-file: LICENSE +Author: Michael Snoyman +Maintainer: michael@snoyman.com +Homepage: http://github.com/yesodweb/wai +Category: Web, Yesod +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: Stable +Description: SSL support for Warp via the TLS package + +Library + Build-Depends: base >= 4 && < 5 + , bytestring >= 0.9 && < 0.10 + , wai >= 1.0 && < 1.1 + , warp >= 1.0 && < 1.1 + , transformers >= 0.2 && < 0.3 + , conduit + , certificate >= 1.0.1 && < 1.1 + , cryptocipher >= 0.3 && < 0.4 + , tls-extra >= 0.4 && < 0.5 + , tls >= 0.8.1 && < 0.9 + , crypto-api >= 0.8 && < 0.9 + , network >= 2.2.1 && < 2.4 + Exposed-modules: Network.Wai.Handler.WarpTLS + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/yesodweb/wai.git