@@ -1,9 +1,17 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
35module Network.Wai.Handler.WarpTLS
4− ( TLSSettings (..)
6+ ( TLSSettings
7+ , certFile
8+ , keyFile
9+ , onInsecure
10+ , OnInsecure (..)
11+ , tlsSettings
512 , runTLS
613 , runTLSSocket
14+ , WarpTLSException (..)
715 ) where
816
917import qualified Network.TLS as TLS
@@ -28,16 +36,37 @@ import Data.Maybe (fromMaybe)
2836import qualified Data.IORef as I
2937import Control.Monad (unless)
3038import Crypto.Random.API (getSystemRandomGen)
39+import Control.Exception (Exception, throwIO)
40+import Data.Typeable (Typeable)
3141
3242data TLSSettings = TLSSettings
3343 { certFile :: FilePath
44+ -- ^ File containing the certificate.
3445 , keyFile :: FilePath
46+ -- ^ File containing the key
47+ , onInsecure :: OnInsecure
48+ -- ^ Do we allow insecure connections with this server as well? Default
49+ -- is a simple text response stating that a secure connection is required.
50+ --
51+ -- Since 1.4.0
52+ }
53+
54+data OnInsecure = DenyInsecure L.ByteString
55+ | AllowInsecure
56+
57+tlsSettings :: FilePath -- ^ Certificate file
58+ -> FilePath -- ^ key file
59+ -> TLSSettings
60+tlsSettings cert key = TLSSettings
61+ { certFile = cert
62+ , keyFile = key
63+ , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
3564 }
3665
3766runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
38−runTLSSocket tset set sock app = do
39− certs <- readCertificates $ certFile tset
40− pk <- readPrivateKey $ keyFile tset
67+runTLSSocket TLSSettings {..} set sock app = do
68+ certs <- readCertificates certFile
69+ pk <- readPrivateKey keyFile
4170 let params =
4271 TLS.updateServerParams
4372 (\sp -> sp { TLS.serverWantClientCert = False }) $
@@ -84,13 +113,26 @@ runTLSSocket tset set sock app = do
84113 , connRecv = TLS.recvData ctx
85114 }
86115 return conn
87− else do
88− let conn = (socketConnection s)
89− { connRecv = getNext $ fmap (fromMaybe B.empty) C.await
90− }
91− return conn
116+ else
117+ case onInsecure of
118+ AllowInsecure ->
119+ let conn = (socketConnection s)
120+ { connRecv = getNext $ fmap (fromMaybe B.empty) C.await
121+ }
122+ in return conn
123+ DenyInsecure lbs -> do
124+ let src = do
125+ C.yield "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
126+ mapM_ C.yield $ L.toChunks lbs
127+ src C.$$ sinkSocket s
128+ sClose s
129+ throwIO InsecureConnectionDenied
92130 return (mkConn, sa)
93131
132+data WarpTLSException = InsecureConnectionDenied
133+ deriving (Show, Typeable)
134+instance Exception WarpTLSException
135+
94136runTLS :: TLSSettings -> Settings -> Application -> IO ()
95137runTLS tset set app =
96138 bracket