snap-server-0.9.5.1/0000755000000000000000000000000012522727050012321 5ustar0000000000000000snap-server-0.9.5.1/LICENSE0000644000000000000000000000300612522727050013325 0ustar0000000000000000Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) Copyright (c) 2010, Google, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the Snap Framework authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. snap-server-0.9.5.1/CONTRIBUTORS0000644000000000000000000000051612522727050014203 0ustar0000000000000000Doug Beardsley Gregory Collins Shu-yu Guo Carl Howells John Lenz Herbert Valerio Riedel James Sanders Jacob Stanley Jurriën Stutterheim snap-server-0.9.5.1/snap-server.cabal0000644000000000000000000001153512522727050015557 0ustar0000000000000000name: snap-server version: 0.9.5.1 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in Haskell. For more information or to download the latest version, you can visit the Snap project website at . . The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web server library written in Haskell. Together with the @snap-core@ library upon which it depends, it provides a clean and efficient Haskell programming interface to the HTTP protocol. license: BSD3 license-file: LICENSE author: James Sanders, Gregory Collins, Doug Beardsley maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.6 homepage: http://snapframework.com/ category: Web, Snap extra-source-files: CONTRIBUTORS, extra/haddock.css, extra/hscolour.css, extra/logo.gif, haddock.sh, LICENSE, README.md, 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/runTestsAndCoverage.sh, test/snap-server-testsuite.cabal, test/suite/Snap/Internal/Http/Parser/Tests.hs, test/suite/Snap/Internal/Http/Server/Tests.hs, test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs, test/suite/Test/Blackbox.hs, test/suite/TestSuite.hs, test/testserver/Main.hs, test/testserver/static/hello.txt Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used. Default: False Flag openssl Description: Enable https support using the HsOpenSSL library. Default: False Flag debug Description: Enable support for debugging. Default: False Manual: True Library hs-source-dirs: src exposed-modules: Snap.Http.Server, Snap.Http.Server.Config, System.FastLogger other-modules: Paths_snap_server, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Backend, Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.ListenHelpers, Snap.Internal.Http.Server.HttpPort, Snap.Internal.Http.Server.SimpleBackend, Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.TLS, Control.Concurrent.Extended build-depends: attoparsec >= 0.10 && < 0.13, attoparsec-enumerator >= 0.3 && < 0.4, base >= 4.4 && < 5, blaze-builder >= 0.2.1.4 && < 0.5, blaze-builder-enumerator >= 0.2.0 && < 0.3, bytestring >= 0.9.1 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6, enumerator >= 0.4.15 && < 0.5, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, network >= 2.3 && < 2.7, old-locale, snap-core >= 0.9.3 && < 0.10, text >= 0.11 && < 1.3, time >= 1.0 && < 1.6, unix-compat >= 0.2 && < 0.5 extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.12 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 ghc-prof-options: -prof -auto-all if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(debug) cpp-options: -DLABEL_THREADS source-repository head type: git location: git://github.com/snapframework/snap-server.git snap-server-0.9.5.1/Setup.hs0000644000000000000000000000005712522727050013757 0ustar0000000000000000import Distribution.Simple main = defaultMain snap-server-0.9.5.1/haddock.sh0000755000000000000000000000043112522727050014253 0ustar0000000000000000#!/bin/sh set -x HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' cabal haddock $HADDOCK_OPTS --hyperlink-source $@ cp extra/logo.gif dist/doc/html/snap-server/haskell_icon.gif cp extra/hscolour.css dist/doc/html/snap-server/src/ snap-server-0.9.5.1/README.md0000644000000000000000000000417212522727050013604 0ustar0000000000000000Snap Framework HTTP Server Library ---------------------------------- This is the Snap Framework HTTP Server library. For more information about Snap, read the `README.SNAP.md` or visit the Snap project website at http://www.snapframework.com/. The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web server library written in Haskell. Together with the `snap-core` library upon which it depends, it provides a clean and efficient Haskell programming interface to the HTTP protocol. Higher-level facilities for building web applications (like user/session management, component interfaces, data modeling, etc.) are not yet implemented, so this release will mostly be of interest for those who: * need a fast and minimal HTTP API at roughly the same level of abstraction as Java servlets, or * are interested in contributing to the Snap Framework project. Building snap-server -------------------- ## Dependencies To build the Snap HTTP server, you need to `cabal install` the `snap-core` library (which should have come with this package). ### Optional dependencies If you would like SSL support, `snap-server` requires the [openssl](http://www.openssl.org/) library. ## Building snap-server The snap-server library is built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run cabal install to install snap-server. If you would like SSL support, pass the `openssl` flag to `cabal install`: cabal install -fopenssl ## Building the Haddock Documentation The haddock documentation can be built using the supplied `haddock.sh` shell script: ./haddock.sh The docs get put in `dist/doc/html/`. ## Building the testsuite The `snap-server` has a fairly comprehensive test suite. To build and run it, `cd` into the `test/` directory and run $ cabal configure # for the stock backend, or.. $ cabal configure -fopenssl # for the SSL backend $ cabal build From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. snap-server-0.9.5.1/README.SNAP.md0000644000000000000000000000210712522727050014340 0ustar0000000000000000Snap Framework -------------- Snap is a simple and fast web development framework and server written in Haskell. For more information or to download the latest version, you can visit the Snap project website at http://snapframework.com/. Snap Status and Features ------------------------ The Snap core system consists of: * a high-speed HTTP server * a sensible and clean monad for web programming * an xml-based templating system for generating HTML that allows you to bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. Snap Philosophy --------------- Snap aims to be the *de facto* web toolkit for Haskell, on the basis of: * High performance * High design standards * Simplicity and ease of use, even for Haskell beginners * Excellent documentation * Robustness and high test coverage snap-server-0.9.5.1/src/0000755000000000000000000000000012522727050013110 5ustar0000000000000000snap-server-0.9.5.1/src/Control/0000755000000000000000000000000012522727050014530 5ustar0000000000000000snap-server-0.9.5.1/src/Control/Concurrent/0000755000000000000000000000000012522727050016652 5ustar0000000000000000snap-server-0.9.5.1/src/Control/Concurrent/Extended.hs0000644000000000000000000001204412522727050020747 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} -- | Handy functions that should really be merged into -- Control.Concurrent itself. module Control.Concurrent.Extended ( forkIOLabeledBs , forkIOLabeledWithUnmaskBs , forkOnLabeledBs , forkOnLabeledWithUnmaskBs ) where ------------------------------------------------------------------------------ import Control.Concurrent (forkIO, forkOn, forkIOWithUnmask, forkOnWithUnmask) import Control.Exception (mask, mask_) import qualified Data.ByteString as B import GHC.Conc.Sync (ThreadId (..)) #ifdef LABEL_THREADS import qualified Data.ByteString.Unsafe as BU import GHC.Base (labelThread#) import Foreign.C.String (CString) import GHC.IO (IO (..)) import GHC.Ptr (Ptr (..)) #endif ------------------------------------------------------------------------------ -- | Sparks off a new thread using 'forkIO' to run the given IO -- computation, but first labels the thread with the given label -- (using 'labelThreadBs'). -- -- The implementation makes sure that asynchronous exceptions are -- masked until the given computation is executed. This ensures the -- thread will always be labeled which guarantees you can always -- easily find it in the GHC event log. -- -- Note that the given computation is executed in the masked state of -- the calling thread. -- -- Returns the 'ThreadId' of the newly created thread. forkIOLabeledBs :: B.ByteString -- ^ Latin-1 encoded label -> IO () -> IO ThreadId forkIOLabeledBs label m = mask $ \restore -> forkIO $ do labelMe label restore m ------------------------------------------------------------------------------ -- | Like 'forkIOLabeledBs', but lets you specify on which capability -- (think CPU) the thread should run. forkOnLabeledBs :: B.ByteString -- ^ Latin-1 encoded label -> Int -- ^ Capability -> IO () -> IO ThreadId forkOnLabeledBs label cap m = mask $ \restore -> forkOn cap $ do labelMe label restore m ------------------------------------------------------------------------------ -- | Sparks off a new thread using 'forkIOWithUnmask' to run the given -- IO computation, but first labels the thread with the given label -- (using 'labelThreadBs'). -- -- The implementation makes sure that asynchronous exceptions are -- masked until the given computation is executed. This ensures the -- thread will always be labeled which guarantees you can always -- easily find it in the GHC event log. -- -- Like 'forkIOWithUnmask', the given computation is given a function -- to unmask asynchronous exceptions. See the documentation of that -- function for the motivation. -- -- Returns the 'ThreadId' of the newly created thread. forkIOLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forkIOLabeledWithUnmaskBs label m = mask_ $ forkIOWithUnmask $ \unmask -> do labelMe label m unmask ------------------------------------------------------------------------------ -- | Like 'forkIOLabeledWithUnmaskBs', but lets you specify on which -- capability (think CPU) the thread should run. forkOnLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label -> Int -- ^ Capability -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forkOnLabeledWithUnmaskBs label cap m = mask_ $ forkOnWithUnmask cap $ \unmask -> do labelMe label m unmask ------------------------------------------------------------------------------ -- | Label the current thread. {-# INLINE labelMe #-} labelMe :: B.ByteString -> IO () #if defined(LABEL_THREADS) labelMe label = do tid <- myThreadId labelThreadBs tid label ------------------------------------------------------------------------------ -- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' -- instead of a 'String'. -- -- Note that if you terminate the ByteString with a '\0' this function -- will use a more efficient implementation which avoids copying the -- ByteString. labelThreadBs :: ThreadId -> B.ByteString -> IO () labelThreadBs tid bs | n == 0 = return () | B.index bs (n - 1) == 0 = BU.unsafeUseAsCString bs $ labelThreadCString tid | otherwise = B.useAsCString bs $ labelThreadCString tid where n = B.length bs ------------------------------------------------------------------------------ -- | Like 'labelThread' but uses a 'CString' instead of a 'String' labelThreadCString :: ThreadId -> CString -> IO () labelThreadCString (ThreadId t) (Ptr p) = IO $ \s -> case labelThread# t p s of s1 -> (# s1, () #) #elif defined(TESTSUITE) labelMe !_ = return $! () #else labelMe _label = return $! () #endif snap-server-0.9.5.1/src/System/0000755000000000000000000000000012522727050014374 5ustar0000000000000000snap-server-0.9.5.1/src/System/FastLogger.hs0000644000000000000000000002147712522727050017000 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger ( Logger , timestampedLogEntry , combinedLogEntry , newLogger , newLoggerWithCustomErrorFunction , logMsg , stopLogger ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 import Control.Concurrent import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception import Control.Monad import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Lazy.Char8 as L import Data.Int import Data.IORef import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import System.IO import Snap.Internal.Http.Server.Date ------------------------------------------------------------------------------ -- | Holds the state for a logger. data Logger = Logger { _queuedMessages :: !(IORef Builder) , _dataWaiting :: !(MVar ()) , _loggerPath :: !(FilePath) , _loggingThread :: !(MVar ThreadId) , _errAction :: ByteString -> IO () } ------------------------------------------------------------------------------ -- | Creates a new logger, logging to the given file. If the file argument is -- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr, -- otherwise we log to a regular file in append mode. The file is closed and -- re-opened every 15 minutes to facilitate external log rotation. newLogger :: FilePath -- ^ log file to use -> IO Logger newLogger = newLoggerWithCustomErrorFunction (\s -> S.hPutStr stderr s >> hFlush stderr) ------------------------------------------------------------------------------ -- | Like 'newLogger', but uses a custom error action if the logger needs to -- print an error message of its own (for instance, if it can't open the -- output file.) newLoggerWithCustomErrorFunction :: (ByteString -> IO ()) -- ^ logger uses this action to log any -- error messages of its own -> FilePath -- ^ log file to use -> IO Logger newLoggerWithCustomErrorFunction errAction fp = do q <- newIORef mempty dw <- newEmptyMVar th <- newEmptyMVar let lg = Logger q dw fp th errAction mask_ $ do tid <- forkIOLabeledWithUnmaskBs "snap-server: logging" $ loggingThread lg putMVar th tid return lg ------------------------------------------------------------------------------ -- | Prepares a log message with the time prepended. timestampedLogEntry :: ByteString -> IO ByteString timestampedLogEntry msg = do timeStr <- getLogDateString return $! toByteString $! mconcat [ fromWord8 $ c2w '[' , fromByteString timeStr , fromByteString "] " , fromByteString msg ] ------------------------------------------------------------------------------ -- | Prepares a log message in \"combined\" format. combinedLogEntry :: ByteString -- ^ remote host -> Maybe ByteString -- ^ remote user -> ByteString -- ^ request line (up to you to ensure -- there are no quotes in here) -> Int -- ^ status code -> Maybe Int64 -- ^ num bytes sent -> Maybe ByteString -- ^ referer (up to you to ensure -- there are no quotes in here) -> ByteString -- ^ user agent (up to you to ensure -- there are no quotes in here) -> IO ByteString combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !ua = do timeStr <- getLogDateString let !l = [ fromByteString host , fromByteString " - " , user , fromByteString " [" , fromByteString timeStr , fromByteString "] \"" , fromByteString req , fromByteString "\" " , fromShow status , space , numBytes , space , referer , fromByteString " \"" , fromByteString ua , quote ] let !output = toByteString $ mconcat l return $! output where dash = fromWord8 $ c2w '-' quote = fromWord8 $ c2w '\"' space = fromWord8 $ c2w ' ' user = maybe dash fromByteString mbUser numBytes = maybe dash fromShow mbNumBytes referer = maybe dash (\s -> mconcat [ quote , fromByteString s , quote ]) mbReferer ------------------------------------------------------------------------------ -- | Sends out a log message verbatim with a newline appended. Note: -- 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' = fromByteString s `mappend` (fromWord8 $ c2w '\n') atomicModifyIORef (_queuedMessages lg) $ \d -> (d `mappend` s',()) tryPutMVar (_dataWaiting lg) () >> return () ------------------------------------------------------------------------------ loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO () loggingThread (Logger queue notifier filePath _ errAct) unmask = do initialize >>= go where openIt = if filePath == "-" then return stdout else if filePath == "stderr" then return stderr else openFile filePath AppendMode `catch` \(e::IOException) -> do logInternalError $ "Can't open log file \"" ++ filePath ++ "\".\n" logInternalError $ "Exception: " ++ show e ++ "\n" logInternalError $ "Logging to stderr instead. " ++ "**THIS IS BAD, YOU OUGHT TO " ++ "FIX THIS**\n\n" return stderr closeIt h = unless (h == stdout || h == stderr) $ hClose h logInternalError = errAct . T.encodeUtf8 . T.pack go (href, lastOpened) = (unmask $ forever $ waitFlushDelay (href, lastOpened)) `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do logInternalError $ "logger got exception: " ++ Prelude.show e ++ "\n" threadDelay 20000000 go (href, lastOpened) ] initialize = do lh <- openIt href <- newIORef lh t <- getCurrentDateTime tref <- newIORef t return (href, tref) killit (href, lastOpened) = do flushIt (href, lastOpened) h <- readIORef href closeIt h flushIt (!href, !lastOpened) = do dl <- atomicModifyIORef queue $ \x -> (mempty,x) let !msgs = toLazyByteString dl h <- readIORef href (do L.hPut h msgs hFlush h) `catch` \(e::IOException) -> do logInternalError $ "got exception writing to log " ++ filePath ++ ": " ++ show e ++ "\n" logInternalError $ "writing log entries to stderr.\n" mapM_ errAct $ L.toChunks msgs -- close the file every 15 minutes (for log rotation) t <- getCurrentDateTime old <- readIORef lastOpened when (t-old > 900) $ do closeIt h mask_ $ openIt >>= writeIORef href writeIORef lastOpened t waitFlushDelay !d = do -- wait on the notification mvar _ <- takeMVar notifier -- grab the queued messages and write them out flushIt d -- at least five seconds between log dumps threadDelay 5000000 ------------------------------------------------------------------------------ -- | Kills a logger thread, causing any unwritten contents to be -- flushed out to disk stopLogger :: Logger -> IO () stopLogger lg = withMVar (_loggingThread lg) killThread snap-server-0.9.5.1/src/System/SendFile.hs0000644000000000000000000000101412522727050016415 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Snap's unified interface to sendfile. -- Modified from sendfile 0.6.1 module System.SendFile ( sendFile , sendFileMode ) where #if defined(LINUX) import System.SendFile.Linux (sendFile) sendFileMode :: String sendFileMode = "LINUX_SENDFILE" #elif defined(FREEBSD) import System.SendFile.FreeBSD (sendFile) sendFileMode :: String sendFileMode = "FREEBSD_SENDFILE" #elif defined(OSX) import System.SendFile.Darwin (sendFile) sendFileMode :: String sendFileMode = "DARWIN_SENDFILE" #endif snap-server-0.9.5.1/src/System/SendFile/0000755000000000000000000000000012522727050016065 5ustar0000000000000000snap-server-0.9.5.1/src/System/SendFile/Darwin.hsc0000644000000000000000000000351212522727050020011 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} -- | Darwin system-dependent code for 'sendfile'. module System.SendFile.Darwin (sendFile) where import Data.Int import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(CInt)) #else import Foreign.C.Types (CInt) #endif import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek, poke) #if __GLASGOW_HASKELL__ >= 703 import System.Posix.Types (Fd(Fd), COff(COff)) #else import System.Posix.Types (Fd, COff) #endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count | count == 0 = return 0 | otherwise = alloca $ \pbytes -> do poke pbytes $ min maxBytes (fromIntegral count) sbytes <- sendfile onBlock out_fd in_fd (fromIntegral off) pbytes return $ fromIntegral sbytes sendfile :: IO () -> Fd -> Fd -> COff -> Ptr COff -> IO COff sendfile onBlock out_fd in_fd off pbytes = do status <- c_sendfile out_fd in_fd off pbytes nsent <- peek pbytes if status == 0 then return nsent else do errno <- getErrno if (errno == eAGAIN) || (errno == eINTR) then do if nsent == 0 then onBlock >> sendfile onBlock out_fd in_fd off pbytes else return nsent else throwErrno "System.SendFile.Darwin" -- max num of bytes in one send maxBytes :: COff maxBytes = maxBound :: COff -- in Darwin sendfile gives LFS support (no sendfile64 routine) foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_darwin :: Fd -> Fd -> COff -> Ptr COff -> Ptr () -> CInt -> IO CInt c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO CInt c_sendfile out_fd in_fd off pbytes = c_sendfile_darwin in_fd out_fd off pbytes nullPtr 0 snap-server-0.9.5.1/src/System/SendFile/FreeBSD.hsc0000644000000000000000000000353512522727050020004 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | FreeBSD system-dependent code for 'sendfile'. module System.SendFile.FreeBSD (sendFile) where import Control.Concurrent (threadWaitWrite) import Data.Int import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CSize(..), CInt(..)) #else import Foreign.C.Types (CInt, CSize) #endif import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek) #if __GLASGOW_HASKELL__ >= 703 import System.Posix.Types (COff(..), Fd(..)) #else import System.Posix.Types (COff, Fd) #endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count | count == 0 = return 0 | otherwise = alloca $ \pbytes -> do sbytes <- sendfile onBlock out_fd in_fd (fromIntegral off) (fromIntegral count) pbytes return $ fromIntegral sbytes sendfile :: IO () -> Fd -> Fd -> COff -> CSize -> Ptr COff -> IO COff sendfile onBlock out_fd in_fd off count pbytes = do res <- c_sendfile_freebsd in_fd out_fd off count nullPtr pbytes 0 nsent <- peek pbytes if (res == 0) then return nsent else do errno <- getErrno if (errno == eAGAIN) || (errno == eINTR) then if nsent == 0 then do onBlock sendfile onBlock out_fd in_fd off count pbytes else return nsent else throwErrno "System.SendFile.FreeBSD.sendfile" -- max num of bytes in one send maxBytes :: CSize maxBytes = maxBound :: CSize foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_freebsd :: Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt snap-server-0.9.5.1/src/System/SendFile/Linux.hsc0000644000000000000000000000326312522727050017667 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | Linux system-dependent code for 'sendfile'. module System.SendFile.Linux (sendFile) where import Data.Int import Foreign.C.Error (eAGAIN, getErrno, throwErrno) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CSize(..), CInt(..)) #else import Foreign.C.Types (CSize) #endif import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (poke) #if __GLASGOW_HASKELL__ >= 703 import System.Posix.Types (Fd(..), COff(..), CSsize(..)) #else import System.Posix.Types (Fd, COff, CSsize) #endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count | count == 0 = return 0 | off == 0 = do sbytes <- sendfile onBlock out_fd in_fd nullPtr bytes return $ fromIntegral sbytes | otherwise = alloca $ \poff -> do poke poff (fromIntegral off) sbytes <- sendfile onBlock out_fd in_fd poff bytes return $ fromIntegral sbytes where bytes = min (fromIntegral count) maxBytes sendfile :: IO () -> Fd -> Fd -> Ptr COff -> CSize -> IO CSsize sendfile onBlock out_fd in_fd poff bytes = do nsent <- c_sendfile out_fd in_fd poff bytes if nsent <= -1 then do errno <- getErrno if errno == eAGAIN then onBlock >> sendfile onBlock out_fd in_fd poff bytes else throwErrno "System.SendFile.Linux" else return nsent -- max num of bytes in one send maxBytes :: CSize maxBytes = maxBound :: CSize -- sendfile64 gives LFS support foreign import ccall unsafe "sys/sendfile.h sendfile64" c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize snap-server-0.9.5.1/src/Snap/0000755000000000000000000000000012522727050014011 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Http/0000755000000000000000000000000012522727050014730 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Http/Server.hs0000644000000000000000000001705112522727050016536 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | The Snap HTTP server is a high performance, epoll-enabled, iteratee-based -- web server library written in Haskell. Together with the @snap-core@ -- library upon which it depends, it provides a clean and efficient Haskell -- programming interface to the HTTP protocol. -- module Snap.Http.Server ( simpleHttpServe , httpServe , quickHttpServe , snapServerVersion , setUnicodeLocale , module Snap.Http.Server.Config ) where ------------------------------------------------------------------------------ import Control.Applicative import Control.Concurrent (newMVar, withMVar) import Control.Monad import Control.Monad.CatchIO import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.List import Data.Maybe #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int import Snap.Internal.Http.Server.Config (emptyStartupInfo, setStartupSockets, setStartupConfig) import Snap.Core import Snap.Util.GZip import Snap.Util.Proxy #ifndef PORTABLE import System.Posix.Env #endif import System.IO import System.FastLogger ------------------------------------------------------------------------------ -- | A short string describing the Snap server version snapServerVersion :: ByteString snapServerVersion = Int.snapServerVersion ------------------------------------------------------------------------------ -- | Starts serving HTTP requests using the given handler. This function never -- returns; to shut down the HTTP server, kill the controlling thread. -- -- This function is like 'httpServe' except it doesn't setup compression, -- reverse proxy address translation (via 'Snap.Util.Proxy.behindProxy'), or -- the error handler; this allows it to be used from 'MonadSnap'. simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO () simpleHttpServe config handler = do conf <- completeConfig config let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr mapM_ (output . ("Listening on "++) . show) $ listeners conf go conf `finally` output "\nShutting down..." where -------------------------------------------------------------------------- go conf = do let tout = fromMaybe 60 $ getDefaultTimeout conf setUnicodeLocale $ fromJust $ getLocale conf withLoggers (fromJust $ getAccessLog conf) (fromJust $ getErrorLog conf) $ \(alog, elog) -> Int.httpServe tout (listeners conf) (fromJust $ getHostname conf) alog elog (\sockets -> let dat = mkStartupInfo sockets conf in maybe (return ()) ($ dat) (getStartupHook conf)) (runSnap handler) -------------------------------------------------------------------------- mkStartupInfo sockets conf = setStartupSockets sockets $ setStartupConfig conf emptyStartupInfo -------------------------------------------------------------------------- maybeSpawnLogger f (ConfigFileLog fp) = liftM Just $ newLoggerWithCustomErrorFunction f fp maybeSpawnLogger _ _ = return Nothing -------------------------------------------------------------------------- maybeIoLog (ConfigIoLog a) = Just a maybeIoLog _ = Nothing -------------------------------------------------------------------------- withLoggers afp efp act = bracket (do mvar <- newMVar () let f s = withMVar mvar (const $ BS.hPutStr stderr s >> hFlush stderr) alog <- maybeSpawnLogger f afp elog <- maybeSpawnLogger f efp return (alog, elog)) (\(alog, elog) -> do maybe (return ()) stopLogger alog maybe (return ()) stopLogger elog) (\(alog, elog) -> act ( liftM logMsg alog <|> maybeIoLog afp , liftM logMsg elog <|> maybeIoLog efp)) {-# INLINE simpleHttpServe #-} ------------------------------------------------------------------------------ listeners :: Config m a -> [Int.ListenPort] listeners conf = catMaybes [ httpListener, httpsListener ] where httpsListener = do b <- getSSLBind conf p <- getSSLPort conf cert <- getSSLCert conf chainCert <- getSSLChainCert conf key <- getSSLKey conf return $! Int.HttpsPort b p cert chainCert key httpListener = do p <- getPort conf b <- getBind conf return $! Int.HttpPort b p ------------------------------------------------------------------------------ -- | Starts serving HTTP requests using the given handler, with settings from -- the 'Config' passed in. This function never returns; to shut down the HTTP -- server, kill the controlling thread. httpServe :: Config Snap a -> Snap () -> IO () httpServe config handler0 = do conf <- completeConfig config let !handler = chooseProxy conf let serve = compress conf . catch500 conf $ handler simpleHttpServe conf serve where chooseProxy conf = maybe handler0 (\ptype -> behindProxy ptype handler0) (getProxyType conf) {-# INLINE httpServe #-} ------------------------------------------------------------------------------ catch500 :: MonadSnap m => Config m a -> m () -> m () catch500 conf = flip catch $ fromJust $ getErrorHandler conf {-# INLINE catch500 #-} ------------------------------------------------------------------------------ compress :: MonadSnap m => Config m a -> m () -> m () compress conf = if fromJust $ getCompression conf then withCompression else id {-# INLINE compress #-} ------------------------------------------------------------------------------ -- | Starts serving HTTP using the given handler. The configuration is read -- from the options given on the command-line, as returned by -- 'commandLineConfig'. This function never returns; to shut down the HTTP -- server, kill the controlling thread. quickHttpServe :: Snap () -> IO () quickHttpServe m = commandLineConfig emptyConfig >>= \c -> httpServe c m ------------------------------------------------------------------------------ -- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\". -- This doesn't work on Windows. setUnicodeLocale :: String -> IO () setUnicodeLocale = #ifndef PORTABLE \lang -> mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True) [ "LANG" , "LC_CTYPE" , "LC_NUMERIC" , "LC_TIME" , "LC_COLLATE" , "LC_MONETARY" , "LC_MESSAGES" , "LC_PAPER" , "LC_NAME" , "LC_ADDRESS" , "LC_TELEPHONE" , "LC_MEASUREMENT" , "LC_IDENTIFICATION" , "LC_ALL" ] #else const $ return () #endif snap-server-0.9.5.1/src/Snap/Http/Server/0000755000000000000000000000000012522727050016176 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Http/Server/Config.hs0000644000000000000000000000174112522727050017742 0ustar0000000000000000{-| This module exports the 'Config' datatype, which you can use to configure the Snap HTTP server. -} module Snap.Http.Server.Config ( Config , ConfigLog(..) , emptyConfig , defaultConfig , commandLineConfig , extendedCommandLineConfig , completeConfig , optDescrs , fmapOpt , getAccessLog , getBind , getCompression , getDefaultTimeout , getErrorHandler , getErrorLog , getHostname , getLocale , getOther , getPort , getProxyType , getSSLBind , getSSLCert , getSSLKey , getSSLChainCert , getSSLPort , getVerbose , getStartupHook , setAccessLog , setBind , setCompression , setDefaultTimeout , setErrorHandler , setErrorLog , setHostname , setLocale , setOther , setPort , setProxyType , setSSLBind , setSSLCert , setSSLKey , setSSLChainCert , setSSLPort , setVerbose , setStartupHook , StartupInfo , getStartupSockets , getStartupConfig ) where import Snap.Internal.Http.Server.Config snap-server-0.9.5.1/src/Snap/Internal/0000755000000000000000000000000012522727050015565 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Internal/Http/0000755000000000000000000000000012522727050016504 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Internal/Http/Parser.hs0000644000000000000000000001547212522727050020305 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ViewPatterns #-} module Snap.Internal.Http.Parser ( IRequest(..) , HttpParseException , parseRequest , readChunkedTransferEncoding , iterParser , parseCookie , parseUrlEncoded , strictize ) where ------------------------------------------------------------------------------ import Control.Exception import Control.Monad (liftM) import Control.Monad.Trans import Data.Attoparsec import Data.Attoparsec.Enumerator import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy.Char8 as L import Data.Char import Data.Int import Data.Typeable import Prelude hiding (head, take, takeWhile) ---------------------------------------------------------------------------- import Snap.Internal.Http.Types import Snap.Internal.Iteratee.Debug import Snap.Internal.Parsing hiding (pHeaders) import Snap.Iteratee hiding (map, take) ------------------------------------------------------------------------------ -- | an internal version of the headers part of an HTTP request data IRequest = IRequest { iMethod :: Method , iRequestUri :: ByteString , iHttpVersion :: (Int,Int) , iRequestHeaders :: [(ByteString, ByteString)] } ------------------------------------------------------------------------------ instance Show IRequest where show (IRequest m u v r) = concat [ show m , " " , show u , " " , show v , " " , show r ] ------------------------------------------------------------------------------ data HttpParseException = HttpParseException String deriving (Typeable, Show) instance Exception HttpParseException ------------------------------------------------------------------------------ parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest) parseRequest = do eof <- isEOF if eof then return Nothing else do line <- pLine if S.null line then parseRequest else do let (!mStr,!s) = bSp line let (!uri,!vStr) = bSp s !method <- methodFromString mStr let ver@(!_,!_) = pVer vStr hdrs <- pHeaders return $! Just $! IRequest method uri ver hdrs where pVer s = if S.isPrefixOf "HTTP/" s then let (a,b) = bDot $ S.drop 5 s in (read $ S.unpack a, read $ S.unpack b) else (1,0) isSp = (== ' ') bSp = splitWith isSp isDot = (== '.') bDot = splitWith isDot ------------------------------------------------------------------------------ pLine :: (Monad m) => Iteratee ByteString m ByteString pLine = continue $ k S.empty where k _ EOF = throwError $ HttpParseException "parse error: expected line ending in crlf" k !pre (Chunks xs) = if S.null b then continue $ k a else yield a (Chunks [S.drop 2 b]) where (!a,!b) = S.breakSubstring "\r\n" s !s = S.append pre s' !s' = S.concat xs ------------------------------------------------------------------------------ splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString) splitWith !f !s = let (!a,!b) = S.break f s !b' = S.dropWhile f b in (a, b') ------------------------------------------------------------------------------ pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)] pHeaders = do f <- go id return $! f [] where go !dlistSoFar = {-# SCC "pHeaders/go" #-} do line <- pLine if S.null line then return dlistSoFar else do let (!k,!v) = pOne line vf <- pCont id let vs = vf [] let !v' = S.concat (v:vs) go (dlistSoFar . ((k,v'):)) where pOne s = let (k,v) = splitWith (== ':') s in (trim k, trim v) isCont c = c == ' ' || c == '\t' pCont !dlist = do mbS <- peek maybe (return dlist) (\s -> if S.null s then head >> pCont dlist else if isCont $ w2c $ S.unsafeHead s then procCont dlist else return dlist) mbS procCont !dlist = do line <- pLine let !t = trim line pCont (dlist . (" ":) . (t:)) ------------------------------------------------------------------------------ methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method methodFromString "GET" = return GET methodFromString "POST" = return POST methodFromString "HEAD" = return HEAD methodFromString "PUT" = return PUT methodFromString "DELETE" = return DELETE methodFromString "TRACE" = return TRACE methodFromString "OPTIONS" = return OPTIONS methodFromString "CONNECT" = return CONNECT methodFromString "PATCH" = return PATCH methodFromString s = return $ Method s ------------------------------------------------------------------------------ readChunkedTransferEncoding :: (MonadIO m) => Enumeratee ByteString ByteString m a readChunkedTransferEncoding = chunkParserToEnumeratee $ iterateeDebugWrapper "pGetTransferChunk" $ iterParser pGetTransferChunk ------------------------------------------------------------------------------ chunkParserToEnumeratee :: (MonadIO m) => Iteratee ByteString m (Maybe ByteString) -> Enumeratee ByteString ByteString m a chunkParserToEnumeratee getChunk client = do mbB <- getChunk maybe finishIt sendBS mbB where sendBS s = do step <- lift $ runIteratee $ enumBS s client chunkParserToEnumeratee getChunk step finishIt = lift $ runIteratee $ enumEOF client ------------------------------------------------------------------------------ -- parse functions ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ pGetTransferChunk :: Parser (Maybe ByteString) pGetTransferChunk = do !hex <- liftM unsafeFromHex $ (takeWhile (isHexDigit . w2c)) takeTill ((== '\r') . w2c) crlf if hex <= (0 :: Int) then return Nothing else do x <- take hex crlf return $! Just x snap-server-0.9.5.1/src/Snap/Internal/Http/Server.hs0000644000000000000000000011346412522727050020317 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 import Blaze.ByteString.Builder.Enumerator import Blaze.ByteString.Builder.HTTP import Control.Arrow (first, second) import Control.Exception hiding (catch, throw) import Control.Monad.CatchIO hiding (Handler, bracket, catches, finally) import qualified Control.Monad.CatchIO as CatchIO import Control.Monad.State.Strict import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as SC import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import Data.Char import Data.Enumerator.Internal import Data.Int import Data.IORef import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing) import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable import Data.Version import GHC.Conc import Network.Socket (Socket, withSocketsDo) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import System.IO #if !MIN_VERSION_time(1,5,0) import System.Locale #endif ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Exceptions (EscapeHttpException (..)) import Snap.Internal.Http.Parser import Snap.Internal.Http.Server.Date import Snap.Internal.Http.Types import System.FastLogger (combinedLogEntry, timestampedLogEntry) import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.HttpPort import Snap.Internal.Http.Server.SimpleBackend import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Iteratee.Debug import Snap.Internal.Parsing (unsafeFromInt) import Snap.Iteratee hiding (head, map, take) import qualified Snap.Iteratee as I import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H 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 -- request body, it is responsible for setting @rqBody=return@ in the returned -- request (otherwise we will mess up reading the input stream). -- -- Note that we won't be bothering end users with this -- the details will be -- hidden inside the Snap monad type ServerHandler = (ByteString -> IO ()) -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) ------------------------------------------------------------------------------ type ServerMonad = StateT ServerState (Iteratee ByteString IO) ------------------------------------------------------------------------------ data ListenPort = -- (bind address, port) HttpPort ByteString Int | -- (bind address, port, path to certificate, whether certificate is a complete chain, path to key) HttpsPort ByteString Int FilePath Bool FilePath ------------------------------------------------------------------------------ instance Show ListenPort where show (HttpPort b p ) = concat [ "http://" , SC.unpack b, ":", show p, "/" ] show (HttpsPort b p _ _ _) = concat [ "https://", SC.unpack b, ":", show p, "/" ] ------------------------------------------------------------------------------ -- This exception will be thrown if we decided to terminate the request before -- running the user handler. data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException deriving (Show, Typeable) instance Exception TerminatedBeforeHandlerException -- We throw this if we get an exception that escaped from the user handler. data ExceptionAlreadyCaught = ExceptionAlreadyCaught deriving (Show, Typeable) instance Exception ExceptionAlreadyCaught ------------------------------------------------------------------------------ data ServerState = ServerState { _forceConnectionClose :: Bool , _localHostname :: ByteString , _sessionPort :: SessionInfo , _logAccess :: Request -> Response -> IO () , _logError :: ByteString -> IO () } ------------------------------------------------------------------------------ runServerMonad :: ByteString -- ^ local host name -> SessionInfo -- ^ session port information -> (Request -> Response -> IO ()) -- ^ access log function -> (ByteString -> IO ()) -- ^ error log function -> ServerMonad a -- ^ monadic action to run -> Iteratee ByteString IO a runServerMonad lh s la le m = evalStateT m st where st = ServerState False lh s la le ------------------------------------------------------------------------------ -- input/output ------------------------------------------------------------------------------ httpServe :: Int -- ^ default timeout -> [ListenPort] -- ^ ports to listen on -> ByteString -- ^ local hostname (server name) -> Maybe (ByteString -> IO ()) -- ^ access log action -> Maybe (ByteString -> IO ()) -- ^ error log action -> ([Socket] -> IO ()) -- ^ initialisation -> ServerHandler -- ^ handler procedure -> IO () httpServe defaultTimeout ports localHostname alog' elog' initial handler = withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers where -------------------------------------------------------------------------- errorHandlers = [ Handler sslException , Handler threadWasKilled , Handler otherException ] -------------------------------------------------------------------------- sslException (e@(TLS.TLSException msg)) = do logE elog' msg SC.hPutStrLn stderr msg throw e ------------------------------------------------------------------------------ threadWasKilled (_ :: AsyncException) = return () ------------------------------------------------------------------------------ otherException (e :: SomeException) = do let msg = SC.concat [ "Error on startup: \n" , T.encodeUtf8 $ T.pack $ show e ] logE elog' msg SC.hPutStrLn stderr msg throw e -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do logE elog $ S.concat [ "Server.httpServe: START, binding to " , bshow ports ] let isHttps p = case p of { (HttpsPort _ _ _ _ _) -> True; _ -> False;} let initHttps = foldr (\p b -> b || isHttps p) False ports if initHttps then TLS.initTLS else return () nports <- mapM bindPort ports let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports (simpleEventLoop defaultTimeout nports numCapabilities (logE elog) (initial socks) $ runHTTP defaultTimeout alog elog handler localHostname) `finally` do logE elog "Server.httpServe: SHUTDOWN" if initHttps then TLS.stopTLS else return () logE elog "Server.httpServe: BACKEND STOPPED" -------------------------------------------------------------------------- bindPort (HttpPort baddr port ) = bindHttp baddr port bindPort (HttpsPort baddr port cert chainCert key) = TLS.bindHttps baddr port cert chainCert key ------------------------------------------------------------------------------ debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s) ------------------------------------------------------------------------------ logE :: Maybe (ByteString -> IO ()) -> ByteString -> IO () logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog ------------------------------------------------------------------------------ logE' :: (ByteString -> IO ()) -> ByteString -> IO () logE' logger s = (timestampedLogEntry s) >>= logger ------------------------------------------------------------------------------ bshow :: (Show a) => a -> ByteString bshow = toBS . show ------------------------------------------------------------------------------ logA :: Maybe (ByteString -> IO ()) -> Request -> Response -> IO () logA alog = maybe (\_ _ -> return ()) logA' alog ------------------------------------------------------------------------------ logA' :: (ByteString -> IO ()) -> Request -> Response -> IO () logA' logger req rsp = do let hdrs = rqHeaders req let host = rqRemoteAddr req let user = Nothing -- TODO we don't do authentication yet let (v, v') = rqVersion req let ver = S.concat [ "HTTP/", bshow v, ".", bshow v' ] let method = toBS $ show (rqMethod req) let reql = S.intercalate " " [ method, rqURI req, ver ] let status = rspStatus rsp let cl = rspContentLength rsp let referer = maybe Nothing (Just . head) $ H.lookup "referer" hdrs let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs msg <- combinedLogEntry host user reql status cl referer userAgent logger msg ------------------------------------------------------------------------------ runHTTP :: Int -- ^ default timeout -> Maybe (ByteString -> IO ()) -- ^ access logger -> Maybe (ByteString -> IO ()) -- ^ error logger -> ServerHandler -- ^ handler procedure -> ByteString -- ^ local host name -> SessionInfo -- ^ session port information -> Enumerator ByteString IO () -- ^ read end of socket -> Iteratee ByteString IO () -- ^ write end of socket -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end -> ((Int -> Int) -> IO ()) -- ^ timeout tickler -> IO () runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile tickle = go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do return () , Handler $ \(_ :: ExceptionAlreadyCaught) -> do return () , Handler $ \(_ :: HttpParseException) -> do return () , Handler $ \(e :: AsyncException) -> do throwIO e , Handler $ \(e :: SomeException) -> logE elog $ toByteString $ lmsg e ] where lmsg e = mconcat [ fromByteString "[" , fromShow $ remoteAddress sinfo , fromByteString "]: " , fromByteString "an exception escaped to toplevel:\n" , fromShow e ] go = do buf <- allocBuffer 16384 let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $ httpSession defaultTimeout writeEnd buf onSendFile tickle handler let iter = iterateeDebugWrapper "httpSession iteratee" iter1 debug "runHTTP/go: prepping iteratee for start" step <- liftIO $ runIteratee iter debug "runHTTP/go: running..." run_ $ readEnd step debug "runHTTP/go: finished" ------------------------------------------------------------------------------ requestErrorMessage :: Request -> SomeException -> Builder requestErrorMessage req e = mconcat [ fromByteString "During processing of request from " , fromByteString $ rqRemoteAddr req , fromByteString ":" , fromShow $ rqRemotePort req , fromByteString "\nrequest:\n" , fromShow $ show req , fromByteString "\n" , msgB ] where msgB = mconcat [ fromByteString "A web handler threw an exception. Details:\n" , fromShow e ] ------------------------------------------------------------------------------ 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 :: Int -> Iteratee ByteString IO () -- ^ write end of socket -> Buffer -- ^ builder buffer -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile continuation -> ((Int -> Int) -> IO ()) -- ^ timeout modifier -> ServerHandler -- ^ handler procedure -> ServerMonad () httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd' debug "Server.httpSession: entered" mreq <- receiveRequest writeEnd debug "Server.httpSession: receiveRequest finished" -- successfully got a request, so restart timer liftIO $ tickle (max defaultTimeout) case mreq of (Just req) -> do debug $ "Server.httpSession: got request: " ++ show (rqMethod req) ++ " " ++ SC.unpack (rqURI req) ++ " " ++ show (rqVersion req) -- check for Expect: 100-continue checkExpect100Continue req writeEnd logerr <- gets _logError (req',rspOrig) <- (lift $ handler logerr tickle req) `CatchIO.catches` [ CatchIO.Handler $ escapeHttpCatch , CatchIO.Handler $ errCatch "user handler" req ] debug $ "Server.httpSession: finished running user handler" let rspTmp = rspOrig { rspHttpVersion = rqVersion req } checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp) cc <- gets _forceConnectionClose let rsp = if cc then (setHeader "Connection" "close" rspTmp) else rspTmp debug "Server.httpSession: handled, skipping request body" if rspTransformingRqBody rsp then debug $ "Server.httpSession: not skipping " ++ "request body, transforming." else do srqEnum <- liftIO $ readIORef $ rqBody req' let (SomeEnumerator rqEnum) = srqEnum skipStep <- (liftIO $ runIteratee $ iterateeDebugWrapper "httpSession/skipToEof" skipToEof) `catch` errCatch "skipping request body" req (lift $ rqEnum skipStep) `catch` errCatch "skipping request body" req debug $ "Server.httpSession: request body skipped, " ++ "sending response" date <- liftIO getDateString let insHeader = H.set "Server" sERVER_HEADER let ins = H.set "Date" date . if isJust (getHeader "Server" rsp) then id else insHeader let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile `catch` errCatch "sending response" req debug $ "Server.httpSession: sent " ++ (show bytesSent) ++ " bytes" maybe (logAccess req rsp') (\_ -> logAccess req $ setContentLength bytesSent rsp') (rspContentLength rsp') if cc then do debug $ "httpSession: Connection: Close, harikari" liftIO $ myThreadId >>= killThread else httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler Nothing -> do debug $ "Server.httpSession: parser did not produce a " ++ "request, ending session" return () where escapeHttpCatch :: EscapeHttpException -> ServerMonad a escapeHttpCatch (EscapeHttpException escapeIter) = do lift $ escapeIter tickle writeEnd' throw ExceptionAlreadyCaught errCatch :: ByteString -> Request -> SomeException -> ServerMonad a errCatch phase req e = do logError $ toByteString $ mconcat [ fromByteString "httpSession caught an exception during " , fromByteString phase , fromByteString " phase:\n" , requestErrorMessage req e ] throw ExceptionAlreadyCaught ------------------------------------------------------------------------------ checkExpect100Continue :: Request -> Iteratee ByteString IO () -> ServerMonad () checkExpect100Continue req writeEnd = do let mbEx = getHeaders "Expect" req maybe (return ()) (\l -> if elem "100-continue" l then go else return ()) mbEx where go = do let (major,minor) = rqVersion req let hl = mconcat [ fromByteString "HTTP/" , fromShow major , fromWord8 $ c2w '.' , fromShow minor , fromByteString " 100 Continue\r\n\r\n" ] liftIO $ runIteratee ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd) return () ------------------------------------------------------------------------------ return411 :: Request -> Iteratee ByteString IO () -> ServerMonad a return411 req writeEnd = do go liftIO $ throwIO $ TerminatedBeforeHandlerException where go = do let (major,minor) = rqVersion req let hl = mconcat [ fromByteString "HTTP/" , fromShow major , fromWord8 $ c2w '.' , fromShow minor , fromByteString " 411 Length Required\r\n\r\n" , fromByteString "411 Length Required\r\n" ] liftIO $ runIteratee ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd) return () ------------------------------------------------------------------------------ receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request) receiveRequest writeEnd = do debug "receiveRequest: entered" mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $ iterateeDebugWrapper "parseRequest" $ joinI' $ takeNoMoreThan maxHeadersSize $$ parseRequest debug "receiveRequest: parseRequest returned" case mreq of (Just ireq) -> do req' <- toRequest ireq setEnumerator req' req <- parseForm req' checkConnectionClose (rqVersion req) (rqHeaders req) return $! Just req Nothing -> return Nothing where -------------------------------------------------------------------------- -- TODO(gdc): make this a policy decision (expose in -- Snap.Http.Server.Config) maxHeadersSize = 256 * 1024 -------------------------------------------------------------------------- -- check: did the client specify "transfer-encoding: chunked"? then we -- have to honor that. -- -- otherwise: check content-length header. if set: only take N bytes from -- the read end of the socket -- -- if no content-length and no chunked encoding, enumerate the entire -- socket and close afterwards setEnumerator :: Request -> ServerMonad () setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do if isChunked then do debug $ "receiveRequest/setEnumerator: " ++ "input in chunked encoding" let e = joinI . readChunkedTransferEncoding liftIO $ writeIORef (rqBody req) (SomeEnumerator e) else maybe (noContentLength req) hasContentLength mbCL where isChunked = maybe False ((== ["chunked"]) . map CI.mk) (H.lookup "transfer-encoding" hdrs) hasContentLength :: Int64 -> ServerMonad () hasContentLength len = do debug $ "receiveRequest/setEnumerator: " ++ "request had content-length " ++ show len liftIO $ writeIORef (rqBody req) (SomeEnumerator e) debug "receiveRequest/setEnumerator: body enumerator set" where e :: Enumerator ByteString IO a e st = do st' <- lift $ runIteratee $ iterateeDebugWrapper "rqBody iterator" $ returnI st joinI $ takeExactly len st' noContentLength :: Request -> ServerMonad () noContentLength rq = do debug ("receiveRequest/setEnumerator: " ++ "request did NOT have content-length") when (rqMethod rq == POST || rqMethod rq == PUT) $ return411 req writeEnd let enum = SomeEnumerator $ iterateeDebugWrapper "noContentLength" . joinI . I.take 0 liftIO $ writeIORef (rqBody rq) enum debug "receiveRequest/setEnumerator: body enumerator set" hdrs = rqHeaders req mbCL = H.lookup "content-length" hdrs >>= return . unsafeFromInt . head -------------------------------------------------------------------------- parseForm :: Request -> ServerMonad Request parseForm req = {-# SCC "receiveRequest/parseForm" #-} if doIt then getIt else return req where mbCT = liftM head $ H.lookup "content-type" (rqHeaders req) trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';') . SC.dropWhile isSpace mbCT' = liftM trimIt mbCT doIt = mbCT' == Just "application/x-www-form-urlencoded" maximumPOSTBodySize :: Int64 maximumPOSTBodySize = 10*1024*1024 getIt :: ServerMonad Request getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do debug "parseForm: got application/x-www-form-urlencoded" debug "parseForm: reading POST body" senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum consumeStep <- liftIO $ runIteratee consume step <- liftIO $ runIteratee $ joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep body <- liftM S.concat $ lift $ enum step let newParams = parseUrlEncoded body debug "parseForm: stuffing 'enumBS body' into request" let e = enumBS body >==> I.joinI . I.take 0 let e' = \st -> do let ii = iterateeDebugWrapper "regurgitate body" (returnI st) st' <- lift $ runIteratee ii e st' liftIO $ writeIORef (rqBody req) $ SomeEnumerator e' return $! req { rqParams = Map.unionWith (++) (rqParams req) newParams , rqPostParams = newParams } -------------------------------------------------------------------------- toRequest (IRequest method uri version kvps) = {-# SCC "receiveRequest/toRequest" #-} do localAddr <- gets $ localAddress . _sessionPort lport <- gets $ localPort . _sessionPort remoteAddr <- gets $ remoteAddress . _sessionPort rport <- gets $ remotePort . _sessionPort localHostname <- gets $ _localHostname secure <- gets $ isSecure . _sessionPort let (serverName, serverPort) = fromMaybe (localHostname, lport) (liftM (parseHost . head) (H.lookup "host" hdrs)) -- will override in "setEnumerator" enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "") return $! Request serverName serverPort remoteAddr rport localAddr lport localHostname secure hdrs enum mbContentLength method version cookies pathInfo contextPath uri queryString params params Map.empty where dropLeadingSlash s = maybe s f mbS where f (a,s') = if a == c2w '/' then s' else s mbS = S.uncons s hdrs = toHeaders kvps mbContentLength = liftM (unsafeFromInt . head) $ H.lookup "content-length" hdrs cookies = concat $ maybe [] (catMaybes . map parseCookie) (H.lookup "cookie" hdrs) contextPath = "/" parseHost h = (a, unsafeFromInt (S.drop 1 b)) where (a,b) = S.break (== (c2w ':')) h params = parseUrlEncoded queryString (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $ S.break (== (c2w '?')) uri ------------------------------------------------------------------------------ -- Response must be well-formed here sendResponse :: forall a . Request -> Response -> Buffer -> Iteratee ByteString IO a -- ^ iteratee write end -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on -- sendfile -> ServerMonad (Int64, a) sendResponse req rsp0 buffer writeEnd' onSendFile = do let rsp1 = renderCookies rsp0 let (rsp, shouldClose) = if isNothing $ rspContentLength rsp1 then noCL rsp1 else (rsp1, False) when shouldClose $ modify $! \s -> s { _forceConnectionClose = True } let (!headerString,!hlen) = mkHeaderBuilder rsp let writeEnd = fixCLIteratee hlen rsp writeEnd' (!x,!bs) <- case (rspBody rsp) of (Enum e) -> lift $ whenEnum writeEnd headerString hlen rsp e (SendFile f Nothing) -> lift $ whenSendFile writeEnd headerString rsp f 0 (SendFile f (Just (st,_))) -> lift $ whenSendFile writeEnd headerString rsp f st debug "sendResponse: response sent" return $! (bs,x) where -------------------------------------------------------------------------- noCL :: Response -> (Response, Bool) noCL r = if rqMethod req == HEAD then let r' = r { rspBody = Enum $ enumBuilder mempty } in (r', False) else if rspHttpVersion r >= (1,1) then let r' = setHeader "Transfer-Encoding" "chunked" r origE = rspBodyToEnum $ rspBody r e = \i -> joinI $ origE $$ chunkIt i in (r' { rspBody = Enum e }, False) else -- HTTP/1.0 and no content-length? We'll have to close the -- socket. (setHeader "Connection" "close" r, True) {-# INLINE noCL #-} -------------------------------------------------------------------------- chunkIt :: forall x . Enumeratee Builder Builder IO x chunkIt = checkDone $ continue . step where step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return step k (Chunks []) = continue $ step k step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunkIt -------------------------------------------------------------------------- whenEnum :: Iteratee ByteString IO a -> Builder -> Int -> Response -> (forall x . Enumerator Builder IO x) -> Iteratee ByteString IO (a,Int64) whenEnum writeEnd hs hlen rsp e = do -- "enum" here has to be run in the context of the READ iteratee, even -- though it's writing to the output, because we may be transforming -- the input. That's why we check if we're transforming the request -- body here, and if not, send EOF to the write end; so that it -- doesn't join up with the read iteratee and try to get more data -- from the socket. let eBuilder = enumBuilder hs >==> e let enum = if rspTransformingRqBody rsp then eBuilder else eBuilder >==> mapEnum toByteString fromByteString (joinI . I.take 0) debug $ "sendResponse: whenEnum: enumerating bytes" outstep <- lift $ runIteratee $ iterateeDebugWrapper "countBytes writeEnd" $ countBytes writeEnd let bufferFunc = if getBufferingMode rsp then unsafeBuilderToByteString (return buffer) else I.map (toByteString . (`mappend` flush)) (x,bs) <- mapIter fromByteString toByteString (enum $$ joinI $ bufferFunc outstep) debug $ "sendResponse: whenEnum: " ++ show bs ++ " bytes enumerated" return (x, bs - fromIntegral hlen) -------------------------------------------------------------------------- whenSendFile :: Iteratee ByteString IO a -- ^ write end -> Builder -- ^ headers -> Response -> FilePath -- ^ file to send -> Int64 -- ^ start byte offset -> Iteratee ByteString IO (a,Int64) whenSendFile writeEnd hs r f start = do -- Guaranteed to have a content length here. Sending EOF through to -- the write end guarantees that we flush the buffer before we send -- the file with sendfile(). lift $ runIteratee ((enumBuilder hs >==> enumEOF) $$ unsafeBuilderToByteString (return buffer) $$ writeEnd) let !cl = fromJust $ rspContentLength r x <- liftIO $ onSendFile f start cl return (x, cl) -------------------------------------------------------------------------- (major,minor) = rspHttpVersion rsp0 -------------------------------------------------------------------------- buildHdrs :: Headers -> (Builder,Int) buildHdrs hdrs = {-# SCC "buildHdrs" #-} H.fold f (mempty,0) hdrs where f (!b,!len) !k !ys = let (!b',len') = h k ys in (b `mappend` b', len+len') crlf = fromByteString "\r\n" doOne pre plen (b,len) y = ( mconcat [ b , pre , fromByteString y , crlf ] , len + plen + 2 + S.length y ) h k ys = foldl' (doOne kb klen) (mempty,0) ys where k' = CI.original k kb = fromByteString k' `mappend` fromByteString ": " klen = S.length k' + 2 -------------------------------------------------------------------------- fixCLIteratee :: Int -- ^ header length -> Response -- ^ response -> Iteratee ByteString IO a -- ^ write end -> Iteratee ByteString IO a fixCLIteratee hlen resp we = maybe we f mbCL where f cl = case rspBody resp of (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen) $$ we (SendFile _ _) -> we mbCL = rspContentLength resp -------------------------------------------------------------------------- renderCookies :: Response -> Response renderCookies r = updateHeaders f r where f h = if null cookies then h else foldl' (\m v -> H.insert "Set-Cookie" v m) h cookies cookies = fmap cookieToBS . Map.elems $ rspCookies r -------------------------------------------------------------------------- mkHeaderBuilder :: Response -> (Builder,Int) mkHeaderBuilder r = {-# SCC "mkHeaderBuilder" #-} ( mconcat [ fromByteString "HTTP/" , fromString majstr , fromWord8 $ c2w '.' , fromString minstr , space , fromString $ statstr , space , fromByteString reason , crlf , hdrs , crlf ] , 12 + majlen + minlen + statlen + S.length reason + hlen ) where (hdrs,hlen) = buildHdrs $ headers r majstr = show major minstr = show minor majlen = length majstr minlen = length minstr statstr = show $ rspStatus r statlen = length statstr crlf = fromByteString "\r\n" space = fromWord8 $ c2w ' ' reason = rspStatusReason r ------------------------------------------------------------------------------ checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad () checkConnectionClose ver hdrs = -- For HTTP/1.1: -- if there is an explicit Connection: close, close the socket. -- 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"]) then modify $ \s -> s { _forceConnectionClose = True } else return () where l = liftM (map tl) $ H.lookup "Connection" hdrs tl = S.map (c2w . toLower . w2c) ------------------------------------------------------------------------------ -- FIXME: whitespace-trim the values here. toHeaders :: [(ByteString,ByteString)] -> Headers toHeaders kvps = H.fromList kvps' where kvps' = map (first CI.mk) kvps ------------------------------------------------------------------------------ -- | Convert 'Cookie' into 'ByteString' for output. cookieToBS :: Cookie -> ByteString cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie where cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] path = maybe "" (S.append "; path=") mbPath domain = maybe "" (S.append "; domain=") mbDomain exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime secure = if isSec then "; Secure" else "" hOnly = if isHOnly then "; HttpOnly" else "" fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" ------------------------------------------------------------------------------ l2s :: L.ByteString -> S.ByteString l2s = S.concat . L.toChunks ------------------------------------------------------------------------------ toBS :: String -> ByteString toBS = S.pack . map c2w snap-server-0.9.5.1/src/Snap/Internal/Http/Server/0000755000000000000000000000000012522727050017752 5ustar0000000000000000snap-server-0.9.5.1/src/Snap/Internal/Http/Server/TimeoutManager.hs0000644000000000000000000002052012522727050023226 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} module Snap.Internal.Http.Server.TimeoutManager ( TimeoutManager , TimeoutHandle , initialize , stop , register , tickle , set , modify , cancel ) where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception import Control.Monad import Data.IORef import Foreign.C.Types ------------------------------------------------------------------------------ data State = Deadline !CTime | Canceled deriving (Eq, Show) ------------------------------------------------------------------------------ instance Ord State where compare Canceled Canceled = EQ compare Canceled _ = LT compare _ Canceled = GT compare (Deadline a) (Deadline b) = compare a b ------------------------------------------------------------------------------ -- Probably breaks Num laws, but I can live with it -- instance Num State where -------------------------------------------------------------------------- Canceled + Canceled = Canceled Canceled + x = x x + Canceled = x (Deadline a) + (Deadline b) = Deadline $! a + b -------------------------------------------------------------------------- Canceled - Canceled = Canceled Canceled - x = negate x x - Canceled = x (Deadline a) - (Deadline b) = Deadline $! a - b -------------------------------------------------------------------------- Canceled * _ = Canceled _ * Canceled = Canceled (Deadline a) * (Deadline b) = Deadline $! a * b -------------------------------------------------------------------------- negate Canceled = Canceled negate (Deadline d) = Deadline (negate d) -------------------------------------------------------------------------- abs Canceled = Canceled abs (Deadline d) = Deadline (abs d) -------------------------------------------------------------------------- signum Canceled = Canceled signum (Deadline d) = Deadline (signum d) -------------------------------------------------------------------------- fromInteger = Deadline . fromInteger ------------------------------------------------------------------------------ data TimeoutHandle = TimeoutHandle { _killAction :: !(IO ()) , _state :: !(IORef State) , _hGetTime :: !(IO CTime) } ------------------------------------------------------------------------------ -- | Given a 'State' value and the current time, apply the given modification -- function to the amount of time remaining. -- smap :: CTime -> (Int -> Int) -> State -> State smap _ _ Canceled = Canceled smap now f (Deadline t) = Deadline t' where !remaining = fromEnum $ max 0 (t - now) !newremaining = f remaining !t' = now + toEnum newremaining ------------------------------------------------------------------------------ data TimeoutManager = TimeoutManager { _defaultTimeout :: !Int , _getTime :: !(IO CTime) , _connections :: !(IORef [TimeoutHandle]) , _inactivity :: !(IORef Bool) , _morePlease :: !(MVar ()) , _managerThread :: !(MVar ThreadId) } ------------------------------------------------------------------------------ -- | Create a new TimeoutManager. initialize :: Int -- ^ default timeout -> IO CTime -- ^ function to get current time -> IO TimeoutManager initialize defaultTimeout getTime = do conns <- newIORef [] inact <- newIORef False mp <- newEmptyMVar mthr <- newEmptyMVar let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr thr <- forkIOLabeledWithUnmaskBs "snap-server: timeout manager" $ managerThread tm putMVar mthr thr return tm ------------------------------------------------------------------------------ -- | Stop a TimeoutManager. stop :: TimeoutManager -> IO () stop tm = readMVar (_managerThread tm) >>= killThread ------------------------------------------------------------------------------ -- | Register a new connection with the TimeoutManager. register :: IO () -- ^ action to run when the timeout deadline is exceeded. -> TimeoutManager -- ^ manager to register with. -> IO TimeoutHandle register killAction tm = do now <- getTime let !state = Deadline $ now + toEnum defaultTimeout stateRef <- newIORef state let !h = TimeoutHandle killAction stateRef getTime atomicModifyIORef connections $ \x -> (h:x, ()) inact <- readIORef inactivity when inact $ do -- wake up manager thread writeIORef inactivity False _ <- tryPutMVar morePlease () return () return h where getTime = _getTime tm inactivity = _inactivity tm morePlease = _morePlease tm connections = _connections tm defaultTimeout = _defaultTimeout tm ------------------------------------------------------------------------------ -- | Tickle the timeout on a connection to be at least N seconds into the -- future. If the existing timeout is set for M seconds from now, where M > N, -- then the timeout is unaffected. tickle :: TimeoutHandle -> Int -> IO () tickle th = modify th . max {-# INLINE tickle #-} ------------------------------------------------------------------------------ -- | Set the timeout on a connection to be N seconds into the future. set :: TimeoutHandle -> Int -> IO () set th = modify th . const {-# INLINE set #-} ------------------------------------------------------------------------------ -- | Modify the timeout with the given function. modify :: TimeoutHandle -> (Int -> Int) -> IO () modify th f = do now <- getTime state <- readIORef stateRef let !state' = smap now f state writeIORef stateRef state' where getTime = _hGetTime th stateRef = _state th {-# INLINE modify #-} ------------------------------------------------------------------------------ -- | Cancel a timeout. cancel :: TimeoutHandle -> IO () cancel h = writeIORef (_state h) Canceled {-# INLINE cancel #-} ------------------------------------------------------------------------------ managerThread :: TimeoutManager -> (forall a. IO a -> IO a) -> IO () managerThread tm unmask = unmask loop `finally` (readIORef connections >>= destroyAll) where -------------------------------------------------------------------------- connections = _connections tm getTime = _getTime tm inactivity = _inactivity tm morePlease = _morePlease tm waitABit = threadDelay 5000000 -------------------------------------------------------------------------- loop = do waitABit handles <- atomicModifyIORef connections (\x -> ([],x)) if null handles then do -- we're inactive, go to sleep until we get new threads writeIORef inactivity True takeMVar morePlease else do now <- getTime dlist <- processHandles now handles id atomicModifyIORef connections (\x -> (dlist x, ())) loop -------------------------------------------------------------------------- processHandles !now handles initDlist = go handles initDlist where go [] !dlist = return dlist go (x:xs) !dlist = do state <- readIORef $ _state x !dlist' <- case state of Canceled -> return dlist Deadline t -> if t <= now then do _killAction x return dlist else return (dlist . (x:)) go xs dlist' -------------------------------------------------------------------------- destroyAll = mapM_ diediedie -------------------------------------------------------------------------- diediedie x = do state <- readIORef $ _state x case state of Canceled -> return () _ -> _killAction x snap-server-0.9.5.1/src/Snap/Internal/Http/Server/TLS.hs0000644000000000000000000001451612522727050020757 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ module Snap.Internal.Http.Server.TLS ( TLSException (..) , initTLS , stopTLS , bindHttps , freePort , createSession , endSession , recv , send ) where ------------------------------------------------------------------------------ import Control.Exception import Data.ByteString.Char8 (ByteString) import Data.Dynamic import Foreign.C import qualified Data.ByteString.Char8 as S ------------------------------------------------------------------------------ #ifdef OPENSSL import Control.Monad import qualified Network.Socket as Socket import Network.Socket hiding ( accept , shutdown , recv , recvLen , send , socket ) import OpenSSL import OpenSSL.Session import qualified OpenSSL.Session as SSL import Prelude hiding (catch) import Unsafe.Coerce import Snap.Internal.Http.Server.Address #endif ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Backend ------------------------------------------------------------------------------ data TLSException = TLSException S.ByteString deriving (Show, Typeable) instance Exception TLSException #ifndef OPENSSL ------------------------------------------------------------------------------ sslNotSupportedException :: TLSException sslNotSupportedException = TLSException $ S.concat [ "This version of snap-server was not built with SSL " , "support.\n" , "Please compile snap-server with -fopenssl to enable it." ] ------------------------------------------------------------------------------ initTLS :: IO () initTLS = throwIO sslNotSupportedException ------------------------------------------------------------------------------ stopTLS :: IO () stopTLS = return () ------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO ListenSocket bindHttps _ _ _ _ _ = throwIO sslNotSupportedException ------------------------------------------------------------------------------ freePort :: ListenSocket -> IO () freePort _ = return () ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession _ _ _ _ = throwIO sslNotSupportedException ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () endSession _ = return () ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send _ _ _ _ = return () ------------------------------------------------------------------------------ recv :: IO b -> NetworkSession -> IO (Maybe ByteString) recv _ _ = throwIO sslNotSupportedException #else ------------------------------------------------------------------------------ initTLS :: IO () initTLS = withOpenSSL $ return () ------------------------------------------------------------------------------ stopTLS :: IO () stopTLS = return () ------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO ListenSocket bindHttps bindAddress bindPort cert chainCert key = do (family, addr) <- getSockAddr bindPort bindAddress sock <- Socket.socket family Socket.Stream 0 Socket.setSocketOption sock Socket.ReuseAddr 1 Socket.bindSocket sock addr Socket.listen sock 150 ctx <- context contextSetPrivateKeyFile ctx key if chainCert then contextSetCertificateChainFile ctx cert else contextSetCertificateFile ctx cert contextSetDefaultCiphers ctx certOK <- contextCheckPrivateKey ctx when (not certOK) $ throwIO $ TLSException certificateError return $! ListenHttps sock ctx where certificateError = "OpenSSL says that the certificate doesn't match the private key!" ------------------------------------------------------------------------------ freePort :: ListenSocket -> IO () freePort (ListenHttps sock _) = Socket.sClose sock freePort _ = return () ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession (ListenHttps _ ctx) recvSize socket _ = do csock <- mkSocket socket AF_INET Stream defaultProtocol Connected handle (\(e::SomeException) -> Socket.sClose csock >> throwIO e) $ do ssl <- connection ctx csock accept ssl return $! NetworkSession socket (unsafeCoerce ssl) recvSize createSession _ _ _ _ = error "can't call createSession on a ListenHttp" ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () endSession (NetworkSession _ aSSL _) = shutdown (unsafeCoerce aSSL) Unidirectional ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send tickleTimeout _ (NetworkSession _ aSSL sz) bs = go bs where ssl = unsafeCoerce aSSL -- I think we have to chop the data into chunks here because HsOpenSSL -- won't; of course, blaze-builder may already be doing this for us, but I -- don't want to risk it. go !s = if S.null s then return () else do SSL.write ssl a tickleTimeout go b where (a,b) = S.splitAt sz s ------------------------------------------------------------------------------ recv :: IO b -> NetworkSession -> IO (Maybe ByteString) recv _ (NetworkSession _ aSSL recvLen) = do b <- SSL.read ssl recvLen return $! if S.null b then Nothing else Just b where ssl = unsafeCoerce aSSL #endif snap-server-0.9.5.1/src/Snap/Internal/Http/Server/SimpleBackend.hs0000644000000000000000000003026412522727050023014 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.SimpleBackend ( simpleEventLoop ) where ------------------------------------------------------------------------------ import Control.Monad.Trans import Control.Concurrent hiding (yield) import Control.Concurrent.Extended (forkOnLabeledWithUnmaskBs) import Control.Exception import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as SC import Data.ByteString.Internal (c2w) import Foreign hiding (new) import Foreign.C #if MIN_VERSION_base(4,4,0) import GHC.Conc (forkOn, labelThread) #else import GHC.Conc (forkOnIO, labelThread) #endif import Network.Socket #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Http.Server.Address import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.Date import qualified Snap.Internal.Http.Server.ListenHelpers as Listen import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) import qualified Snap.Internal.Http.Server.TimeoutManager as TM import Snap.Iteratee hiding (map) #if defined(HAS_SENDFILE) import System.Posix.IO import System.Posix.Types (Fd (..)) import qualified System.SendFile as SF #endif ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,4,0) forkOn :: Int -> IO () -> IO ThreadId forkOn = forkOnIO #endif ------------------------------------------------------------------------------ -- | For each cpu, we store: -- * A list of accept threads, one per port. -- * A TimeoutManager -- * An mvar to signal when the timeout thread is shutdown data EventLoopCpu = EventLoopCpu { _boundCpu :: Int , _acceptThreads :: [ThreadId] , _timeoutManager :: TimeoutManager , _exitMVar :: !(MVar ()) } ------------------------------------------------------------------------------ simpleEventLoop :: EventLoop simpleEventLoop defaultTimeout sockets cap elog initial handler = do loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog) [0..(cap-1)] initial debug "simpleEventLoop: waiting for mvars" --wait for all threads to exit Prelude.mapM_ (takeMVar . _exitMVar) loops `finally` do debug "simpleEventLoop: killing all threads" _ <- mapM_ stopLoop loops mapM_ Listen.closeSocket sockets ------------------------------------------------------------------------------ newLoop :: Int -> [ListenSocket] -> SessionHandler -> (S.ByteString -> IO ()) -> Int -> IO EventLoopCpu newLoop defaultTimeout sockets handler elog cpu = do tmgr <- TM.initialize defaultTimeout getCurrentDateTime exit <- newEmptyMVar accThreads <- forM sockets $ \p -> do let label = S.concat [ "snap-server: ", SC.pack (show p) , " on capability: ", SC.pack (show cpu) ] forkOnLabeledWithUnmaskBs label cpu $ \unmask -> acceptThread defaultTimeout handler tmgr elog cpu p unmask `finally` (tryPutMVar exit () >> return ()) return $! EventLoopCpu cpu accThreads tmgr exit ------------------------------------------------------------------------------ stopLoop :: EventLoopCpu -> IO () stopLoop loop = mask_ $ do TM.stop $ _timeoutManager loop Prelude.mapM_ killThread $ _acceptThreads loop ------------------------------------------------------------------------------ acceptThread :: Int -> SessionHandler -> TimeoutManager -> (S.ByteString -> IO ()) -> Int -> ListenSocket -> (forall a. IO a -> IO a) -> IO () acceptThread defaultTimeout handler tmgr elog cpu sock unmask = loop where loop = do unmask (forever acceptAndFork) `catches` acceptHandler loop acceptAndFork = do debug $ "acceptThread: calling accept() on socket " ++ show sock (s,addr) <- accept $ Listen.listenSocket sock setSocketOption s NoDelay 1 debug $ "acceptThread: accepted connection from remote: " ++ show addr let label = S.concat [ "snap-server: connection from: " , SC.pack (show addr) , " on socket: " , SC.pack (show (fdSocket s)) , "\0" ] _ <- forkOnLabeledWithUnmaskBs label cpu $ \unmask' -> unmask' (runSession defaultTimeout handler tmgr sock s addr) `catches` cleanup return () acceptHandler = [ Handler $ \(e :: AsyncException) -> throwIO e , Handler $ \(e :: SomeException) -> do elog $ S.concat [ "SimpleBackend.acceptThread: accept threw: " , S.pack . map c2w $ show e ] -- we're out of file descriptors, and it isn't likely to get -- better immediately; sleep for 10ms to avoid spamming the error -- log. threadDelay $ 10000 ] cleanup = [ Handler $ \(e :: AsyncException) -> case e of ThreadKilled -> return () UserInterrupt -> return () _ -> throwIO e -- This ensures all other asynchronous exceptions -- (StackOverflow and HeapOverflow) are logged to -- stderr by forkIO. , Handler $ \(e :: SomeException) -> elog $ S.concat [ "SimpleBackend.acceptThread: " , S.pack . map c2w $ show e] ] ------------------------------------------------------------------------------ runSession :: Int -> SessionHandler -> TimeoutManager -> ListenSocket -> Socket -> SockAddr -> IO () runSession defaultTimeout handler tmgr lsock sock addr = do let fd = fdSocket sock curId <- myThreadId debug $ "Backend.withConnection: running session: " ++ show addr (rport,rhost) <- getAddress addr (lport,lhost) <- getSocketName sock >>= getAddress let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock timeoutHandle <- TM.register (killThread curId) tmgr let modifyTimeout = TM.modify timeoutHandle let tickleTimeout = modifyTimeout . max bracket (Listen.createSession lsock 8192 fd (threadWaitRead $ fromIntegral fd)) (\session -> mask_ $ do debug "thread killed, closing socket" -- cancel thread timeout TM.cancel timeoutHandle eatException $ Listen.endSession lsock session eatException $ shutdown sock ShutdownBoth eatException $ sClose sock ) (\s -> let writeEnd = writeOut lsock s sock (tickleTimeout defaultTimeout) in handler sinfo (enumerate lsock s sock) writeEnd (sendFile lsock (tickleTimeout defaultTimeout) fd writeEnd) modifyTimeout ) ------------------------------------------------------------------------------ eatException :: IO a -> IO () eatException act = (act >> return ()) `catch` \(_::SomeException) -> return () ------------------------------------------------------------------------------ sendFile :: ListenSocket -> IO () -> CInt -> Iteratee ByteString IO () -> FilePath -> Int64 -> Int64 -> IO () #if defined(HAS_SENDFILE) sendFile lsock tickle sock writeEnd fp start sz = case lsock of ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags) (closeFd) (go start sz) _ -> do step <- runIteratee writeEnd run_ $ enumFilePartial fp (start,start+sz) step where go off bytes fd | bytes == 0 = return () | otherwise = do sent <- SF.sendFile (threadWaitWrite $ fromIntegral sock) sfd fd off bytes if sent < bytes then tickle >> go (off+sent) (bytes-sent) fd else return () sfd = Fd sock #else sendFile _ _ _ writeEnd fp start sz = do -- no need to count bytes step <- runIteratee writeEnd run_ $ enumFilePartial fp (start,start+sz) step return () #endif ------------------------------------------------------------------------------ enumerate :: (MonadIO m) => ListenSocket -> NetworkSession -> Socket -> Enumerator ByteString m a enumerate port session sock = loop where dbg s = debug $ "SimpleBackend.enumerate(" ++ show (_socket session) ++ "): " ++ s loop (Continue k) = do dbg "reading from socket" s <- liftIO $ timeoutRecv case s of Nothing -> do dbg "got EOF from socket" sendOne k "" Just s' -> do dbg $ "got " ++ Prelude.show (S.length s') ++ " bytes from read end" sendOne k s' loop x = returnI x sendOne k s | S.null s = do dbg "sending EOF to continuation" enumEOF $ Continue k | otherwise = do dbg $ "sending " ++ show s ++ " to continuation" step <- lift $ runIteratee $ k $ Chunks [s] case step of (Yield x st) -> do dbg $ "got yield, remainder is " ++ show st yield x st r@(Continue _) -> do dbg $ "got continue" loop r (Error e) -> throwError e fd = fdSocket sock #ifdef PORTABLE timeoutRecv = Listen.recv port sock (threadWaitRead $ fromIntegral fd) session #else timeoutRecv = Listen.recv port (threadWaitRead $ fromIntegral fd) session #endif ------------------------------------------------------------------------------ writeOut :: (MonadIO m) => ListenSocket -> NetworkSession -> Socket -> (IO ()) -> Iteratee ByteString m () writeOut port session sock tickle = loop where dbg s = debug $ "SimpleBackend.writeOut(" ++ show (_socket session) ++ "): " ++ s loop = continue k k EOF = yield () EOF k (Chunks xs) = do let s = S.concat xs let n = S.length s dbg $ "got chunk with " ++ show n ++ " bytes" ee <- liftIO $ try $ timeoutSend s case ee of (Left (e::SomeException)) -> do dbg $ "timeoutSend got error " ++ show e throwError e (Right _) -> do let last10 = S.drop (n-10) s dbg $ "wrote " ++ show n ++ " bytes, last 10=" ++ show last10 loop fd = fdSocket sock #ifdef PORTABLE timeoutSend = Listen.send port sock tickle (threadWaitWrite $ fromIntegral fd) session #else timeoutSend = Listen.send port tickle (threadWaitWrite $ fromIntegral fd) session #endif snap-server-0.9.5.1/src/Snap/Internal/Http/Server/ListenHelpers.hs0000644000000000000000000000530712522727050023074 0ustar0000000000000000{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.ListenHelpers where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import Foreign.C import Network.Socket (Socket, sClose) import Snap.Internal.Http.Server.Backend import qualified Snap.Internal.Http.Server.HttpPort as Http import qualified Snap.Internal.Http.Server.TLS as TLS ------------------------------------------------------------------------------ listenSocket :: ListenSocket -> Socket listenSocket (ListenHttp s ) = s listenSocket (ListenHttps s _) = s ------------------------------------------------------------------------------ isSecure :: ListenSocket -> Bool isSecure (ListenHttp _ ) = False isSecure (ListenHttps _ _) = True ------------------------------------------------------------------------------ closeSocket :: ListenSocket -> IO () closeSocket (ListenHttp s) = sClose s closeSocket p = TLS.freePort p ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession (ListenHttp _ ) = Http.createSession createSession p@(ListenHttps _ _) = TLS.createSession p ------------------------------------------------------------------------------ endSession :: ListenSocket -> NetworkSession -> IO () endSession (ListenHttp _ ) = Http.endSession endSession (ListenHttps _ _) = TLS.endSession #ifdef PORTABLE -- For portable builds, we can't call read/write directly so we need the -- original haskell socket to use with network-bytestring package. -- Only the simple backend creates sockets in haskell so the following -- functions only work with the simple backend. ------------------------------------------------------------------------------ recv :: ListenSocket -> Socket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv (ListenHttp _ ) s = Http.recv s recv (ListenHttps _ _) _ = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send (ListenHttp _ ) s = Http.send s send (ListenHttps _ _) _ = TLS.send #else ------------------------------------------------------------------------------ recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv (ListenHttp _ ) = Http.recv recv (ListenHttps _ _) = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send (ListenHttp _ ) = Http.send send (ListenHttps _ _) = TLS.send #endif snap-server-0.9.5.1/src/Snap/Internal/Http/Server/Date.hs0000644000000000000000000000501712522727050021166 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Date ( getDateString , getLogDateString , getCurrentDateTime) where import Control.Exception import Control.Monad import Data.ByteString (ByteString) import Data.IORef import Foreign.C.Types import System.IO.Unsafe import System.PosixCompat.Time import Snap.Internal.Http.Types (formatHttpTime, formatLogTime) ------------------------------------------------------------------------------ data DateState = DateState { _cachedDateString :: !(IORef ByteString) , _cachedLogString :: !(IORef ByteString) , _lastFetchTime :: !(IORef CTime) } ------------------------------------------------------------------------------ dateState :: DateState dateState = unsafePerformIO $ do (s1,s2,date) <- fetchTime bs1 <- newIORef s1 bs2 <- newIORef s2 dt <- newIORef date return $! DateState bs1 bs2 dt ------------------------------------------------------------------------------ fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do now <- epochTime t1 <- formatHttpTime now t2 <- formatLogTime now return (t1, t2, now) ------------------------------------------------------------------------------ updateState :: DateState -> IO () updateState (DateState dateString logString time) = do (s1,s2,now) <- fetchTime atomicModifyIORef dateString $ const (s1,()) atomicModifyIORef logString $ const (s2,()) atomicModifyIORef time $ const (now,()) -- force values in the iorefs to prevent thunk buildup !_ <- readIORef dateString !_ <- readIORef logString !_ <- readIORef time return () ------------------------------------------------------------------------------ ensureFreshDate :: IO () ensureFreshDate = mask $ \_ -> do now <- epochTime old <- readIORef $ _lastFetchTime dateState when (now > old) $ updateState dateState ------------------------------------------------------------------------------ getDateString :: IO ByteString getDateString = mask $ \_ -> do ensureFreshDate readIORef $ _cachedDateString dateState ------------------------------------------------------------------------------ getLogDateString :: IO ByteString getLogDateString = mask $ \_ -> do ensureFreshDate readIORef $ _cachedLogString dateState ------------------------------------------------------------------------------ getCurrentDateTime :: IO CTime getCurrentDateTime = epochTime snap-server-0.9.5.1/src/Snap/Internal/Http/Server/Config.hs0000644000000000000000000006100612522727050021516 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| This module exports the 'Config' datatype, which you can use to configure the Snap HTTP server. -} module Snap.Internal.Http.Server.Config where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 import Control.Exception (SomeException) import Control.Monad import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char import Data.Function import Data.List import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import Network(Socket) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) import Snap.Internal.Debug (debug) import Snap.Util.Proxy import System.Console.GetOpt import System.Environment hiding (getEnv) #ifndef PORTABLE import System.Posix.Env #endif import System.Exit import System.IO ------------------------------------------------------------------------------ import Snap.Internal.Http.Server (requestErrorMessage) ------------------------------------------------------------------------------ -- | This datatype allows you to override which backend (either simple or -- libev) to use. Most users will not want to set this, preferring to rely on -- the compile-type default. -- -- Note that if you specify the libev backend and have not compiled in support -- for it, your server will fail at runtime. data ConfigBackend = ConfigSimpleBackend | ConfigLibEvBackend deriving (Show, Eq) ------------------------------------------------------------------------------ -- | Data type representing the configuration of a logging target data ConfigLog = ConfigNoLog -- ^ no logging | ConfigFileLog FilePath -- ^ log to text file | ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler instance Show ConfigLog where show ConfigNoLog = "no log" show (ConfigFileLog f) = "log to file " ++ show f show (ConfigIoLog _) = "custom logging handler" ------------------------------------------------------------------------------ -- | A record type which represents partial configurations (for 'httpServe') -- by wrapping all of its fields in a 'Maybe'. Values of this type are usually -- constructed via its 'Monoid' instance by doing something like: -- -- > setPort 1234 mempty -- -- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and -- this is the norm) are filled in with default values from 'defaultConfig'. data Config m a = Config { hostname :: Maybe ByteString , accessLog :: Maybe ConfigLog , errorLog :: Maybe ConfigLog , locale :: Maybe String , port :: Maybe Int , bind :: Maybe ByteString , sslport :: Maybe Int , sslbind :: Maybe ByteString , sslcert :: Maybe FilePath , sslchaincert :: Maybe Bool , sslkey :: Maybe FilePath , compression :: Maybe Bool , verbose :: Maybe Bool , errorHandler :: Maybe (SomeException -> m ()) , defaultTimeout :: Maybe Int , other :: Maybe a , backend :: Maybe ConfigBackend , proxyType :: Maybe ProxyType , startupHook :: Maybe (StartupInfo m a -> IO ()) } #if MIN_VERSION_base(4,7,0) deriving Typeable #else ------------------------------------------------------------------------------ -- | The 'Typeable1' instance is here so 'Config' values can be -- dynamically loaded with Hint. configTyCon :: TyCon configTyCon = mkTyCon "Snap.Http.Server.Config.Config" {-# NOINLINE configTyCon #-} instance (Typeable1 m) => Typeable1 (Config m) where typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())] #endif instance Show (Config m a) where show c = unlines [ "Config:" , "hostname: " ++ _hostname , "accessLog: " ++ _accessLog , "errorLog: " ++ _errorLog , "locale: " ++ _locale , "port: " ++ _port , "bind: " ++ _bind , "sslport: " ++ _sslport , "sslbind: " ++ _sslbind , "sslcert: " ++ _sslcert , "sslchaincert: " ++ _sslchaincert , "sslkey: " ++ _sslkey , "compression: " ++ _compression , "verbose: " ++ _verbose , "defaultTimeout: " ++ _defaultTimeout , "backend: " ++ _backend , "proxyType: " ++ _proxyType ] where _hostname = show $ hostname c _accessLog = show $ accessLog c _errorLog = show $ errorLog c _locale = show $ locale c _port = show $ port c _bind = show $ bind c _sslport = show $ sslport c _sslbind = show $ sslbind c _sslcert = show $ sslcert c _sslchaincert = show $ sslchaincert c _sslkey = show $ sslkey c _compression = show $ compression c _verbose = show $ verbose c _defaultTimeout = show $ defaultTimeout c _backend = show $ backend c _proxyType = show $ proxyType c ------------------------------------------------------------------------------ -- | Returns a completely empty 'Config'. Equivalent to 'mempty' from -- 'Config''s 'Monoid' instance. emptyConfig :: Config m a emptyConfig = mempty ------------------------------------------------------------------------------ instance Monoid (Config m a) where mempty = Config { hostname = Nothing , accessLog = Nothing , errorLog = Nothing , locale = Nothing , port = Nothing , bind = Nothing , sslport = Nothing , sslbind = Nothing , sslcert = Nothing , sslchaincert = Nothing , sslkey = Nothing , compression = Nothing , verbose = Nothing , errorHandler = Nothing , defaultTimeout = Nothing , other = Nothing , backend = Nothing , proxyType = Nothing , startupHook = Nothing } a `mappend` b = Config { hostname = ov hostname , accessLog = ov accessLog , errorLog = ov errorLog , locale = ov locale , port = ov port , bind = ov bind , sslport = ov sslport , sslbind = ov sslbind , sslcert = ov sslcert , sslchaincert = ov sslchaincert , sslkey = ov sslkey , compression = ov compression , verbose = ov verbose , errorHandler = ov errorHandler , defaultTimeout = ov defaultTimeout , other = ov other , backend = ov backend , proxyType = ov proxyType , startupHook = ov startupHook } where ov f = getLast $! (mappend `on` (Last . f)) a b ------------------------------------------------------------------------------ -- | These are the default values for the options defaultConfig :: MonadSnap m => Config m a defaultConfig = mempty { hostname = Just "localhost" , accessLog = Just $ ConfigFileLog "log/access.log" , errorLog = Just $ ConfigFileLog "log/error.log" , locale = Just "en_US" , compression = Just True , verbose = Just True , errorHandler = Just defaultErrorHandler , bind = Just "0.0.0.0" , sslbind = Just "0.0.0.0" , sslcert = Just "cert.pem" , sslchaincert = Just False , sslkey = Just "key.pem" , defaultTimeout = Just 60 } ------------------------------------------------------------------------------ -- | The hostname of the HTTP server. This field has the same format as an HTTP -- @Host@ header; if a @Host@ header came in with the request, we use that, -- otherwise we default to this value specified in the configuration. getHostname :: Config m a -> Maybe ByteString getHostname = hostname -- | Path to the access log getAccessLog :: Config m a -> Maybe ConfigLog getAccessLog = accessLog -- | Path to the error log getErrorLog :: Config m a -> Maybe ConfigLog getErrorLog = errorLog -- | Gets the locale to use. Locales are used on Unix only, to set the -- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the -- locale to \"@en_US@\", we'll set the relevant environment variables to -- \"@en_US.UTF-8@\". getLocale :: Config m a -> Maybe String getLocale = locale -- | Returns the port to listen on (for http) getPort :: Config m a -> Maybe Int getPort = port -- | Returns the address to bind to (for http) getBind :: Config m a -> Maybe ByteString getBind = bind -- | Returns the port to listen on (for https) getSSLPort :: Config m a -> Maybe Int getSSLPort = sslport -- | Returns the address to bind to (for https) getSSLBind :: Config m a -> Maybe ByteString getSSLBind = sslbind -- | Path to the SSL certificate file getSSLCert :: Config m a -> Maybe FilePath getSSLCert = sslcert -- | Path to the SSL certificate file getSSLChainCert :: Config m a -> Maybe Bool getSSLChainCert = sslchaincert -- | Path to the SSL key file getSSLKey :: Config m a -> Maybe FilePath getSSLKey = sslkey -- | If set and set to True, compression is turned on when applicable getCompression :: Config m a -> Maybe Bool getCompression = compression -- | Whether to write server status updates to stderr getVerbose :: Config m a -> Maybe Bool getVerbose = verbose -- | A MonadSnap action to handle 500 errors getErrorHandler :: Config m a -> Maybe (SomeException -> m ()) getErrorHandler = errorHandler getDefaultTimeout :: Config m a -> Maybe Int getDefaultTimeout = defaultTimeout getOther :: Config m a -> Maybe a getOther = other getBackend :: Config m a -> Maybe ConfigBackend getBackend = backend getProxyType :: Config m a -> Maybe ProxyType getProxyType = proxyType -- | A startup hook is run after the server initializes but before user request -- processing begins. The server passes, through a 'StartupInfo' object, the -- startup hook a list of the sockets it is listening on and the final 'Config' -- object completed after command-line processing. getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ()) getStartupHook = startupHook ------------------------------------------------------------------------------ setHostname :: ByteString -> Config m a -> Config m a setHostname x c = c { hostname = Just x } setAccessLog :: ConfigLog -> Config m a -> Config m a setAccessLog x c = c { accessLog = Just x } setErrorLog :: ConfigLog -> Config m a -> Config m a setErrorLog x c = c { errorLog = Just x } setLocale :: String -> Config m a -> Config m a setLocale x c = c { locale = Just x } setPort :: Int -> Config m a -> Config m a setPort x c = c { port = Just x } setBind :: ByteString -> Config m a -> Config m a setBind x c = c { bind = Just x } setSSLPort :: Int -> Config m a -> Config m a setSSLPort x c = c { sslport = Just x } setSSLBind :: ByteString -> Config m a -> Config m a setSSLBind x c = c { sslbind = Just x } setSSLCert :: FilePath -> Config m a -> Config m a setSSLCert x c = c { sslcert = Just x } setSSLChainCert :: Bool -> Config m a -> Config m a setSSLChainCert x c = c { sslchaincert = Just x } setSSLKey :: FilePath -> Config m a -> Config m a setSSLKey x c = c { sslkey = Just x } setCompression :: Bool -> Config m a -> Config m a setCompression x c = c { compression = Just x } setVerbose :: Bool -> Config m a -> Config m a setVerbose x c = c { verbose = Just x } setErrorHandler :: (SomeException -> m ()) -> Config m a -> Config m a setErrorHandler x c = c { errorHandler = Just x } setDefaultTimeout :: Int -> Config m a -> Config m a setDefaultTimeout x c = c { defaultTimeout = Just x } setOther :: a -> Config m a -> Config m a setOther x c = c { other = Just x } setBackend :: ConfigBackend -> Config m a -> Config m a setBackend x c = c { backend = Just x } setProxyType :: ProxyType -> Config m a -> Config m a setProxyType x c = c { proxyType = Just x } setStartupHook :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a setStartupHook x c = c { startupHook = Just x } ------------------------------------------------------------------------------ -- | Arguments passed to 'setStartupHook'. data StartupInfo m a = StartupInfo { startupHookConfig :: Config m a , startupHookSockets :: [Socket] } emptyStartupInfo :: StartupInfo m a emptyStartupInfo = StartupInfo emptyConfig [] -- | The the 'Socket's opened by the server. There will be two 'Socket's for SSL connections, and one otherwise. getStartupSockets :: StartupInfo m a -> [Socket] getStartupSockets = startupHookSockets -- The 'Config', after any command line parsing has been performed. getStartupConfig :: StartupInfo m a -> Config m a getStartupConfig = startupHookConfig setStartupSockets :: [Socket] -> StartupInfo m a -> StartupInfo m a setStartupSockets x c = c { startupHookSockets = x } setStartupConfig :: Config m a -> StartupInfo m a -> StartupInfo m a setStartupConfig x c = c { startupHookConfig = x } ------------------------------------------------------------------------------ completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a) completeConfig config = do when noPort $ hPutStrLn stderr "no port specified, defaulting to port 8000" return $! cfg `mappend` cfg' where cfg = defaultConfig `mappend` config sslVals = map ($ cfg) [ isJust . getSSLPort , isJust . getSSLBind , isJust . getSSLKey , isJust . getSSLCert ] sslValid = and sslVals noPort = isNothing (getPort cfg) && not sslValid cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing } ------------------------------------------------------------------------------ bsFromString :: String -> ByteString bsFromString = T.encodeUtf8 . T.pack ------------------------------------------------------------------------------ toString :: ByteString -> String toString = T.unpack . T.decodeUtf8 ------------------------------------------------------------------------------ -- | Returns a description of the snap command line options suitable for use -- with "System.Console.GetOpt". optDescrs :: MonadSnap m => Config m a -- ^ the configuration defaults. -> [OptDescr (Maybe (Config m a))] optDescrs defaults = [ Option [] ["hostname"] (ReqArg (Just . setConfig setHostname . bsFromString) "NAME") $ "local hostname" ++ defaultC getHostname , Option ['b'] ["address"] (ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString s }) "ADDRESS") $ "address to bind to" ++ defaultO bind , Option ['p'] ["port"] (ReqArg (\s -> Just $ mempty { port = Just $ read s}) "PORT") $ "port to listen on" ++ defaultO port , Option [] ["ssl-address"] (ReqArg (\s -> Just $ mempty { sslbind = Just $ bsFromString s }) "ADDRESS") $ "ssl address to bind to" ++ defaultO sslbind , Option [] ["ssl-port"] (ReqArg (\s -> Just $ mempty { sslport = Just $ read s}) "PORT") $ "ssl port to listen on" ++ defaultO sslport , Option [] ["ssl-cert"] (ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH") $ "path to ssl certificate in PEM format" ++ defaultO sslcert , Option [] ["ssl-chain-cert"] (NoArg $ Just $ setConfig setSSLChainCert True) $ "certificate file contains complete certificate chain" ++ defaultB sslchaincert "site certificate only" "complete certificate chain" , Option [] ["no-ssl-chain-cert"] (NoArg $ Just $ setConfig setSSLChainCert False) $ "certificate file contains only the site certificate" ++ defaultB sslchaincert "site certificate only" "complete certificate chain" , Option [] ["ssl-key"] (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey , Option [] ["access-log"] (ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH") $ "access log" ++ (defaultC $ getAccessLog) , Option [] ["error-log"] (ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH") $ "error log" ++ (defaultC $ getErrorLog) , Option [] ["no-access-log"] (NoArg $ Just $ setConfig setAccessLog ConfigNoLog) $ "don't have an access log" , Option [] ["no-error-log"] (NoArg $ Just $ setConfig setErrorLog ConfigNoLog) $ "don't have an error log" , Option ['c'] ["compression"] (NoArg $ Just $ setConfig setCompression True) $ "use gzip compression on responses" ++ defaultB getCompression "compressed" "uncompressed" , Option ['t'] ["timeout"] (ReqArg (\t -> Just $ mempty { defaultTimeout = Just $ read t }) "SECS") $ "set default timeout in seconds" ++ defaultC defaultTimeout , Option [] ["no-compression"] (NoArg $ Just $ setConfig setCompression False) $ "serve responses uncompressed" ++ defaultB compression "compressed" "uncompressed" , Option ['v'] ["verbose"] (NoArg $ Just $ setConfig setVerbose True) $ "print server status updates to stderr" ++ defaultC getVerbose , Option ['q'] ["quiet"] (NoArg $ Just $ setConfig setVerbose False) $ "do not print anything to stderr" ++ defaultB getVerbose "verbose" "quiet" , Option [] ["proxy"] (ReqArg (\t -> Just $ setConfig setProxyType $ read t) "X_Forwarded_For") $ concat [ "Set --proxy=X_Forwarded_For if your snap application " , "is behind an HTTP reverse proxy to ensure that " , "rqRemoteAddr is set properly." , defaultC getProxyType ] , Option ['h'] ["help"] (NoArg Nothing) $ "display this help and exit" ] where setConfig f c = f c mempty conf = defaultConfig `mappend` defaults defaultB f y n = maybe "" (\b -> ", default " ++ if b then y else n) $ f conf :: String defaultC f = maybe "" ((", default " ++) . show) $ f conf defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf ------------------------------------------------------------------------------ defaultErrorHandler :: MonadSnap m => SomeException -> m () defaultErrorHandler e = do debug "Snap.Http.Server.Config errorHandler:" req <- getRequest let sm = smsg req debug $ toString sm logError sm finishWith $ setContentType "text/plain; charset=utf-8" . setContentLength (fromIntegral $ B.length msg) . setResponseStatus 500 "Internal Server Error" . modifyResponseBody (>==> enumBuilder (fromByteString msg)) $ emptyResponse where smsg req = toByteString $ requestErrorMessage req e msg = toByteString msgB msgB = mconcat [ fromByteString "A web handler threw an exception. Details:\n" , fromShow e ] ------------------------------------------------------------------------------ -- | Returns a 'Config' obtained from parsing command-line options, using the -- default Snap 'OptDescr' set. -- -- On Unix systems, the locale is read from the @LANG@ environment variable. commandLineConfig :: MonadSnap m => Config m a -- ^ default configuration. This is combined with -- 'defaultConfig' to obtain default values to use if the -- given parameter is specified on the command line. -- Usually it is fine to use 'emptyConfig' here. -> IO (Config m a) commandLineConfig defaults = extendedCommandLineConfig (optDescrs defaults) f defaults where -- Here getOpt can ever change the "other" field, because we only use the -- Snap OptDescr list. The combining function will never be invoked. f = undefined ------------------------------------------------------------------------------ -- | Returns a 'Config' obtained from parsing command-line options, using the -- default Snap 'OptDescr' set as well as a list of user OptDescrs. User -- OptDescrs use the \"other\" field (accessible using 'getOther' and -- 'setOther') to store additional command-line option state. These are -- combined using a user-defined combining function. -- -- On Unix systems, the locale is read from the @LANG@ environment variable. extendedCommandLineConfig :: MonadSnap m => [OptDescr (Maybe (Config m a))] -- ^ User options. -> (a -> a -> a) -- ^ State for multiple invoked user command-line -- options will be combined using this function. -> Config m a -- ^ default configuration. This is combined with -- Snap's 'defaultConfig' to obtain default values -- to use if the given parameter is specified on -- the command line. Usually it is fine to use -- 'emptyConfig' here. -> IO (Config m a) extendedCommandLineConfig opts combiningFunction defaults = do args <- getArgs prog <- getProgName result <- either (usage prog) return (case getOpt Permute opts args of (f, _, [] ) -> maybe (Left []) Right $ fmap (foldl' combine mempty) $ sequence f (_, _, errs) -> Left errs) #ifndef PORTABLE lang <- getEnv "LANG" completeConfig $ mconcat [defaults, mempty {locale = fmap upToUtf8 lang}, result] #else completeConfig $ mconcat [defaults, result] #endif where usage prog errs = do let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:" let msg = concat errs ++ usageInfo hdr opts hPutStrLn stderr msg exitFailure #ifndef PORTABLE upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c #endif combine !a !b = a `mappend` b `mappend` newOther where -- combined is only a Just if both a and b have other fields, and then -- we use the combining function. Config's mappend picks the last -- "Just" in the other list. combined = do x <- getOther a y <- getOther b return $! combiningFunction x y newOther = mempty { other = combined } fmapArg :: (a -> b) -> ArgDescr a -> ArgDescr b fmapArg f (NoArg a) = NoArg (f a) fmapArg f (ReqArg g s) = ReqArg (f . g) s fmapArg f (OptArg g s) = OptArg (f . g) s fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b fmapOpt f (Option s l d e) = Option s l (fmapArg f d) e snap-server-0.9.5.1/src/Snap/Internal/Http/Server/HttpPort.hs0000644000000000000000000000732012522727050022074 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.HttpPort ( bindHttp , createSession , endSession , recv , send ) where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import Foreign import Foreign.C import Network.Socket hiding (recv, send) import Unsafe.Coerce ------------------------------------------------------------------------------ #ifdef PORTABLE import qualified Data.ByteString as B import qualified Network.Socket.ByteString as SB #else import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BI #endif ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.Address ------------------------------------------------------------------------------ bindHttp :: ByteString -> Int -> IO ListenSocket bindHttp bindAddr bindPort = do (family, addr) <- getSockAddr bindPort bindAddr sock <- socket family Stream 0 debug $ "bindHttp: binding port " ++ show addr setSocketOption sock ReuseAddr 1 bindSocket sock addr listen sock 150 debug $ "bindHttp: bound socket " ++ show sock return $! ListenHttp sock ------------------------------------------------------------------------------ createSession :: Int -> CInt -> IO () -> IO NetworkSession createSession buffSize s _ = return $! NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () endSession _ = return () #ifdef PORTABLE ------------------------------------------------------------------------------ recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv sock _ (NetworkSession { _recvLen = s }) = do bs <- SB.recv sock (fromIntegral s) return $! if B.null bs then Nothing else Just bs ------------------------------------------------------------------------------ send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send sock tickle _ _ bs = SB.sendAll sock bs >> tickle #else ------------------------------------------------------------------------------ recv :: IO () -> NetworkSession -> IO (Maybe ByteString) recv onBlock (NetworkSession s _ buffSize) = do fp <- BI.mallocByteString $ fromEnum buffSize sz <- withForeignPtr fp $ \p -> throwErrnoIfMinus1RetryMayBlock "recv" (c_read s p $ toEnum buffSize) onBlock if sz == 0 then return Nothing else return $! Just $! BI.fromForeignPtr fp 0 $! fromEnum sz ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send tickleTimeout onBlock (NetworkSession s _ _) bs = BI.unsafeUseAsCStringLen bs $ uncurry loop where loop ptr len = do sent <- throwErrnoIfMinus1RetryMayBlock "send" (c_write s ptr $ toEnum len) onBlock let sent' = fromIntegral sent if sent' < len then tickleTimeout >> loop (plusPtr ptr sent') (len - sent') else tickleTimeout ------------------------------------------------------------------------------ foreign import ccall unsafe "unistd.h read" c_read :: CInt -> Ptr a -> CSize -> IO (CSize) foreign import ccall unsafe "unistd.h write" c_write :: CInt -> Ptr a -> CSize -> IO (CSize) #endif snap-server-0.9.5.1/src/Snap/Internal/Http/Server/Backend.hs0000644000000000000000000000662112522727050021642 0ustar0000000000000000{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Backend where {- The server backend is made up of two APIs. + The ListenSocket class abstracts the reading and writing from the network. We have seperate implementations of ListenSocket for http and https. + The EventLoop function is the interface to accept on the socket. The EventLoop function will listen on the ports, and for each accepted connection it wil call the SessionHandler. -} #ifdef OPENSSL import OpenSSL.Session #endif import GHC.Exts (Any) import Data.ByteString (ByteString) import Foreign import Foreign.C import Network.Socket (Socket) import Snap.Iteratee (Iteratee, Enumerator) ------------------------------------------------------------------------------ data SessionInfo = SessionInfo { localAddress :: ByteString , localPort :: Int , remoteAddress :: ByteString , remotePort :: Int , isSecure :: Bool } ------------------------------------------------------------------------------ type SessionHandler = SessionInfo -- ^ session port information -> Enumerator ByteString IO () -- ^ read end of socket -> Iteratee ByteString IO () -- ^ write end of socket -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end -> ((Int -> Int) -> IO ()) -- ^ timeout tickler -> IO () ------------------------------------------------------------------------------ type EventLoop = Int -- ^ default timeout -> [ListenSocket] -- ^ list of ports -> Int -- ^ number of capabilities -> (ByteString -> IO ()) -- ^ error log -> IO () -- ^ initialisation function -> SessionHandler -- ^ session handler -> IO () {- For performance reasons, we do not implement this as a class class ListenSocket a where data ListenSocketSession a :: * listenSocket :: a -> Socket isSecure :: a -> Bool closePort :: a -> IO () createSession :: a -> Int -- ^ recv buffer size -> CInt -- ^ network socket -> IO () -- ^ action to block waiting for handshake -> IO (ListenSocketSession a) endSession :: a -> ListenSocketSession a -> IO () recv :: a -> IO () -- ^ action to block waiting for data -> ListenSocketSession a -- ^ session -> IO (Maybe ByteString) send :: a -> IO () -- ^ action to tickle the timeout -> IO () -- ^ action to block waiting for data -> ListenSocketSession a -- ^ session -> ByteString -- ^ data to send -> IO () -} ------------------------------------------------------------------------------ data ListenSocket = ListenHttp Socket #ifdef OPENSSL | ListenHttps Socket SSLContext #else | ListenHttps Socket () #endif instance Show ListenSocket where show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")" show (ListenHttps s _) = "ListenHttps (" ++ show s ++ ")" ------------------------------------------------------------------------------ data NetworkSession = NetworkSession { _socket :: CInt , _session :: Any -- ^ brutal hack. , _recvLen :: Int } snap-server-0.9.5.1/src/Snap/Internal/Http/Server/Address.hs0000644000000000000000000000476512522727050021707 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.Address ( getHostAddr , getSockAddr , getAddress ) where ------------------------------------------------------------------------------ import Control.Exception import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Char8 () import Data.ByteString.Internal (c2w, w2c) import Data.Maybe import Data.Typeable import Network.Socket ------------------------------------------------------------------------------ data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) instance Show AddressNotSupportedException where show (AddressNotSupportedException x) = "Address not supported: " ++ x instance Exception AddressNotSupportedException ------------------------------------------------------------------------------ getHostAddr :: SockAddr -> IO String getHostAddr addr = (fromMaybe "" . fst) `liftM` getNameInfo [NI_NUMERICHOST] True False addr ------------------------------------------------------------------------------ getAddress :: SockAddr -> IO (Int, ByteString) getAddress addr = do port <- case addr of SockAddrInet p _ -> return p SockAddrInet6 p _ _ _ -> return p x -> throwIO $ AddressNotSupportedException $ show x host <- getHostAddr addr return (fromIntegral port, S.pack $ map c2w host) ------------------------------------------------------------------------------ getSockAddr :: Int -> ByteString -> IO (Family, SockAddr) getSockAddr p s | s == "*" = return $! ( AF_INET , SockAddrInet (fromIntegral p) iNADDR_ANY ) getSockAddr p s | s == "::" = return $! ( AF_INET6 , SockAddrInet6 (fromIntegral p) 0 iN6ADDR_ANY 0 ) getSockAddr p s = do let hints = defaultHints { addrFlags = [AI_NUMERICSERV] , addrSocketType = Stream } ais <- getAddrInfo (Just hints) (Just $ map w2c $ S.unpack s) (Just $ show p) if null ais then throwIO $ AddressNotSupportedException $ show s else do let ai = head ais let fm = addrFamily ai let sa = addrAddress ai return (fm, sa) snap-server-0.9.5.1/test/0000755000000000000000000000000012522727050013300 5ustar0000000000000000snap-server-0.9.5.1/test/snap-server-testsuite.cabal0000644000000000000000000001447412522727050020572 0ustar0000000000000000name: snap-server-testsuite version: 0.1.1 build-type: Simple cabal-version: >= 1.6 Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used. Default: False Flag openssl Description: Enable https support using the HsOpenSSL library. Default: False Executable testsuite hs-source-dirs: suite common ../src main-is: TestSuite.hs build-depends: QuickCheck >= 2, attoparsec >= 0.10 && <0.13, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5, base16-bytestring == 0.1.*, binary >= 0.5 && <0.7, blaze-builder >= 0.2.1.4 && <0.5, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, conduit >= 0.5 && <0.6, containers, cprng-aes <0.4, cryptocipher >= 0.3.7 && <0.4, crypto-api <0.13, directory, directory-tree, enumerator >= 0.4.15 && <0.5, filepath, http-conduit >= 1.8 && <1.9, HUnit >= 1.2 && <2, mtl >= 2 && <3, network >= 2.3 && <2.6, old-locale, parallel >= 2 && <4, process, snap-core >= 0.9.3 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, text >= 0.11 && <1.2, time, tls >= 1.0 && <1.1, tls-extra >= 0.5 && <0.6, transformers extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving if !os(windows) build-depends: unix if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11 if flag(portable) || os(windows) cpp-options: -DPORTABLE cpp-options: -DTESTSUITE ghc-prof-options: -prof -auto-all ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts Executable pongserver hs-source-dirs: pongserver common ../src main-is: Main.hs build-depends: QuickCheck >= 2, attoparsec >= 0.10 && <0.13, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5, base16-bytestring == 0.1.*, blaze-builder >= 0.2.1.4 && <0.5, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, cereal >= 0.3 && <0.4, containers, directory-tree, enumerator >= 0.4.15 && <0.5, filepath, HUnit >= 1.2 && <2, mtl >= 2 && <3, old-locale, parallel >= 3.2 && <4, MonadCatchIO-transformers >= 0.2.1 && <0.4, network >= 2.3 && <2.6, snap-core >= 0.9.3 && <0.10, template-haskell, time, transformers, unix-compat >= 0.2 && <0.5, utf8-string >= 0.3.6 && <0.4 if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11 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 -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all Executable testserver hs-source-dirs: testserver common ../src main-is: Main.hs build-depends: QuickCheck >= 2, attoparsec >= 0.10 && <0.13, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5, binary >= 0.5 && <0.7, blaze-builder >= 0.2.1.4 && <0.5, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, case-insensitive >= 0.3 && <1.3, containers, directory-tree, enumerator >= 0.4.15 && <0.5, filepath, HUnit >= 1.2 && <2, MonadCatchIO-transformers >= 0.2.1 && <0.4, mtl >= 2 && <3, network >= 2.3 && <2.6, old-locale, parallel >= 3.2 && <4, snap-core >= 0.9.3 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, text >= 0.11 && <1.2, time if !os(windows) build-depends: unix if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11 if flag(portable) || os(windows) cpp-options: -DPORTABLE ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all Executable benchmark hs-source-dirs: benchmark common ../src main-is: Benchmark.hs ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all build-depends: base >= 4 && < 5, network >= 2.3 && < 2.6, criterion >= 0.8 && < 0.9 snap-server-0.9.5.1/test/runTestsAndCoverage.sh0000755000000000000000000000157012522727050017570 0ustar0000000000000000#!/bin/sh set -e if [ -z "$DEBUG" ]; then export DEBUG=testsuite fi SUITE=./dist/build/testsuite/testsuite rm -f *.tix if [ ! -f $SUITE ]; then cat </dev/null 2>&1 rm -f testsuite.tix cat < Identity () parseGet s = do !_ <- run_ $ enumBS s $$ parseRequest return () benchmarks = bgroup "parser" [ bench "firefoxget" $ whnf (runIdentity . parseGet) parseGetData ] snap-server-0.9.5.1/test/data/0000755000000000000000000000000012522727050014211 5ustar0000000000000000snap-server-0.9.5.1/test/data/fileServe/0000755000000000000000000000000012522727050016135 5ustar0000000000000000snap-server-0.9.5.1/test/data/fileServe/foo.bin0000644000000000000000000000000412522727050017404 0ustar0000000000000000FOO snap-server-0.9.5.1/test/data/fileServe/foo.txt0000644000000000000000000000000412522727050017453 0ustar0000000000000000FOO snap-server-0.9.5.1/test/data/fileServe/foo.bin.bin.bin0000644000000000000000000000000412522727050020722 0ustar0000000000000000FOO snap-server-0.9.5.1/test/data/fileServe/foo.html0000644000000000000000000000000412522727050017600 0ustar0000000000000000FOO snap-server-0.9.5.1/test/common/0000755000000000000000000000000012522727050014570 5ustar0000000000000000snap-server-0.9.5.1/test/common/Paths_snap_server.hs0000644000000000000000000000026012522727050020610 0ustar0000000000000000module Paths_snap_server ( version ) where import Data.Version (Version(..)) version :: Version version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} snap-server-0.9.5.1/test/common/Test/0000755000000000000000000000000012522727050015507 5ustar0000000000000000snap-server-0.9.5.1/test/common/Test/Common/0000755000000000000000000000000012522727050016737 5ustar0000000000000000snap-server-0.9.5.1/test/common/Test/Common/Rot13.hs0000644000000000000000000000100012522727050020172 0ustar0000000000000000module 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 snap-server-0.9.5.1/test/common/Test/Common/TestHandler.hs0000644000000000000000000001526212522727050021516 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Test.Common.TestHandler (testHandler) where import Blaze.ByteString.Builder import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Snap.Core import Snap.Internal.Debug import Snap.Iteratee hiding (Enumerator) import qualified Snap.Iteratee as I import Snap.Util.FileServe import Snap.Util.FileUploads import Snap.Util.GZip import System.Directory import Test.Common.Rot13 (rot13) ------------------------------------------------------------------------------ -- timeout handling ------------------------------------------------------------------------------ timeoutTickleHandler :: Snap () timeoutTickleHandler = do noCompression -- FIXME: remove this when zlib-bindings and -- zlib-enumerator support gzip stream flushing modifyResponse $ setResponseBody (trickleOutput 10) . setContentType "text/plain" . setBufferingMode False setTimeout 2 badTimeoutTickleHandler :: Snap () badTimeoutTickleHandler = do noCompression -- FIXME: remove this when zlib-bindings and -- zlib-enumerator support gzip stream flushing modifyResponse $ setResponseBody (trickleOutput 10) . setContentType "text/plain" setTimeout 2 trickleOutput :: Int -> Enumerator Builder IO a trickleOutput n = concatEnums $ dots `interleave` delays where enumOne i = do debug "enumOne: .\\n" enumList 1 [fromByteString ".\n"] i delay st = do debug "delay 1s" liftIO $ threadDelay 1000000 returnI st interleave x0 y0 = (go id x0 y0) [] where go !dl [] ys = dl . (++ys) go !dl xs [] = dl . (++xs) go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys dots = replicate n enumOne delays = replicate n delay ------------------------------------------------------------------------------ pongHandler :: Snap () pongHandler = modifyResponse $ setResponseBody (enumBuilder $ fromByteString "PONG") . setContentType "text/plain" . setContentLength 4 echoUriHandler :: Snap () echoUriHandler = do req <- getRequest writeBS $ rqURI req echoHandler :: Snap () echoHandler = transformRequestBody returnI rot13Handler :: Snap () rot13Handler = transformRequestBody f where f origStep = do mbX <- I.head maybe (enumEOF origStep) (feedStep origStep) mbX feedStep origStep b = do let x = toByteString b let e = enumBuilder $ fromByteString $ rot13 x step <- lift $ runIteratee $ e origStep f step 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 uploadForm :: Snap () uploadForm = do modifyResponse $ setContentType "text/html" writeBS form where form = S.concat [ "Upload a file\n" , "

