git.iko.soy/typeable/wai
on master help sign in
Merge pull request #27 from yesodweb/warp-tls-rebase
e220f2eMichael Snoyman
package-list.sh+1
compare with master
unifiedsplit
@@ -4,6 +4,7 @@ pkgs=( ./wai
4 ./wai-test
4 ./wai-test
5 ./wai-extra
5 ./wai-extra
6 ./warp
6 ./warp
7+ ./warp-tls
7 ./wai-app-static
8 ./wai-app-static
8 ./wai-handler-fastcgi
9 ./wai-handler-fastcgi
9 ./wai-handler-launch
10 ./wai-handler-launch
warp-tls/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Suite Solutions. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
warp-tls/Network/Wai/Handler/WarpTLS.hsnew file+114
@@ -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
warp-tls/Setup.lhsnew file+7
@@ -0,0 +1,7 @@
1+#!/usr/bin/env runhaskell
2+
3+> module Main where
4+> import Distribution.Simple
5+
6+> main :: IO ()
7+> main = defaultMain
warp-tls/certificate.pemnew file+15
@@ -0,0 +1,15 @@
1+-----BEGIN CERTIFICATE-----
2+MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV
3+BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX
4+aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF
5+MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50
6+ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
7+gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx
8+EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs
9++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV
10+HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM
11+b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk
12+D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0
13+k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw
14+VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==
15+-----END CERTIFICATE-----
warp-tls/key.pemnew file+15
@@ -0,0 +1,15 @@
1+-----BEGIN RSA PRIVATE KEY-----
2+MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd
3+thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD
4+JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB
5+AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63
6+CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM
7+MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp
8+ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid
9+Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B
10+5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs
11+eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV
12+YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv
13+jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG
14+T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=
15+-----END RSA PRIVATE KEY-----
warp-tls/pong.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Network.Wai
3+import Network.Wai.Handler.Warp (defaultSettings)
4+import Network.Wai.Handler.WarpTLS
5+import Network.HTTP.Types (status200)
6+import Blaze.ByteString.Builder (copyByteString)
7+import Data.Monoid
8+import qualified Data.Conduit.List as CL
9+
10+main = do
11+ putStrLn "https://localhost:3000/"
12+ runTLS (TLSSettings "certificate.pem" "key.pem") defaultSettings app
13+
14+app req = return $
15+ case rawPathInfo req of
16+ "/builder/withlen" -> builderWithLen
17+ "/builder/nolen" -> builderNoLen
18+ "/file/withlen" -> fileWithLen
19+ "/file/nolen" -> fileNoLen
20+ "/source/withlen" -> sourceWithLen
21+ "/source/nolen" -> sourceNoLen
22+ x -> index x
23+
24+builderWithLen = ResponseBuilder
25+ status200
26+ [ ("Content-Type", "text/plain")
27+ , ("Content-Length", "4")
28+ ]
29+ $ copyByteString "PONG"
30+
31+builderNoLen = ResponseBuilder
32+ status200
33+ [ ("Content-Type", "text/plain")
34+ ]
35+ $ copyByteString "PONG"
36+
37+sourceWithLen = ResponseSource
38+ status200
39+ [ ("Content-Type", "text/plain")
40+ , ("Content-Length", "4")
41+ ]
42+ $ CL.sourceList [copyByteString "PONG"]
43+
44+sourceNoLen = ResponseSource
45+ status200
46+ [ ("Content-Type", "text/plain")
47+ ]
48+ $ CL.sourceList [copyByteString "PONG"]
49+
50+fileWithLen = ResponseFile
51+ status200
52+ [ ("Content-Type", "text/plain")
53+ , ("Content-Length", "4")
54+ ]
55+ "pong.txt"
56+ Nothing
57+
58+fileNoLen = ResponseFile
59+ status200
60+ [ ("Content-Type", "text/plain")
61+ ]
62+ "pong.txt"
63+ Nothing
64+
65+index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString
66+ [ "<p><a href='/builder/withlen'>builder withlen</a></p>\n"
67+ , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
68+ , "<p><a href='/file/withlen'>file withlen</a></p>\n"
69+ , "<p><a href='/file/nolen'>file nolen</a></p>\n"
70+ , "<p><a href='/source/withlen'>source withlen</a></p>\n"
71+ , "<p><a href='/source/nolen'>source nolen</a></p>\n"
72+ , p
73+ ]
warp-tls/pong.txtnew file+1
@@ -0,0 +1 @@
1+PONG
warp-tls/warp-tls.cabalnew file+33
@@ -0,0 +1,33 @@
1+Name: warp-tls
2+Version: 1.0.0
3+Synopsis: SSL support for Warp via the TLS package
4+License: BSD3
5+License-file: LICENSE
6+Author: Michael Snoyman
7+Maintainer: michael@snoyman.com
8+Homepage: http://github.com/yesodweb/wai
9+Category: Web, Yesod
10+Build-Type: Simple
11+Cabal-Version: >=1.6
12+Stability: Stable
13+Description: SSL support for Warp via the TLS package
14+
15+Library
16+ Build-Depends: base >= 4 && < 5
17+ , bytestring >= 0.9 && < 0.10
18+ , wai >= 1.0 && < 1.1
19+ , warp >= 1.0 && < 1.1
20+ , transformers >= 0.2 && < 0.3
21+ , conduit >= 0.0 && < 0.1
22+ , certificate >= 1.0.1 && < 1.1
23+ , cryptocipher >= 0.3 && < 0.4
24+ , tls-extra >= 0.4 && < 0.5
25+ , tls >= 0.8.1 && < 0.9
26+ , crypto-api >= 0.8 && < 0.9
27+ , network >= 2.2.1 && < 2.4
28+ Exposed-modules: Network.Wai.Handler.WarpTLS
29+ ghc-options: -Wall
30+
31+source-repository head
32+ type: git
33+ location: git://github.com/yesodweb/wai.git
warp/Network/Wai/Handler/Warp.hs+47−21
@@ -36,6 +36,9 @@ module Network.Wai.Handler.Warp
36 , settingsTimeout
36 , settingsTimeout
37 , settingsIntercept
37 , settingsIntercept
38 , settingsManager
38 , settingsManager
39+ -- * Connection
40+ , Connection (..)
41+ , runSettingsConnection
39 -- * Datatypes
42 -- * Datatypes
40 , Port
43 , Port
41 , InvalidRequest (..)
44 , InvalidRequest (..)
@@ -117,6 +120,7 @@ import qualified Control.Concurrent.MVar as MV
117import Network.Socket (withSocketsDo)
120import Network.Socket (withSocketsDo)
118#endif
121#endif
119
122
123+
120#ifndef MEGA
124#ifndef MEGA
121import Data.Version (showVersion)
125import Data.Version (showVersion)
122import qualified Paths_warp
126import qualified Paths_warp
@@ -126,6 +130,26 @@ warpVersion = "0.4.6"
126#endif
130#endif
127warpVersion :: String
131warpVersion :: String
128
132
133+data Connection = Connection
134+ { connSendMany :: [B.ByteString] -> IO ()
135+ , connSendAll :: B.ByteString -> IO ()
136+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length
137+ , connSink :: T.Handle -> C.Sink B.ByteString IO ()
138+ , connClose :: IO ()
139+ , connSource :: T.Handle -> C.Source IO B.ByteString
140+ }
141+
142+socketConnection :: Socket -> Connection
143+socketConnection s = Connection
144+ { connSendMany = Sock.sendMany s
145+ , connSendAll = Sock.sendAll s
146+ , connSendFile = \fp off len act -> sendfile s fp (PartOfFile off len) act
147+ , connSink = flip sinkSocket s
148+ , connClose = sClose s
149+ , connSource = \th -> C.Source $ return $ sourceSocket th bytesPerRead s
150+ }
151+
152+
129bindPort :: Int -> String -> IO Socket
153bindPort :: Int -> String -> IO Socket
130bindPort p s = do
154bindPort p s = do
131 let hints = defaultHints { addrFlags = [AI_PASSIVE
155 let hints = defaultHints { addrFlags = [AI_PASSIVE
@@ -185,32 +209,40 @@ type Port = Int
185-- 'serverPort' record.
209-- 'serverPort' record.
186runSettingsSocket :: Settings -> Socket -> Application -> IO ()
210runSettingsSocket :: Settings -> Socket -> Application -> IO ()
187runSettingsSocket set socket app = do
211runSettingsSocket set socket app = do
212+ runSettingsConnection set getter app
213+ where
214+ getter = do
215+ (conn, sa) <- accept socket
216+ return (socketConnection conn, sa)
217+
218+runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
219+runSettingsConnection set getConn app = do
188 let onE = settingsOnException set
220 let onE = settingsOnException set
189 port = settingsPort set
221 port = settingsPort set
190 tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return
222 tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return
191 $ settingsManager set
223 $ settingsManager set
192 forever $ do
224 forever $ do
193− (conn, sa) <- accept socket
225+ (conn, addr) <- getConn
194 _ <- forkIO $ do
226 _ <- forkIO $ do
195 th <- T.registerKillThread tm
227 th <- T.registerKillThread tm
196− serveConnection set th onE port app conn sa
228+ serveConnection set th onE port app conn addr
197 T.cancel th
229 T.cancel th
198 return ()
230 return ()
199
231
200serveConnection :: Settings
232serveConnection :: Settings
201 -> T.Handle
233 -> T.Handle
202 -> (SomeException -> IO ())
234 -> (SomeException -> IO ())
203− -> Port -> Application -> Socket -> SockAddr -> IO ()
235+ -> Port -> Application -> Connection -> SockAddr -> IO ()
204serveConnection settings th onException port app conn remoteHost' = do
236serveConnection settings th onException port app conn remoteHost' = do
205 catch
237 catch
206 (finally
238 (finally
207 (runResourceT serveConnection')
239 (runResourceT serveConnection')
208− (sClose conn))
240+ (connClose conn))
209 onException
241 onException
210 where
242 where
211 serveConnection' :: ResourceT IO ()
243 serveConnection' :: ResourceT IO ()
212 serveConnection' = do
244 serveConnection' = do
213− fromClient <- C.bufferSource $ sourceSocket th bytesPerRead conn
245+ fromClient <- C.bufferSource $ connSource conn th
214 env <- parseRequest port remoteHost' fromClient
246 env <- parseRequest port remoteHost' fromClient
215 case settingsIntercept settings env of
247 case settingsIntercept settings env of
216 Nothing -> do
248 Nothing -> do
@@ -371,8 +403,8 @@ hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
371 H.statusCode s >= 200 && requestMethod req /= "HEAD"
403 H.statusCode s >= 200 && requestMethod req /= "HEAD"
372
404
373sendResponse :: T.Handle
405sendResponse :: T.Handle
374− -> Request -> Socket -> Response -> ResourceT IO Bool
406+ -> Request -> Connection -> Response -> ResourceT IO Bool
375−sendResponse th req socket r = sendResponse' r
407+sendResponse th req conn r = sendResponse' r
376 where
408 where
377 version = httpVersion req
409 version = httpVersion req
378 isPersist = checkPersist req
410 isPersist = checkPersist req
@@ -392,19 +424,13 @@ sendResponse th req socket r = sendResponse' r
392 (Nothing, Just part) -> do
424 (Nothing, Just part) -> do
393 let cl = filePartByteCount part
425 let cl = filePartByteCount part
394 return $ addClToHeaders cl
426 return $ addClToHeaders cl
395− Sock.sendMany socket $ L.toChunks $ toLazyByteString $
427+ connSendMany conn $ L.toChunks $ toLazyByteString $
396 headers version s lengthyHeaders False
428 headers version s lengthyHeaders False
397
429
398 if not (hasBody s req) then return isPersist else do
430 if not (hasBody s req) then return isPersist else do
399 case mpart of
431 case mpart of
400− Nothing -> sendfile socket fp PartOfFile {
432+ Nothing -> connSendFile conn fp 0 cl (T.tickle th)
401− rangeOffset = 0
433+ Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)
402− , rangeLength = cl
403− } (T.tickle th)
404− Just part -> sendfile socket fp PartOfFile {
405− rangeOffset = filePartOffset part
406− , rangeLength = filePartByteCount part
407− } (T.tickle th)
408 T.tickle th
434 T.tickle th
409 return isPersist
435 return isPersist
410 where
436 where
@@ -413,11 +439,11 @@ sendResponse th req socket r = sendResponse' r
413 sendResponse' (ResponseBuilder s hs b)
439 sendResponse' (ResponseBuilder s hs b)
414 | hasBody s req = liftIO $ do
440 | hasBody s req = liftIO $ do
415 toByteStringIO (\bs -> do
441 toByteStringIO (\bs -> do
416− Sock.sendAll socket bs
442+ connSendAll conn bs
417 T.tickle th) body
443 T.tickle th) body
418 return (isKeepAlive hs)
444 return (isKeepAlive hs)
419 | otherwise = liftIO $ do
445 | otherwise = liftIO $ do
420− Sock.sendMany socket
446+ connSendMany conn
421 $ L.toChunks
447 $ L.toChunks
422 $ toLazyByteString
448 $ toLazyByteString
423 $ headers' False
449 $ headers' False
@@ -440,7 +466,7 @@ sendResponse th req socket r = sendResponse' r
440 -- functions below. Should lessen greatly the GC burden (I hope)
466 -- functions below. Should lessen greatly the GC burden (I hope)
441 response
467 response
442 | not (hasBody s req) = do
468 | not (hasBody s req) = do
443− liftIO $ Sock.sendMany socket
469+ liftIO $ connSendMany conn
444 $ L.toChunks $ toLazyByteString
470 $ L.toChunks $ toLazyByteString
445 $ headers' False
471 $ headers' False
446 return (checkPersist req)
472 return (checkPersist req)
@@ -448,7 +474,7 @@ sendResponse th req socket r = sendResponse' r
448 let src =
474 let src =
449 CL.sourceList [headers' needsChunked'] `mappend`
475 CL.sourceList [headers' needsChunked'] `mappend`
450 (if needsChunked' then body C.$= chunk else body)
476 (if needsChunked' then body C.$= chunk else body)
451− src C.$$ builderToByteString C.=$ sinkSocket th socket
477+ src C.$$ builderToByteString C.=$ connSink conn th
452 return $ isKeepAlive hs
478 return $ isKeepAlive hs
453 needsChunked' = needsChunked hs
479 needsChunked' = needsChunked hs
454 chunk :: C.Conduit Builder IO Builder
480 chunk :: C.Conduit Builder IO Builder
@@ -516,7 +542,7 @@ data Settings = Settings
516 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
542 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
517 , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
543 , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
518 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
544 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
519− , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Socket -> ResourceT IO ())
545+ , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Connection -> ResourceT IO ())
520 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
546 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
521 }
547 }
522
548
warp/pong.hs+18
@@ -4,6 +4,7 @@ import Network.Wai.Handler.Warp
4import Network.HTTP.Types (status200)
4import Network.HTTP.Types (status200)
5import Blaze.ByteString.Builder (copyByteString)
5import Blaze.ByteString.Builder (copyByteString)
6import Data.Monoid
6import Data.Monoid
7+import qualified Data.Conduit.List as CL
7
8
8main = run 3000 app
9main = run 3000 app
9
10
@@ -13,6 +14,8 @@ app req = return $
13 "/builder/nolen" -> builderNoLen
14 "/builder/nolen" -> builderNoLen
14 "/file/withlen" -> fileWithLen
15 "/file/withlen" -> fileWithLen
15 "/file/nolen" -> fileNoLen
16 "/file/nolen" -> fileNoLen
17+ "/source/withlen" -> sourceWithLen
18+ "/source/nolen" -> sourceNoLen
16 x -> index x
19 x -> index x
17
20
18builderWithLen = ResponseBuilder
21builderWithLen = ResponseBuilder
@@ -28,6 +31,19 @@ builderNoLen = ResponseBuilder
28 ]
31 ]
29 $ copyByteString "PONG"
32 $ copyByteString "PONG"
30
33
34+sourceWithLen = ResponseSource
35+ status200
36+ [ ("Content-Type", "text/plain")
37+ , ("Content-Length", "4")
38+ ]
39+ $ CL.sourceList [copyByteString "PONG"]
40+
41+sourceNoLen = ResponseSource
42+ status200
43+ [ ("Content-Type", "text/plain")
44+ ]
45+ $ CL.sourceList [copyByteString "PONG"]
46+
31fileWithLen = ResponseFile
47fileWithLen = ResponseFile
32 status200
48 status200
33 [ ("Content-Type", "text/plain")
49 [ ("Content-Type", "text/plain")
@@ -48,5 +64,7 @@ index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $
48 , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
64 , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
49 , "<p><a href='/file/withlen'>file withlen</a></p>\n"
65 , "<p><a href='/file/withlen'>file withlen</a></p>\n"
50 , "<p><a href='/file/nolen'>file nolen</a></p>\n"
66 , "<p><a href='/file/nolen'>file nolen</a></p>\n"
67+ , "<p><a href='/source/withlen'>source withlen</a></p>\n"
68+ , "<p><a href='/source/nolen'>source nolen</a></p>\n"
51 , p
69 , p
52 ]
70 ]
warp/pong.txtnew file+1
@@ -0,0 +1 @@
1+PONG