git.iko.soy/typeable/wai
on master help sign in
warp-tls: settings type, no automatic HTTP support #143
e13c50aMichael Snoyman
warp-tls/Network/Wai/Handler/WarpTLS.hs+51−9
compare with master
unifiedsplit
@@ -1,9 +1,17 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
3module Network.Wai.Handler.WarpTLS
5module Network.Wai.Handler.WarpTLS
4− ( TLSSettings (..)
6+ ( TLSSettings
7+ , certFile
8+ , keyFile
9+ , onInsecure
10+ , OnInsecure (..)
11+ , tlsSettings
5 , runTLS
12 , runTLS
6 , runTLSSocket
13 , runTLSSocket
14+ , WarpTLSException (..)
7 ) where
15 ) where
8
16
9import qualified Network.TLS as TLS
17import qualified Network.TLS as TLS
@@ -28,16 +36,37 @@ import Data.Maybe (fromMaybe)
28import qualified Data.IORef as I
36import qualified Data.IORef as I
29import Control.Monad (unless)
37import Control.Monad (unless)
30import Crypto.Random.API (getSystemRandomGen)
38import Crypto.Random.API (getSystemRandomGen)
39+import Control.Exception (Exception, throwIO)
40+import Data.Typeable (Typeable)
31
41
32data TLSSettings = TLSSettings
42data TLSSettings = TLSSettings
33 { certFile :: FilePath
43 { certFile :: FilePath
44+ -- ^ File containing the certificate.
34 , keyFile :: FilePath
45 , 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."
35 }
64 }
36
65
37runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
66runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
38−runTLSSocket tset set sock app = do
67+runTLSSocket TLSSettings {..} set sock app = do
39− certs <- readCertificates $ certFile tset
68+ certs <- readCertificates certFile
40− pk <- readPrivateKey $ keyFile tset
69+ pk <- readPrivateKey keyFile
41 let params =
70 let params =
42 TLS.updateServerParams
71 TLS.updateServerParams
43 (\sp -> sp { TLS.serverWantClientCert = False }) $
72 (\sp -> sp { TLS.serverWantClientCert = False }) $
@@ -84,13 +113,26 @@ runTLSSocket tset set sock app = do
84 , connRecv = TLS.recvData ctx
113 , connRecv = TLS.recvData ctx
85 }
114 }
86 return conn
115 return conn
87− else do
116+ else
117+ case onInsecure of
118+ AllowInsecure ->
88− let conn = (socketConnection s)
119+ let conn = (socketConnection s)
89− { connRecv = getNext $ fmap (fromMaybe B.empty) C.await
120+ { connRecv = getNext $ fmap (fromMaybe B.empty) C.await
90− }
121+ }
91− return conn
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
92 return (mkConn, sa)
130 return (mkConn, sa)
93
131
132+data WarpTLSException = InsecureConnectionDenied
133+ deriving (Show, Typeable)
134+instance Exception WarpTLSException
135+
94runTLS :: TLSSettings -> Settings -> Application -> IO ()
136runTLS :: TLSSettings -> Settings -> Application -> IO ()
95runTLS tset set app =
137runTLS tset set app =
96 bracket
138 bracket
warp-tls/pong.hs+1−1
@@ -13,7 +13,7 @@ import Network.HTTP.Conduit
13main = do
13main = do
14 putStrLn "https://localhost:3009/"
14 putStrLn "https://localhost:3009/"
15 manager <- newManager def
15 manager <- newManager def
16− runTLS (TLSSettings "config/tls-cert" "config/tls-key") defaultSettings { settingsPort = 3009 } app
16+ runTLS (tlsSettings "config/tls-cert" "config/tls-key") defaultSettings { settingsPort = 3009 } app
17
17
18app req = return $
18app req = return $
19 case rawPathInfo req of
19 case rawPathInfo req of
warp-tls/warp-tls.cabal+1−1
@@ -1,5 +1,5 @@
1Name: warp-tls
1Name: warp-tls
2−Version: 1.3.5.1
2+Version: 1.4.0
3Synopsis: SSL support for Warp via the TLS package
3Synopsis: SSL support for Warp via the TLS package
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE