snap-server 0.2.8 → 0.2.8.1
raw patch · 2 files changed
+111/−34 lines, 2 filesdep ~snap-core
Dependency ranges changed: snap-core
Files
- snap-server.cabal +2/−2
- src/Snap/Internal/Http/Server.hs +109/−32
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.2.8+version: 0.2.8.1 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a@@ -117,7 +117,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale,- snap-core >= 0.2.8 && <0.2.9,+ snap-core >= 0.2.8.1 && <0.3, time, transformers, unix-compat,
src/Snap/Internal/Http/Server.hs view
@@ -38,6 +38,8 @@ import System.FastLogger import Snap.Internal.Http.Types hiding (Enumerator) import Snap.Internal.Http.Parser+import Snap.Internal.Http.Server.Date+import Snap.Internal.Iteratee.Debug import Snap.Iteratee hiding (foldl', head, take, FileOffset) import qualified Snap.Iteratee as I @@ -49,10 +51,9 @@ import Snap.Internal.Http.Server.SimpleBackend (debug) #endif -import Snap.Internal.Http.Server.Date- import qualified Paths_snap_server as V + ------------------------------------------------------------------------------ -- | 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@@ -94,7 +95,6 @@ st = ServerState False lh lip lp rip rp la le - ------------------------------------------------------------------------------ -- input/output @@ -112,6 +112,7 @@ (\(alog, elog) -> spawnAll alog elog) where+ -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do logE elog $ S.concat [ "Server.httpServe: START (" , Backend.name, ")"]@@ -124,24 +125,30 @@ (runAll alog elog) + -------------------------------------------------------------------------- runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do mapM_ f $ xs `zip` [0..] mapM_ (takeMVar . snd) xs where- f ((backend,mvar),cpu) =- forkOnIO cpu $ do- labelMe $ map w2c $ S.unpack $- S.concat ["accThread ", l2s $ show cpu]- (try $ (goooo alog elog backend cpu)) :: IO (Either SomeException ())- putMVar mvar ()+ f ((backend,mvar),cpu) = forkOnIO cpu $ do+ labelMe $ map w2c $ S.unpack $+ S.concat ["accThread ", l2s $ show cpu]+ (try $ goooo alog elog backend cpu) :: IO (Either SomeException ())+ putMVar mvar () ++ -------------------------------------------------------------------------- goooo alog elog backend cpu = {-# SCC "httpServe/goooo" #-} let loop = go alog elog backend cpu >> loop in loop ++ -------------------------------------------------------------------------- maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger ++ -------------------------------------------------------------------------- withLoggers afp efp = bracket (do alog <- maybeSpawnLogger afp elog <- maybeSpawnLogger efp@@ -151,11 +158,15 @@ maybe (return ()) stopLogger alog maybe (return ()) stopLogger elog) ++ -------------------------------------------------------------------------- labelMe :: String -> IO () labelMe s = do tid <- myThreadId labelThread tid s ++ -------------------------------------------------------------------------- spawn n = do sock <- Backend.bindIt bindAddress bindPort backends <- mapM (Backend.new sock) $ [0..(n-1)]@@ -164,6 +175,7 @@ return (backends `zip` mvars) + -------------------------------------------------------------------------- runOne alog elog backend cpu = Backend.withConnection backend cpu $ \conn -> {-# SCC "httpServe/runOne" #-} do@@ -184,6 +196,7 @@ debug "Server.httpServe.runHTTP: finished" + -------------------------------------------------------------------------- go alog elog backend cpu = runOne alog elog backend cpu `catches` [ Handler $ \(_ :: Backend.TimeoutException) -> return ()@@ -195,17 +208,22 @@ throwIO e , Handler $ \(e :: Backend.BackendTerminatedException) -> do- logE elog $ "Server.httpServe.go: got backend terminated, waiting for cleanup"+ logE elog $+ S.concat ["Server.httpServe.go: got backend terminated, "+ , "waiting for cleanup" ] throwIO e , Handler $ \(e :: IOException) -> do- logE elog $ S.concat [ "Server.httpServe.go: got io exception: "- , bshow e ]+ logE elog $+ S.concat [ "Server.httpServe.go: got io exception: "+ , bshow e ] , Handler $ \(e :: SomeException) -> do- logE elog $ S.concat [ "Server.httpServe.go: got someexception: "- , bshow e ] ]+ logE elog $+ S.concat [ "Server.httpServe.go: got someexception: "+ , bshow e ] ] + ------------------------------------------------------------------------------ debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)@@ -215,17 +233,23 @@ logE :: Maybe Logger -> ByteString -> IO () logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog ++------------------------------------------------------------------------------ logE' :: Logger -> ByteString -> IO () logE' logger s = (timestampedLogEntry s) >>= logMsg logger +------------------------------------------------------------------------------ bshow :: (Prelude.Show a) => a -> ByteString bshow = toBS . Prelude.show + ------------------------------------------------------------------------------ logA ::Maybe Logger -> Request -> Response -> IO () logA alog = maybe (\_ _ -> return ()) logA' alog ++------------------------------------------------------------------------------ logA' :: Logger -> Request -> Response -> IO () logA' logger req rsp = do let hdrs = rqHeaders req@@ -283,17 +307,22 @@ sERVER_HEADER :: [ByteString] sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]] ++------------------------------------------------------------------------------ snapServerVersion :: ByteString snapServerVersion = SC.pack $ showVersion $ V.version + ------------------------------------------------------------------------------ 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@@ -313,17 +342,21 @@ liftIO $ debug "Server.httpSession: entered" mreq <- receiveRequest+ -- successfully got a request, so restart timer liftIO tickle case mreq of (Just req) -> do- liftIO $ debug $ "got request: " +++ liftIO $ debug $ "Server.httpSession: got request: " ++ Prelude.show (rqMethod req) ++ " " ++ SC.unpack (rqURI req) ++ " " ++ Prelude.show (rqVersion req) logerr <- gets _logError (req',rspOrig) <- lift $ handler logerr req++ liftIO $ debug $ "Server.httpSession: finished running user handler"+ let rspTmp = rspOrig { rspHttpVersion = rqVersion req } checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp) @@ -332,15 +365,15 @@ then (setHeader "Connection" "close" rspTmp) else rspTmp - liftIO $ debug "Server.httpSession: handled, skipping request body" srqEnum <- liftIO $ readIORef $ rqBody req' let (SomeEnumerator rqEnum) = srqEnum lift $ joinIM $ rqEnum skipToEof- liftIO $ debug "Server.httpSession: request body skipped, sending response"+ liftIO $ debug $ "Server.httpSession: request body skipped, " +++ "sending response" date <- liftIO getDateString- let ins = (Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER)+ let ins = Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse rsp' writeEnd ibuf killBuffer onSendFile @@ -355,8 +388,12 @@ then return () else httpSession writeEnd' ibuf onSendFile tickle handler - Nothing -> return ()+ Nothing -> do+ liftIO $ debug $ "Server.httpSession: parser did not produce a " +++ "request, ending session"+ return () + ------------------------------------------------------------------------------ receiveRequest :: ServerMonad (Maybe Request) receiveRequest = do@@ -374,6 +411,7 @@ where+ -------------------------------------------------------------------------- -- check: did the client specify "transfer-encoding: chunked"? then we have -- to honor that. --@@ -386,8 +424,12 @@ setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} if isChunked- then liftIO $ writeIORef (rqBody req)- (SomeEnumerator readChunkedTransferEncoding)+ then do+ liftIO $ debug $ "receiveRequest/setEnumerator: " +++ "input in chunked encoding"+ let e = readChunkedTransferEncoding+ liftIO $ writeIORef (rqBody req)+ (SomeEnumerator e) else maybe noContentLength hasContentLength mbCL where@@ -397,25 +439,35 @@ hasContentLength :: Int -> ServerMonad () hasContentLength l = do- liftIO $ writeIORef (rqBody req)- (SomeEnumerator e)+ liftIO $ debug $ "receiveRequest/setEnumerator: " +++ "request had content-length"+ liftIO $ writeIORef (rqBody req) (SomeEnumerator e)+ liftIO $ debug "receiveRequest/setEnumerator: body enumerator set" where e :: Enumerator IO a- e = return . joinI . I.take l+ e = return . joinI . I.take l .+ iterateeDebugWrapper "rqBody iterator" noContentLength :: ServerMonad ()- noContentLength =- liftIO $ writeIORef (rqBody req)- (SomeEnumerator $ return . joinI . I.take 0 )+ noContentLength = do+ liftIO $ debug ("receiveRequest/setEnumerator: " +++ "request did NOT have content-length") + -- FIXME: should we not just read everything?+ let e = return . joinI . I.take 0 + liftIO $ writeIORef (rqBody req) (SomeEnumerator e)+ liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"++ hdrs = rqHeaders req mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head + -------------------------------------------------------------------------- parseForm :: Request -> ServerMonad Request- parseForm req =- {-# SCC "receiveRequest/parseForm" #-} if doIt then getIt else return req+ parseForm req = {-# SCC "receiveRequest/parseForm" #-}+ if doIt then getIt else return req where doIt = mbCT == Just "application/x-www-form-urlencoded" mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req)@@ -425,17 +477,26 @@ getIt :: ServerMonad Request getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do+ liftIO $ debug "parseForm: got application/x-www-form-urlencoded"+ liftIO $ debug "parseForm: reading POST body" senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum let i = joinI $ takeNoMoreThan maximumPOSTBodySize stream2stream iter <- liftIO $ enum i body <- liftM unWrap $ lift iter let newParams = parseUrlEncoded body- liftIO $ writeIORef (rqBody req)- (SomeEnumerator $ enumBS body)++ liftIO $ debug "parseForm: stuffing 'enumBS body' into request"++ let e = enumBS body >. enumEof++ liftIO $ writeIORef (rqBody req) $ SomeEnumerator $+ e . iterateeDebugWrapper "regurgitate body"+ return $ req { rqParams = rqParams req `mappend` newParams } + -------------------------------------------------------------------------- toRequest (IRequest method uri version kvps) = {-# SCC "receiveRequest/toRequest" #-} do localAddr <- gets _localAddress@@ -525,6 +586,7 @@ return $! (bs,x) where+ -------------------------------------------------------------------------- whenEnum hs e = do let enum = enumBS hs >. e let hl = fromIntegral $ S.length hs@@ -533,6 +595,8 @@ return (x, bs-hl) ++ -------------------------------------------------------------------------- whenSendFile hs r f = do -- guaranteed to have a content length here. enumBS hs writeEnd >>= run@@ -541,9 +605,12 @@ x <- onSendFile f cl return (x, cl) ++ -------------------------------------------------------------------------- (major,minor) = rspHttpVersion rsp' + -------------------------------------------------------------------------- fmtHdrs hdrs = {-# SCC "fmtHdrs" #-} concat xs@@ -555,6 +622,7 @@ g k y = S.concat [ unCI k, ": ", y, "\r\n" ] + -------------------------------------------------------------------------- noCL :: Response -> ServerMonad Response noCL r = {-# SCC "noCL" #-}@@ -576,6 +644,7 @@ return $ setHeader "Connection" "close" r + -------------------------------------------------------------------------- hasCL :: Int64 -> Response -> ServerMonad Response hasCL cl r = {-# SCC "hasCL" #-}@@ -593,6 +662,7 @@ i enum iter = enum (joinI $ takeExactly cl iter) + -------------------------------------------------------------------------- setFileSize :: FilePath -> Response -> ServerMonad Response setFileSize fp r = {-# SCC "setFileSize" #-}@@ -601,11 +671,14 @@ return $ r { rspContentLength = Just fs } + -------------------------------------------------------------------------- handle304 :: Response -> Response handle304 r = setResponseBody (enumBS "") $ updateHeaders (Map.delete "Transfer-Encoding") $ setContentLength 0 r ++ -------------------------------------------------------------------------- fixupResponse :: Response -> ServerMonad Response fixupResponse r = {-# SCC "fixupResponse" #-}@@ -626,9 +699,11 @@ (Just sz) -> hasCL sz r''' + -------------------------------------------------------------------------- bsshow = l2s . show + -------------------------------------------------------------------------- mkHeaderString :: Response -> ByteString mkHeaderString r = {-# SCC "mkHeaderString" #-}@@ -657,7 +732,7 @@ -- For HTTP/1.0: -- if there is no explicit Connection: Keep-Alive, close the socket. if (ver == (1,1) && l == Just ["close"]) ||- (ver == (1,0) && l /= Just ["Keep-Alive"])+ (ver == (1,0) && l /= Just ["keep-alive"]) then modify $ \s -> s { _forceConnectionClose = True } else return () where@@ -679,9 +754,11 @@ getFileSize fp = liftM fileSize $ getFileStatus fp +------------------------------------------------------------------------------ l2s :: L.ByteString -> S.ByteString l2s = S.concat . L.toChunks +------------------------------------------------------------------------------ toBS :: String -> ByteString toBS = S.pack . map c2w