27c373f · typeable/wai

28import qualified Network.TLS as TLS

29import Network.Wai.Handler.Warp

30import Network.Wai (Application)

31−import Network.Socket (Socket, sClose, withSocketsDo)

31+import Network.Socket (Socket, sClose, withSocketsDo, SockAddr)

32import qualified Data.ByteString.Lazy as L

33import Control.Exception (bracket, finally, handle, fromException, try, IOException)

34import qualified Network.TLS.Extra as TLSExtra

47import qualified System.IO as IO

48import System.IO.Error (isEOFError)

49

50+----------------------------------------------------------------

51+

50−data TLSSettings = TLSSettings

52+data TLSSettings = TLSSettings {

51− { certFile :: FilePath

53+ certFile :: FilePath

52− -- ^ File containing the certificate.

54+ -- ^ File containing the certificate.

53− , keyFile :: FilePath

55+ , keyFile :: FilePath

54− -- ^ File containing the key

56+ -- ^ File containing the key

55− , onInsecure :: OnInsecure

57+ , onInsecure :: OnInsecure

56− -- ^ Do we allow insecure connections with this server as well? Default

58+ -- ^ Do we allow insecure connections with this server as well? Default

57− -- is a simple text response stating that a secure connection is required.

59+ -- is a simple text response stating that a secure connection is required.

58− --

60+ --

59− -- Since 1.4.0

61+ -- Since 1.4.0

60− , tlsLogging :: TLS.Logging

62+ , tlsLogging :: TLS.Logging

61− -- ^ The level of logging to turn on.

63+ -- ^ The level of logging to turn on.

62− --

64+ --

63− -- Default: 'TLS.defaultLogging'.

65+ -- Default: 'TLS.defaultLogging'.

64− --

66+ --

65− -- Since 1.4.0

67+ -- Since 1.4.0

66− , tlsAllowedVersions :: [TLS.Version]

68+ , tlsAllowedVersions :: [TLS.Version]

67− -- ^ The TLS versions this server accepts.

69+ -- ^ The TLS versions this server accepts.

68− --

70+ --

69− -- Default: '[TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]'.

71+ -- Default: '[TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]'.

70− --

72+ --

71− -- Since 1.4.2

73+ -- Since 1.4.2

72− , tlsCiphers :: [TLS.Cipher]

74+ , tlsCiphers :: [TLS.Cipher]

73− -- ^ The TLS ciphers this server accepts.

75+ -- ^ The TLS ciphers this server accepts.

74− --

76+ --

75− -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSExtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'

77+ -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'

76− --

78+ --

77− -- Since 1.4.2

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

78− }

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+----------------------------------------------------------------

79

103

80-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.

104-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.

81data OnInsecure = DenyInsecure L.ByteString

105data OnInsecure = DenyInsecure L.ByteString

82 | AllowInsecure

106 | AllowInsecure

83

107

108+----------------------------------------------------------------

109+

84-- | A smart constructor for 'TLSSettings'.

110-- | A smart constructor for 'TLSSettings'.

85tlsSettings :: FilePath -- ^ Certificate file

111tlsSettings :: FilePath -- ^ Certificate file

86 -> FilePath -- ^ Key file

112 -> FilePath -- ^ Key file

87 -> TLSSettings

113 -> TLSSettings

88−tlsSettings cert key = defaultTlsSettings

114+tlsSettings cert key = defaultTlsSettings {

89− { certFile = cert

115+ certFile = cert

90− , keyFile = key

116+ , keyFile = key

91− }

117+ }

92

118

93−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.

119+----------------------------------------------------------------

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

213

120

214-- | Running 'Application' with 'TLSSettings' and 'Settings'.

121-- | Running 'Application' with 'TLSSettings' and 'Settings'.

215runTLS :: TLSSettings -> Settings -> Application -> IO ()

122runTLS :: TLSSettings -> Settings -> Application -> IO ()

219 sClose

126 sClose

220 (\sock -> runTLSSocket tset set sock app)

127 (\sock -> runTLSSocket tset set sock app)

221

128

222−-- taken from stunnel example in tls-extra

129+----------------------------------------------------------------

223−ciphers :: [TLS.Cipher]

130+

224−ciphers =

131+-- | Running 'Application' with 'TLSSettings' and 'Settings' using

225− [ TLSExtra.cipher_AES128_SHA1

132+-- specified 'Socket'.

226− , TLSExtra.cipher_AES256_SHA1

133+runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()

227− , TLSExtra.cipher_RC4_128_MD5

134+runTLSSocket tlsset@TLSSettings{..} set sock app = do

228− , TLSExtra.cipher_RC4_128_SHA1

135+ credential <- either error id <$> TLS.credentialLoadX509 certFile keyFile

229− ]

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

230

231tryIO :: IO a -> IO (Either IOException a)

232tryIO = 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