[Snap Framework] snap-server branch, master, updated. ae3a7163af9f340a83e76364a77367ec4fa74bdf

noreply at snapframework.com noreply at snapframework.com
Sun Apr 25 22:07:05 CDT 2010


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  ae3a7163af9f340a83e76364a77367ec4fa74bdf (commit)
      from  f2dfdc22e981fc68c93c14fbc15a1f037a9fb382 (commit)


Summary of changes:
 snap-server.cabal                              |    4 +-
 src/Snap/Internal/Http/Server.hs               |  257 ++++++++++++++++--------
 src/Snap/Internal/Http/Server/LibevBackend.hs  |    9 +
 src/Snap/Internal/Http/Server/SimpleBackend.hs |    8 +
 src/System/FastLogger.hs                       |   37 ++--
 test/snap-server-testsuite.cabal               |    4 +-
 test/suite/Snap/Internal/Http/Server/Tests.hs  |   44 ++--
 7 files changed, 239 insertions(+), 124 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 ae3a7163af9f340a83e76364a77367ec4fa74bdf
Author: Gregory Collins <greg at gregorycollins.net>
Date:   Sun Apr 25 23:06:55 2010 -0400

    Add sendfile() support to snap-server

diff --git a/snap-server.cabal b/snap-server.cabal
index e40fd40..4db7fc3 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -52,9 +52,11 @@ Library
     monads-fd,
     network == 2.2.1.*,
     old-locale,
+    sendfile >= 0.6.1 && < 0.7,
     snap-core == 0.1.1,
     time,
-    transformers
+    transformers,
+    unix
 
   if flag(libev)
     build-depends: hlibev >= 0.2.1
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index c008cf9..299fbfd 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -7,6 +8,7 @@ module Snap.Internal.Http.Server where
 ------------------------------------------------------------------------------
 import           Control.Arrow (first, second)
 import           Control.Monad.State.Strict
+import           Control.Concurrent.MVar
 import           Control.Exception
 import           Data.Char
 import           Data.CIByteString
@@ -18,16 +20,17 @@ import qualified Data.ByteString.Nums.Careless.Int as Cvt
 import           Data.IORef
 import           Data.List (foldl')
 import qualified Data.Map as Map
-import           Data.Maybe (catMaybes, fromMaybe)
+import           Data.Maybe (fromJust, catMaybes, fromMaybe)
 import           Data.Monoid
-import           Prelude hiding (catch)
-
 import           GHC.Conc
-import           Control.Concurrent.MVar
-import           System.IO.Error hiding (try,catch)
-import           System.FastLogger
 import           GHC.IOBase (IOErrorType(..))
+import           Prelude hiding (catch, show, Show)
+import qualified Prelude
+import           System.IO.Error hiding (try,catch)
+import           System.Posix.Files
+import           Text.Show.ByteString hiding (runPut)
 ------------------------------------------------------------------------------
+import           System.FastLogger
 import           Snap.Internal.Http.Types hiding (Enumerator)
 import           Snap.Internal.Http.Parser
 import           Snap.Iteratee hiding (foldl', head, take)
@@ -44,6 +47,7 @@ import           Snap.Internal.Http.Server.SimpleBackend (debug)
 
 import           Snap.Internal.Http.Server.Date
 
+------------------------------------------------------------------------------
 -- | The handler has to return the request object because we have to clear the
 -- HTTP request body before we send the response. If the handler consumes the
 -- request body, it is responsible for setting @rqBody=return@ in the returned
@@ -67,6 +71,7 @@ data ServerState = ServerState
     }
 
 
+------------------------------------------------------------------------------
 runServerMonad :: ByteString                     -- ^ local host name
                -> ByteString                     -- ^ local ip address
                -> Int                            -- ^ local port
@@ -86,8 +91,8 @@ runServerMonad lh lip lp rip rp logA logE m = evalStateT m st
 -- input/output
 
 
+------------------------------------------------------------------------------
 -- FIXME: exception handling
-
 httpServe :: ByteString         -- ^ bind address, or \"*\" for all
           -> Int                -- ^ port to bind to
           -> ByteString         -- ^ local hostname (server name)
@@ -115,7 +120,8 @@ httpServe bindAddress bindPort localHostname alogPath elogPath handler =
       where
         f ((backend,mvar),cpu) =
             forkOnIO cpu $ do
-                labelMe $ "accThread " ++ show cpu
+                labelMe $ map w2c $ S.unpack $
+                          S.concat ["accThread ", l2s $ show cpu]
                 (try $ (forever $ go alog elog backend cpu)) :: IO (Either SomeException ())
                 putMVar mvar ()
 
@@ -153,7 +159,9 @@ httpServe bindAddress bindPort localHostname alogPath elogPath handler =
         let lport = Backend.getLocalPort conn
 
         runHTTP localHostname laddr lport raddr rport
-                alog elog readEnd writeEnd handler
+                alog elog readEnd writeEnd (Backend.sendFile conn)
+                handler
+
         debug "Server.httpServe.runHTTP: finished"
 
 
@@ -183,11 +191,19 @@ httpServe bindAddress bindPort localHostname alogPath elogPath handler =
                        , bshow e ]
               return () ]
 
