diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -1,5 +1,5 @@ -Snap Framework 0.1.1 --------------------- +Snap Framework +-------------- This is the first developer prerelease of the Snap framework. Snap is a simple and fast web development framework and server written in Haskell. For more diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -Snap Framework HTTP Server Library 0.1.1 ----------------------------------------- +Snap Framework HTTP Server Library +---------------------------------- This is the first developer prerelease of the Snap Framework HTTP Server library. For more information about Snap, read the `README.SNAP.md` or visit diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.1.4 +version: 0.2.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 @@ -107,14 +107,14 @@ network == 2.2.1.*, old-locale, sendfile >= 0.6.1 && < 0.7, - snap-core >= 0.1.2 && <0.2, + snap-core >= 0.2.1 && <0.3, time, transformers, unix, vector >= 0.6 && <0.7 if flag(libev) - build-depends: hlibev >= 0.2.1 + build-depends: hlibev >= 0.2.2 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else @@ -137,4 +137,4 @@ source-repository head type: git - location: http://git.snapframework.com/snap-server + location: http://git.snapframework.com/snap-server.git diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -52,7 +52,9 @@ -- -- Note that we won't be bothering end users with this -- the details will be -- hidden inside the Snap monad -type ServerHandler = Request -> Iteratee IO (Request,Response) +type ServerHandler = (ByteString -> IO ()) + -> Request + -> Iteratee IO (Request,Response) type ServerMonad = StateT ServerState (Iteratee IO) @@ -101,7 +103,7 @@ (\(alog, elog) -> spawnAll alog elog) where - spawnAll alog elog = do + spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do let n = numCapabilities bracket (spawn n) (\xs -> do @@ -111,7 +113,7 @@ (runAll alog elog) - runAll alog elog xs = do + runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do mapM_ f $ xs `zip` [0..] mapM_ (takeMVar . snd) xs where @@ -123,6 +125,7 @@ putMVar mvar () goooo alog elog backend cpu = + {-# SCC "httpServe/goooo" #-} let loop = go alog elog backend cpu >> loop in loop @@ -150,21 +153,23 @@ return (backends `zip` mvars) - runOne alog elog backend cpu = Backend.withConnection backend cpu $ \conn -> do - debug "Server.httpServe.runOne: entered" - let readEnd = Backend.getReadEnd conn - writeEnd <- I.bufferIteratee $ Backend.getWriteEnd conn + runOne alog elog backend cpu = + Backend.withConnection backend cpu $ \conn -> + {-# SCC "httpServe/runOne" #-} do + debug "Server.httpServe.runOne: entered" + let readEnd = Backend.getReadEnd conn + writeEnd <- I.bufferIteratee $ Backend.getWriteEnd conn - let raddr = Backend.getRemoteAddr conn - let rport = Backend.getRemotePort conn - let laddr = Backend.getLocalAddr conn - let lport = Backend.getLocalPort conn + let raddr = Backend.getRemoteAddr conn + let rport = Backend.getRemotePort conn + let laddr = Backend.getLocalAddr conn + let lport = Backend.getLocalPort conn - runHTTP localHostname laddr lport raddr rport - alog elog readEnd writeEnd (Backend.sendFile conn) - handler + runHTTP localHostname laddr lport raddr rport + alog elog readEnd writeEnd (Backend.sendFile conn) + handler - debug "Server.httpServe.runHTTP: finished" + debug "Server.httpServe.runHTTP: finished" go alog elog backend cpu = runOne alog elog backend cpu @@ -186,10 +191,8 @@ , bshow e ] , Handler $ \(e :: SomeException) -> do - logE elog $ S.concat [ - "Server.httpServe.go: got someexception: " - , bshow e ] - return () ] + logE elog $ S.concat [ "Server.httpServe.go: got someexception: " + , bshow e ] ] ------------------------------------------------------------------------------ debugE :: (MonadIO m) => ByteString -> m () @@ -249,7 +252,8 @@ , Handler $ \(_ :: Backend.TimeoutException) -> return () , Handler $ \(e :: SomeException) -> - logE elog $ toBS $ Prelude.show e ] + logE elog $ S.concat [ "Server.runHTTP.go: got someexception: " + , bshow e ] ] where go = do @@ -283,7 +287,8 @@ case mreq of (Just req) -> do - (req',rspOrig) <- lift $ handler req + logerr <- gets _logError + (req',rspOrig) <- lift $ handler logerr req let rspTmp = rspOrig { rspHttpVersion = rqVersion req } checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp) @@ -317,7 +322,7 @@ ------------------------------------------------------------------------------ receiveRequest :: ServerMonad (Maybe Request) receiveRequest = do - mreq <- lift parseRequest + mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift parseRequest case mreq of (Just ireq) -> do @@ -341,6 +346,7 @@ -- socket and close afterwards setEnumerator :: Request -> ServerMonad () setEnumerator req = + {-# SCC "receiveRequest/setEnumerator" #-} if isChunked then liftIO $ writeIORef (rqBody req) (SomeEnumerator readChunkedTransferEncoding) @@ -370,7 +376,8 @@ parseForm :: Request -> ServerMonad Request - parseForm req = 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) @@ -379,7 +386,7 @@ maximumPOSTBodySize = 10*1024*1024 getIt :: ServerMonad Request - getIt = do + getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum let i = joinI $ takeNoMoreThan maximumPOSTBodySize stream2stream @@ -391,42 +398,43 @@ return $ req { rqParams = rqParams req `mappend` newParams } - toRequest (IRequest method uri version kvps) = do - localAddr <- gets _localAddress - localPort <- gets _localPort - remoteAddr <- gets _remoteAddr - remotePort <- gets _remotePort - localHostname <- gets _localHostname + toRequest (IRequest method uri version kvps) = + {-# SCC "receiveRequest/toRequest" #-} do + localAddr <- gets _localAddress + localPort <- gets _localPort + remoteAddr <- gets _remoteAddr + remotePort <- gets _remotePort + localHostname <- gets _localHostname - let (serverName, serverPort) = fromMaybe - (localHostname, localPort) - (liftM (parseHost . head) - (Map.lookup "host" hdrs)) + let (serverName, serverPort) = fromMaybe + (localHostname, localPort) + (liftM (parseHost . head) + (Map.lookup "host" hdrs)) - -- will override in "setEnumerator" - enum <- liftIO $ newIORef $ SomeEnumerator return + -- will override in "setEnumerator" + enum <- liftIO $ newIORef $ SomeEnumerator return - return $ Request serverName - serverPort - remoteAddr - remotePort - localAddr - localPort - localHostname - isSecure - hdrs - enum - mbContentLength - method - version - cookies - snapletPath - pathInfo - contextPath - uri - queryString - params + return $ Request serverName + serverPort + remoteAddr + remotePort + localAddr + localPort + localHostname + isSecure + hdrs + enum + mbContentLength + method + version + cookies + snapletPath + pathInfo + contextPath + uri + queryString + params where snapletPath = "" -- TODO: snaplets in v0.2 diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -62,7 +62,7 @@ timestampedLogEntry msg = do timeStr <- getLogDateString - return $ runPut $ do + return $! runPut $! do putWord8 $ c2w '[' putByteString timeStr putByteString "] " @@ -81,14 +81,14 @@ -> ByteString -- ^ user agent (up to you to ensure -- there are no quotes in here) -> IO ByteString -combinedLogEntry host mbUser req status mbNumBytes mbReferer userAgent = do +combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent = do let user = fromMaybe "-" mbUser let numBytes = maybe "-" (\s -> strict $ show s) mbNumBytes let referer = maybe "-" (\s -> S.concat ["\"", s, "\""]) mbReferer timeStr <- getLogDateString - let p = [ host + let !p = [ host , " - " , user , " [" @@ -105,9 +105,11 @@ , userAgent , "\"" ] - return $ S.concat p + let !output = S.concat p + return $! output + where strict = S.concat . L.toChunks @@ -116,8 +118,8 @@ -- if you want a fancy log message you'll have to format it yourself -- (or use 'combinedLogEntry'). logMsg :: Logger -> ByteString -> IO () -logMsg lg s = do - let s' = S.snoc s '\n' +logMsg !lg !s = do + let !s' = S.snoc s '\n' atomicModifyIORef (_queuedMessages lg) $ \d -> (D.snoc d s',()) tryPutMVar (_dataWaiting lg) () >> return () @@ -150,7 +152,7 @@ initialize = do lh <- openIt href <- newIORef lh - t <- getCurrentTime + t <- getCurrentDateTime tref <- newIORef t return (href, tref) @@ -161,17 +163,17 @@ closeIt h - flushIt (href, lastOpened) = do + flushIt (!href, !lastOpened) = do dl <- atomicModifyIORef queue $ \x -> (D.empty,x) - let msgs = D.toList dl - let s = L.fromChunks msgs + let !msgs = D.toList dl + let !s = L.fromChunks msgs h <- readIORef href L.hPut h s hFlush h -- close the file every 15 minutes (for log rotation) - t <- getCurrentTime + t <- getCurrentDateTime old <- readIORef lastOpened if diffUTCTime t old > 900 @@ -182,17 +184,16 @@ else return () - loop (href, lastOpened) = do + loop !d = do -- wait on the notification mvar _ <- takeMVar notifier -- grab the queued messages and write them out - flushIt (href, lastOpened) + flushIt d -- at least five seconds between log dumps threadDelay 5000000 - - loop (href, lastOpened) + loop d -- | Kills a logger thread, causing any unwritten contents to be diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -37,7 +37,7 @@ old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4, - snap-core == 0.1.1, + snap-core >= 0.2.1 && <0.3, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, @@ -87,7 +87,7 @@ network == 2.2.1.*, network-bytestring >= 0.1.2 && < 0.2, sendfile >= 0.6.1 && < 0.7, - snap-core == 0.1.1, + snap-core >= 0.2.1 && <0.3, time, transformers, unix, diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -323,8 +323,10 @@ -echoServer :: Request -> Iteratee IO (Request,Response) -echoServer req = do +echoServer :: (ByteString -> IO ()) + -> Request + -> Iteratee IO (Request,Response) +echoServer _ req = do se <- liftIO $ readIORef (rqBody req) let (SomeEnumerator enum) = se let i = joinIM $ enum stream2stream @@ -337,9 +339,9 @@ , rspContentLength = Just $ fromIntegral cl } -echoServer2 :: Request -> Iteratee IO (Request,Response) -echoServer2 req = do - (rq,rsp) <- echoServer req +echoServer2 :: ServerHandler +echoServer2 _ req = do + (rq,rsp) <- echoServer (const $ return ()) req return (rq, addCookie cook rsp) where cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") @@ -412,8 +414,8 @@ where lower = S.map (c2w . toLower . w2c) . S.concat . L.toChunks - f :: Request -> Iteratee IO (Request, Response) - f req = do + f :: ServerHandler + f _ req = do let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd" let out = enumLBS s return (req, emptyResponse { rspBody = Enum out }) @@ -439,8 +441,17 @@ let (iter,onSendFile) = mkIter ref - runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384 - Nothing Nothing enumBody iter onSendFile echoServer2 + runHTTP "localhost" + "127.0.0.1" + 80 + "127.0.0.1" + 58384 + Nothing + Nothing + enumBody + iter + onSendFile + echoServer2 s <- readIORef ref @@ -494,9 +505,13 @@ testServerStartupShutdown :: Test testServerStartupShutdown = testCase "startup/shutdown" $ do - tid <- forkIO $ httpServe "*" port "localhost" - (Just "test-access.log") (Just "test-error.log") $ - runSnap pongServer + tid <- forkIO $ + httpServe "*" + port + "localhost" + (Just "test-access.log") + (Just "test-error.log") + (runSnap pongServer) waitabit rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/")