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.2.11 +version: 0.2.12 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 @@ -57,22 +57,24 @@ README.SNAP.md, test/benchmark/Benchmark.hs, test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs, + test/benchmark/Snap/Internal/Http/Parser/Data.hs, + test/common/Paths_snap_server.hs, + test/common/Snap/Test/Common.hs, + test/common/Test/Common/TestHandler.hs, + test/common/Test/Common/Rot13.hs, test/data/fileServe/foo.bin, test/data/fileServe/foo.bin.bin.bin, test/data/fileServe/foo.html, test/data/fileServe/foo.txt, test/pongserver/Main.hs, - test/pongserver/Paths_snap_server.hs, test/runTestsAndCoverage.sh, test/snap-server-testsuite.cabal, - test/suite/Paths_snap_server.hs, test/suite/Data/Concurrent/HashMap/Tests.hs, test/suite/Snap/Internal/Http/Parser/Tests.hs, test/suite/Snap/Internal/Http/Server/Tests.hs, - test/suite/Snap/Test/Common.hs, + test/suite/Test/Blackbox.hs, test/suite/TestSuite.hs, test/testserver/Main.hs, - test/testserver/Paths_snap_server.hs, test/testserver/static/hello.txt @@ -120,7 +122,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale, - snap-core >= 0.2.11 && <0.3, + snap-core >= 0.2.12 && <0.3, template-haskell, time, transformers, diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -30,9 +30,10 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Nums.Careless.Hex as Cvt import Data.Char +import Data.DList (DList) +import qualified Data.DList as D import Data.List (foldl') import Data.Int -import Data.IORef import Data.Iteratee.WrappedByteString import Data.Map (Map) import qualified Data.Map as Map @@ -40,15 +41,12 @@ import qualified Data.Vector.Unboxed as Vec import Data.Vector.Unboxed (Vector) import Data.Word (Word8, Word64) -import Foreign.C.Types -import Foreign.ForeignPtr import Prelude hiding (take, takeWhile) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types hiding (Enumerator) import Snap.Iteratee hiding (take, foldl', filter) - ------------------------------------------------------------------------------ -- | an internal version of the headers part of an HTTP request data IRequest = IRequest @@ -98,9 +96,9 @@ | n .&. 0xf000000000000000 == 0 = trim (i-1) (n `shiftL` 4) | otherwise = fst (S.unfoldrN i f n) - f n = Just (char (n `shiftR` 60), n `shiftL` 4) + f n = Just (ch (n `shiftR` 60), n `shiftL` 4) - char (fromIntegral -> i) + ch (fromIntegral -> i) | i < 10 = (c2w '0' - 0) + i | otherwise = (c2w 'a' - 10) + i @@ -118,50 +116,58 @@ -- > -- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty -- -writeChunkedTransferEncoding :: ForeignPtr CChar - -> Enumerator IO a - -> Enumerator IO a -writeChunkedTransferEncoding buf enum it = do - killwrap <- newIORef False - (out,_) <- unsafeBufferIterateeWithBuffer buf - (ignoreEOF $ wrap killwrap it) - i <- enum out - v <- runIter i (EOF Nothing) - j <- checkIfDone return v - writeIORef killwrap True - w <- runIter j (Chunk (WrapBS "0\r\n\r\n")) - checkIfDone return w +writeChunkedTransferEncoding :: Enumerator IO a +writeChunkedTransferEncoding it = do + let out = wrap it + return out where - ignoreEOF iter = IterateeG $ \s -> + wrap iter = bufIt (0,D.empty) iter + + bufSiz = 16284 + + sendOut :: DList ByteString + -> Iteratee IO a + -> IO (Iteratee IO a) + sendOut dl iter = do + let chunks = D.toList dl + let bs = L.fromChunks chunks + let n = L.length bs + + if n == 0 + then return iter + else do + let o = L.concat [ L.fromChunks [ toHex (toEnum . fromEnum $ n) + , "\r\n" ] + , bs + , "\r\n" ] + + enumLBS o iter + + + bufIt (n,dl) iter = IterateeG $ \s -> do case s of - (EOF Nothing) -> return $ Cont iter Nothing - _ -> do - i <- runIter iter s >>= checkIfDone return - return $ Cont (ignoreEOF i) Nothing + (EOF Nothing) -> do + i' <- sendOut dl iter + j <- liftM liftI $ runIter i' (Chunk (WrapBS "0\r\n\r\n")) + runIter j (EOF Nothing) - wrap killwrap iter = IterateeG $ \s -> do - quit <- readIORef killwrap + (EOF e) -> return $ Cont undefined e - if quit - then runIter iter s - else case s of - (EOF Nothing) -> do - return $ Cont iter Nothing + (Chunk (WrapBS x)) -> do + let m = S.length x - (EOF e) -> return $ Cont undefined e - (Chunk (WrapBS x)) -> do - let n = S.length x - if n == 0 - then do - return $ Cont iter Nothing - else do - let o = S.concat [ toHex (toEnum n) - , "\r\n" - , x - , "\r\n" ] - i <- liftM liftI $ runIter iter (Chunk $ WrapBS o) - return $ Cont (wrap killwrap i) Nothing + if m == 0 + then return $ Cont (bufIt (n,dl) iter) Nothing + else do + let n' = m + n + let dl' = D.snoc dl x + + if n' > bufSiz + then do + i' <- sendOut dl' iter + return $ Cont (bufIt (0,D.empty) i') Nothing + else return $ Cont (bufIt (n',dl') iter) Nothing ------------------------------------------------------------------------------ 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server where @@ -156,7 +157,6 @@ elog <- maybeSpawnLogger efp return (alog, elog)) (\(alog, elog) -> do - threadDelay 1000000 maybe (return ()) stopLogger alog maybe (return ()) stopLogger elog) @@ -206,7 +206,7 @@ , Handler $ \(e :: AsyncException) -> do logE elog $ S.concat [ "Server.httpServe.go: got async exception, " - , "terminating:\n", bshow e ] + , "terminating: ", bshow e ] throwIO e , Handler $ \(e :: Backend.BackendTerminatedException) -> do @@ -299,9 +299,10 @@ go = do buf <- mkIterateeBuffer - let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $ - httpSession writeEnd buf onSendFile tickle - handler + let iter1 = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $ + httpSession writeEnd buf onSendFile tickle + handler + let iter = iterateeDebugWrapper "httpSession iteratee" iter1 readEnd iter >>= run @@ -335,16 +336,15 @@ -> ServerMonad () httpSession writeEnd' ibuf onSendFile tickle handler = do - (writeEnd, cancelBuffering) <- - liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' - - -- (writeEnd, cancelBuffering) <- liftIO $ I.bufferIteratee writeEnd' - let killBuffer = writeIORef cancelBuffering True + writeEnd1 <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' + let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd1 liftIO $ debug "Server.httpSession: entered" mreq <- receiveRequest + + -- successfully got a request, so restart timer liftIO tickle @@ -359,6 +359,7 @@ checkExpect100Continue req writeEnd logerr <- gets _logError + (req',rspOrig) <- lift $ handler logerr req liftIO $ debug $ "Server.httpSession: finished running user handler" @@ -372,16 +373,18 @@ else rspTmp liftIO $ debug "Server.httpSession: handled, skipping request body" + srqEnum <- liftIO $ readIORef $ rqBody req' let (SomeEnumerator rqEnum) = srqEnum - lift $ joinIM $ rqEnum skipToEof + lift $ joinIM + $ rqEnum (iterateeDebugWrapper "httpSession/skipToEof" skipToEof) liftIO $ debug $ "Server.httpSession: request body skipped, " ++ "sending response" date <- liftIO getDateString let ins = Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp - (bytesSent,_) <- sendResponse rsp' writeEnd ibuf killBuffer onSendFile + (bytesSent,_) <- sendResponse rsp' writeEnd onSendFile liftIO . debug $ "Server.httpSession: sent " ++ (Prelude.show bytesSent) ++ " bytes" @@ -469,13 +472,13 @@ hasContentLength :: Int -> ServerMonad () hasContentLength l = do liftIO $ debug $ "receiveRequest/setEnumerator: " ++ - "request had content-length" + "request had content-length " ++ Prelude.show l liftIO $ writeIORef (rqBody req) (SomeEnumerator e) liftIO $ debug "receiveRequest/setEnumerator: body enumerator set" where e :: Enumerator IO a - e = return . joinI . I.take l . - iterateeDebugWrapper "rqBody iterator" + e it = return $ joinI $ I.take l $ + iterateeDebugWrapper "rqBody iterator" it noContentLength :: ServerMonad () noContentLength = do @@ -601,29 +604,33 @@ ------------------------------------------------------------------------------ -- Response must be well-formed here -sendResponse :: Response +sendResponse :: forall a . Response -> Iteratee IO a - -> ForeignPtr CChar - -> IO () -> (FilePath -> Int64 -> IO a) -> ServerMonad (Int64, a) -sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do +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 + (Enum e) -> lift $ whenEnum headerString rsp e + (SendFile f) -> lift $ whenSendFile headerString rsp f return $! (bs,x) where -------------------------------------------------------------------------- - whenEnum hs e = do - let enum = enumBS hs >. e - let hl = fromIntegral $ S.length hs + whenEnum :: ByteString + -> Response + -> (forall x . Enumerator IO x) + -> Iteratee IO (a,Int64) + whenEnum hs rsp e = do + let enum = if rspTransformingRqBody rsp + then enumBS hs >. e + else enumBS hs >. e >. enumEof - (x,bs) <- liftIO $ enum (countBytes writeEnd) >>= run + let hl = fromIntegral $ S.length hs + (x,bs) <- joinIM $ enum (countBytes writeEnd) return (x, bs-hl) @@ -631,10 +638,10 @@ -------------------------------------------------------------------------- whenSendFile hs r f = do -- guaranteed to have a content length here. - enumBS hs writeEnd >>= run + joinIM $ (enumBS hs >. enumEof) writeEnd let !cl = fromJust $ rspContentLength r - x <- onSendFile f cl + x <- liftIO $ onSendFile f cl return (x, cl) @@ -663,10 +670,11 @@ let sendChunked = (rspHttpVersion r) == (1,1) if sendChunked then do - liftIO $ killBuffering let r' = setHeader "Transfer-Encoding" "chunked" r - let e = writeChunkedTransferEncoding ibuf $ - rspBodyToEnum $ rspBody r + let origE = rspBodyToEnum $ rspBody r + + let e i = writeChunkedTransferEncoding i >>= origE + return $ r' { rspBody = Enum e } else do @@ -690,7 +698,7 @@ return $ r' { rspBody = b } where - i :: Enumerator IO a -> Enumerator IO a + i :: forall z . Enumerator IO z -> Enumerator IO z i enum iter = enum (joinI $ takeExactly cl iter) diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -9,9 +9,9 @@ module Snap.Internal.Http.Server.LibevBackend ( Backend - , BackendTerminatedException + , BackendTerminatedException(..) , Connection - , TimeoutException + , TimeoutException(..) , name , debug , bindIt @@ -47,11 +47,10 @@ import Foreign hiding (new) import Foreign.C.Error import Foreign.C.Types -import GHC.Conc (forkOnIO) +import GHC.Conc (forkOnIO, numCapabilities) import Network.Libev import Network.Socket import Prelude hiding (catch) -import System.Timeout ------------------------------------------------------------------------------ -- FIXME: should be HashSet, make that later. @@ -80,8 +79,9 @@ , _asyncObj :: !EvAsyncPtr , _killCb :: !(FunPtr AsyncCallback) , _killObj :: !EvAsyncPtr - , _connectionThreads :: !(HashMap ThreadId ()) + , _connectionThreads :: !(HashMap ThreadId Connection) , _backendCPU :: !Int + , _backendFreed :: !(MVar ()) } @@ -216,6 +216,9 @@ -- thread set stuff connSet <- H.new (H.hashString . show) + -- freed gets stuffed with () when all resources are released. + freed <- newEmptyMVar + let b = Backend sock sockFd connq @@ -230,6 +233,7 @@ killObj connSet cpu + freed forkOnIO cpu $ loopThread b @@ -244,9 +248,11 @@ (ignoreException go) `finally` cleanup debug $ "loop finished" where - cleanup = do + cleanup = block $ do debug $ "loopThread: cleaning up" ignoreException $ freeBackend backend + putMVar (_backendFreed backend) () + lock = _loopLock backend loop = _evLoop backend go = takeMVar lock >> block (evLoop loop 0) @@ -288,43 +294,28 @@ writeIORef active False -seconds :: Int -> Int -seconds n = n * ((10::Int)^(6::Int)) - - stop :: Backend -> IO () stop b = ignoreException $ do debug $ "Backend.stop" - -- FIXME: what are we gonna do here? - -- -- 1. take the loop lock -- 2. shut down the accept() callback -- 3. stuff a poison pill (a bunch of -1 values should do) down the -- connection queue so that withConnection knows to throw an exception -- back up to its caller - -- 4. release the loop lock - -- 5. wait until all of the threads have finished, or until 10 seconds have - -- elapsed, whichever comes first - -- 6. take the loop lock - -- 7. call evUnloop and wake up the loop using evAsyncSend - -- 8. release the loop lock, the main loop thread should then free/clean + -- 4. call evUnloop and wake up the loop using evAsyncSend + -- 5. release the loop lock, the main loop thread should then free/clean -- everything up (threads, connections, io objects, callbacks, etc) + -- 6. wait for the loop thread to signal it has cleaned up and exited withMVar lock $ \_ -> do evIoStop loop acceptObj - replicateM_ 10 $ writeChan connQ (-1) - - debug $ "Backend.stop: waiting at most 10 seconds for connection threads to die" - waitForThreads b $ seconds 10 - debug $ "Backend.stop: all threads presumed dead, unlooping" - - withMVar lock $ \_ -> do + replicateM_ (numCapabilities*2) $ writeChan connQ (-1) evUnloop loop evunloop_all evAsyncSend loop killObj - debug $ "unloop sent" - + debug $ "accepting threads killed, unloop sent, waiting for completion" + takeMVar $ _backendFreed b where loop = _evLoop b @@ -335,18 +326,6 @@ -waitForThreads :: Backend -> Int -> IO () -waitForThreads backend t = timeout t wait >> return () - where - threadSet = _connectionThreads backend - wait = do - b <- H.null threadSet - if b - then return () - else threadDelay (seconds 1) >> wait - - - getAddr :: SockAddr -> IO (ByteString, Int) getAddr addr = case addr of @@ -370,41 +349,60 @@ now <- getCurrentDateTime whenToDie <- readIORef ioref - if whenToDie < now + if whenToDie <= now then do debug "Backend.timerCallback: killing thread" tid <- readMVar tmv throwTo tid TimeoutException else do - evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now) - evTimerAgain loop tmr + debug $ "Backend.timerCallback: now=" ++ show now + ++ ", whenToDie=" ++ show whenToDie + evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now) + evTimerAgain loop tmr -freeConnection :: Connection -> IO () -freeConnection conn = ignoreException $ do - withMVar loopLock $ \_ -> block $ do - debug $ "freeConnection (" ++ show fd ++ ")" +-- if you already hold the loop lock, you are entitled to destroy a connection +destroyConnection :: Connection -> IO () +destroyConnection conn = do + debug "Backend.destroyConnection: closing socket and killing connection" + c_close fd - c_close fd + -- stop and free timer object + evTimerStop loop timerObj + freeEvTimer timerObj + freeTimerCallback timerCb - -- stop and free timer object - evTimerStop loop timerObj - freeEvTimer timerObj - freeTimerCallback timerCb + -- stop and free i/o objects + evIoStop loop ioWrObj + freeEvIo ioWrObj + freeIoCallback ioWrCb - -- stop and free i/o objects - evIoStop loop ioWrObj - freeEvIo ioWrObj - freeIoCallback ioWrCb + evIoStop loop ioRdObj + freeEvIo ioRdObj + freeIoCallback ioRdCb - evIoStop loop ioRdObj - freeEvIo ioRdObj - freeIoCallback ioRdCb + where + backend = _backend conn + loop = _evLoop backend + fd = _socketFd conn + ioWrObj = _connWriteIOObj conn + ioWrCb = _connWriteIOCallback conn + ioRdObj = _connReadIOObj conn + ioRdCb = _connReadIOCallback conn + timerObj = _timerObj conn + timerCb = _timerCallback conn + + +freeConnection :: Connection -> IO () +freeConnection conn = ignoreException $ do + withMVar loopLock $ \_ -> block $ do + debug $ "freeConnection (" ++ show fd ++ ")" + destroyConnection conn tid <- readMVar $ _connThread conn - -- removal the thread id from the backend set + -- remove the thread id from the backend set H.delete tid $ _connectionThreads backend -- wake up the event loop so it can be apprised of the changes @@ -415,14 +413,7 @@ loop = _evLoop backend loopLock = _loopLock backend asyncObj = _asyncObj backend - fd = _socketFd conn - ioWrObj = _connWriteIOObj conn - ioWrCb = _connWriteIOCallback conn - ioRdObj = _connReadIOObj conn - ioRdCb = _connReadIOCallback conn - timerObj = _timerObj conn - timerCb = _timerCallback conn ignoreException :: IO () -> IO () @@ -431,15 +422,26 @@ freeBackend :: Backend -> IO () freeBackend backend = ignoreException $ block $ do - -- note: we only get here after an unloop - + -- note: we only get here after an unloop, so we have the loop lock + -- here. (?) -- kill everything in thread table tset <- H.toList $ _connectionThreads backend + + let nthreads = Prelude.length tset + + debug $ "Backend.freeBackend: killing active connection threads" + + Prelude.mapM_ (destroyConnection . snd) tset + + -- kill the threads twice, they're probably getting stuck in the + -- freeConnection 'finally' handler Prelude.mapM_ (killThread . fst) tset + Prelude.mapM_ (killThread . fst) tset - debug $ "Backend.freeBackend: all threads killed" - debug $ "Backend.freeBackend: destroying resources" + debug $ "Backend.freeBackend: " ++ show nthreads ++ " thread(s) killed" + debug $ "Backend.freeBackend: destroying libev resources" + freeEvIo acceptObj freeIoCallback acceptCb c_close fd @@ -474,7 +476,10 @@ withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () withConnection backend cpu proc = go where - threadProc conn = ignoreException (proc conn) `finally` freeConnection conn + threadProc conn = (do + x <- blocked + debug $ "withConnection/threadProc: we are blocked? " ++ show x + proc conn) `finally` freeConnection conn go = do debug $ "withConnection: reading from chan" @@ -563,7 +568,7 @@ tid <- forkOnIO cpu $ threadProc conn - H.update tid () (_connectionThreads backend) + H.update tid conn (_connectionThreads backend) putMVar thrmv tid @@ -636,7 +641,7 @@ tickleTimeout conn = do debug "Backend.tickleTimeout" now <- getCurrentDateTime - writeIORef (_timerTimeoutTime conn) (now + 20) + writeIORef (_timerTimeoutTime conn) (now + 30) recvData :: Connection -> Int -> IO ByteString diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs --- a/src/Snap/Internal/Http/Server/SimpleBackend.hs +++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs @@ -9,9 +9,9 @@ module Snap.Internal.Http.Server.SimpleBackend ( Backend - , BackendTerminatedException + , BackendTerminatedException(..) , Connection - , TimeoutException + , TimeoutException(..) , name , debug , bindIt @@ -33,6 +33,7 @@ import Control.Concurrent import Control.Exception +import Control.Monad import Data.ByteString (ByteString) import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString as B @@ -72,10 +73,15 @@ type TimeoutTable = PSQ ThreadId CTime +type QueueElem = Maybe (Socket,SockAddr) + data Backend = Backend - { _acceptSocket :: !Socket - , _timeoutEdits :: !(IORef (DList (TimeoutTable -> TimeoutTable))) - , _timeoutThread :: !(MVar ThreadId) } + { _acceptSocket :: !Socket + , _acceptThread :: !ThreadId + , _timeoutEdits :: !(IORef (DList (TimeoutTable -> TimeoutTable))) + , _timeoutThread :: !(MVar ThreadId) + , _connectionQueue :: !(Chan QueueElem) + } data Connection = Connection { _backend :: Backend @@ -127,49 +133,92 @@ return sock +acceptThread :: Socket -> Chan QueueElem -> IO () +acceptThread sock connq = loop `finally` cleanup + where + loop = do + debug $ "acceptThread: calling accept()" + s@(_,addr) <- accept sock + debug $ "acceptThread: accepted connection from remote: " ++ show addr + debug $ "acceptThread: queueing" + writeChan connq $ Just s + loop + + cleanup = block $ do + debug $ "acceptThread: cleanup, closing socket and notifying " + ++ "chan listeners" + sClose sock + replicateM 10 $ writeChan connq Nothing + + new :: Socket -- ^ value you got from bindIt -> Int -> IO Backend -new sock _ = do +new sock cpu = do debug $ "Backend.new: listening" - ed <- newIORef D.empty - t <- newEmptyMVar + ed <- newIORef D.empty + t <- newEmptyMVar - let b = Backend sock ed t + connq <- newChan + accThread <- forkOnIO cpu $ acceptThread sock connq - tid <- forkIO $ timeoutThread b PSQ.empty + let b = Backend sock accThread ed t connq + + tid <- forkIO $ timeoutThread b putMVar t tid return b -timeoutThread :: Backend -> TimeoutTable -> IO () -timeoutThread backend = loop - where - loop tt = do - tt' <- killTooOld tt +timeoutThread :: Backend -> IO () +timeoutThread backend = do + tref <- newIORef $ PSQ.empty + let loop = do + killTooOld tref threadDelay (5000000) - loop tt' + loop + loop `catch` (\(_::SomeException) -> killAll tref) - killTooOld table = do - -- atomic swap edit list - now <- getCurrentDateTime + where + applyEdits table = do edits <- atomicModifyIORef tedits $ \t -> (D.empty, D.toList t) + return $ foldl' (flip ($)) table edits - let table' = foldl' (flip ($)) table edits - !t' <- killOlderThan now table' - return t' + killTooOld tref = do + !table <- readIORef tref + -- atomic swap edit list + now <- getCurrentDateTime + table' <- applyEdits table + !t' <- killOlderThan now table' + writeIORef tref t' - -- timeout = 60 seconds - tIMEOUT = 60 + -- timeout = 30 seconds + tIMEOUT = 30 + killAll !tref = do + debug "Backend.timeoutThread: shutdown, killing all connections" + !table <- readIORef tref + !table' <- applyEdits table + go table' + where + go !t = maybe (return ()) + (\m -> (killThread $ PSQ.key m) >> + (go $ PSQ.deleteMin t)) + (PSQ.findMin t) + killOlderThan now !table = do + debug "Backend.timeoutThread: killing old connections" let mmin = PSQ.findMin table maybe (return table) - (\m -> if now - PSQ.prio m > tIMEOUT + (\m -> do + debug $ "Backend.timeoutThread: minimum value " + ++ show (PSQ.prio m) ++ ", cutoff=" + ++ show (now - tIMEOUT) + + if now - PSQ.prio m >= tIMEOUT then do killThread $ PSQ.key m killOlderThan now $ PSQ.deleteMin table @@ -180,15 +229,22 @@ stop :: Backend -> IO () -stop (Backend s _ t) = do - debug $ "Backend.stop" - sClose s +stop backend = do + debug $ "Backend.stop: killing accept thread" + killThread acthr - -- kill timeout thread and current thread - readMVar t >>= killThread - myThreadId >>= killThread + debug $ "Backend.stop: killing timeout thread" + -- kill timeout thread; timeout thread handler will stop all of the running + -- connection threads + readMVar tthr >>= killThread + debug $ "Backend.stop: exiting.." + where + acthr = _acceptThread backend + tthr = _timeoutThread backend + + data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) @@ -200,14 +256,19 @@ withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () withConnection backend cpu proc = do - debug $ "Backend.withConnection: calling accept()" - let asock = _acceptSocket backend - (sock,addr) <- accept asock + debug $ "Backend.withConnection: reading from chan" + qelem <- readChan $ _connectionQueue backend + when (qelem == Nothing) $ do + debug $ "Backend.withConnection: channel terminated, throwing " + ++ "BackendTerminatedException" + throwIO BackendTerminatedException + + let (Just (sock,addr)) = qelem let fd = fdSocket sock - debug $ "Backend.withConnection: accepted connection" - debug $ "Backend.withConnection: remote: " ++ show addr + debug $ "Backend.withConnection: dequeued connection from remote: " + ++ show addr (port,host) <- case addr of @@ -233,7 +294,7 @@ labelMe $ "connHndl " ++ show fd bracket (return c) (\_ -> block $ do - debug "sClose sock" + debug "thread killed, closing socket" thr <- readMVar tmvar -- remove thread from timeout table @@ -312,8 +373,9 @@ tedits = _timeoutEdits $ _backend conn -cancelTimeout :: Connection -> IO () -cancelTimeout conn = do +_cancelTimeout :: Connection -> IO () +_cancelTimeout conn = do + debug "Backend.cancelTimeout" tid <- readMVar $ _connTid conn atomicModifyIORef tedits $ \es -> (D.snoc es (PSQ.delete tid), ()) diff --git a/test/benchmark/Benchmark.hs b/test/benchmark/Benchmark.hs --- a/test/benchmark/Benchmark.hs +++ b/test/benchmark/Benchmark.hs @@ -1,15 +1,7 @@ module Main where -import Criterion.Main - +import Criterion.Main import qualified Snap.Internal.Http.Parser.Benchmark as PB -fib :: Int -> Int -fib 0 = 0 -fib 1 = 1 -fib n = fib (n-1) + fib (n-2) - main :: IO () -main = defaultMain [ - PB.benchmarks - ] +main = defaultMain [ PB.benchmarks ] diff --git a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs --- a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs +++ b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs @@ -1,36 +1,40 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Parser.Benchmark ( benchmarks ) where -import Criterion.Main -import Snap.Internal.Http.Parser -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Snap.Iteratee as SI -import qualified Control.Exception as E -import Data.Attoparsec hiding (Result(..)) +import Criterion.Main hiding (run) +import Snap.Internal.Http.Parser +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Snap.Iteratee as SI +import qualified Control.Exception as E +import Data.Attoparsec hiding (Result(..)) +import Snap.Internal.Http.Parser.Data +import "monads-fd" Control.Monad.Identity +import Data.Iteratee +import Data.Iteratee.WrappedByteString +import Snap.Iteratee hiding (take, foldl', filter) +import qualified Data.ByteString.Lazy.Char8 as L -req1 = S.concat - [ "GET /favicon.ico HTTP/1.1\r\n" - , "Host: 0.0.0.0=5000\r\n" - , "User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9) Gecko/2008061015 Firefox/3.0\r\n" - , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n" - , "Accept-Language: en-us,en;q=0.5\r\n" - , "Accept-Encoding: gzip,deflate\r\n" - , "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n" - , "Keep-Alive: 300\r\n" - , "Connection: keep-alive\r\n" - , "\r\n" ] +parseGet :: IO () +parseGet = SI.enumBS parseGetData parseRequest >>= SI.run >> return () -test1 :: IO () -test1 = do - i <- SI.enumBS req1 parseRequest +parseChunked :: IO () +parseChunked = do + c <- toChunked parseChunkedData + i <- SI.enumLBS c (readChunkedTransferEncoding stream2stream) f <- SI.run i return () +-- utils +toChunked lbs = writeChunkedTransferEncoding stream2stream >>= + enumLBS lbs >>= run >>= return . fromWrap + benchmarks = bgroup "parser" - [ bench "firefoxget" $ whnfIO test1 ] + [ bench "firefoxget" $ whnfIO parseGet + , bench "readChunkedTransferEncoding" $ whnfIO parseChunked ] diff --git a/test/benchmark/Snap/Internal/Http/Parser/Data.hs b/test/benchmark/Snap/Internal/Http/Parser/Data.hs new file mode 100644 --- /dev/null +++ b/test/benchmark/Snap/Internal/Http/Parser/Data.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Internal.Http.Parser.Data + ( parseGetData + , parseChunkedData + ) + where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +parseGetData = S.concat + [ "GET /favicon.ico HTTP/1.1\r\n" + , "Host: 0.0.0.0=5000\r\n" + , "User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9) Gecko/2008061015 Firefox/3.0\r\n" + , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n" + , "Accept-Language: en-us,en;q=0.5\r\n" + , "Accept-Encoding: gzip,deflate\r\n" + , "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n" + , "Keep-Alive: 300\r\n" + , "Connection: keep-alive\r\n" + , "\r\n" ] + +parseChunkedData = L.fromChunks ["In the beginning, everything was void, and J.H.W.H. Conway began to create numbers.", "Conway said, \"Let there be two rules which bring forth all numbers larege and small.", "This shall be the first rule: Every number corresponds to two sets of previously created numbers, such that no member of the left set is greater than or equal to any member of the right set.", "And the second rule shall be this: One number is less than or equal to another number if and only if no member of the first number \'s left set is greater than or equal to the second number, and no member of the second number\'s right set is less than or equal to the first number.\" And Conway examined these two rules he had made, and behold! They were very good.", "And the first number was created from the void left set and the void right set. Conway called this number \"zero,\" and said that it shall be a sign to separate positive numbers from negative numbers.", "Conway proved that zero was less than or equal to zero, end he saw that it was good.", "And the evening and the morning were the day of zero.", "On the next day, two more numbers were created, one with zero as its left set and one with zero as its right set. And Conway called the former number \"one,\" and the latter he called \"minus one.\" And he proved that minus one is less than but not equal to zero and zero is less than but not equal to one.", "And the evening day.", "And Conway said, \"Let the numbers be added to each other in this wise: The left set of the sum of two numbers shall be the sums of all left parts of each number with the other; and in like manner the right set shall be from the right parts, each according to its kind.\" Conway proved that every number plus zero is unchanged, and he saw that addition was good.", "And the evening and the morning were the third day."] diff --git a/test/common/Paths_snap_server.hs b/test/common/Paths_snap_server.hs new file mode 100644 --- /dev/null +++ b/test/common/Paths_snap_server.hs @@ -0,0 +1,9 @@ +module Paths_snap_server ( + version + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} + diff --git a/test/common/Snap/Test/Common.hs b/test/common/Snap/Test/Common.hs new file mode 100644 --- /dev/null +++ b/test/common/Snap/Test/Common.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Snap.Test.Common where + +import Control.Exception (SomeException) +import Control.Monad +import Control.Monad.CatchIO +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal (c2w) +import qualified Data.DList as D +import Network.Socket +import qualified Network.Socket.ByteString as N +import Prelude hiding (catch) +import Test.QuickCheck +import System.Timeout + +import Snap.Internal.Iteratee.Debug () + + +instance Arbitrary S.ByteString where + arbitrary = liftM (S.pack . map c2w) arbitrary + +instance Arbitrary L.ByteString where + arbitrary = do + n <- choose(0,5) + chunks <- replicateM n arbitrary + return $ L.fromChunks chunks + + + +expectExceptionBeforeTimeout :: IO a -- ^ action to run + -> Int -- ^ number of seconds to expect + -- exception by + -> IO Bool +expectExceptionBeforeTimeout act nsecs = do + x <- timeout (nsecs * (10::Int)^(6::Int)) f + case x of + Nothing -> return False + (Just y) -> return y + + where + f = (act >> return False) `catch` \(e::SomeException) -> do + if show e == "<>" + then return False + else return True + + +withSock :: Int -> (Socket -> IO a) -> IO a +withSock port go = do + addr <- liftM (addrAddress . Prelude.head) $ + getAddrInfo (Just myHints) + (Just "127.0.0.1") + (Just $ show port) + + sock <- socket AF_INET Stream defaultProtocol + connect sock addr + + go sock `finally` sClose sock + + where + myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] } + + +recvAll :: Socket -> IO ByteString +recvAll sock = do + d <- f D.empty sock + return $ S.concat $ D.toList d + + where + f d sk = do + s <- N.recv sk 100000 + if S.null s + then return d + else f (D.snoc d s) sk + + +ditchHeaders :: [ByteString] -> [ByteString] +ditchHeaders ("":xs) = xs +ditchHeaders ("\r":xs) = xs +ditchHeaders (_:xs) = ditchHeaders xs +ditchHeaders [] = [] + diff --git a/test/common/Test/Common/Rot13.hs b/test/common/Test/Common/Rot13.hs new file mode 100644 --- /dev/null +++ b/test/common/Test/Common/Rot13.hs @@ -0,0 +1,19 @@ +module Test.Common.Rot13 (rot13) where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.Char + +rotone :: Char -> Char +rotone x | acc x = f + | otherwise = x + where + aA = ord 'A' + aa = ord 'a' + xx = ord x + f = g $ if isAsciiUpper x then aA else aa + g st = chr $ st + (xx - st + 13) `mod` 26 + acc c = isAlpha c && (isAsciiUpper c || isAsciiLower c) + +rot13 :: ByteString -> ByteString +rot13 = S.map rotone diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs new file mode 100644 --- /dev/null +++ b/test/common/Test/Common/TestHandler.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Common.TestHandler (testHandler) where + + +import Control.Monad + +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Iteratee.WrappedByteString +import Data.Maybe + +import Snap.Iteratee hiding (Enumerator) +import Snap.Types +import Snap.Http.Server +import Snap.Util.FileServe +import Snap.Internal.Iteratee.Debug +import Test.Common.Rot13 (rot13) + + +pongHandler :: Snap () +pongHandler = modifyResponse $ setResponseBody (enumBS "PONG") . + setContentType "text/plain" . + setContentLength 4 + +echoUriHandler :: Snap () +echoUriHandler = do + req <- getRequest + writeBS $ rqURI req + + +echoHandler :: Snap () +echoHandler = transformRequestBody return + + +rot13Handler :: Snap () +rot13Handler = transformRequestBody $ return . f + where + f i = IterateeG $ \ch -> do + case ch of + (EOF _) -> runIter i ch + (Chunk (WrapBS s)) -> do + i' <- liftM liftI $ runIter i $ Chunk $ WrapBS $ rot13 s + return $ Cont (f i') Nothing + + +bigResponseHandler :: Snap () +bigResponseHandler = do + let sz = 4000000 + let s = L.take sz $ L.cycle $ L.fromChunks [S.replicate 400000 '.'] + modifyResponse $ setContentLength sz + writeLBS s + + +responseHandler :: Snap () +responseHandler = do + !code <- liftM (read . S.unpack . fromMaybe "503") $ getParam "code" + modifyResponse $ setResponseCode code + writeBS $ S.pack $ show code + + +testHandler :: Snap () +testHandler = + route [ ("pong" , pongHandler ) + , ("echo" , echoHandler ) + , ("rot13" , rot13Handler ) + , ("echoUri" , echoUriHandler ) + , ("fileserve" , fileServe "testserver/static") + , ("bigresponse" , bigResponseHandler ) + , ("respcode/:code" , responseHandler ) + ] + diff --git a/test/pongserver/Paths_snap_server.hs b/test/pongserver/Paths_snap_server.hs deleted file mode 100644 --- a/test/pongserver/Paths_snap_server.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Paths_snap_server ( - version - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} - diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -2,6 +2,10 @@ set -e +if [ "x$DEBUG" == "x" ]; then + export DEBUG=testsuite +fi + SUITE=./dist/build/testsuite/testsuite rm -f *.tix @@ -25,15 +29,18 @@ EXCLUDES='Main Data.CIByteString -Data.HashMap.Concurrent.Internal -Data.HashMap.Concurrent.Tests +Data.Concurrent.HashMap.Internal +Data.Concurrent.HashMap.Tests Paths_snap_server Snap.Internal.Http.Parser.Tests Snap.Internal.Http.Server.Tests Snap.Internal.Http.Types.Tests Snap.Internal.Iteratee.Tests Text.Snap.Templates.Tests -Snap.Test.Common' +Snap.Test.Common +Test.Blackbox +Test.Common.Rot13 +Test.Common.TestHandler' EXCL="" 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 @@ -13,7 +13,7 @@ Default: False Executable testsuite - hs-source-dirs: suite ../src + hs-source-dirs: suite common ../src main-is: TestSuite.hs build-depends: @@ -40,7 +40,8 @@ old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4, - snap-core >= 0.2.10 && <0.3, + snap-core >= 0.2.12 && <0.3, + template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, @@ -64,12 +65,13 @@ if flag(portable) || os(windows) cpp-options: -DPORTABLE - ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded + ghc-options: -O2 -Wall -fhpc -fwarn-tabs + -funbox-strict-fields -threaded -fno-warn-unused-do-bind Executable pongserver - hs-source-dirs: pongserver ../src + hs-source-dirs: pongserver common ../src main-is: Main.hs build-depends: @@ -92,10 +94,12 @@ old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4, + MonadCatchIO-transformers >= 0.2.1 && < 0.3, murmur-hash >= 0.1 && < 0.2, network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, - snap-core >= 0.2.10 && <0.3, + snap-core >= 0.2.12 && <0.3, + template-haskell, time, transformers, unix-compat, @@ -143,7 +147,7 @@ Executable testserver - hs-source-dirs: testserver ../src + hs-source-dirs: testserver common ../src main-is: Main.hs build-depends: @@ -152,33 +156,35 @@ attoparsec >= 0.8.1 && < 0.9, attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, + binary >= 0.5 && < 0.6, bytestring, bytestring-nums >= 0.3.1 && < 0.4, bytestring-show >= 0.3.2 && < 0.4, - cereal >= 0.3 && < 0.4, containers, directory-tree, dlist >= 0.5 && < 0.6, filepath, haskell98, + HTTP >= 4000.0.9 && < 4001, HUnit >= 1.2 && < 2, + MonadCatchIO-transformers >= 0.2.1 && < 0.3, monads-fd, - old-locale, - parallel > 2, - iteratee >= 0.3.1 && < 0.4, murmur-hash >= 0.1 && < 0.2, network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, - snap-core >= 0.2.10 && <0.3, + old-locale, + parallel > 2, + iteratee >= 0.3.1 && < 0.4, + snap-core >= 0.2.12 && <0.3, template-haskell, + test-framework >= 0.3.1 && <0.4, + test-framework-hunit >= 0.2.5 && < 0.3, + test-framework-quickcheck2 >= 0.2.6 && < 0.3, time, transformers, - unix-compat, vector >= 0.6.0.1 && < 0.7 - if flag(portable) || os(windows) - cpp-options: -DPORTABLE - else + if !os(windows) build-depends: unix if flag(libev) @@ -191,38 +197,19 @@ other-modules: Snap.Internal.Http.Server.SimpleBackend - if os(linux) && !flag(portable) - cpp-options: -DLINUX -DHAS_SENDFILE - other-modules: - System.SendFile, - System.SendFile.Linux - - if os(darwin) && !flag(portable) - cpp-options: -DOSX -DHAS_SENDFILE - other-modules: - System.SendFile, - System.SendFile.Darwin - - if os(freebsd) && !flag(portable) - cpp-options: -DFREEBSD -DHAS_SENDFILE - other-modules: - System.SendFile, - System.SendFile.FreeBSD - if flag(portable) || os(windows) cpp-options: -DPORTABLE - ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded + ghc-options: -O2 -Wall -fwarn-tabs + -funbox-strict-fields -threaded -fno-warn-unused-do-bind - ghc-prof-options: -prof -auto-all Executable benchmark - hs-source-dirs: benchmark ../src + hs-source-dirs: benchmark common ../src main-is: Benchmark.hs build-depends: base >= 4 && < 5, network == 2.2.1.7, HTTP >= 4000.0.9 && < 4001, criterion >= 0.5 && <0.6 - diff --git a/test/suite/Paths_snap_server.hs b/test/suite/Paths_snap_server.hs deleted file mode 100644 --- a/test/suite/Paths_snap_server.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Paths_snap_server ( - version - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} - diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -20,6 +20,7 @@ import Data.List import qualified Data.Map as Map import Data.Maybe (isNothing) +import Data.Monoid import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 @@ -32,6 +33,7 @@ import Snap.Internal.Http.Parser import Snap.Internal.Http.Types hiding (Enumerator) import Snap.Iteratee hiding (foldl') +import qualified Snap.Iteratee as I import Snap.Test.Common() @@ -41,7 +43,6 @@ , testChunked , testBothChunked , testBothChunkedBuffered1 - , testBothChunkedBuffered2 , testBothChunkedPipelined , testBothChunkedEmpty , testP2I @@ -152,9 +153,10 @@ monadicIO $ forAllM arbitrary prop where prop s = do - buf <- QC.run mkIterateeBuffer + it <- QC.run $ writeChunkedTransferEncoding stream2stream + bs <- QC.run $ - writeChunkedTransferEncoding buf (enumBS s) stream2stream + enumBS s it >>= run >>= return . unWrap let enum = enumBS bs @@ -168,7 +170,7 @@ testBothChunkedBuffered1 :: Test -testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered1" $ +testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered2" $ monadicIO prop where prop = do @@ -177,62 +179,42 @@ ntimes <- QC.pick (choose (4,7)) let e = enumLBS s' - - buf <- QC.run mkIterateeBuffer - - enums <- QC.run $ - replicateM ntimes - (mkIterateeBuffer >>= - return . flip writeChunkedTransferEncoding e) + let n = fromEnum $ L.length s' - let mothra = foldl' (>.) (enumBS "") enums + let enum = foldl' (>.) (enumBS "") (replicate ntimes e) - ---------------------------------------------------------------------- - -- first go, buffer, no cancellation - (inputIter1,_) <- QC.run $ bufferIteratee stream2stream - bs1 <- QC.run $ mothra inputIter1 - >>= run >>= return . unWrap - let e1 = enumBS bs1 - let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s - iters <- QC.run $ - replicateM ntimes $ - readChunkedTransferEncoding stream2stream - let godzilla = sequence $ map (>>= pcrlf) iters - outiter1 <- QC.run $ e1 godzilla - x1 <- QC.run $ liftM (map unWrap) $ run outiter1 + (bufi,_) <- QC.run $ bufferIteratee stream2stream + iter' <- QC.run $ writeChunkedTransferEncoding bufi + let iter = I.joinI $ I.take n iter' + let iters = replicate ntimes iter - QC.assert $ - (map (L.fromChunks . (:[])) x1) == (replicate ntimes s') + let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t) + mempty + iters + bs <- QC.run $ enum mothra + >>= run >>= return . unWrap -testBothChunkedBuffered2 :: Test -testBothChunkedBuffered2 = testProperty "testBothChunkedBuffered2" $ - monadicIO prop - where - prop = do - sz <- QC.pick (choose (1000,4000)) - s' <- QC.pick $ resize sz arbitrary - ntimes <- QC.pick (choose (4,7)) - - let e = enumLBS s' - - buf <- QC.run mkIterateeBuffer - - enums <- QC.run $ - replicateM ntimes - (mkIterateeBuffer >>= - return . flip writeChunkedTransferEncoding e) - - let mothra = foldl' (>.) (enumBS "") enums - ---------------------------------------------------------------------- -- 2nd pass, cancellation let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s (inputIter2,esc) <- QC.run $ bufferIteratee stream2stream QC.run $ writeIORef esc True - bs2 <- QC.run $ mothra inputIter2 + + iter2' <- QC.run $ writeChunkedTransferEncoding inputIter2 + let iter2 = I.joinI $ I.take n iter2' + let iters2 = replicate ntimes iter2 + + let mothra2 = foldM (\s it -> it >>= \t -> return $ s `mappend` t) + mempty + iters2 + + + bs2 <- QC.run $ enum mothra2 >>= run >>= return . unWrap + + let e2 = enumBS bs2 iters' <- QC.run $ replicateM ntimes $ @@ -257,19 +239,21 @@ --let s' = L.take 2000 $ L.fromChunks $ repeat s let e = enumLBS s' + let n = fromEnum $ L.length s' - buf <- QC.run mkIterateeBuffer + let enum = foldl' (>.) (enumBS "") (replicate ntimes e) - enums <- QC.run $ - replicateM ntimes - (mkIterateeBuffer >>= - return . flip writeChunkedTransferEncoding e) + (bufi,_) <- QC.run $ bufferIteratee stream2stream - let mothra = foldl' (>.) (enumBS "") enums + iter' <- QC.run $ writeChunkedTransferEncoding bufi + let iter = I.joinI $ I.take n iter' - (bufi,_) <- QC.run $ bufferIteratee stream2stream + let iters = replicate ntimes iter + let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t) + mempty + iters - bs <- QC.run $ mothra bufi + bs <- QC.run $ enum mothra >>= run >>= return . unWrap let e2 = enumBS bs @@ -296,18 +280,20 @@ prop = do let s' = "" let e = enumLBS s' + let n = fromEnum $ L.length s' let ntimes = 5 - - buf <- mkIterateeBuffer + let enum = foldl' (>.) (enumBS "") (replicate ntimes e) - enums <- replicateM ntimes - (mkIterateeBuffer >>= - return . flip writeChunkedTransferEncoding e) + iter' <- writeChunkedTransferEncoding stream2stream + let iter = I.joinI $ I.take n iter' - let mothra = foldl' (>.) (enumBS "") enums + let iters = replicate ntimes iter + let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t) + mempty + iters - bs <- mothra stream2stream + bs <- enum mothra >>= run >>= return . unWrap let e2 = enumBS bs 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} @@ -5,39 +6,49 @@ module Snap.Internal.Http.Server.Tests ( tests ) where -import Control.Concurrent -import Control.Exception (try, SomeException) -import Control.Monad +import Control.Concurrent +import Control.Exception (try, throwIO, SomeException) +import Control.Monad import "monads-fd" Control.Monad.Trans -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as LC -import Data.ByteString (ByteString) -import Data.ByteString.Internal (c2w, w2c) -import Data.Char -import Data.Int -import Data.IORef -import Data.Iteratee.WrappedByteString -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import Data.Monoid -import Data.Time.Calendar -import Data.Time.Clock -import Data.Word -import qualified Network.HTTP as HTTP -import Prelude hiding (take) -import qualified Prelude -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, path) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w, w2c) +import Data.Char +import Data.Int +import Data.IORef +import Data.Iteratee.WrappedByteString +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Monoid +import Data.Time.Calendar +import Data.Time.Clock +import Data.Word +import qualified Network.HTTP as HTTP +import qualified Network.Socket.ByteString as N +import Prelude hiding (take) +import qualified Prelude +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) +import qualified Snap.Http.Server as Svr -import Snap.Internal.Http.Types -import Snap.Internal.Http.Server -import Snap.Iteratee -import Snap.Types +import Snap.Internal.Debug +import Snap.Internal.Http.Types +import Snap.Internal.Http.Server +import Snap.Iteratee +import Snap.Test.Common +import Snap.Types +#ifdef LIBEV +import qualified Snap.Internal.Http.Server.LibevBackend as Backend +#else +import qualified Snap.Internal.Http.Server.SimpleBackend as Backend +#endif + tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest @@ -51,13 +62,24 @@ , testHttp1 , testHttp2 , testHttp100 + , testExpectGarbage , testPartialParse , testMethodParsing , testServerStartupShutdown + , testServerShutdownWithOpenConns , testChunkOn1_0 - , testSendFile ] + , testSendFile + , testTrivials] +testTrivials :: Test +testTrivials = testCase "server/trivials" $ do + let !v = Svr.snapServerVersion + let !s1 = show Backend.BackendTerminatedException + let !s2 = show Backend.TimeoutException + + return $! v `seq` s1 `seq` s2 `seq` () + ------------------------------------------------------------------------------ -- HTTP request tests @@ -84,6 +106,17 @@ , "\r\n" , "0123456789" ] +sampleRequestExpectGarbage :: ByteString +sampleRequestExpectGarbage = + S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" + , "Host: www.zabble.com:7777\r\n" + , "Content-Length: 10\r\n" + , "Expect: wuzzawuzzawuzza\r\n" + , "X-Random-Other-Header: foo\r\n bar\r\n" + , "Cookie: foo=\"bar\\\"\"\r\n" + , "\r\n" + , "0123456789" ] + sampleRequest1_0 :: ByteString sampleRequest1_0 = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.0\r\n" @@ -96,7 +129,7 @@ testMethodParsing :: Test testMethodParsing = - testCase "method parsing" $ Prelude.mapM_ testOneMethod ms + testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms where ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ] @@ -117,7 +150,7 @@ testHttpRequest1 :: Test testHttpRequest1 = - testCase "HttpRequest1" $ do + testCase "server/HttpRequest1" $ do iter <- enumBS sampleRequest $ do r <- liftM fromJust $ rsm receiveRequest @@ -160,7 +193,7 @@ testMultiRequest :: Test testMultiRequest = - testCase "MultiRequest" $ do + testCase "server/MultiRequest" $ do iter <- (enumBS sampleRequest >. enumBS sampleRequest) $ do r1 <- liftM fromJust $ rsm receiveRequest @@ -211,7 +244,7 @@ testPartialParse :: Test -testPartialParse = testCase "Short" $ do +testPartialParse = testCase "server/short" $ do iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest expectException $ run iter @@ -237,7 +270,7 @@ testHttpRequest2 :: Test testHttpRequest2 = - testCase "HttpRequest2" $ do + testCase "server/HttpRequest2" $ do iter <- enumBS sampleRequest2 $ do r <- liftM fromJust $ rsm receiveRequest @@ -253,7 +286,7 @@ testHttpRequest3 :: Test testHttpRequest3 = - testCase "HttpRequest3" $ do + testCase "server/HttpRequest3" $ do iter <- enumBS sampleRequest3 $ do r <- liftM fromJust $ rsm receiveRequest @@ -286,7 +319,7 @@ testHttpRequest3' :: Test testHttpRequest3' = - testCase "HttpRequest3'" $ do + testCase "server/HttpRequest3'" $ do iter <- enumBS sampleRequest3' $ do r <- liftM fromJust $ rsm receiveRequest @@ -347,13 +380,11 @@ testHttpResponse1 :: Test -testHttpResponse1 = testCase "HttpResponse1" $ do +testHttpResponse1 = testCase "server/HttpResponse1" $ do let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run - buf <- mkIterateeBuffer - b <- run $ rsm $ - sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>= + sendResponse rsp1 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [ @@ -373,13 +404,11 @@ testHttpResponse2 :: Test -testHttpResponse2 = testCase "HttpResponse2" $ do +testHttpResponse2 = testCase "server/HttpResponse2" $ do let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run - buf <- mkIterateeBuffer - b2 <- run $ rsm $ - sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>= + sendResponse rsp2 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [ @@ -399,13 +428,11 @@ testHttpResponse3 :: Test -testHttpResponse3 = testCase "HttpResponse3" $ do +testHttpResponse3 = testCase "server/HttpResponse3" $ do let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run - buf <- mkIterateeBuffer - b3 <- run $ rsm $ - sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>= + sendResponse rsp3 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" b3 $ L.concat [ @@ -431,13 +458,11 @@ testHttpResponse4 :: Test -testHttpResponse4 = testCase "HttpResponse4" $ do +testHttpResponse4 = testCase "server/HttpResponse4" $ do let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run - buf <- mkIterateeBuffer - b <- run $ rsm $ - sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>= + sendResponse rsp1 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [ @@ -480,7 +505,7 @@ testHttp1 :: Test -testHttp1 = testCase "http session" $ do +testHttp1 = testCase "server/http session" $ do let enumBody = enumBS sampleRequest >. enumBS sampleRequest2 ref <- newIORef "" @@ -526,7 +551,7 @@ testChunkOn1_0 :: Test -testChunkOn1_0 = testCase "transfer-encoding chunked" $ do +testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do let enumBody = enumBS sampleRequest1_0 ref <- newIORef "" @@ -543,7 +568,7 @@ assertBool "connection close" $ S.isInfixOf "connection: close" output where - lower = S.map (c2w . toLower . w2c) . S.concat . L.toChunks + lower = S.map toLower . S.concat . L.toChunks f :: ServerHandler f _ req = do @@ -565,7 +590,7 @@ testHttp2 :: Test -testHttp2 = testCase "connection: close" $ do +testHttp2 = testCase "server/connection: close" $ do let enumBody = enumBS sampleRequest4 >. enumBS sampleRequest2 ref <- newIORef "" @@ -607,7 +632,7 @@ testHttp100 :: Test -testHttp100 = testCase "Expect: 100-continue" $ do +testHttp100 = testCase "server/Expect: 100-continue" $ do let enumBody = enumBS sampleRequestExpectContinue ref <- newIORef "" @@ -648,8 +673,48 @@ assertBool "100 Continue" ok +testExpectGarbage :: Test +testExpectGarbage = testCase "server/Expect: garbage" $ do + let enumBody = enumBS sampleRequestExpectGarbage + ref <- newIORef "" + let (iter,onSendFile) = mkIter ref + + runHTTP "localhost" + "127.0.0.1" + 80 + "127.0.0.1" + 58384 + Nothing + Nothing + enumBody + iter + onSendFile + (return ()) + echoServer2 + + s <- readIORef ref + + let lns = LC.lines s + + let ok = case lns of + ([ "HTTP/1.1 200 OK\r" + , "Content-Length: 10\r" + , d1 + , s1 + , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" + , "\r" + , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) && + ("Server" `L.isPrefixOf` s1)) + + _ -> False + + assertBool "random expect: header" ok + + + + pongServer :: Snap () pongServer = modifyResponse $ setResponseBody (enumBS "PONG") . setContentType "text/plain" . @@ -660,7 +725,7 @@ testSendFile :: Test -testSendFile = testCase "sendFile" $ do +testSendFile = testCase "server/sendFile" $ do tid <- forkIO $ httpServe "*" port "localhost" Nothing Nothing $ runSnap sendFileFoo @@ -680,7 +745,7 @@ testServerStartupShutdown :: Test -testServerStartupShutdown = testCase "startup/shutdown" $ do +testServerStartupShutdown = testCase "server/startup/shutdown" $ do tid <- forkIO $ httpServe "*" port @@ -703,4 +768,49 @@ where waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8145 + + +testServerShutdownWithOpenConns :: Test +testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do + tid <- forkIO $ + httpServe "127.0.0.1" + port + "localhost" + Nothing + Nothing + (runSnap pongServer) + + waitabit + + result <- newEmptyMVar + + forkIO $ do + e <- try $ withSock port $ \sock -> do + N.sendAll sock "GET /" + waitabit + killThread tid + waitabit + N.sendAll sock "pong HTTP/1.1\r\n" + N.sendAll sock "Host: 127.0.0.1\r\n" + N.sendAll sock "Content-Length: 0\r\n" + N.sendAll sock "Connection: close\r\n\r\n" + + resp <- recvAll sock + when (S.null resp) $ throwIO Backend.BackendTerminatedException + + let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp + debug $ "got HTTP response " ++ s ++ ", we shouldn't be here...." + + putMVar result e + + r <- takeMVar result + + case r of + (Left (_::SomeException)) -> return () + (Right _) -> assertFailure "socket didn't get killed" + + + where + waitabit = threadDelay $ 2*((10::Int)^(6::Int)) + port = 8146 diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs deleted file mode 100644 --- a/test/suite/Snap/Test/Common.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Snap.Test.Common where - -import Control.Monad -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w) -import Test.QuickCheck - - -instance Arbitrary S.ByteString where - arbitrary = liftM (S.pack . map c2w) arbitrary - -instance Arbitrary L.ByteString where - arbitrary = do - n <- choose(0,5) - chunks <- replicateM n arbitrary - return $ L.fromChunks chunks - diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs new file mode 100644 --- /dev/null +++ b/test/suite/Test/Blackbox.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} + +module Test.Blackbox + ( tests + , startTestServer ) where + + +import Control.Concurrent +import Control.Monad +import Control.Monad.CatchIO +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.DList as D +import Data.Int +import Data.Maybe (fromJust) +import qualified Network.HTTP as HTTP +import qualified Network.URI as URI +import Network.Socket +import qualified Network.Socket.ByteString as N +import Prelude hiding (take) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test, path) +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic hiding (run, assert) + +import Snap.Http.Server +import Snap.Test.Common + +import Test.Common.Rot13 +import Test.Common.TestHandler + + +tests :: Int -> [Test] +tests port = map ($ port) [ testPong + , testEcho + , testRot13 + , testSlowLoris + , testBlockingRead + , testBigResponse + , testPartial ] + + +startTestServer :: IO (ThreadId,Int) +startTestServer = do + tid <- forkIO $ + httpServe "*" + port + "localhost" + (Just "ts-access.log") + (Just "ts-error.log") + testHandler + waitabit + + return $ (tid, port) + + where + port = 8199 + + +doPong :: Int -> IO String +doPong port = do + rsp <- HTTP.simpleHTTP $ + HTTP.getRequest $ + "http://localhost:" ++ show port ++ "/pong" + + HTTP.getResponseBody rsp + + +testPong :: Int -> Test +testPong port = testCase "blackbox/pong" $ do + doc <- doPong port + assertEqual "pong response" "PONG" doc + + +testEcho :: Int -> Test +testEcho port = testProperty "blackbox/echo" $ + monadicIO $ forAllM arbitrary prop + where + prop txt = do + let uri = fromJust $ + URI.parseURI $ + "http://localhost:" ++ show port ++ "/echo" + + let len = S.length txt + + let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString + let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req' + + rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) } + doc <- QC.run $ HTTP.getResponseBody rsp + + QC.assert $ txt == doc + + +testRot13 :: Int -> Test +testRot13 port = testProperty "blackbox/rot13" $ + monadicIO $ forAllM arbitrary prop + where + prop txt = do + let uri = fromJust $ + URI.parseURI $ + "http://localhost:" ++ show port ++ "/rot13" + + let len = S.length txt + + let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString + let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req' + + rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) } + doc <- QC.run $ HTTP.getResponseBody rsp + + QC.assert $ txt == rot13 doc + + +testSlowLoris :: Int -> Test +testSlowLoris port = testCase "blackbox/slowloris" $ withSock port go + + where + go sock = do + N.sendAll sock "POST /echo HTTP/1.1\r\n" + N.sendAll sock "Host: 127.0.0.1\r\n" + N.sendAll sock "Content-Length: 2500000\r\n" + N.sendAll sock "Connection: close\r\n\r\n" + + b <- expectExceptionBeforeTimeout (loris sock) 60 + + assertBool "didn't catch slow loris attack" b + + loris sock = do + N.sendAll sock "." + waitabit + loris sock + + +testBlockingRead :: Int -> Test +testBlockingRead port = testCase "blackbox/testBlockingRead" $ + withSock port $ \sock -> do + N.sendAll sock "GET /" + waitabit + N.sendAll sock "pong HTTP/1.1\r\n" + N.sendAll sock "Host: 127.0.0.1\r\n" + N.sendAll sock "Content-Length: 0\r\n" + N.sendAll sock "Connection: close\r\n\r\n" + + resp <- recvAll sock + + let s = head $ ditchHeaders $ S.lines resp + + assertEqual "pong response" "PONG" s + + +-- test server's ability to trap/recover from IO errors +testPartial :: Int -> Test +testPartial port = testCase "blackbox/testPartial" $ do + withSock port $ \sock -> + N.sendAll sock "GET /pong HTTP/1.1\r\n" + + doc <- doPong port + assertEqual "pong response" "PONG" doc + + +testBigResponse :: Int -> Test +testBigResponse port = testCase "blackbox/testBigResponse" $ + withSock port $ \sock -> do + N.sendAll sock "GET /bigresponse HTTP/1.1\r\n" + N.sendAll sock "Host: 127.0.0.1\r\n" + N.sendAll sock "Content-Length: 0\r\n" + N.sendAll sock "Connection: close\r\n\r\n" + + let body = S.replicate 4000000 '.' + resp <- recvAll sock + + let s = head $ ditchHeaders $ S.lines resp + + assertBool "big response" $ body == s + + +------------------------------------------------------------------------------ +waitabit :: IO () +waitabit = threadDelay $ 2*((10::Int)^(6::Int)) diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -1,17 +1,28 @@ module Main where -import Test.Framework (defaultMain, testGroup) +import Control.Concurrent (killThread) +import Test.Framework (defaultMain, testGroup) + + import qualified Data.Concurrent.HashMap.Tests import qualified Snap.Internal.Http.Parser.Tests import qualified Snap.Internal.Http.Server.Tests +import qualified Test.Blackbox main :: IO () -main = defaultMain tests - where tests = [ testGroup "Data.Concurrent.HashMap.Tests" - Data.Concurrent.HashMap.Tests.tests - , testGroup "Snap.Internal.Http.Parser.Tests" - Snap.Internal.Http.Parser.Tests.tests - , testGroup "Snap.Internal.Http.Server.Tests" - Snap.Internal.Http.Server.Tests.tests - ] +main = do + (tid,pt) <- Test.Blackbox.startTestServer + defaultMain $ tests pt + killThread tid + + where tests pt = + [ testGroup "Data.Concurrent.HashMap.Tests" + Data.Concurrent.HashMap.Tests.tests + , testGroup "Snap.Internal.Http.Parser.Tests" + Snap.Internal.Http.Parser.Tests.tests + , testGroup "Snap.Internal.Http.Server.Tests" + Snap.Internal.Http.Server.Tests.tests + , testGroup "Test.Blackbox" + $ Test.Blackbox.tests pt + ] diff --git a/test/testserver/Main.hs b/test/testserver/Main.hs --- a/test/testserver/Main.hs +++ b/test/testserver/Main.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + module Main where import Control.Concurrent -import Snap.Iteratee -import Snap.Types import Snap.Http.Server -import Snap.Util.FileServe +import Test.Common.TestHandler + {- /pong @@ -18,33 +20,7 @@ -} -pongHandler :: Snap () -pongHandler = modifyResponse $ setResponseBody (enumBS "PONG") . - setContentType "text/plain" . - setContentLength 4 -echoHandler :: Snap () -echoHandler = do - req <- getRequest - writeBS $ rqPathInfo req - -responseHandler = do - code <- getParam "code" - case code of - Nothing -> undefined - Just code -> f code - where - f "300" = undefined - f "304" = undefined - -handlers :: Snap () -handlers = - route [ ("pong", pongHandler) - , ("echo", echoHandler) - , ("fileserve", fileServe "static") - , ("respcode/:code", responseHandler) - ] - main :: IO () main = do m <- newEmptyMVar @@ -56,6 +32,7 @@ where go m = do - httpServe "*" 3000 "localhost" Nothing Nothing handlers + httpServe "*" 3000 "localhost" (Just "ts-access.log") + (Just "ts-error.log") testHandler putMVar m () diff --git a/test/testserver/Paths_snap_server.hs b/test/testserver/Paths_snap_server.hs deleted file mode 100644 --- a/test/testserver/Paths_snap_server.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Paths_snap_server ( - version - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} -