+------------------------------------------------------------------------------
 debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)
 
+
+------------------------------------------------------------------------------
 logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog
 logE' logger s = (timestampedLogEntry s) >>= logMsg logger
 
+
+bshow :: (Prelude.Show a) => a -> ByteString
+bshow = toBS . Prelude.show
+
+------------------------------------------------------------------------------
 logA alog = maybe (\_ _ -> return ()) logA' alog
 logA' logger req rsp = do
     let hdrs      = rqHeaders req
@@ -195,7 +211,7 @@ logA' logger req rsp = do
     let user      = Nothing -- FIXME we don't do authentication yet
     let (v, v')   = rqVersion req
     let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
-    let method    = bshow (rqMethod req)
+    let method    = toBS $ Prelude.show (rqMethod req)
     let reql      = S.intercalate " " [ method, rqURI req, ver ]
     let status    = rspStatus rsp
     let cl        = rspContentLength rsp
@@ -206,48 +222,54 @@ logA' logger req rsp = do
     logMsg logger msg
 
 
-
-
-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
-        -> 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 -> IO ())  -- ^ sendfile end
+        -> ServerHandler        -- ^ handler procedure
         -> IO ()
-runHTTP lh lip lp rip rp alog elog readEnd writeEnd handler =
+runHTTP lh lip lp rip rp alog elog readEnd writeEnd onSendFile handler =
     go `catches` [ Handler $ \(e :: AsyncException) -> do
                        logE elog "runHTTP: caught async exception:"
-                       logE elog $ bshow e
+                       logE elog $ toBS $ Prelude.show e
                        throwIO e
-                 , Handler $ \(e :: SomeException) -> logE elog $ bshow e ]
+                 , Handler $ \(e :: SomeException) ->
+                             logE elog $ toBS $ Prelude.show e ]
 
   where
     go = do
         let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $
-                                  httpSession writeEnd handler
+                                  httpSession writeEnd onSendFile handler
         readEnd iter >>= run
 
 
+------------------------------------------------------------------------------
 sERVER_HEADER :: [ByteString]
 sERVER_HEADER = ["Snap/0.pre-1"]
 
 
+------------------------------------------------------------------------------
 logAccess :: Request -> Response -> ServerMonad ()
 logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)
 
+------------------------------------------------------------------------------
 logError :: ByteString -> ServerMonad ()
 logError s = gets _logError >>= (\l -> liftIO $ l s)
 
+------------------------------------------------------------------------------
 -- | Runs an HTTP session.
-httpSession :: Iteratee IO ()      -- ^ write end of socket
-            -> ServerHandler       -- ^ handler procedure
+httpSession :: Iteratee IO ()       -- ^ write end of socket
+            -> (FilePath -> IO ())  -- ^ sendfile continuation
+            -> ServerHandler        -- ^ handler procedure
             -> ServerMonad ()
-httpSession writeEnd handler = do
+httpSession writeEnd onSendFile handler = do
     liftIO $ debug "Server.httpSession: entered"
     mreq       <- receiveRequest
 
