@@ -28,7 +28,7 @@ module Network.Wai.Handler.WarpTLS (
2828import qualified Network.TLS as TLS
2929import Network.Wai.Handler.Warp
3030import Network.Wai (Application)
31−import Network.Socket (Socket, sClose, withSocketsDo)
31+import Network.Socket (Socket, sClose, withSocketsDo, SockAddr)
3232import qualified Data.ByteString.Lazy as L
3333import Control.Exception (bracket, finally, handle, fromException, try, IOException)
3434import qualified Network.TLS.Extra as TLSExtra
@@ -47,169 +47,76 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize)
4747import qualified System.IO as IO
4848import System.IO.Error (isEOFError)
4949
50−data TLSSettings = TLSSettings
51− { certFile :: FilePath
52− -- ^ File containing the certificate.
53− , keyFile :: FilePath
54− -- ^ File containing the key
55− , onInsecure :: OnInsecure
56− -- ^ Do we allow insecure connections with this server as well? Default
57− -- is a simple text response stating that a secure connection is required.
58− --
59− -- Since 1.4.0
60− , tlsLogging :: TLS.Logging
61− -- ^ The level of logging to turn on.
62− --
63− -- Default: 'TLS.defaultLogging'.
64− --
65− -- Since 1.4.0
66− , tlsAllowedVersions :: [TLS.Version]
67− -- ^ The TLS versions this server accepts.
68− --
69− -- Default: '[TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]'.
70− --
71− -- Since 1.4.2
72− , tlsCiphers :: [TLS.Cipher]
73− -- ^ The TLS ciphers this server accepts.
74− --
75− -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSExtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'
76− --
77− -- Since 1.4.2
78− }
50+----------------------------------------------------------------
51+
52+data TLSSettings = TLSSettings {
53+ certFile :: FilePath
54+ -- ^ File containing the certificate.
55+ , keyFile :: FilePath
56+ -- ^ File containing the key
57+ , onInsecure :: OnInsecure
58+ -- ^ Do we allow insecure connections with this server as well? Default
59+ -- is a simple text response stating that a secure connection is required.
60+ --
61+ -- Since 1.4.0
62+ , tlsLogging :: TLS.Logging
63+ -- ^ The level of logging to turn on.
64+ --
65+ -- Default: 'TLS.defaultLogging'.
66+ --
67+ -- Since 1.4.0
68+ , tlsAllowedVersions :: [TLS.Version]
69+ -- ^ The TLS versions this server accepts.
70+ --
71+ -- Default: '[TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]'.
72+ --
73+ -- Since 1.4.2
74+ , tlsCiphers :: [TLS.Cipher]
75+ -- ^ The TLS ciphers this server accepts.
76+ --
77+ -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'
78+ --
79+ -- Since 1.4.2
80+ }
81+
82+-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.
83+defaultTlsSettings :: TLSSettings
84+defaultTlsSettings = TLSSettings {
85+ certFile = "certificate.pem"
86+ , keyFile = "key.pem"
87+ , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
88+ , tlsLogging = def
89+ , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]
90+ , tlsCiphers = ciphers
91+ }
92+
93+-- taken from stunnel example in tls-extra
94+ciphers :: [TLS.Cipher]
95+ciphers =
96+ [ TLSExtra.cipher_AES128_SHA1
97+ , TLSExtra.cipher_AES256_SHA1
98+ , TLSExtra.cipher_RC4_128_MD5
99+ , TLSExtra.cipher_RC4_128_SHA1
100+ ]
101+
102+----------------------------------------------------------------
79103
80104-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
81105data OnInsecure = DenyInsecure L.ByteString
82106 | AllowInsecure
83107
108+----------------------------------------------------------------
109+
84110-- | A smart constructor for 'TLSSettings'.
85111tlsSettings :: FilePath -- ^ Certificate file
86112 -> FilePath -- ^ Key file
87113 -> TLSSettings
88−tlsSettings cert key = defaultTlsSettings
89− { certFile = cert
90− , keyFile = key
91− }
114+tlsSettings cert key = defaultTlsSettings {
115+ certFile = cert
116+ , keyFile = key
117+ }
92118
93−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.
94−defaultTlsSettings :: TLSSettings
95−defaultTlsSettings = TLSSettings
96− { certFile = "certificate.pem"
97− , keyFile = "key.pem"
98− , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
99− , tlsLogging = def
100− , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]
101− , tlsCiphers = ciphers
102− }
103−
104−-- | Running 'Application' with 'TLSSettings' and 'Settings' using
105−-- specified 'Socket'.
106−runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
107−runTLSSocket TLSSettings {..} set sock app = do
108− credential <- either error id <$> TLS.credentialLoadX509 certFile keyFile
109− let params = def
110− { TLS.serverWantClientCert = False
111− , TLS.serverSupported = def
112− { TLS.supportedVersions = tlsAllowedVersions
113− , TLS.supportedCiphers = tlsCiphers
114− }
115− , TLS.serverShared = def
116− { TLS.sharedCredentials = TLS.Credentials [credential]
117− }
118− }
119− runSettingsConnectionMakerSecure set (getter params) app
120− where
121− getter params = do
122− (s, sa) <- acceptSafe sock
123− let mkConn :: IO (Connection, Bool)
124− mkConn = do
125− firstBS <- safeRecv s 4096
126− cachedRef <- I.newIORef firstBS
127− let getNext size = do
128− cached <- I.readIORef cachedRef
129− loop cached
130− where
131− loop bs | B.length bs >= size = do
132− let (x, y) = B.splitAt size bs
133− I.writeIORef cachedRef y
134− return x
135− loop bs1 = do
136− bs2 <- safeRecv s 4096
137− if B.null bs2
138− then do
139− -- FIXME does this deserve an exception being thrown?
140− I.writeIORef cachedRef B.empty
141− return bs1
142− else loop $ B.append bs1 bs2
143− if not (B.null firstBS) && B.head firstBS == 0x16
144− then do
145− gen <- Crypto.Random.AESCtr.makeSystem
146− ctx <- TLS.contextNew
147− TLS.Backend
148− { TLS.backendFlush = return ()
149− , TLS.backendClose = sClose s
150− , TLS.backendSend = sendAll s
151− , TLS.backendRecv = getNext
152− }
153− params
154− gen
155− TLS.contextHookSetLogging ctx tlsLogging
156− TLS.handshake ctx
157− readBuf <- allocateBuffer bufferSize
158− writeBuf <- allocateBuffer bufferSize
159− let conn = Connection
160− { connSendMany = TLS.sendData ctx . L.fromChunks
161− , connSendAll = TLS.sendData ctx . L.fromChunks . return
162− , connSendFile = \fp offset len _th headers -> do
163− TLS.sendData ctx $ L.fromChunks headers
164− IO.withBinaryFile fp IO.ReadMode $ \h -> do
165− IO.hSeek h IO.AbsoluteSeek offset
166− let loop remaining | remaining <= 0 = return ()
167− loop remaining = do
168− bs <- B.hGetSome h defaultChunkSize
169− unless (B.null bs) $ do
170− let x = B.take remaining bs
171− TLS.sendData ctx $ L.fromChunks [x]
172− loop $ remaining - B.length x
173− loop $ fromIntegral len
174− , connClose =
175− freeBuffer readBuf `finally`
176− freeBuffer writeBuf `finally`
177− void (tryIO $ TLS.bye ctx) `finally`
178− TLS.contextClose ctx
179− , connRecv =
180− let onEOF e
181− | Just TLS.Error_EOF <- fromException e = return B.empty
182− | Just ioe <- fromException e, isEOFError ioe = return B.empty
183− | otherwise = throwIO e
184− go = do
185− x <- TLS.recvData ctx
186− if B.null x
187− then go
188− else return x
189− in handle onEOF go
190− , connSendFileOverride = NotOverride
191− , connReadBuffer = readBuf
192− , connWriteBuffer = writeBuf
193− , connBufferSize = bufferSize
194− }
195− return (conn, True)
196− else
197− case onInsecure of
198− AllowInsecure -> do
199− conn' <- socketConnection s
200− return (conn'
201− { connRecv = getNext 4096
202− }, False)
203− DenyInsecure lbs -> do
204− sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
205− mapM_ (sendAll s) $ L.toChunks lbs
206− sClose s
207− throwIO InsecureConnectionDenied
208− return (mkConn, sa)
209−
210−data WarpTLSException = InsecureConnectionDenied
211− deriving (Show, Typeable)
212−instance Exception WarpTLSException
119+----------------------------------------------------------------
213120
214121-- | Running 'Application' with 'TLSSettings' and 'Settings'.
215122runTLS :: TLSSettings -> Settings -> Application -> IO ()
@@ -219,14 +126,146 @@ runTLS tset set app = withSocketsDo $
219126 sClose
220127 (\sock -> runTLSSocket tset set sock app)
221128
222−-- taken from stunnel example in tls-extra
223−ciphers :: [TLS.Cipher]
224−ciphers =
225− [ TLSExtra.cipher_AES128_SHA1
226− , TLSExtra.cipher_AES256_SHA1
227− , TLSExtra.cipher_RC4_128_MD5
228− , TLSExtra.cipher_RC4_128_SHA1
229− ]
129+----------------------------------------------------------------
130+
131+-- | Running 'Application' with 'TLSSettings' and 'Settings' using
132+-- specified 'Socket'.
133+runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
134+runTLSSocket tlsset@TLSSettings{..} set sock app = do
135+ credential <- either error id <$> TLS.credentialLoadX509 certFile keyFile
136+ runTLSSocket' tlsset set credential sock app
137+
138+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()
139+runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
140+ runSettingsConnectionMakerSecure set get app
141+ where
142+ get = getter tlsset sock params
143+ params = def {
144+ TLS.serverWantClientCert = False
145+ , TLS.serverSupported = def {
146+ TLS.supportedVersions = tlsAllowedVersions
147+ , TLS.supportedCiphers = tlsCiphers
148+ }
149+ , TLS.serverShared = def {
150+ TLS.sharedCredentials = TLS.Credentials [credential]
151+ }
152+ }
153+
154+----------------------------------------------------------------
155+
156+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Bool), SockAddr)
157+getter tlsset@TLSSettings{..} sock params = do
158+ (s, sa) <- acceptSafe sock
159+ return (mkConn tlsset s params, sa)
160+
161+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Bool)
162+mkConn tlsset s params = do
163+ firstBS <- safeRecv s 4096
164+ cachedRef <- I.newIORef firstBS
165+ if not (B.null firstBS) && B.head firstBS == 0x16 then
166+ httpOverTls tlsset s cachedRef params
167+ else
168+ plainHTTP tlsset s cachedRef
169+
170+----------------------------------------------------------------
171+
172+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Bool)
173+httpOverTls TLSSettings{..} s cachedRef params = do
174+ gen <- Crypto.Random.AESCtr.makeSystem
175+ ctx <- TLS.contextNew backend params gen
176+ TLS.contextHookSetLogging ctx tlsLogging
177+ TLS.handshake ctx
178+ readBuf <- allocateBuffer bufferSize
179+ writeBuf <- allocateBuffer bufferSize
180+ return (conn ctx readBuf writeBuf, True)
181+ where
182+ backend = TLS.Backend {
183+ TLS.backendFlush = return ()
184+ , TLS.backendClose = sClose s
185+ , TLS.backendSend = sendAll s
186+ , TLS.backendRecv = getNext cachedRef s
187+ }
188+ conn ctx readBuf writeBuf = Connection {
189+ connSendMany = TLS.sendData ctx . L.fromChunks
190+ , connSendAll = TLS.sendData ctx . L.fromChunks . return
191+ , connSendFile = sendfile
192+ , connClose = close
193+ , connRecv = recv
194+ , connSendFileOverride = NotOverride
195+ , connReadBuffer = readBuf
196+ , connWriteBuffer = writeBuf
197+ , connBufferSize = bufferSize
198+ }
199+ where
200+ sendfile fp offset len _th headers = do
201+ TLS.sendData ctx $ L.fromChunks headers
202+ IO.withBinaryFile fp IO.ReadMode $ \h -> do
203+ IO.hSeek h IO.AbsoluteSeek offset
204+ loop h $ fromIntegral len
205+ where
206+ loop _ remaining | remaining <= 0 = return ()
207+ loop h remaining = do
208+ bs <- B.hGetSome h defaultChunkSize
209+ unless (B.null bs) $ do
210+ let x = B.take remaining bs
211+ TLS.sendData ctx $ L.fromChunks [x]
212+ loop h $ remaining - B.length x
213+
214+ close = freeBuffer readBuf `finally`
215+ freeBuffer writeBuf `finally`
216+ void (tryIO $ TLS.bye ctx) `finally`
217+ TLS.contextClose ctx
218+
219+ recv = handle onEOF go
220+ where
221+ onEOF e
222+ | Just TLS.Error_EOF <- fromException e = return B.empty
223+ | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e
224+ go = do
225+ x <- TLS.recvData ctx
226+ if B.null x then
227+ go
228+ else
229+ return x
230230
231231tryIO :: IO a -> IO (Either IOException a)
232232tryIO = try
233+
234+----------------------------------------------------------------
235+
236+plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Bool)
237+plainHTTP TLSSettings{..} s cachedRef = case onInsecure of
238+ AllowInsecure -> do
239+ conn' <- socketConnection s
240+ return (conn' { connRecv = getNext cachedRef s 4096 }, False)
241+ DenyInsecure lbs -> do
242+ sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
243+ mapM_ (sendAll s) $ L.toChunks lbs
244+ sClose s
245+ throwIO InsecureConnectionDenied
246+
247+----------------------------------------------------------------
248+
249+getNext :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString
250+getNext cachedRef s size = do
251+ cached <- I.readIORef cachedRef
252+ loop cached
253+ where
254+ loop bs | B.length bs >= size = do
255+ let (x, y) = B.splitAt size bs
256+ I.writeIORef cachedRef y
257+ return x
258+ loop bs1 = do
259+ bs2 <- safeRecv s 4096
260+ if B.null bs2 then do
261+ -- FIXME does this deserve an exception being thrown?
262+ I.writeIORef cachedRef B.empty
263+ return bs1
264+ else
265+ loop $ B.append bs1 bs2
266+
267+----------------------------------------------------------------
268+
269+data WarpTLSException = InsecureConnectionDenied
270+ deriving (Show, Typeable)
271+instance Exception WarpTLSException