Upload some text/plain files:

\n" , "
\n" , "\n" , "\n" , "
" ] uploadHandler :: Snap () uploadHandler = do liftIO $ createDirectoryIfMissing True tmpdir handleFileUploads tmpdir defaultUploadPolicy partPolicy hndl where isRight (Left _) = False isRight (Right _) = True f (_, Left _) = error "impossible" f (p, Right x) = (fromMaybe "-" $ partFileName p, x) hndl xs' = do let xs = [ f x | x <- xs', isRight (snd x) ] files <- mapM (\(x,fp) -> do c <- liftIO $ S.readFile fp return (x,c)) xs let m = sort files params <- liftM (Prelude.map (\(a,b) -> (a,S.concat b)) . Map.toAscList . rqParams) getRequest modifyResponse $ setContentType "text/plain" writeBuilder $ buildRqParams params `mappend` buildFiles m builder _ [] = mempty builder ty ((k,v):xs) = mconcat [ fromByteString ty , fromByteString ":\n" , fromByteString k , fromByteString "\nValue:\n" , fromByteString v , fromByteString "\n\n" , builder ty xs ] buildRqParams = builder "Param" buildFiles = builder "File" tmpdir = "dist/filetmp" partPolicy partInfo = if partContentType partInfo == "text/plain" then allowWithMaximumSize 200000 else disallow serverHeaderHandler :: Snap () serverHeaderHandler = modifyResponse $ setHeader "Server" "foo" chunkedResponse :: Snap () chunkedResponse = writeBS "chunked" testHandler :: Snap () testHandler = withCompression $ route [ ("pong" , pongHandler ) , ("echo" , echoHandler ) , ("rot13" , rot13Handler ) , ("echoUri" , echoUriHandler ) , ("fileserve" , serveDirectory "testserver/static") , ("bigresponse" , bigResponseHandler ) , ("respcode/:code" , responseHandler ) , ("upload/form" , uploadForm ) , ("upload/handle" , uploadHandler ) , ("timeout/tickle" , timeoutTickleHandler ) , ("timeout/badtickle" , badTimeoutTickleHandler ) , ("server-header" , serverHeaderHandler ) , ("chunked" , chunkedResponse ) ] snap-server-0.9.5.1/test/common/Snap/0000755000000000000000000000000012522727050015471 5ustar0000000000000000snap-server-0.9.5.1/test/common/Snap/Test/0000755000000000000000000000000012522727050016410 5ustar0000000000000000snap-server-0.9.5.1/test/common/Snap/Test/Common.hs0000644000000000000000000000520412522727050020175 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Test.Common where import Blaze.ByteString.Builder 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 Data.Monoid import Network.Socket import qualified Network.Socket.ByteString as N import Prelude hiding (catch) import Test.HUnit (assertFailure) 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 expectException :: IO a -> IO () expectException m = do e <- try m case e of Left (_::SomeException) -> return () Right _ -> assertFailure "expected exception, didn't get it" 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 b <- f mempty sock return $! toByteString b where f b sk = do s <- N.recv sk 100000 if S.null s then return b else f (b `mappend` fromByteString s) sk ditchHeaders :: [ByteString] -> [ByteString] ditchHeaders ("":xs) = xs ditchHeaders ("\r":xs) = xs ditchHeaders (_:xs) = ditchHeaders xs ditchHeaders [] = [] snap-server-0.9.5.1/test/suite/0000755000000000000000000000000012522727050014431 5ustar0000000000000000snap-server-0.9.5.1/test/suite/TestSuite.hs0000644000000000000000000000406612522727050016724 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Exception import Control.Concurrent (killThread) import Control.Concurrent.MVar import Control.Monad import Prelude hiding (catch) import Network (withSocketsDo) import Test.Framework (defaultMain, testGroup) import System.Environment import Snap.Http.Server.Config import qualified Snap.Internal.Http.Parser.Tests import qualified Snap.Internal.Http.Server.Tests import qualified Snap.Internal.Http.Server.TimeoutManager.Tests import qualified Test.Blackbox ports :: Int -> [Int] ports sp = [sp] #ifdef OPENSSL sslports :: Int -> [Maybe Int] sslports sp = map Just [(sp + 100)] #else sslports :: Int -> [Maybe Int] sslports _ = repeat Nothing #endif backends :: Int -> [(Int,Maybe Int)] backends sp = zip (ports sp) (sslports sp) getStartPort :: IO Int getStartPort = (liftM read (getEnv "STARTPORT") >>= evaluate) `catch` \(_::SomeException) -> return 8111 main :: IO () main = withSocketsDo $ do sp <- getStartPort let bends = backends sp tinfos <- forM bends $ \(port,sslport) -> Test.Blackbox.startTestServer port sslport defaultMain (tests ++ concatMap blackbox bends) `finally` do mapM_ killThread $ map fst tinfos mapM_ takeMVar $ map snd tinfos where 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 "Snap.Internal.Http.Server.TimeoutManager.Tests" Snap.Internal.Http.Server.TimeoutManager.Tests.tests ] blackbox (port, sslport) = [ testGroup ("Test.Blackbox") $ Test.Blackbox.tests port , testGroup ("Test.Blackbox SSL") $ Test.Blackbox.ssltests sslport ] snap-server-0.9.5.1/test/suite/Test/0000755000000000000000000000000012522727050015350 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Test/Blackbox.hs0000644000000000000000000004300212522727050017430 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Blackbox ( tests , ssltests , startTestServer ) where -------------------------------------------------------------------------------- import Blaze.ByteString.Builder import Control.Concurrent import Control.Exception (SomeException, catch, throwIO) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Base16 as B16 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.CaseInsensitive (CI) import Data.Conduit (ResourceT) import Data.Int import Data.List import Data.Monoid import qualified Network.HTTP.Conduit as HTTP import qualified Network.Socket.ByteString as N import Network.TLS (CertificateUsage (..)) import Prelude hiding (catch, take) import System.Timeout import Test.Framework import Test.Framework.Options import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test, path) import Test.QuickCheck import Test.QuickCheck.Monadic hiding (assert, run) import qualified Test.QuickCheck.Monadic as QC import qualified Test.QuickCheck.Property as QC ------------------------------------------------------------------------------ import Snap.Http.Server import Snap.Internal.Debug import Snap.Iteratee hiding (head, map) import qualified Snap.Iteratee as I import Snap.Test.Common import Test.Common.Rot13 import Test.Common.TestHandler ------------------------------------------------------------------------------ testFunctions :: [Bool -> Int -> String -> Test] testFunctions = [ testPong -- FIXME: waiting on http-enumerator patch for HEAD behaviour -- , testHeadPong , testEcho , testRot13 , testSlowLoris , testBlockingRead , testBigResponse , testPartial , testFileUpload , testTimeoutTickle , testTimeoutBadTickle , testServerHeader , testChunkedHead ] ------------------------------------------------------------------------------ tests :: Int -> [Test] tests port = map (\f -> f False port "") testFunctions ------------------------------------------------------------------------------ slowTestOptions :: Bool -> TestOptions' Maybe slowTestOptions ssl = if ssl then mempty { topt_maximum_generated_tests = Just 75 } else mempty { topt_maximum_generated_tests = Just 300 } ------------------------------------------------------------------------------ ssltests :: Maybe Int -> [Test] ssltests = maybe [] httpsTests where httpsTests port = map (\f -> f True port sslname) testFunctions sslname = "ssl/" ------------------------------------------------------------------------------ startTestServer :: Int -> Maybe Int -> IO (ThreadId, MVar ()) startTestServer port sslport = do let cfg = setAccessLog (ConfigFileLog "ts-access.log") . setErrorLog (ConfigFileLog "ts-error.log") . setBind "*" . setPort port . setDefaultTimeout 10 . setVerbose False $ defaultConfig let cfg' = maybe cfg (\p -> setSSLPort p . setSSLBind "*" . setSSLCert "cert.pem" . setSSLKey "key.pem" . setAccessLog (ConfigFileLog "ts-access-ssl.log") . setErrorLog (ConfigFileLog "ts-error-ssl.log") $ cfg) sslport mvar <- newEmptyMVar tid <- forkIO $ do (httpServe cfg' testHandler) `catch` \(_::SomeException) -> return () putMVar mvar () threadDelay $ 4*seconds return (tid,mvar) ------------------------------------------------------------------------------ doPong :: Bool -> Int -> IO ByteString doPong ssl port = do debug "getting URI" let !uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/pong" debug $ "URI is: '" ++ uri ++ "', calling simpleHttp" rsp <- fetch uri debug $ "response was " ++ show rsp return $ S.concat $ L.toChunks rsp ------------------------------------------------------------------------------ -- FIXME: waiting on http-enumerator patch for HEAD behaviour -- headPong :: Bool -> Int -> IO ByteString -- headPong ssl port = do -- let uri = (if ssl then "https" else "http") -- ++ "://127.0.0.1:" ++ show port ++ "/echo" -- req0 <- HTTP.parseUrl uri -- let req = req0 { HTTP.method = "HEAD" } -- rsp <- HTTP.httpLbs req -- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp ------------------------------------------------------------------------------ testPong :: Bool -> Int -> String -> Test testPong ssl port name = testCase (name ++ "blackbox/pong") $ do doc <- doPong ssl port assertEqual "pong response" "PONG" doc ------------------------------------------------------------------------------ -- FIXME: waiting on http-enumerator patch for HEAD behaviour -- testHeadPong :: Bool -> Int -> String -> Test -- testHeadPong ssl port name = testCase (name ++ "blackbox/pong/HEAD") $ do -- doc <- headPong ssl port -- assertEqual "pong HEAD response" "" doc ------------------------------------------------------------------------------ testEcho :: Bool -> Int -> String -> Test testEcho ssl port name = plusTestOptions (slowTestOptions ssl) $ testProperty (name ++ "blackbox/echo") $ QC.mapSize (if ssl then min 100 else min 300) $ monadicIO $ forAllM arbitrary prop where prop txt = do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/echo" doc <- QC.run $ post uri txt [] QC.assert $ txt == doc ------------------------------------------------------------------------------ testFileUpload :: Bool -> Int -> String -> Test testFileUpload ssl port name = plusTestOptions (slowTestOptions ssl) $ testProperty (name ++ "blackbox/upload") $ QC.mapSize (if ssl then min 100 else min 300) $ monadicIO $ forAllM arbitrary prop where boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl" prefix = [ "--" , boundary , "\r\n" , "content-disposition: form-data; name=\"submit\"\r\n" , "\r\nSubmit\r\n" ] body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix where part (k,v) = [ "--" , boundary , "\r\ncontent-disposition: attachment; filename=\"" , k , "\"\r\nContent-Type: text/plain\r\n\r\n" , v , "\r\n" ] suffix = [ "--", boundary, "--\r\n" ] hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ] ++ L.toChunks boundary) ] b16 (k,v) = (ne $ e k, e v) where ne s = if L.null s then "file" else s e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ] response kvps = L.concat $ [ "Param:\n" , "submit\n" , "Value:\n" , "Submit\n\n" ] ++ concatMap responseKVP kvps responseKVP (k,v) = [ "File:\n" , k , "\nValue:\n" , v , "\n\n" ] prop kvps' = do let kvps = sort $ map b16 kvps' let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/upload/handle" let txt = response kvps doc <- QC.run $ post uri (body kvps) hdrs when (txt /= doc) $ QC.run $ do L.putStrLn "expected:" L.putStrLn "----------------------------------------" L.putStrLn txt L.putStrLn "----------------------------------------" L.putStrLn "\ngot:" L.putStrLn "----------------------------------------" L.putStrLn doc L.putStrLn "----------------------------------------" QC.assert $ txt == doc ------------------------------------------------------------------------------ testRot13 :: Bool -> Int -> String -> Test testRot13 ssl port name = plusTestOptions (slowTestOptions ssl) $ testProperty (name ++ "blackbox/rot13") $ monadicIO $ forAllM arbitrary prop where prop txt = do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/rot13" doc <- QC.run $ liftM (S.concat . L.toChunks) $ post uri (L.fromChunks [txt]) [] QC.assert $ txt == rot13 doc ------------------------------------------------------------------------------ -- TODO: this one doesn't work w/ SSL testSlowLoris :: Bool -> Int -> String -> Test testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $ if ssl then return () else withSock port go where go sock = do m <- timeout (120*seconds) $ go' sock maybe (assertFailure "slowloris: timeout") (const $ return ()) m 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 ------------------------------------------------------------------------------ testChunkedHead :: Bool -> Int -> String -> Test testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $ if ssl then return () else withSock port go where go sock = do N.sendAll sock $ "HEAD /chunked HTTP/1.1\r\n\r\n" s <- N.recv sock 4096 assertBool "no body" $ isOK s split x l | S.null x = reverse l | otherwise = let (a, b) = S.break (== '\r') x b' = S.drop 2 b in split b' (a : l) isOK s = let lns = split s [] lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns in null lns' ------------------------------------------------------------------------------ -- TODO: doesn't work w/ ssl testBlockingRead :: Bool -> Int -> String -> Test testBlockingRead ssl port name = testCase (name ++ "blackbox/testBlockingRead") $ if ssl then return () else runIt where runIt = withSock port $ \sock -> do m <- timeout (60*seconds) $ go sock maybe (assertFailure "timeout") (const $ return ()) m go 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 ------------------------------------------------------------------------------ -- TODO: no ssl here -- test server's ability to trap/recover from IO errors testPartial :: Bool -> Int -> String -> Test testPartial ssl port name = testCase (name ++ "blackbox/testPartial") $ if ssl then return () else runIt where runIt = do m <- timeout (60*seconds) go maybe (assertFailure "timeout") (const $ return ()) m go = do withSock port $ \sock -> N.sendAll sock "GET /pong HTTP/1.1\r\n" doc <- doPong ssl port assertEqual "pong response" "PONG" doc ------------------------------------------------------------------------------ -- TODO: no ssl testBigResponse :: Bool -> Int -> String -> Test testBigResponse ssl port name = testCase (name ++ "blackbox/testBigResponse") $ if ssl then return () else runIt where runIt = withSock port $ \sock -> do m <- timeout (120*seconds) $ go sock maybe (assertFailure "timeout") (const $ return ()) m go 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*seconds ------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) ------------------------------------------------------------------------------ fetchReq :: HTTP.Request (ResourceT IO) -> IO (L.ByteString) fetchReq req = go `catch` (\(e::SomeException) -> do debug $ "simpleHttp threw exception: " ++ show e throwIO e) where go = do rsp <- HTTP.withManagerSettings settings $ HTTP.httpLbs req return $ HTTP.responseBody rsp settings = HTTP.def { HTTP.managerCheckCerts = \_ _ _ -> return CertificateUsageAccept } ------------------------------------------------------------------------------ fetchResponse :: String -> IO (HTTP.Response L.ByteString) fetchResponse url = do req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do debug $ "parseUrl threw exception: " ++ show e throwIO e) go req `catch` (\(e::SomeException) -> do debug $ "simpleHttp threw exception: " ++ show e throwIO e) where go req = HTTP.withManagerSettings settings $ HTTP.httpLbs req settings = HTTP.def { HTTP.managerCheckCerts = \_ _ _ -> return CertificateUsageAccept } ------------------------------------------------------------------------------ fetch :: String -> IO (L.ByteString) fetch url = do req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do debug $ "HTTP.parseUrl threw exception: " ++ show e throwIO e) fetchReq req ------------------------------------------------------------------------------ post :: String -> L.ByteString -> [(CI ByteString, ByteString)] -> IO (L.ByteString) post url body hdrs = do req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do debug $ "HTTP.parseUrl threw exception: " ++ show e throwIO e) fetchReq $ req { HTTP.requestBody = HTTP.RequestBodyLBS body , HTTP.method = "POST" , HTTP.requestHeaders = hdrs } ------------------------------------------------------------------------------ -- This test checks two things: -- -- 1. that the timeout tickling logic works -- 2. that "flush" is passed along through a gzip operation. testTimeoutTickle :: Bool -> Int -> String -> Test testTimeoutTickle ssl port name = testCase (name ++ "blackbox/timeout/tickle") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle" doc <- liftM (S.concat . L.toChunks) $ fetch uri let expected = S.concat $ replicate 10 ".\n" assertEqual "response equal" expected doc ------------------------------------------------------------------------------ testTimeoutBadTickle :: Bool -> Int -> String -> Test testTimeoutBadTickle ssl port name = testCase (name ++ "blackbox/timeout/badtickle") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/timeout/badtickle" expectException $ fetch uri ------------------------------------------------------------------------------ testServerHeader :: Bool -> Int -> String -> Test testServerHeader ssl port name = testCase (name ++ "/blackbox/server-header") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/server-header" rsp <- fetchResponse uri let serverHeader = lookup "server" $ HTTP.responseHeaders rsp assertEqual "server header" (Just "foo") serverHeader snap-server-0.9.5.1/test/suite/Snap/0000755000000000000000000000000012522727050015332 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/0000755000000000000000000000000012522727050017106 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/Http/0000755000000000000000000000000012522727050020025 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Server/0000755000000000000000000000000012522727050021273 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Server/Tests.hs0000644000000000000000000010001512522727050022726 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Tests ( tests ) where import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Enumerator import Control.Concurrent import Control.Exception (Exception, SomeException, bracket, catch, finally, throwIO, try) import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.CaseInsensitive as CI import Data.Char import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL import Data.Int import Data.IORef import Data.List (foldl', sort) import Data.Maybe (fromJust, isJust) import Data.Time.Calendar import Data.Time.Clock import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.Socket.ByteString as N import Prelude hiding (catch, take) import qualified Prelude import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) import qualified Snap.Http.Server as Svr import Snap.Core import Snap.Internal.Debug import Snap.Internal.Http.Server import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Types import Snap.Iteratee hiding (map) import qualified Snap.Iteratee as I import qualified Snap.Test as Test import Snap.Test.Common import qualified Snap.Types.Headers as H data TestException = TestException deriving (Show, Typeable) instance Exception TestException tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest , testHttpRequest2 , testHttpRequest3 , testHttpRequest3' , testHttpResponse1 , testHttpResponse2 , testHttpResponse3 , testHttpResponse4 , testHttpResponseCookies , testHttp1 , testHttp2 , testHttp100 , test411 , testEscapeHttp , testExpectGarbage , testPartialParse , testMethodParsing , testServerStartupShutdown , testServerShutdownWithOpenConns , testChunkOn1_0 , testSendFile , testTrivials] testTrivials :: Test testTrivials = testCase "server/trivials" $ do let !v = Svr.snapServerVersion return $! v `seq` () ------------------------------------------------------------------------------ -- HTTP request tests -- note leading crlf -- test tolerance of this, some old browsers send an extra -- crlf after a post body sampleRequest :: ByteString sampleRequest = 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" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] sampleRequestExpectContinue :: ByteString sampleRequestExpectContinue = 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: 100-continue\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] sampleRequest411 :: ByteString sampleRequest411 = S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" , "Host: www.zabble.com:7777\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" ] 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" , "Host: www.zabble.com:7777\r\n" , "Content-Length: 10\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] testMethodParsing :: Test testMethodParsing = testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms where ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH , Method "COPY", Method "MOVE" ] dummyIter :: Iteratee ByteString IO () dummyIter = consume >> return () testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString) testReceiveRequest = do r <- liftM fromJust $ rsm $ receiveRequest dummyIter se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se it <- liftM e $ lift $ runIteratee copyingStream2Stream b <- it return (r,b) testReceiveRequestIter :: ByteString -> IO (Iteratee ByteString IO (Request,L.ByteString)) testReceiveRequestIter req = liftM (enumBS req) $ runIteratee testReceiveRequest testHttpRequest1 :: Test testHttpRequest1 = testCase "server/HttpRequest1" $ do iter <- testReceiveRequestIter sampleRequest (req,body) <- run_ iter assertEqual "not secure" False $ rqIsSecure req assertEqual "content length" (Just 10) $ rqContentLength req assertEqual "parse body" "0123456789" body assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing False False] (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $ H.lookup "x-random-other-header" $ rqHeaders req assertEqual "parse URI" "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc" $ rqURI req assertEqual "server port" 7777 $ rqServerPort req assertEqual "context path" "/" $ rqContextPath req assertEqual "pathinfo" "foo/bar.html" $ rqPathInfo req assertEqual "query string" "param1=abc¶m2=def%20+¶m1=abc" $ rqQueryString req assertEqual "server name" "www.zabble.com" $ rqServerName req assertEqual "version" (1,1) $ rqVersion req assertEqual "param1" (Just ["abc","abc"]) $ rqParam "param1" req assertEqual "param2" (Just ["def "]) $ rqParam "param2" req testMultiRequest :: Test testMultiRequest = testCase "server/MultiRequest" $ do let clientIter = do (r1,b1) <- testReceiveRequest (r2,b2) <- testReceiveRequest return (r1,b1,r2,b2) iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $ runIteratee clientIter (req1,body1,req2,body2) <- run_ iter assertEqual "parse body 1" "0123456789" body1 assertEqual "parse body 2" "0123456789" body2 assertEqual "parse URI 1" "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc" $ rqURI req1 assertEqual "parse URI 2" "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc" $ rqURI req2 testOneMethod :: Method -> IO () testOneMethod m = do step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumLBS txt step req <- run_ iter assertEqual "method" m $ rqMethod req where txt = methodTestText m sampleShortRequest :: ByteString sampleShortRequest = "GET /fo" testPartialParse :: Test testPartialParse = testCase "server/short" $ do step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumBS sampleShortRequest step expectException $ run_ iter methodTestText :: Method -> L.ByteString methodTestText m = L.concat [ mbs m , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ] where mbs (Method b) = L.fromChunks [b] mbs b = L.pack $ map c2w $ show b sampleRequest2 :: ByteString sampleRequest2 = S.concat [ "GET /foo/bar.html?param1=abc¶m2=def¶m1=abc HTTP/1.1\r\n" , "Host: www.foo.com:8080\r\n" , "Transfer-Encoding: chunked\r\n" , "\r\n" , "a\r\n" , "0123456789\r\n" , "4\r\n" , "0123\r\n" , "0\r\n\r\n" ] testHttpRequest2 :: Test testHttpRequest2 = testCase "server/HttpRequest2" $ do iter <- testReceiveRequestIter sampleRequest2 (_,body) <- run_ iter assertEqual "parse body" "01234567890123" body testHttpRequest3 :: Test testHttpRequest3 = testCase "server/HttpRequest3" $ do iter <- testReceiveRequestIter sampleRequest3 (req,body) <- run_ iter assertEqual "no cookies" [] $ rqCookies req assertEqual "multiheader" (Just ["1","2"]) $ H.lookup "Multiheader" (rqHeaders req) assertEqual "host" ("localhost", 80) $ (rqServerName req, rqServerPort req) assertEqual "post param 1" (rqParam "postparam1" req) (Just ["1"]) assertEqual "post param 2" (rqParam "postparam2" req) (Just ["2"]) -- make sure the post body is still emitted assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body testHttpRequest3' :: Test testHttpRequest3' = testCase "server/HttpRequest3'" $ do iter <- testReceiveRequestIter sampleRequest3' (req,body) <- run_ iter assertEqual "post param 1" (rqParam "postparam1" req) (Just ["1"]) assertEqual "post param 2" (rqParam "postparam2" req) (Just ["2"]) -- make sure the post body is still emitted assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body samplePostBody3 :: ByteString samplePostBody3 = "postparam1=1&postparam2=2" sampleRequest3 :: ByteString sampleRequest3 = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" , "Content-Type: application/x-www-form-urlencoded\r\n" , "Content-Length: 25\r\n" , "Multiheader: 1\r\n" , "Multiheader: 2\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "\r\n" , samplePostBody3 ] sampleRequest3' :: ByteString sampleRequest3' = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" , "Content-Type: application/x-www-form-urlencoded; charset=UTF-8\r\n" , "Content-Length: 25\r\n" , "Multiheader: 1\r\n" , "Multiheader: 2\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "\r\n" , samplePostBody3 ] rsm :: ServerMonad a -> Iteratee ByteString IO a rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog where alog = const . const . return $ () elog = const $ return () testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do buf <- allocBuffer 16384 req <- Test.buildRequest $ return () b <- run_ $ rsm $ sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http response" (b == text1 || b == text2) where text1 = L.concat [ "HTTP/1.0 600 Test\r\n" , "Content-Length: 10\r\n" , "Foo: Bar\r\n\r\n" , "0123456789" ] text2 = L.concat [ "HTTP/1.0 600 Test\r\n" , "Foo: Bar\r\n" , "Content-Length: 10\r\n\r\n" , "0123456789" ] rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } strToHeaders :: L.ByteString -> H.Headers strToHeaders s = foldl' mkHeader H.empty lns where lns = LC.lines s mkHeader hdrs x = hdrs' where (a0,b0) = LC.break (== ':') x a = CI.mk $ S.concat $ LC.toChunks a0 b = S.concat $ LC.toChunks $ LC.drop 2 b0 hdrs' = H.insert a b hdrs testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString testOnSendFile f st sz = do sstep <- runIteratee copyingStream2Stream run_ $ enumFilePartial f (st,st+sz) sstep testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do buf <- allocBuffer 16384 req <- Test.buildRequest $ return () b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $ sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http prefix" ("HTTP/1.0 600 Test\r\n" `S.isPrefixOf` b2) assertBool "connection close" ("Connection: close\r\n" `S.isInfixOf` b2) assertBool "foo: bar" ("Foo: Bar\r\n" `S.isInfixOf` b2) assertBool "body" ("\r\n\r\n0123456789" `S.isSuffixOf` b2) where rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = rsp1 { rspContentLength = Nothing } testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do buf <- allocBuffer 16384 req <- Test.buildRequest $ return () b3 <- run_ $ rsm $ sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b3 let ok = case lns of ([ "HTTP/1.1 600 Test\r" , h1, h2, h3 , "\r" , "000A\r" , "0123456789\r" , "0\r" , "\r"]) -> check $ LC.unlines [h1,h2,h3] _ -> False when (not ok) $ LC.putStrLn $ LC.concat ["***testHttpResponse3: b3 was:\n", b3] assertBool "http response" ok where check s = (H.lookup "Content-Type" hdrs == Just ["text/plain\r"]) && (H.lookup "Foo" hdrs == Just ["Bar\r"]) && (H.lookup "Transfer-Encoding" hdrs == Just ["chunked\r"]) where hdrs = strToHeaders s rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = deleteHeader "Content-Length" $ rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) testHttpResponse4 :: Test testHttpResponse4 = testCase "server/HttpResponse4" $ do buf <- allocBuffer 16384 req <- Test.buildRequest $ return () b <- run_ $ rsm $ sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertEqual "http response" (L.concat [ "HTTP/1.0 304 Test\r\n" , "Content-Length: 0\r\n\r\n" ]) b where rsp1 = setResponseStatus 304 "Test" $ setContentLength' 0 $ emptyResponse { rspHttpVersion = (1,0) } testHttpResponseCookies :: Test testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384 req <- Test.buildRequest $ return () b <- run_ $ rsm $ sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b let ok = case lns of ([ "HTTP/1.0 304 Test\r" , h1, h2, h3, h4 , "\r"]) -> check $ LC.unlines [h1,h2,h3,h4] _ -> False when (not ok) $ LC.putStrLn $ LC.concat ["*** testHttpResponseCookies: b was:\n", b] assertBool "http response" ok where check s = (H.lookup "Connection" hdrs == Just ["close\r"]) && (ch $ H.lookup "Set-Cookie" hdrs) where hdrs = strToHeaders s ch Nothing = False ch (Just l) = sort l == [ "ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r" , "ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r" , "ck3=bar\r" ] rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = addResponseCookie cook3 . addResponseCookie cook2 . addResponseCookie cook $ rsp1 utc = UTCTime (ModifiedJulianDay 55226) 0 cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False echoServer :: (ByteString -> IO ()) -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) echoServer _ _ req = do se <- liftIO $ readIORef (rqBody req) let (SomeEnumerator enum) = se i <- liftM enum $ lift $ runIteratee copyingStream2Stream b <- i let cl = L.length b liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0) return (req, rsp b cl) where rsp s cl = setContentLength' cl $ emptyResponse { rspBody = Enum $ enumBuilder (fromLazyByteString s) } echoServer2 :: ServerHandler echoServer2 _ _ req = do (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req return (rq, addResponseCookie cook rsp) where cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False utc = UTCTime (ModifiedJulianDay 55226) 0 testHttp1 :: Test testHttp1 = testCase "server/httpSession" $ do let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2 ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , "\r" , "0123456789HTTP/1.1 200 OK\r" , g1 , g2 , g3 , "\r" , "01234567890123" ]) -> (check1 $ LC.unlines [h1,h2,h3]) && (check2 $ LC.unlines [g1,g2,g3]) _ -> False when (not ok) $ do putStrLn "server/httpSession fail!!!! got:" LC.putStrLn s assertBool "pipelined responses" ok where check1 s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s check2 s = (H.lookup "Content-Length" hdrs == Just ["14\r"]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s mkIter :: IORef L.ByteString -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ()) mkIter ref = (iter, \f st sz -> onF f st sz iter) where iter = do x <- copyingStream2Stream liftIO $ modifyIORef ref $ \s -> L.append s x onF f st sz i = do step <- runIteratee i let it = enumFilePartial f (st,st+sz) step run_ it testChunkOn1_0 :: Test testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do let enumBody = enumBS sampleRequest1_0 ref <- newIORef "" let (iter,onSendFile) = mkIter ref done <- newEmptyMVar forkIO (runHTTP 60 Nothing Nothing f "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) `finally` putMVar done ()) takeMVar done -- this is a pretty lame way of checking whether the output was chunked, -- but "whatever" output <- liftM lower $ readIORef ref assertBool "chunked output" $ not $ S.isInfixOf "chunked" output assertBool "connection close" $ S.isInfixOf "connection: close" output where lower = S.map toLower . S.concat . L.toChunks f :: ServerHandler f _ _ req = do let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd" let out = enumBuilder $ fromLazyByteString s return (req, emptyResponse { rspBody = Enum out }) sampleRequest4 :: ByteString sampleRequest4 = 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" , "Connection: close\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] testHttp2 :: Test testHttp2 = testCase "server/connectionClose" $ do let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2 ref <- newIORef "" let (iter,onSendFile) = mkIter ref done <- newEmptyMVar forkIO (runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) `finally` putMVar done ()) takeMVar done s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , h4 , h5 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4,h5]) _ -> False assertBool "connection: close" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Connection" hdrs == Just ["close\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s testHttp100 :: Test testHttp100 = testCase "server/expect100" $ do let enumBody = enumBS sampleRequestExpectContinue ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 100 Continue\r" , "\r" , "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , h4 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False when (not ok) $ do putStrLn "expect100 fail! got:" LC.putStrLn s assertBool "100 Continue" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s test411 :: Test test411 = testCase "server/expect411" $ do let enumBody = enumBS sampleRequest411 ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ("HTTP/1.1 411 Length Required\r":_) -> True _ -> False when (not ok) $ do putStrLn "expect411 fail! got:" LC.putStrLn s assertBool "411 Length Required" ok testEscapeHttp :: Test testEscapeHttp = testCase "server/escapeHttp" $ do ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing escapeServer "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) (enumBS sampleRequest) iter onSendFile (const $ return ()) s <- readIORef ref assertEqual "escapeHttp" "0123456789" s where -- Escape HTTP traffic. Read one ByteString and send it back. escapeServer = runSnap $ escapeHttp $ \_ sendIter -> do Just bs <- EL.head liftIO $ E.run_ $ E.enumList 1 [bs] $$ sendIter testExpectGarbage :: Test testExpectGarbage = testCase "server/expectGarbage" $ do let enumBody = enumBS sampleRequestExpectGarbage ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , h4 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False assertBool "random expect: header" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s pongServer :: Snap () pongServer = modifyResponse $ setResponseBody enum . setContentType "text/plain" . setContentLength' 4 where enum = enumBuilder $ fromByteString "PONG" sendFileFoo :: Snap () sendFileFoo = sendFile "data/fileServe/foo.html" testSendFile :: Test testSendFile = testCase "server/sendFile" $ do bracket (forkIO serve) (killThread) (\tid -> do m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) where serve = (httpServe 60 [HttpPort "*" port] "localhost" Nothing Nothing (const $ return ()) $ runSnap sendFileFoo) `catch` \(_::SomeException) -> return () go tid = do waitabit doc <- HTTP.simpleHttp "http://127.0.0.1:8123/" killThread tid waitabit assertEqual "sendFile" "FOO\n" doc waitabit = threadDelay $ ((10::Int)^(6::Int)) port = 8123 testServerStartupShutdown :: Test testServerStartupShutdown = testCase "server/startup/shutdown" $ do bracket (forkIO $ httpServe 20 [HttpPort "*" port] "localhost" (Just $ const (return ())) -- dummy logging (Just $ const (return ())) -- dummy logging (const $ return ()) (runSnap pongServer)) (killThread) (\tid -> do m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) where go tid = do debug $ "testServerStartupShutdown: waiting a bit" waitabit debug $ "testServerStartupShutdown: sending http request" doc <- HTTP.simpleHttp "http://127.0.0.1:8145/" assertEqual "server" "PONG" doc debug $ "testServerStartupShutdown: killing thread" killThread tid debug $ "testServerStartupShutdown: kill signal sent to thread" waitabit expectException $ HTTP.simpleHttp "http://127.0.0.1:8145/" return () waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8145 testServerShutdownWithOpenConns :: Test testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do tid <- forkIO $ httpServe 20 [HttpPort "*" port] "localhost" Nothing Nothing (const $ return ()) (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 TestException let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp debug $ "got HTTP response " ++ s ++ ", we shouldn't be here...." putMVar result e e <- timeout (75*seconds) $ takeMVar result case e of Nothing -> killThread tid >> assertFailure "timeout" (Just r) -> case r of (Left (_::SomeException)) -> return () (Right _) -> assertFailure "socket didn't get killed" where waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8149 seconds :: Int seconds = (10::Int) ^ (6::Int) copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString copyingStream2Stream = go [] where go l = do mbx <- I.head maybe (return $ L.fromChunks $ reverse l) (\x -> let !z = S.copy x in go (z:l)) mbx setContentLength' :: Int64 -> Response -> Response setContentLength' cl = setHeader "Content-Length" (S.pack $ show cl) . setContentLength cl snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Server/TimeoutManager/0000755000000000000000000000000012522727050024214 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs0000644000000000000000000000365412522727050025662 0ustar0000000000000000module Snap.Internal.Http.Server.TimeoutManager.Tests ( tests ) where import Control.Concurrent import Data.IORef import Data.Maybe import System.PosixCompat.Time import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) import qualified Snap.Internal.Http.Server.TimeoutManager as TM tests :: [Test] tests = [ testOneTimeout , testOneTimeoutAfterInactivity , testCancel , testTickle ] testOneTimeout :: Test testOneTimeout = testCase "timeout/oneTimeout" $ do mgr <- TM.initialize 3 epochTime oneTimeout mgr testOneTimeoutAfterInactivity :: Test testOneTimeoutAfterInactivity = testCase "timeout/oneTimeoutAfterInactivity" $ do mgr <- TM.initialize 3 epochTime threadDelay $ 7 * seconds oneTimeout mgr oneTimeout :: TM.TimeoutManager -> IO () oneTimeout mgr = do mv <- newEmptyMVar _ <- TM.register (putMVar mv ()) mgr m <- timeout (6*seconds) $ takeMVar mv assertBool "timeout fired" $ isJust m TM.stop mgr testTickle :: Test testTickle = testCase "timeout/tickle" $ do mgr <- TM.initialize 8 epochTime ref <- newIORef (0 :: Int) h <- TM.register (writeIORef ref 1) mgr threadDelay $ 5 * seconds b0 <- readIORef ref assertEqual "b0" 0 b0 TM.tickle h 8 threadDelay $ 5 * seconds b1 <- readIORef ref assertEqual "b1" 0 b1 threadDelay $ 8 * seconds b2 <- readIORef ref assertEqual "b2" 1 b2 TM.stop mgr testCancel :: Test testCancel = testCase "timeout/cancel" $ do mgr <- TM.initialize 3 epochTime ref <- newIORef (0 :: Int) h <- TM.register (writeIORef ref 1) mgr threadDelay $ 1 * seconds TM.cancel h threadDelay $ 5 * seconds b0 <- readIORef ref assertEqual "b0" 0 b0 TM.stop mgr seconds :: Int seconds = (10::Int) ^ (6::Int) snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Parser/0000755000000000000000000000000012522727050021261 5ustar0000000000000000snap-server-0.9.5.1/test/suite/Snap/Internal/Http/Parser/Tests.hs0000644000000000000000000001156112522727050022723 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Parser.Tests ( tests ) where import qualified Control.Exception as E import Control.Exception hiding (try, assert) import Control.Monad import Control.Parallel.Strategies import Data.Attoparsec hiding (Result(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) 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 import Test.QuickCheck import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.Monadic hiding (run, assert) import Test.HUnit hiding (Test, path) import Text.Printf import Snap.Internal.Http.Parser import Snap.Internal.Http.Types import Snap.Internal.Debug import Snap.Iteratee hiding (map, sequence) import qualified Snap.Iteratee as I import Snap.Test.Common() tests :: [Test] tests = [ testShow , testCookie , testChunked , testP2I , testNull , testPartial , testParseError , testFormEncoded ] emptyParser :: Parser ByteString emptyParser = option "foo" $ string "bar" testShow :: Test testShow = testCase "parser/show" $ do let i = IRequest GET "/" (1,1) [] let !b = show i `using` rdeepseq return $ b `seq` () testP2I :: Test testP2I = testCase "parser/iterParser" $ do i <- liftM (enumBS "z") $ runIteratee (iterParser emptyParser) l <- run_ i assertEqual "should be foo" "foo" l forceErr :: SomeException -> IO () forceErr e = f `seq` (return ()) where !f = show e testNull :: Test testNull = testCase "parser/shortParse" $ do f <- run_ (parseRequest) assertBool "should be Nothing" $ isNothing f testPartial :: Test testPartial = testCase "parser/partial" $ do i <- liftM (enumBS "GET / ") $ runIteratee parseRequest f <- E.try $ run_ i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x testParseError :: Test testParseError = testCase "parser/error" $ do step <- runIteratee parseRequest let i = enumBS "ZZZZZZZZZZ" step f <- E.try $ run_ i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x -- | convert a bytestring to chunked transfer encoding transferEncodingChunked :: L.ByteString -> L.ByteString transferEncodingChunked = f . L.toChunks where toChunk s = L.concat [ len, "\r\n", L.fromChunks [s], "\r\n" ] where len = L.pack $ map c2w $ printf "%x" $ S.length s f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"]) -- | ensure that running the 'readChunkedTransferEncoding' iteratee against -- 'transferEncodingChunked' returns the original string testChunked :: Test testChunked = testProperty "parser/chunkedTransferEncoding" $ monadicIO $ forAllM arbitrary prop_chunked where prop_chunked s = do QC.run $ debug "==============================" QC.run $ debug $ "input is " ++ show s QC.run $ debug $ "chunked is " ++ show chunked QC.run $ debug "------------------------------" sstep <- QC.run $ runIteratee $ stream2stream step <- QC.run $ runIteratee $ joinI $ readChunkedTransferEncoding sstep out <- QC.run $ run_ $ enum step QC.assert $ s == out QC.run $ debug "==============================\n" where chunked = (transferEncodingChunked s) enum = enumLBS chunked testCookie :: Test testCookie = testCase "parser/parseCookie" $ do assertEqual "cookie parsing" (Just [cv]) cv2 where cv = Cookie nm v Nothing Nothing Nothing False False cv2 = parseCookie ct nm = "foo" v = "bar" ct = S.concat [ nm , "=" , v ] testFormEncoded :: Test testFormEncoded = testCase "parser/formEncoded" $ do let bs = "foo1=bar1&foo2=bar2+baz2;foo3=foo%20bar" let mp = parseUrlEncoded bs assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp copyingStream2Stream :: (Monad m) => Iteratee ByteString m ByteString copyingStream2Stream = go [] where go l = do mbx <- I.head maybe (return $ S.concat $ reverse l) (\x -> let !z = S.copy x in go (z:l)) mbx stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString stream2stream = liftM L.fromChunks consume snap-server-0.9.5.1/extra/0000755000000000000000000000000012522727050013444 5ustar0000000000000000snap-server-0.9.5.1/extra/haddock.css0000644000000000000000000002023112522727050015551 0ustar0000000000000000/* -------- Global things --------- */ HTML { background-color: #f0f3ff; width: 100%; } BODY { -moz-border-radius:5px; -webkit-border-radius:5px; width: 50em; margin: 2em auto; padding: 0; background-color: #ffffff; color: #000000; font-size: 110%; font-family: Georgia, serif; } A:link { color: #5200A3; text-decoration: none } A:visited { color: #5200A3; text-decoration: none } A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; } TABLE.vanilla { width: 100%; border-width: 0px; /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ } DL { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; letter-spacing: -0.01em; margin: 0; } .vanilla .vanilla dl { font-size: 80%; } .vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; } TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL { padding: 0 30px 0 34px; } TABLE.vanilla2 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; border-width: 0px; } /* font is a little too small in MSIE */ TT, PRE, CODE { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; font-size: 90%; } LI P { margin: 0pt } P { margin-top: 0; margin-bottom: 0.75em; } TD { border-width: 0px; } TABLE.narrow { border-width: 0px; } TD.s8 { height: 0; margin:0; padding: 0 } TD.s15 { height: 20px; } SPAN.keyword { text-decoration: underline; } /* Resize the buttom image to match the text size */ IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } /* --------- Contents page ---------- */ DIV.node { padding-left: 3em; } DIV.cnode { padding-left: 1.75em; } SPAN.pkg { position: absolute; left: 50em; } /* --------- Documentation elements ---------- */ TD FONT { font-weight: bold; letter-spacing: -0.02em; } TD.children { padding-left: 25px; } TD.synopsis { padding: 2px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } TD.decl { padding: 4px 8px; background-color: #FAFAFA; border-bottom: #F2F2F2 solid 1px; border-top: #FCFCFC solid 1px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; } TD.decl TD.decl { font-size: 100%; padding: 4px 0; border: 0; } TD.topdecl { padding: 20px 30px 0.5ex 30px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; ; vertical-align: top; } .vanilla .vanilla .vanilla .topdecl { padding-left: 0; padding-right: 0; } .vanilla .vanilla .vanilla { padding-left: 30px; } .decl .vanilla { padding-left: 0px !important; } .body .vanilla .body { padding-left: 0; padding-right: 0; } .body .vanilla .body .decl { padding-left: 12px; } .body .vanilla .body div .vanilla .decl { padding-left: 12px; } TABLE.declbar { background-color: #f0f0f0; border-spacing: 0px; border-bottom:1px solid #d7d7df; border-right:1px solid #d7d7df; border-top:1px solid #f4f4f9; border-left:1px solid #f4f4f9; padding: 4px; } TD.declname { width: 100%; padding-right: 4px; } TD.declbut { padding-left: 8px; padding-right: 5px; border-left-width: 1px; border-left-color: #000099; border-left-style: solid; white-space: nowrap; font-size: x-small; } /* arg is just like decl, except that wrapping is not allowed. It is used for function and constructor arguments which have a text box to the right, where if wrapping is allowed the text box squashes up the declaration by wrapping it. */ TD.arg { padding: 2px 12px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; white-space: nowrap; } TD.recfield { padding-left: 20px } TD.doc { padding-left: 38px; font-size: 95%; line-height: 1.66; } TD.ndoc { font-size: 95%; line-height: 1.66; padding: 2px 4px 2px 8px; } TD.rdoc { padding: 2px; padding-left: 30px; width: 100%; font-size: 80%; font-style: italic; font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.body { padding: 0 30px; } TD.pkg { width: 100%; padding-left: 30px } TABLE.indexsearch TR.indexrow { display: none; } TABLE.indexsearch TR.indexshow { display: table-row; } TD.indexentry { vertical-align: top; padding: 0 30px } TD.indexannot { vertical-align: top; padding-left: 20px; white-space: nowrap } TD.indexlinks { width: 100% } /* ------- Section Headings ------- */ TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.section1 { padding-top: 14px; font-weight: bold; letter-spacing: -0.02em; font-size: 140% } TD.section2 { padding-top: 4px; font-weight: bold; letter-spacing: -0.02em; font-size: 120% } TD.section3 { padding-top: 5px; font-weight: bold; letter-spacing: -0.02em; font-size: 105% } TD.section4 { font-weight: bold; padding-top: 12px; padding-bottom: 4px; letter-spacing: -0.02em; font-size: 90% } /* -------------- The title bar at the top of the page */ TD.infohead { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; font-weight: bold; padding: 0 30px; text-align: left; } TD.infoval { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding: 0 30px; text-align: left; } TD.topbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; background-color: #3465a4; padding: 5px; -moz-border-radius-topleft:5px; -moz-border-radius-topright:5px; -webkit-border-radius-topleft:5px; -webkit-border-radius-topright:5px; } TD.title { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding-left: 30px; letter-spacing: -0.02em; font-weight: bold; width: 100% } TD.topbut { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; padding-left: 5px; padding-right: 5px; border-left-width: 1px; border-left-color: #ffffff; border-left-style: solid; letter-spacing: -0.02em; font-weight: bold; white-space: nowrap; } TD.topbut A:link { color: #ffffff } TD.topbut A:visited { color: #ffff00 } TD.topbut A:hover { background-color: #C9D3DE; } TD.topbut:hover { background-color: #C9D3DE; } TD.modulebar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #141B24; background-color: #C9D3DE; padding: 5px; border-top-width: 1px; border-top-color: #ffffff; border-top-style: solid; -moz-border-radius-bottomleft:5px; -moz-border-radius-bottomright:5px; -webkit-border-radius-bottomleft:5px; -webkit-border-radius-bottomright:5px; } /* --------- The page footer --------- */ TD.botbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; -moz-border-radius:5px; -webkit-border-radius:5px; background-color: #3465a4; color: #ffffff; padding: 5px } TD.botbar A:link { color: #ffffff; text-decoration: underline } TD.botbar A:visited { color: #ffff00 } TD.botbar A:hover { background-color: #6060ff } /* --------- Mini Synopsis for Frame View --------- */ .outer { margin: 0 0; padding: 0 0; } .mini-synopsis { padding: 0.25em 0.25em; } .mini-synopsis H1 { font-size: 120%; } .mini-synopsis H2 { font-size: 107%; } .mini-synopsis H3 { font-size: 100%; } .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; margin-top: 0.5em; margin-bottom: 0.25em; padding: 0 0; font-weight: bold; letter-spacing: -0.02em; } .mini-synopsis H1 { border-bottom: 1px solid #ccc; } .mini-topbar { font-size: 120%; background: #0077dd; padding: 0.25em; } snap-server-0.9.5.1/extra/logo.gif0000644000000000000000000000113712522727050015075 0ustar0000000000000000GIF89a` J"K#M%N(P1W1X3Z6\?d4e=i9i:j