packages feed

snap-server 0.1.4 → 0.2.1

raw patch · 7 files changed

+117/−93 lines, 7 filesdep ~hlibevdep ~snap-core

Dependency ranges changed: hlibev, snap-core

Files

README.SNAP.md view
@@ -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
README.md view
@@ -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
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Server.hs view
@@ -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
src/System/FastLogger.hs view
@@ -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
test/snap-server-testsuite.cabal view
@@ -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,
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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/")