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 6737c7d5102c573296a1ca7a8b2560e6e081f259 (commit)
via fdeb9def160fb610aa7723b5c3788ef7c58a1aeb (commit)
via 2e5888136d04168b02d4d4ad3a168300e61727d7 (commit)
from 9b077119d681c625c1af61993a58da57f7eff69f (commit)
Summary of changes:
snap-server.cabal | 12 +++++--
src/Snap/Internal/Http/Server.hs | 45 +++++++++++++----------
src/Snap/Internal/Http/Server/LibevBackend.hs | 31 ++++++++++------
src/Snap/Internal/Http/Server/SimpleBackend.hs | 31 ++++++++++++----
src/System/SendFile.hs | 30 ++++++++++++++++
src/System/SendFile/Darwin.hsc | 40 +++++++++++++++++++++
src/System/SendFile/FreeBSD.hsc | 37 +++++++++++++++++++
src/System/SendFile/Linux.hsc | 41 +++++++++++++++++++++
8 files changed, 224 insertions(+), 43 deletions(-)
create mode 100644 src/System/SendFile.hs
create mode 100644 src/System/SendFile/Darwin.hsc
create mode 100644 src/System/SendFile/FreeBSD.hsc
create mode 100644 src/System/SendFile/Linux.hsc
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 6737c7d5102c573296a1ca7a8b2560e6e081f259
Merge: fdeb9de 9b07711
Author: Shu-yu Guo <[email protected]>
Date: Sun Jun 6 17:40:43 2010 -0700
Merge branch 'master' of git.snapframework.com:snap-server
Conflicts:
src/Snap/Internal/Http/Server/SimpleBackend.hs
diff --cc src/Snap/Internal/Http/Server/SimpleBackend.hs
index bc074c0,03a138c..657c946
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@@ -149,7 -135,7 +149,7 @@@ timeoutThread backend = loo
-- atomic swap edit list
now <- getCurrentDateTime
edits <- atomicModifyIORef tedits $ \t -> (D.empty, D.toList t)
--
++
let table' = foldl' (flip ($)) table edits
!t' <- killOlderThan now table'
return t'
commit fdeb9def160fb610aa7723b5c3788ef7c58a1aeb
Author: Shu-yu Guo <[email protected]>
Date: Sun Jun 6 17:39:22 2010 -0700
Add our own sendfile
diff --git a/snap-server.cabal b/snap-server.cabal
index d102e1d..0bf847d 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -93,6 +93,7 @@ Library
Snap.Internal.Http.Parser,
Snap.Internal.Http.Server,
Snap.Internal.Http.Server.Date
+ System.SendFile
build-depends:
array >= 0.2 && <0.4,
@@ -111,7 +112,6 @@ Library
monads-fd,
network == 2.2.1.*,
old-locale,
- sendfile >= 0.6.1 && < 0.7,
snap-core >= 0.2.7 && <0.3,
time,
transformers,
@@ -134,10 +134,16 @@ Library
other-modules: Snap.Internal.Http.Server.SimpleBackend
if os(linux)
- cpp-options: -DLINUX
+ cpp-options: -DLINUX -DHAS_SENDFILE
+ other-modules: System.SendFile.Linux
if os(darwin)
- cpp-options: -DOSX
+ cpp-options: -DOSX -DHAS_SENDFILE
+ other-modules: System.SendFile.Darwin
+
+ if os(freebsd)
+ cpp-options: -DFREEBSD -DHAS_SENDFILE
+ other-modules: System.SendFile.FreeBSD
ghc-prof-options: -prof -auto-all
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 6388395..03f233f 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -243,18 +243,18 @@ logA' logger req rsp = do
------------------------------------------------------------------------------
-runHTTP :: ByteString -- ^ local host name
- -> ByteString -- ^ local ip address
- -> Int -- ^ local port
- -> ByteString -- ^ remote ip address
- -> Int -- ^ remote port
- -> Maybe Logger -- ^ access logger
- -> Maybe Logger -- ^ error logger
- -> Enumerator IO () -- ^ read end of socket
- -> Iteratee IO () -- ^ write end of socket
- -> (FilePath -> IO ()) -- ^ sendfile end
- -> IO () -- ^ timeout tickler
- -> ServerHandler -- ^ handler procedure
+runHTTP :: ByteString -- ^ local host name
+ -> ByteString -- ^ local ip address
+ -> Int -- ^ local port
+ -> ByteString -- ^ remote ip address
+ -> Int -- ^ remote port
+ -> Maybe Logger -- ^ access logger
+ -> Maybe Logger -- ^ error logger
+ -> Enumerator IO () -- ^ read end of socket
+ -> Iteratee IO () -- ^ write end of socket
+ -> (FilePath -> Int -> IO ()) -- ^ sendfile end
+ -> IO () -- ^ timeout tickler
+ -> ServerHandler -- ^ handler procedure
-> IO ()
runHTTP lh lip lp rip rp alog elog
readEnd writeEnd onSendFile tickle handler =
@@ -294,11 +294,11 @@ logError s = gets _logError >>= (\l -> liftIO $ l s)
------------------------------------------------------------------------------
-- | Runs an HTTP session.
-httpSession :: Iteratee IO () -- ^ write end of socket
- -> ForeignPtr CChar -- ^ iteratee buffer
- -> (FilePath -> IO ()) -- ^ sendfile continuation
- -> IO () -- ^ timeout tickler
- -> ServerHandler -- ^ handler procedure
+httpSession :: Iteratee IO () -- ^ write end of socket
+ -> ForeignPtr CChar -- ^ iteratee buffer
+ -> (FilePath -> Int -> IO ()) -- ^ sendfile continuation
+ -> IO () -- ^ timeout tickler
+ -> ServerHandler -- ^ handler procedure
-> ServerMonad ()
httpSession writeEnd' ibuf onSendFile tickle handler = do
@@ -510,15 +510,20 @@ sendResponse :: Response
-> Iteratee IO a
-> ForeignPtr CChar
-> IO ()
- -> (FilePath -> IO a)
- -> ServerMonad (Int,a)
+ -> (FilePath -> Int -> IO a)
+ -> ServerMonad (Int, a)
sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
(Enum e) -> liftIO $ whenEnum headerString e
+#if defined(HAS_SENDFILE)
(SendFile f) -> liftIO $ whenSendFile headerString rsp f
+#else
+ (SendFile f) -> liftIO $ whenEnum headerString
+ (I.enumFile f)
+#endif
return $! (bs,x)
@@ -536,7 +541,7 @@ sendResponse rsp' writeEnd ibuf killBuffering onSendFile =
do
enumBS hs writeEnd >>= run
let !cl = fromJust $ rspContentLength r
- x <- onSendFile f
+ x <- onSendFile f cl
return (x, cl)
(major,minor) = rspHttpVersion rsp'
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 915d9be..f3ba2bb 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
@@ -54,13 +55,17 @@ import Foreign.C.Types
import GHC.Conc (forkOnIO)
import Network.Libev
import Network.Socket
-import qualified Network.Socket.SendFile as SF
import Prelude hiding (catch)
import System.Timeout
------------------------------------------------------------------------------
import Snap.Iteratee
import Snap.Internal.Debug
+#if defined(HAS_SENDFILE) && !defined(PORTABLE)
+import qualified System.SendFile as SF
+import System.Posix.IO
+import System.Posix.Types (Fd(..))
+#endif
data Backend = Backend
{ _acceptSocket :: !Socket
@@ -110,22 +115,16 @@ name :: ByteString
name = "libev"
-sendFile :: Connection -> FilePath -> IO ()
-sendFile c fp = do
+sendFile :: Connection -> FilePath -> Int -> IO ()
+sendFile c fp total = do
withMVar lock $ \_ -> do
act <- readIORef $ _writeActive c
when act $ evIoStop loop io
writeIORef (_writeActive c) False
evAsyncSend loop asy
- evTimerStop loop (_timerObj c)
- -- FIXME
- -- Temporary hack to stop sendFile from timing out.
- -- An actual fix requires us to write our own sendfile wrapper that
- -- checks for EINTR (will libev timers raise EINTR on sendfile?)
- -- on OS X and just the return value on Linux to tickle the timeout.
- SF.sendFile s fp
- tickleTimeout c
+ fd <- openFd fp ReadOnly Nothing defaultFileFlags
+ go fd 0 total
withMVar lock $ \_ -> do
tryTakeMVar $ _readAvailable c
@@ -133,7 +132,15 @@ sendFile c fp = do
evAsyncSend loop asy
where
- s = _socket c
+ go fd off bytes
+ | bytes == 0 = return ()
+ | otherwise = do
+ sent <- SF.sendFile sfd fd off bytes
+ if sent < bytes
+ then tickleTimeout c >> go fd (off+sent) (bytes-sent)
+ else return ()
+
+ sfd = Fd $ _socketFd c
io = _connWriteIOObj c
b = _backend c
loop = _evLoop b
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 9ba4665..bc074c0 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -48,13 +49,18 @@ import Foreign.C.Types (CTime)
import GHC.Conc (labelThread, forkOnIO)
import Network.Socket
import qualified Network.Socket.ByteString as SB
-import qualified Network.Socket.SendFile as SF
import Prelude hiding (catch)
------------------------------------------------------------------------------
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Date
import Snap.Iteratee hiding (foldl')
+#if defined(HAS_SENDFILE) && !defined(PORTABLE)
+import qualified System.SendFile as SF
+import System.Posix.IO
+import System.Posix.Types (Fd(..))
+#endif
+
data BackendTerminatedException = BackendTerminatedException
deriving (Typeable)
@@ -85,10 +91,20 @@ name :: ByteString
name = "simple"
-sendFile :: Connection -> FilePath -> IO ()
-sendFile c fp = do
- let s = _socket c
- SF.sendFile s fp
+sendFile :: Connection -> FilePath -> Int -> IO ()
+sendFile c fp sz = do
+ fd <- openFd fp ReadOnly Nothing defaultFileFlags
+ go fd 0 sz
+ where
+ go fd off bytes
+ | bytes == 0 = return ()
+ | otherwise = do
+ sent <- SF.sendFile sfd fd off bytes
+ if sent < bytes
+ then tickleTimeout c >> go fd (off+sent) (bytes-sent)
+ else return ()
+
+ sfd = Fd . fdSocket $ _socket c
bindIt :: ByteString -- ^ bind address, or \"*\" for all
@@ -278,6 +294,7 @@ instance Exception TimeoutException
tickleTimeout :: Connection -> IO ()
tickleTimeout conn = do
+ debug "Backend.tickleTimeout"
now <- getCurrentDateTime
tid <- readMVar $ _connTid conn
diff --git a/src/System/SendFile.hs b/src/System/SendFile.hs
index 9a2de65..2810232 100644
--- a/src/System/SendFile.hs
+++ b/src/System/SendFile.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
-- | Snap's unified interface to sendfile.
--- Modified from sendfile by Matthew Elder
+-- Modified from sendfile 0.6.1
module System.SendFile
( sendFile
commit 2e5888136d04168b02d4d4ad3a168300e61727d7
Author: Shu-yu Guo <[email protected]>
Date: Sun Jun 6 17:36:22 2010 -0700
Add our own sendfile wrappers so we can do timeout
diff --git a/src/System/SendFile.hs b/src/System/SendFile.hs
new file mode 100644
index 0000000..9a2de65
--- /dev/null
+++ b/src/System/SendFile.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE CPP #-}
+
+-- | Snap's unified interface to sendfile.
+-- Modified from sendfile by Matthew Elder
+
+module System.SendFile
+ ( sendFile
+ , sendFileMode
+ ) where
+
+#if defined(LINUX)
+import System.SendFile.Linux (sendFile)
+
+sendFileMode :: String
+sendFileMode = "LINUX_SENDFILE"
+#endif
+
+#if defined(FREEBSD)
+import System.SendFile.FreeBSD (sendFile)
+
+sendFileMode :: String
+sendFileMode = "FREEBSD_SENDFILE"
+#endif
+
+#if defined(OSX)
+import System.SendFile.Darwin (sendFile)
+
+sendFileMode :: String
+sendFileMode = "DARWIN_SENDFILE"
+#endif
diff --git a/src/System/SendFile/Darwin.hsc b/src/System/SendFile/Darwin.hsc
new file mode 100644
index 0000000..9a8d98a
--- /dev/null
+++ b/src/System/SendFile/Darwin.hsc
@@ -0,0 +1,40 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- | Darwin system-dependent code for 'sendfile'.
+module System.SendFile.Darwin (sendFile) where
+
+import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)
+import Foreign.C.Types (CInt)
+import Foreign.Marshal (alloca)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Storable (peek, poke)
+import System.Posix.Types (Fd, COff)
+
+sendFile :: Fd -> Fd -> Int -> Int -> IO Int
+sendFile out_fd in_fd off count
+ | count == 0 = return 0
+ | otherwise = alloca $ \pbytes -> do
+ poke pbytes $ min maxBytes (fromIntegral count)
+ sbytes <- sendfile out_fd in_fd (fromIntegral off) pbytes
+ return $ fromEnum sbytes
+
+sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO COff
+sendfile out_fd in_fd off pbytes = do
+ status <- c_sendfile out_fd in_fd off pbytes
+ nsent <- peek pbytes
+ if status == 0
+ then return nsent
+ else do errno <- getErrno
+ if (errno == eAGAIN) || (errno == eINTR)
+ then return nsent
+ else throwErrno "System.SendFile.Darwin"
+
+-- max num of bytes in one send
+maxBytes :: COff
+maxBytes = maxBound :: COff
+
+-- in Darwin sendfile gives LFS support (no sendfile64 routine)
+foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_darwin
+ :: Fd -> Fd -> COff -> Ptr COff -> Ptr () -> CInt -> IO CInt
+
+c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO CInt
+c_sendfile out_fd in_fd off pbytes = c_sendfile_darwin in_fd out_fd off pbytes
nullPtr 0
diff --git a/src/System/SendFile/FreeBSD.hsc b/src/System/SendFile/FreeBSD.hsc
new file mode 100644
index 0000000..9be08dc
--- /dev/null
+++ b/src/System/SendFile/FreeBSD.hsc
@@ -0,0 +1,37 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- | FreeBSD system-dependent code for 'sendfile'.
+module System.SendFile.FreeBSD (sendFile) where
+
+import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)
+import Foreign.C.Types (CInt, CSize)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Storable (peek)
+import System.Posix.Types (COff, Fd)
+
+sendFile :: Fd -> Fd -> Int -> Int -> IO Int
+sendFile out_fd in_fd off count
+ | count == 0 = return 0
+ | otherwise = alloca $ \pbytes -> do
+ sbytes <- sendfile out_fd in_fd (fromIntegral off)
+ (fromIntegral count) pbytes
+ return $ fromEnum sbytes
+
+sendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO COff
+sendfile out_fd in_fd off count pbytes =
+ do threadWaitWrite out_fd
+ res <- c_sendfile_freebsd in_fd out_fd off count nullPtr pbytes 0
+ nsent <- peek pbytes
+ if (res == 0)
+ then return nsent
+ else do errno <- getErrno
+ if (errno == eAGAIN) || (errno == eINTR)
+ then return nsent
+ else throwErrno "System.SendFile.FreeBSD.sendfile"
+
+-- max num of bytes in one send
+maxBytes :: CSize
+maxBytes = maxBound :: CSize
+
+foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_freebsd
+ :: Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt
diff --git a/src/System/SendFile/Linux.hsc b/src/System/SendFile/Linux.hsc
new file mode 100644
index 0000000..97962c2
--- /dev/null
+++ b/src/System/SendFile/Linux.hsc
@@ -0,0 +1,41 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- | Linux system-dependent code for 'sendfile'.
+module System.SendFile.Linux (sendFile) where
+
+import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
+import Foreign.C.Types (CSize)
+import Foreign.Marshal (alloca)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Storable (poke)
+import System.Posix.Types (Fd, COff, CSsize)
+
+sendFile :: Fd -> Fd -> Int -> Int -> IO Int
+sendFile out_fd in_fd off count
+ | count == 0 = return 0
+ | off == 0 = do
+ sbytes <- sendfile out_fd in_fd nullPtr bytes
+ return $ fromEnum sbytes
+ | otherwise = alloca $ \poff -> do
+ poke poff (fromIntegral off)
+ sbytes <- sendfile out_fd in_fd poff bytes
+ return $ fromEnum sbytes
+ where
+ bytes = min (fromIntegral count) maxBytes
+
+sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
+sendfile out_fd in_fd poff bytes = do
+ nsent <- c_sendfile out_fd in_fd poff bytes
+ if nsent <= -1
+ then do errno <- getErrno
+ if errno == eAGAIN
+ then sendfile out_fd in_fd poff bytes
+ else throwErrno "System.SendFile.Linux"
+ else return nsent
+
+-- max num of bytes in one send
+maxBytes :: CSize
+maxBytes = maxBound :: CSize
+
+-- sendfile64 gives LFS support
+foreign import ccall unsafe "sys/sendfile.h sendfile64" c_sendfile
+ :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
