This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 44c576f2fb9d1c9a3be07814ede5cf5682420ab9 (commit)
from 6b954db032885d63df10048076ecc47f9deb6e40 (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 31 ++++++++++++++---------
src/Snap/Internal/Http/Server/LibevBackend.hs | 13 +++-------
src/Snap/Internal/Http/Server/SimpleBackend.hs | 10 ++++----
test/suite/Snap/Internal/Http/Server/Tests.hs | 20 ++++++++++-----
4 files changed, 41 insertions(+), 33 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 44c576f2fb9d1c9a3be07814ede5cf5682420ab9
Author: Gregory Collins <[email protected]>
Date: Fri Sep 24 21:25:49 2010 -0400
Add 'Range:' support to fileServe
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 1198ce2..acd5022 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -280,7 +280,8 @@ runHTTP :: ByteString -- ^ local host
name
-> Maybe Logger -- ^ error logger
-> Enumerator IO () -- ^ read end of socket
-> Iteratee IO () -- ^ write end of socket
- -> (FilePath -> Int64 -> IO ()) -- ^ sendfile end
+ -> (FilePath -> Int64 -> Int64 -> IO ())
+ -- ^ sendfile end
-> IO () -- ^ timeout tickler
-> ServerHandler -- ^ handler procedure
-> IO ()
@@ -330,7 +331,8 @@ logError s = gets _logError >>= (\l -> liftIO $ l s)
-- | Runs an HTTP session.
httpSession :: Iteratee IO () -- ^ write end of socket
-> ForeignPtr CChar -- ^ iteratee buffer
- -> (FilePath -> Int64 -> IO ()) -- ^ sendfile continuation
+ -> (FilePath -> Int64 -> Int64 -> IO ())
+ -- ^ sendfile continuation
-> IO () -- ^ timeout tickler
-> ServerHandler -- ^ handler procedure
-> ServerMonad ()
@@ -607,15 +609,18 @@ receiveRequest = do
sendResponse :: forall a . Request
-> Response
-> Iteratee IO a
- -> (FilePath -> Int64 -> IO a)
+ -> (FilePath -> Int64 -> Int64 -> IO a)
-> ServerMonad (Int64, a)
sendResponse req rsp' writeEnd onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
- (Enum e) -> lift $ whenEnum headerString rsp e
- (SendFile f) -> lift $ whenSendFile headerString rsp f
+ (Enum e) -> lift $ whenEnum headerString rsp e
+ (SendFile f Nothing) -> lift $
+ whenSendFile headerString rsp f 0
+ (SendFile f (Just (st,_))) ->
+ lift $ whenSendFile headerString rsp f st
return $! (bs,x)
@@ -637,12 +642,12 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
- whenSendFile hs r f = do
+ whenSendFile hs r f start = do
-- guaranteed to have a content length here.
joinIM $ (enumBS hs >. enumEof) writeEnd
let !cl = fromJust $ rspContentLength r
- x <- liftIO $ onSendFile f cl
+ x <- liftIO $ onSendFile f start cl
return (x, cl)
@@ -693,8 +698,8 @@ sendResponse req rsp' writeEnd onSendFile = do
-- set the content-length header
let r' = setHeader "Content-Length" (l2s $ show cl) r
let b = case (rspBody r') of
- (Enum e) -> Enum (i e)
- (SendFile f) -> SendFile f
+ (Enum e) -> Enum (i e)
+ (SendFile f m) -> SendFile f m
return $ r' { rspBody = b }
@@ -732,14 +737,16 @@ sendResponse req rsp' writeEnd onSendFile = do
r''' <- do
z <- case (rspBody r'') of
- (Enum _) -> return r''
- (SendFile f) -> setFileSize f r''
+ (Enum _) -> return r''
+ (SendFile f Nothing) -> setFileSize f r''
+ (SendFile _ (Just (s,e))) -> return $
+ setContentLength (e-s) r''
case (rspContentLength z) of
Nothing -> noCL z
(Just sz) -> hasCL sz z
- -- HEAD requests cannot have bodies
+ -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4
if rqMethod req == HEAD
then return $ deleteHeader "Transfer-Encoding"
$ r''' { rspBody = Enum $ enumBS "" }
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 9e74833..fdb8cb9 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -112,12 +112,8 @@ name :: ByteString
name = "libev"
-sendFile :: Connection -> FilePath -> Int64 -> IO ()
-#if defined(HAS_SENDFILE)
-sendFile c fp sz = do
-#else
-sendFile c fp _ = do
-#endif
+sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO ()
+sendFile c fp start sz = do
withMVar lock $ \_ -> do
act <- readIORef $ _writeActive c
when act $ evIoStop loop io
@@ -127,10 +123,9 @@ sendFile c fp _ = do
#if defined(HAS_SENDFILE)
bracket (openFd fp ReadOnly Nothing defaultFileFlags)
(closeFd)
- (go 0 sz)
+ (go start sz)
#else
- -- no need to count bytes
- enumFile fp (getWriteEnd c) >>= run
+ enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run
return ()
#endif
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 25bf59a..96901f1 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -97,12 +97,12 @@ name :: ByteString
name = "simple"
-sendFile :: Connection -> FilePath -> Int64 -> IO ()
+sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO ()
#if defined(HAS_SENDFILE)
-sendFile c fp sz = do
+sendFile c fp start sz = do
bracket (openFd fp ReadOnly Nothing defaultFileFlags)
(closeFd)
- (go 0 sz)
+ (go start sz)
where
go off bytes fd
| bytes == 0 = return ()
@@ -114,9 +114,9 @@ sendFile c fp sz = do
sfd = Fd . fdSocket $ _socket c
#else
-sendFile c fp _ = do
+sendFile c fp start sz = do
-- no need to count bytes
- enumFile fp (getWriteEnd c) >>= run
+ enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run
return ()
#endif
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 1ee69aa..086cad2 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -388,7 +388,9 @@ rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1"
58382 alog elog
testHttpResponse1 :: Test
testHttpResponse1 = testCase "server/HttpResponse1" $ do
- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ let onSendFile = \f start sz ->
+ enumFilePartial f (start,start+sz) copyingStream2stream
+ >>= run
req <- mkRequest sampleRequest
@@ -414,7 +416,8 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do
testHttpResponse2 :: Test
testHttpResponse2 = testCase "server/HttpResponse2" $ do
- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ let onSendFile = \f st sz ->
+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run
req <- mkRequest sampleRequest
@@ -440,7 +443,8 @@ testHttpResponse2 = testCase "server/HttpResponse2" $ do
testHttpResponse3 :: Test
testHttpResponse3 = testCase "server/HttpResponse3" $ do
- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ let onSendFile = \f st sz ->
+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run
req <- mkRequest sampleRequest
@@ -472,7 +476,8 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do
testHttpResponse4 :: Test
testHttpResponse4 = testCase "server/HttpResponse4" $ do
- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ let onSendFile = \f st sz ->
+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run
req <- mkRequest sampleRequest
@@ -555,14 +560,15 @@ testHttp1 = testCase "server/http session" $ do
assertBool "pipelined responses" ok
-mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> Int64 -> IO ())
-mkIter ref = (iter, \f _ -> onF f iter)
+mkIter :: IORef L.ByteString
+ -> (Iteratee IO (), FilePath -> Int64 -> Int64 -> IO ())
+mkIter ref = (iter, \f st sz -> onF f st sz iter)
where
iter = do
x <- copyingStream2stream
liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
- onF f i = enumFile f i >>= run
+ onF f st sz i = enumFilePartial f (st,st+sz) i >>= run
testChunkOn1_0 :: Test
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