@@ -273,7 +295,7 @@ httpSession writeEnd handler = do
           date <- liftIO getDateString
           let ins = (Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER)
           let rsp' = updateHeaders ins rsp
-          (bytesSent,_) <- sendResponse rsp' writeEnd
+          (bytesSent,_) <- sendResponse rsp' writeEnd onSendFile
 
           maybe (logAccess req rsp')
                 (\_ -> logAccess req $ setContentLength bytesSent rsp')
@@ -281,11 +303,11 @@ httpSession writeEnd handler = do
 
           if cc
              then return ()
-             else httpSession writeEnd handler
+             else httpSession writeEnd onSendFile handler
 
       Nothing -> return ()
 
-
+------------------------------------------------------------------------------
 receiveRequest :: ServerMonad (Maybe Request)
 receiveRequest = do
     mreq <- lift parseRequest
@@ -426,38 +448,44 @@ receiveRequest = do
                                   S.break (== (c2w '?')) uri
 
 
+------------------------------------------------------------------------------
+-- Response must be well-formed here
 sendResponse :: Response
              -> Iteratee IO a
+             -> (FilePath -> IO a)
              -> ServerMonad (Int,a)
-sendResponse rsp writeEnd = do
-    (hdrs, bodyEnum) <- maybe noCL hasCL (rspContentLength rsp)
-
-    let headerline = S.concat [ "HTTP/"
-                              , bshow major
-                              , "."
-                              , bshow minor
-                              , " "
-                              , bshow $ rspStatus rsp
-                              , " "
-                              , rspStatusReason rsp
-                              , "\r\n" ]
-
-    let headerString = L.fromChunks $ concat [ [headerline]
-                                             , fmtHdrs hdrs
-                                             , ["\r\n"] ]
-
-    let enum = enumLBS headerString >.
-               bodyEnum (rspBody rsp)
-
-    -- send the data out. run throws an exception on error that we will catch
-    -- in the toplevel handler.
-    (x, bs) <- liftIO $ enum (countBytes writeEnd) >>= run
-    let hdrsLength = fromEnum $ L.length headerString
-    return $! (bs - hdrsLength, x)
+sendResponse rsp' writeEnd onSendFile = do
+    rsp <- fixupResponse rsp'
+    let !headerString = mkHeaderString rsp
+
+    (!x,!bs) <- case (rspBody rsp) of
+                  (Enum e)     -> liftIO $ whenEnum headerString e
+                  (SendFile f) -> liftIO $ whenSendFile headerString rsp f
+
+    return $! (bs,x)
 
   where
-    (major,minor) = rspHttpVersion rsp
-    fmtHdrs hdrs = concat xs
+    whenEnum hs e = do
+        let enum = enumBS hs >. e
+        let hl = S.length hs
+        (x,bs) <- liftIO $ enum (countBytes writeEnd) >>= run
+
+        return (x, bs-hl)
+
+    whenSendFile hs r f = do
+        -- guaranteed to have a content length here.
+        enumBS hs writeEnd >>= run
+
+        let !cl = fromJust $ rspContentLength r
+        x <- onSendFile f
+        return (x, cl)
+
+    (major,minor) = rspHttpVersion rsp'
+
+
+    fmtHdrs hdrs =
+        {-# SCC "fmtHdrs" #-}
+        concat xs
       where
         xs = map f $ Map.toList hdrs
 
@@ -465,31 +493,87 @@ sendResponse rsp writeEnd = do
 
         g k y = S.concat [ unCI k, ": ", y, "\r\n" ]
 
-    stHdrs = Map.delete "Content-Length" $ rspHeaders rsp
-
-    noCL :: ServerMonad (Headers, Enumerator IO a -> Enumerator IO a)
-    noCL = do
-        -- are we in HTTP/1.1?
-        let sendChunked = (rspHttpVersion rsp) == (1,1)
-        if sendChunked
-          then do
-              return ( Map.insert "Transfer-Encoding" ["chunked"] stHdrs
-                     , writeChunkedTransferEncoding )
-          else do
-              -- HTTP/1.0 and no content-length? We'll have to close the
-              -- socket.
-              modify $! \s -> s { _forceConnectionClose = True }
-              return (Map.insert "Connection" ["close"] stHdrs, id)
-
-    hasCL :: Int -> ServerMonad (Headers, Enumerator IO a -> Enumerator IO a)
-    hasCL cl = do
-        -- set the content-length header
-        return (Map.insert "Content-Length" [fromStr $ show cl] stHdrs, i)
+
+    noCL :: Response -> ServerMonad Response
+    noCL r =
+        {-# SCC "noCL" #-}
+        do
+            -- are we in HTTP/1.1?
+            let sendChunked = (rspHttpVersion r) == (1,1)
+            if sendChunked
+              then do
+                  let r' = setHeader "Transfer-Encoding" "chunked" r
+                  let e  = writeChunkedTransferEncoding $ rspBodyToEnum $ rspBody r
+                  return $ r' { rspBody = Enum e }
+
+              else do
+                  -- HTTP/1.0 and no content-length? We'll have to close the
+                  -- socket.
+                  modify $! \s -> s { _forceConnectionClose = True }
+                  return $ setHeader "Connection" "close" r
+
+
+    hasCL :: Int -> Response -> ServerMonad Response
+    hasCL cl r =
+        {-# SCC "hasCL" #-}
+        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
+
+            return $ r' { rspBody = b }
+
       where
         i :: Enumerator IO a -> Enumerator IO a
         i enum iter = enum (joinI $ takeExactly cl iter)
 
 
+    setFileSize :: FilePath -> Response -> ServerMonad Response
+    setFileSize fp r =
+        {-# SCC "setFileSize" #-}
+        do
+            fs <- liftM fromEnum $ liftIO $ getFileSize fp
+            return $ r { rspContentLength = Just fs }
+
+
+    fixupResponse :: Response -> ServerMonad Response
+    fixupResponse r =
+        {-# SCC "fixupResponse" #-}
+        do
+            let r' = updateHeaders (Map.delete "Content-Length") r
+            r'' <- case (rspBody r') of
+                     (Enum e)     -> return r'
+                     (SendFile f) -> setFileSize f r'
+            case (rspContentLength r'') of
+              Nothing   -> noCL r''
+              (Just sz) -> hasCL sz r''
+
+
+    bsshow = l2s . show
+
+
+    mkHeaderString :: Response -> ByteString
+    mkHeaderString r =
+        {-# SCC "mkHeaderString" #-}
+        S.concat $ concat [hl, hdr, eol]
+      where
+        hl = [ "HTTP/"
+             , bsshow major
+             , "."
+             , bsshow minor
+             , " "
+             , bsshow $ rspStatus r
+             , " "
+             , rspStatusReason r
+             , "\r\n" ]
+
+        hdr = fmtHdrs $ headers r
+
+        eol = ["\r\n"]
+
+
 ------------------------------------------------------------------------------
 checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()
 checkConnectionClose ver hdrs =
@@ -505,9 +589,8 @@ checkConnectionClose ver hdrs =
     l  = liftM (map tl) $ Map.lookup "Connection" hdrs
     tl = S.map (c2w . toLower . w2c)
 
-bshow :: (Show a) => a -> ByteString
-bshow = S.pack . map c2w . show
 
+------------------------------------------------------------------------------
 -- FIXME: whitespace-trim the values here.
 toHeaders :: [(ByteString,ByteString)] -> Headers
 toHeaders kvps = foldl' f Map.empty kvps'
@@ -515,3 +598,15 @@ toHeaders kvps = foldl' f Map.empty kvps'
     kvps'     = map (first toCI . second (:[])) kvps
     f m (k,v) = Map.insertWith' (flip (++)) k v m
 
+
+------------------------------------------------------------------------------
+getFileSize :: FilePath -> IO FileOffset
+getFileSize fp = liftM fileSize $ getFileStatus fp
+
+
+l2s :: L.ByteString -> S.ByteString
+l2s = S.concat . L.toChunks
+
+
+toBS :: String -> ByteString
+toBS = S.pack . map c2w
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 42512f7..a027068 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -15,6 +15,7 @@ module Snap.Internal.Http.Server.LibevBackend
 , new
 , stop
 , withConnection
+, sendFile
 , getReadEnd
 , getWriteEnd
 , getRemoteAddr
@@ -49,6 +50,7 @@ import           Foreign.Ptr
 import           GHC.Conc (forkOnIO)
 import           Network.Libev
 import           Network.Socket
+import qualified Network.Socket.SendFile as SF
 import           Prelude hiding (catch)
 import           System.Timeout
 ------------------------------------------------------------------------------
@@ -102,12 +104,19 @@ data Connection = Connection
     }
 
 
+sendFile :: Connection -> FilePath -> IO ()
+sendFile c fp = do
+    let s = _socket c
+    SF.sendFile s fp
+
+
 bindIt :: ByteString         -- ^ bind address, or \"*\" for all
        -> Int                -- ^ port to bind to
        -> IO (Socket,CInt)
 bindIt bindAddress bindPort = do
     sock <- socket AF_INET Stream 0
     addr <- getHostAddr bindPort bindAddress
+    setSocketOption sock ReuseAddr 1
     bindSocket sock addr
     listen sock bindPort
     let sockFd = fdSocket sock
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 89ce4b4..a550361 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -14,6 +14,7 @@ module Snap.Internal.Http.Server.SimpleBackend
 , new
 , stop
 , withConnection
+, sendFile
 , getReadEnd
 , getWriteEnd
 , getRemoteAddr
@@ -35,6 +36,7 @@ import           Foreign.C.Types
 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
@@ -68,6 +70,11 @@ data Connection = Connection
     , _localPort   :: Int }
 
 
+sendFile :: Connection -> FilePath -> IO ()
+sendFile c fp = do
+    let s = _socket c
+    SF.sendFile s fp
+
 
 bindIt :: ByteString         -- ^ bind address, or \"*\" for all
        -> Int                -- ^ port to bind to
@@ -75,6 +82,7 @@ bindIt :: ByteString         -- ^ bind address, or \"*\" for all
 bindIt bindAddress bindPort = do
     sock <- socket AF_INET Stream 0
     addr <- getHostAddr bindPort bindAddress
+    setSocketOption sock ReuseAddr 1
     bindSocket sock addr
     listen sock bindPort
     return sock
diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs
index 2be825c..3f72a30 100644
--- a/src/System/FastLogger.hs
+++ b/src/System/FastLogger.hs
@@ -88,25 +88,24 @@ combinedLogEntry host mbUser req status mbNumBytes mbReferer userAgent = do
 
     timeStr <- getLogDateString
 
-    let p = do
-        putByteString host
-        putByteString " - "
-        putByteString user
-        putByteString " ["
-        putByteString timeStr
-        putByteString "] \""
-        putByteString req
-        putByteString "\" "
-        putLazyByteString $ show status
-        putCh ' '
-        putByteString numBytes
-        putCh ' '
-        putByteString referer
-        putByteString " \""
-        putByteString userAgent
-        putCh '\"'
-
-    return $ runPut p
+    let p = [ host
+            , " - "
+            , user
+            , " ["
+            , timeStr
+            , "] \""
+            , req
+            , "\" "
+            , strict $ show status
+            , " "
+            , numBytes
+            , " "
+            , referer
+            , " \""
+            , userAgent
+            , "\"" ]
+
+    return $ S.concat p
 
 
   where
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 8651208..43b824a 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -85,12 +85,14 @@ Executable pongserver
      iteratee >= 0.3.1 && < 0.4,
      network == 2.2.1.*,
      network-bytestring >= 0.1.2 && < 0.2,
+     sendfile >= 0.6.1 && < 0.7,
      snap-core == 0.1.1,
      test-framework < 0.3,
      test-framework-hunit < 0.3,
      test-framework-quickcheck2 < 0.3,
      time,
-     transformers
+     transformers,
+     unix
 
    if flag(libev)
      build-depends: hlibev >= 0.2.1
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs
index da470d8..9f2fab3 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -267,10 +267,13 @@ rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog
     alog = const . const . return $ ()
     elog = const $ return ()
 
+
 testHttpResponse1 :: Test
 testHttpResponse1 = testCase "HttpResponse1" $ do
+    let onSendFile = \f -> enumFile f stream2stream >>= run
+
     b <- run $ rsm $
-         sendResponse rsp1 stream2stream >>= return . fromWrap . snd
+         sendResponse rsp1 stream2stream onSendFile >>= return . fromWrap . snd
 
     assertEqual "http response" (L.concat [
                       "HTTP/1.0 600 Test\r\n"
@@ -280,7 +283,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
                     ]) b
 
     b2 <- run $ rsm $
-          sendResponse rsp2 stream2stream >>= return . fromWrap . snd
+          sendResponse rsp2 stream2stream onSendFile >>= return . fromWrap . snd
 
     assertEqual "http response" (L.concat [
                       "HTTP/1.0 600 Test\r\n"
@@ -290,7 +293,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
                     ]) b2
 
     b3 <- run $ rsm $
-          sendResponse rsp3 stream2stream >>= return . fromWrap . snd
+          sendResponse rsp3 stream2stream onSendFile >>= return . fromWrap . snd
 
     assertEqual "http response" b3 $ L.concat [
                       "HTTP/1.1 600 Test\r\n"
@@ -329,7 +332,7 @@ echoServer req = do
     liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0)
     return (req, rsp b cl)
   where
-    rsp s cl = emptyResponse { rspBody = enumLBS s
+    rsp s cl = emptyResponse { rspBody = Enum $ enumLBS s
                              , rspContentLength = Just $ fromIntegral cl }
 
 
@@ -348,10 +351,10 @@ testHttp1 = testCase "http session" $ do
 
     ref <- newIORef ""
 
-    let iter = mkIter ref
+    let (iter,onSendFile) = mkIter ref
 
     runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384
-            Nothing Nothing enumBody iter echoServer
+            Nothing Nothing enumBody iter onSendFile echoServer
 
     s <- readIORef ref
 
@@ -378,10 +381,14 @@ testHttp1 = testCase "http session" $ do
     assertBool "pipelined responses" ok
 
 
-mkIter :: IORef L.ByteString -> Iteratee IO ()
-mkIter ref = do
-    x <- stream2stream
-    liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
+mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> IO ())
+mkIter ref = (iter, \f -> onF f iter)
+  where
+    iter = do
+        x <- stream2stream
+        liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
+
+    onF f iter = enumFile f iter >>= run
 
 
 testChunkOn1_0 :: Test
@@ -389,10 +396,10 @@ testChunkOn1_0 = testCase "transfer-encoding chunked" $ do
     let enumBody = enumBS sampleRequest1_0
 
     ref <- newIORef ""
-    let iter = mkIter ref
+    let (iter,onSendFile) = mkIter ref
 
     runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384
-            Nothing Nothing enumBody iter f
+            Nothing Nothing enumBody iter onSendFile f
 
     -- this is a pretty lame way of checking whether the output was chunked,
     -- but "whatever"
@@ -408,7 +415,7 @@ testChunkOn1_0 = testCase "transfer-encoding chunked" $ do
     f req = do
         let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd"
         let out = enumLBS s
-        return (req, emptyResponse { rspBody = out })
+        return (req, emptyResponse { rspBody = Enum out })
 
 
 sampleRequest4 :: ByteString
@@ -429,10 +436,10 @@ testHttp2 = testCase "connection: close" $ do
 
     ref <- newIORef ""
 
-    let iter = mkIter ref
+    let (iter,onSendFile) = mkIter ref
 
     runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384
-            Nothing Nothing enumBody iter echoServer2
+            Nothing Nothing enumBody iter onSendFile echoServer2
 
     s <- readIORef ref
 
@@ -454,13 +461,6 @@ testHttp2 = testCase "connection: close" $ do
     assertBool "connection: close" ok
 
 
-  where
-    mkIter :: IORef L.ByteString -> Iteratee IO ()
-    mkIter ref = do
-        x <- stream2stream
-        liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
-
-
 
 pongServer :: Snap ()
 pongServer = modifyResponse $ setResponseBody (enumBS "PONG") .
-----------------------------------------------------------------------


hooks/post-receive
-- 
snap-server


More information about the Snap mailing list