@@ -0,0 +1,114 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Handler.WarpTLS
3+ ( TLSSettings (..)
4+ , runTLS
5+ ) where
6+
7+import qualified Network.TLS as TLS
8+import Network.Wai.Handler.Warp
9+import Network.Wai
10+import Network.Socket
11+import System.IO
12+import Crypto.Random
13+import qualified Data.ByteString.Lazy as L
14+import Data.Conduit.Binary (sourceFileRange)
15+import qualified Data.Conduit as C
16+import qualified Data.Conduit.List as CL
17+import Control.Monad.IO.Class (liftIO)
18+import Control.Exception (bracket, handle, SomeException)
19+import qualified Network.TLS.Extra as TLSExtra
20+import qualified Data.Certificate.X509 as X509
21+import qualified Data.Certificate.PEM as PEM
22+import qualified Data.ByteString as B
23+import Control.Monad (unless)
24+import qualified Data.Certificate.KeyRSA as KeyRSA
25+
26+data TLSSettings = TLSSettings
27+ { certFile :: FilePath
28+ , keyFile :: FilePath
29+ }
30+
31+runTLS :: TLSSettings -> Settings -> Application -> IO ()
32+runTLS tset set app = do
33+ cert <- readCertificate $ certFile tset
34+ pk <- readPrivateKey $ keyFile tset
35+ let params = TLS.defaultParams
36+ { TLS.pWantClientCert = False
37+ , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]
38+ , TLS.pCiphers = ciphers
39+ , TLS.pCertificates = [(cert, Just pk)]
40+ }
41+ bracket
42+ (bindPort (settingsPort set) (settingsHost set))
43+ sClose
44+ (\sock -> runSettingsConnection set (getter params sock) app)
45+ where
46+ retry :: TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)
47+ retry a b _ = getter a b
48+
49+ getter params sock = do
50+ (s, sa) <- accept sock
51+ handle (retry params sock) $ do
52+ h <- socketToHandle s ReadWriteMode
53+ hSetBuffering h NoBuffering
54+ gen <- newGenIO
55+ ctx <- TLS.server params (gen :: SystemRandom) h
56+ b <- TLS.handshake ctx
57+ unless b $ error "Invalid handshake"
58+ let sink = C.Sink $ return $ C.SinkData
59+ { C.sinkPush = \bs -> do
60+ liftIO $ TLS.sendData ctx $ L.fromChunks [bs]
61+ return C.Processing
62+ , C.sinkClose = return ()
63+ }
64+ let conn = Connection
65+ { connSendMany = TLS.sendData ctx . L.fromChunks
66+ , connSendAll = TLS.sendData ctx . L.fromChunks . return
67+ , connSendFile = \fp offset len _th -> C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)
68+ , connSink = \_th -> sink
69+ , connClose = do
70+ TLS.bye ctx
71+ hClose h
72+ , connSource = \_th -> C.sourceState []
73+ (\buffer ->
74+ case buffer of
75+ (bs:bss) -> return (bss, C.Open bs)
76+ [] -> do
77+ lbs <- TLS.recvData ctx
78+ if L.null lbs
79+ then return (undefined, C.Closed)
80+ else let (bs:bss) = L.toChunks lbs
81+ in return (bss, C.Open bs))
82+ }
83+ return (conn, sa)
84+
85+-- taken from stunnel example in tls-extra
86+ciphers :: [TLS.Cipher]
87+ciphers =
88+ [ TLSExtra.cipher_AES128_SHA1
89+ , TLSExtra.cipher_AES256_SHA1
90+ , TLSExtra.cipher_RC4_128_MD5
91+ , TLSExtra.cipher_RC4_128_SHA1
92+ ]
93+
94+readCertificate :: FilePath -> IO X509.X509
95+readCertificate filepath = do
96+ content <- B.readFile filepath
97+ certdata <-
98+ case PEM.parsePEMCert content of
99+ Nothing -> error "no valid certificate section"
100+ Just x -> return x
101+ case X509.decodeCertificate $ L.fromChunks [certdata] of
102+ Left err -> error ("cannot decode certificate: " ++ err)
103+ Right x -> return x
104+
105+readPrivateKey :: FilePath -> IO TLS.PrivateKey
106+readPrivateKey filepath = do
107+ content <- B.readFile filepath
108+ pkdata <-
109+ case PEM.parsePEMKeyRSA content of
110+ Nothing -> error "no valid RSA key section"
111+ Just x -> return (L.fromChunks [x])
112+ case KeyRSA.decodePrivate pkdata of
113+ Left err -> error ("cannot decode key: " ++ err)
114+ Right (_pub, x) -> return $ TLS.PrivRSA x