git.iko.soy/typeable/wai
on master help sign in
moving sendfile from WarpTLS to Warp.

first step for pread().

commitea2f8aa7e1633c1d34ac6cbfcf72820c1d902145 authorKazu Yamamoto <kazu@iij.ad.jp> dateThu 11 Jun 2015, 12:59 (11 years ago) parented36b06
3 files changed+37−26
compare with master
unifiedsplit
warp-tls/Network/Wai/Handler/WarpTLS.hs+5−19 warp/Network/Wai/Handler/Warp.hs+9−7 warp/Network/Wai/Handler/Warp/SendFile.hs+23
warp-tls/Network/Wai/Handler/WarpTLS.hs+5−19
@@ -35,12 +35,11 @@ module Network.Wai.Handler.WarpTLS (
3535import Control.Applicative ((<$>))
3636#endif
3737import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException)
38−import Control.Monad (unless, void)
38+import Control.Monad (void)
3939import qualified Crypto.Random.AESCtr
4040import qualified Data.ByteString as B
4141import qualified Data.ByteString as S
4242import qualified Data.ByteString.Lazy as L
43−import Data.ByteString.Lazy.Internal (defaultChunkSize)
4443import Data.Default.Class (def)
4544import qualified Data.IORef as I
4645import Data.Streaming.Network (bindPortTCP, safeRecv)
@@ -52,7 +51,6 @@ import qualified Network.TLS.Extra as TLSExtra
5251import Network.Wai (Application)
5352import Network.Wai.Handler.Warp
5453import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)
55−import qualified System.IO as IO
5654import System.IO.Error (isEOFError)
5755
5856----------------------------------------------------------------
@@ -285,7 +283,7 @@ httpOverTls TLSSettings{..} s cachedRef params = do
285283 }
286284 conn ctx pool writeBuf = Connection {
287285 connSendMany = TLS.sendData ctx . L.fromChunks
288− , connSendAll = TLS.sendData ctx . L.fromChunks . return
286+ , connSendAll = sendall
289287 , connSendFile = sendfile
290288 , connClose = close
291289 , connRecv = recv
@@ -294,21 +292,9 @@ httpOverTls TLSSettings{..} s cachedRef params = do
294292 , connBufferSize = bufferSize
295293 }
296294 where
297− sendfile fid offset len tickle' headers = do
298− let fp = fileIdPath fid
299− TLS.sendData ctx $ L.fromChunks headers
300− IO.withBinaryFile fp IO.ReadMode $ \h -> do
301− IO.hSeek h IO.AbsoluteSeek offset
302− loop h $ fromIntegral len
303− where
304− loop _ remaining | remaining <= 0 = return ()
305− loop h remaining = do
306− bs <- B.hGetSome h defaultChunkSize
307− unless (B.null bs) $ do
308− let x = B.take remaining bs
309− TLS.sendData ctx $ L.fromChunks [x]
310− void $ tickle' -- This tickles the Timer. It MUST be called per chunk.
311− loop h $ remaining - B.length x
295+ sendall = TLS.sendData ctx . L.fromChunks . return
296+ sendfile fid offset len hook headers =
297+ readSendFile writeBuf bufferSize sendall fid offset len hook headers
312298
313299 close = freeBuffer writeBuf `finally`
314300 void (tryIO $ TLS.bye ctx) `finally`
warp/Network/Wai/Handler/Warp.hs+9−7
@@ -96,6 +96,7 @@ module Network.Wai.Handler.Warp (
9696 , FileId (..)
9797 , socketConnection
9898 , newBufferPool
99+ , readSendFile
99100 -- * Internal
100101 -- ** Version
101102 , warpVersion
@@ -115,6 +116,13 @@ module Network.Wai.Handler.Warp (
115116 , sendResponse
116117 ) where
117118
119+import Control.Exception (SomeException)
120+import Data.ByteString (ByteString)
121+import Data.Maybe (fromMaybe)
122+import Data.Streaming.Network (HostPreference)
123+import qualified Data.Vault.Lazy as Vault
124+import Network.Socket (SockAddr)
125+import Network.Wai (Request, Response, vault)
118126import Network.Wai.Handler.Warp.Buffer
119127import Network.Wai.Handler.Warp.Date
120128import Network.Wai.Handler.Warp.FdCache
@@ -122,16 +130,10 @@ import Network.Wai.Handler.Warp.Header
122130import Network.Wai.Handler.Warp.Request
123131import Network.Wai.Handler.Warp.Response
124132import Network.Wai.Handler.Warp.Run
133+import Network.Wai.Handler.Warp.SendFile
125134import Network.Wai.Handler.Warp.Settings
126135import Network.Wai.Handler.Warp.Timeout
127136import Network.Wai.Handler.Warp.Types
128−import Control.Exception (SomeException)
129−import Network.Wai (Request, Response, vault)
130−import Network.Socket (SockAddr)
131−import Data.Streaming.Network (HostPreference)
132−import Data.ByteString (ByteString)
133−import qualified Data.Vault.Lazy as Vault
134−import Data.Maybe (fromMaybe)
135137
136138-- | Port to listen on. Default value: 3000
137139--
warp/Network/Wai/Handler/Warp/SendFile.hs+23
@@ -2,9 +2,14 @@
22
33module Network.Wai.Handler.Warp.SendFile where
44
5+import Control.Monad (when, void)
6+import Data.ByteString.Internal
7+import Foreign.ForeignPtr (newForeignPtr_)
58import Network.Sendfile
69import Network.Socket (Socket)
10+import Network.Wai.Handler.Warp.Buffer
711import Network.Wai.Handler.Warp.Types
12+import qualified System.IO as IO
813
914defaultSendFile :: Socket -> SendFile
1015#ifdef SENDFILEFD
@@ -20,3 +25,21 @@ defaultSendFile s fid off len act hdr =
2025 where
2126 path = fileIdPath fid
2227#endif
28+
29+readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
30+readSendFile buf siz send fid offset len hook headers = do
31+ mapM_ send headers
32+ fptr <- newForeignPtr_ buf
33+ IO.withBinaryFile path IO.ReadMode $ \h -> do
34+ IO.hSeek h IO.AbsoluteSeek offset
35+ loop fptr h $ fromIntegral len
36+ where
37+ path = fileIdPath fid
38+ loop _ _ remaining | remaining <= 0 = return ()
39+ loop fptr h remaining = do
40+ n <- IO.hGetBufSome h buf siz
41+ when (n /= 0) $ do
42+ let bs = PS fptr 0 n
43+ send bs
44+ void $ hook
45+ loop fptr h $ remaining - n