snap-server-1.1.2.1/0000755000000000000000000000000007346545000012310 5ustar0000000000000000snap-server-1.1.2.1/CONTRIBUTORS0000644000000000000000000000051607346545000014172 0ustar0000000000000000Doug Beardsley Gregory Collins Shu-yu Guo Carl Howells John Lenz Herbert Valerio Riedel James Sanders Jacob Stanley Jurriën Stutterheim snap-server-1.1.2.1/LICENSE0000644000000000000000000000302307346545000013313 0ustar0000000000000000Copyright (c) 2009-present, Snap Framework authors (see CONTRIBUTORS) Copyright (c) 2010-2016, 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-1.1.2.1/README.SNAP.md0000644000000000000000000000213607346545000014331 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 sensible and clean monad for web programming * a high-speed HTTP server called "snap-server" * an xml-based templating system called "heist" 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, 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-1.1.2.1/README.md0000644000000000000000000000360507346545000013573 0ustar0000000000000000Snap Framework HTTP Server Library ---------------------------------- [![Build status](https://github.com/snapframework/snap-server/actions/workflows/ci.yml/badge.svg)](https://github.com/snapframework/snap-server/actions/workflows/ci.yml) 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 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. 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-1.1.2.1/benchmark/0000755000000000000000000000000007346545000014242 5ustar0000000000000000snap-server-1.1.2.1/benchmark/Benchmark.hs0000644000000000000000000000024207346545000016466 0ustar0000000000000000module Main where import Criterion.Main import qualified Snap.Internal.Http.Parser.Benchmark as PB main :: IO () main = defaultMain [ PB.benchmarks ] snap-server-1.1.2.1/benchmark/Snap/Internal/Http/Parser/0000755000000000000000000000000007346545000021072 5ustar0000000000000000snap-server-1.1.2.1/benchmark/Snap/Internal/Http/Parser/Benchmark.hs0000644000000000000000000000151707346545000023324 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Parser.Benchmark ( benchmarks ) where import Control.Monad import qualified Criterion.Main as C import qualified Data.ByteString as S import Snap.Internal.Http.Parser.Data import Snap.Internal.Http.Server.Parser import qualified System.IO.Streams as Streams parseGet :: S.ByteString -> IO () parseGet s = do !_ <- Streams.fromList [s] >>= parseRequest return $! () benchmarks :: C.Benchmark benchmarks = C.bgroup "parser" [ C.bench "firefoxget" $ C.whnfIO $! replicateM_ 1000 $! parseGet parseGetData ] snap-server-1.1.2.1/benchmark/Snap/Internal/Http/Parser/Data.hs0000644000000000000000000000533607346545000022306 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Parser.Data ( parseGetData , parseChunkedData ) where import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L parseGetData :: S.ByteString parseGetData = S.concat [ "GET /favicon.ico HTTP/1.1\r\n" , "Host: 0.0.0.0=5000\r\n" , "User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9) Gecko/2008061015 Firefox/3.0\r\n" , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n" , "Accept-Language: en-us,en;q=0.5\r\n" , "Accept-Encoding: gzip,deflate\r\n" , "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n" , "Keep-Alive: 300\r\n" , "Connection: keep-alive\r\n" , "\r\n" ] parseChunkedData :: L.ByteString parseChunkedData = L.fromChunks ["In the beginning, everything was void, and J.H.W.H. Conway began to create numbers.", "Conway said, \"Let there be two rules which bring forth all numbers larege and small.", "This shall be the first rule: Every number corresponds to two sets of previously created numbers, such that no member of the left set is greater than or equal to any member of the right set.", "And the second rule shall be this: One number is less than or equal to another number if and only if no member of the first number \'s left set is greater than or equal to the second number, and no member of the second number\'s right set is less than or equal to the first number.\" And Conway examined these two rules he had made, and behold! They were very good.", "And the first number was created from the void left set and the void right set. Conway called this number \"zero,\" and said that it shall be a sign to separate positive numbers from negative numbers.", "Conway proved that zero was less than or equal to zero, end he saw that it was good.", "And the evening and the morning were the day of zero.", "On the next day, two more numbers were created, one with zero as its left set and one with zero as its right set. And Conway called the former number \"one,\" and the latter he called \"minus one.\" And he proved that minus one is less than but not equal to zero and zero is less than but not equal to one.", "And the evening day.", "And Conway said, \"Let the numbers be added to each other in this wise: The left set of the sum of two numbers shall be the sums of all left parts of each number with the other; and in like manner the right set shall be from the right parts, each according to its kind.\" Conway proved that every number plus zero is unchanged, and he saw that addition was good.", "And the evening and the morning were the third day."] snap-server-1.1.2.1/pong/0000755000000000000000000000000007346545000013253 5ustar0000000000000000snap-server-1.1.2.1/pong/Main.hs0000644000000000000000000000665407346545000014506 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Applicative ((<$>)) import Control.Concurrent (MVar, ThreadId, forkIOWithUnmask, killThread, newEmptyMVar, putMVar, takeMVar) import Control.Exception (SomeException, bracketOnError, evaluate) import qualified Control.Exception as E import Data.ByteString.Builder (byteString, toLazyByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Network.Socket as N import Snap.Core import System.Environment (getArgs) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler) import qualified Snap.Internal.Http.Server.Socket as Sock import qualified Snap.Internal.Http.Server.Types as Types ------------------------------------------------------------------------------ -- | Returns the thread the server is running in as well as the port it is -- listening on. startTestSocketServer :: Int -> Snap a -> IO (ThreadId, MVar ()) startTestSocketServer portNum userHandler = bracketOnError getSock cleanup forkServer where getSock = Sock.bindSocket "127.0.0.1" (fromIntegral portNum) forkServer sock = do port <- fromIntegral <$> N.socketPort sock putStrLn $ "starting on " ++ show (port :: Int) let scfg = emptyServerConfig mv <- newEmptyMVar tid <- forkIOWithUnmask $ \unmask -> do putStrLn "server start" (unmask $ httpAcceptLoop (snapToServerHandler userHandler) scfg (Sock.httpAcceptFunc sock)) `E.finally` putMVar mv () return (tid, mv) cleanup = N.close logAccess _ _ _ = return () _logError !e = L.putStrLn $ toLazyByteString e onStart _ = return () onParse _ _ = return () onUserHandlerFinished _ _ _ = return () onDataFinished _ _ _ = return () onExceptionHook _ _ = return () onEscape _ = return () emptyServerConfig = Types.ServerConfig logAccess _logError onStart onParse onUserHandlerFinished onDataFinished onExceptionHook onEscape "localhost" 6 False 1 main :: IO () main = do portNum <- (((read . head) <$> getArgs) >>= evaluate) `E.catch` \(_::SomeException) -> return 3000 (tid, mv) <- startTestSocketServer portNum $ do modifyResponse $ setContentLength 4 . setResponseBody output takeMVar mv killThread tid where output os = Streams.write (Just "pong") os >> return os snap-server-1.1.2.1/snap-server.cabal0000644000000000000000000003506207346545000015547 0ustar0000000000000000name: snap-server version: 1.1.2.1 synopsis: A 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 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: Snap Framework Authors (see CONTRIBUTORS) maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.10 homepage: http://snapframework.com/ bug-reports: https://github.com/snapframework/snap-server/issues category: Web, Snap, IO-Streams extra-source-files: CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, test/bad_key.pem, test/cert.pem, test/dummy.txt, test/key.pem, testserver/static/hello.txt tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 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 Manual: True Flag build-pong Description: Build a server that just returns "PONG"? Normally useful only for benchmarks. Default: False Manual: True Flag build-testserver Description: Build the blackbox testserver? Default: False Manual: True Flag debug Description: Enable support for debugging. Default: False Manual: True Library hs-source-dirs: src Default-language: Haskell2010 exposed-modules: Snap.Http.Server, Snap.Http.Server.Config, Snap.Http.Server.Types, Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.Types, System.FastLogger other-modules: Paths_snap_server, Control.Concurrent.Extended, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, Snap.Internal.Http.Server.Common, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Parser, Snap.Internal.Http.Server.Session, Snap.Internal.Http.Server.Socket, Snap.Internal.Http.Server.Thread, Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.TLS build-depends: attoparsec >= 0.12 && < 0.15, base >= 4.6 && < 5, blaze-builder >= 0.4 && < 0.5, bytestring >= 0.9.1 && < 0.12, case-insensitive >= 1.1 && < 1.3, clock >= 0.7.1 && < 0.9, containers >= 0.3 && < 0.7, filepath >= 1.1 && < 2.0, io-streams >= 1.3 && < 1.6, io-streams-haproxy >= 1.0 && < 1.1, lifted-base >= 0.1 && < 0.3, mtl >= 2.0 && < 2.4, network >= 2.3 && < 3.2, old-locale >= 1.0 && < 1.1, snap-core >= 1.0 && < 1.1, text >= 0.11 && < 2.1, time >= 1.0 && < 1.13, transformers >= 0.3 && < 0.7, unix-compat >= 0.2 && < 0.7, vector >= 0.7 && < 0.14 other-extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 if !impl(ghc >= 7.8) build-depends: bytestring-builder >= 0.10.4 && < 0.11 if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix < 2.9 if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10.4 && < 0.12, openssl-streams >= 1.1 && < 1.3 if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.Linux -- Disabling sendfile() on OSX for now. See -- -- https://github.com/snapframework/snap-core/issues/274 and -- https://github.com/snapframework/snap-core/issues/91 -- if os(darwin) && !flag(portable) cpp-options: -DHAS_UNIX_SOCKETS -- if os(darwin) && !flag(portable) -- cpp-options: -DOSX -DHAS_UNIX_SOCKETS if os(freebsd) && !flag(portable) cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.FreeBSD if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields if flag(debug) cpp-options: -DLABEL_THREADS Test-suite testsuite hs-source-dirs: src test Type: exitcode-stdio-1.0 Main-is: TestSuite.hs Default-language: Haskell2010 other-modules: Control.Concurrent.Extended, Paths_snap_server, Snap.Http.Server, Snap.Http.Server.Config, Snap.Http.Server.Types, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, Snap.Internal.Http.Server.Common, Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Parser, Snap.Internal.Http.Server.Session, Snap.Internal.Http.Server.Socket, Snap.Internal.Http.Server.Thread, Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.TLS Snap.Internal.Http.Server.Types, System.FastLogger, Snap.Internal.Http.Server.Address.Tests, Snap.Internal.Http.Server.Parser.Tests, Snap.Internal.Http.Server.Session.Tests, Snap.Internal.Http.Server.Socket.Tests, Snap.Internal.Http.Server.TimeoutManager.Tests, Snap.Test.Common, Test.Blackbox, Test.Common.Rot13, Test.Common.TestHandler build-depends: attoparsec, base, base16-bytestring >= 0.1 && < 1.1, blaze-builder, bytestring, case-insensitive, clock, containers, directory >= 1.1 && < 1.4, filepath, io-streams, io-streams-haproxy, lifted-base, monad-control >= 1.0 && < 1.1, mtl, network, old-locale, random >= 1.0 && < 1.3, snap-core, text, threads >= 0.5 && < 0.6, time, transformers, unix-compat, vector, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2 && < 3, deepseq >= 1.3 && < 2, http-streams >= 0.7 && < 0.9, http-common >= 0.7 && < 0.9, parallel >= 3 && < 4, test-framework >= 0.8.0.3 && < 0.9, test-framework-hunit >= 0.2.7 && < 0.4, test-framework-quickcheck2 >= 0.2.12.1 && < 0.4 other-extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving if !impl(ghc >= 8.0) build-depends: semigroups if !impl(ghc >= 7.8) build-depends: bytestring-builder if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix -- always label threads in testsuite cpp-options: -DLABEL_THREADS if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL, openssl-streams if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.Linux, System.SendFile.Tests c-sources: test/cbits/errno_util.c if os(darwin) && !flag(portable) cpp-options: -DHAS_UNIX_SOCKETS -- if os(darwin) && !flag(portable) -- cpp-options: -DOSX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS -- other-modules: -- System.SendFile, -- System.SendFile.Darwin, -- System.SendFile.Tests -- c-sources: test/cbits/errno_util.c if os(freebsd) && !flag(portable) cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.FreeBSD, System.SendFile.Tests c-sources: test/cbits/errno_util.c cpp-options: -DTESTSUITE ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded Benchmark benchmark type: exitcode-stdio-1.0 hs-source-dirs: benchmark src main-is: Benchmark.hs default-language: Haskell2010 other-modules: Snap.Internal.Http.Parser.Benchmark, Snap.Internal.Http.Parser.Data, Snap.Internal.Http.Server.Parser build-depends: attoparsec, base, blaze-builder, bytestring, bytestring-builder, criterion >= 0.6 && < 1.7, io-streams, io-streams-haproxy, snap-core, transformers, vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -rtsopts other-extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving Executable snap-test-pong-server hs-source-dirs: src pong main-is: Main.hs if !flag(build-pong) buildable: False default-language: Haskell2010 other-modules: Control.Concurrent.Extended Paths_snap_server, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, Snap.Internal.Http.Server.Common, Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Parser, Snap.Internal.Http.Server.Session, Snap.Internal.Http.Server.Socket, Snap.Internal.Http.Server.Thread, Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.TLS, Snap.Internal.Http.Server.Types if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.Linux if os(darwin) && !flag(portable) cpp-options: -DHAS_UNIX_SOCKETS -- if os(darwin) && !flag(portable) -- cpp-options: -DOSX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS -- other-modules: -- System.SendFile, -- System.SendFile.Darwin if os(freebsd) && !flag(portable) cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.FreeBSD if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL, openssl-streams build-depends: attoparsec, base, blaze-builder, bytestring, bytestring-builder, case-insensitive, clock, containers, filepath, io-streams, io-streams-haproxy, lifted-base, mtl, network, old-locale, snap-core, text, time, unix-compat, vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts other-extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving Executable snap-test-server hs-source-dirs: src testserver test main-is: Main.hs if !flag(build-testserver) buildable: False if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL, openssl-streams default-language: Haskell2010 other-modules: Control.Concurrent.Extended, Paths_snap_server, Snap.Http.Server, Snap.Http.Server.Config, Snap.Http.Server.Types, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, Snap.Internal.Http.Server.Common, Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Parser, Snap.Internal.Http.Server.Session, Snap.Internal.Http.Server.Socket, Snap.Internal.Http.Server.TLS, Snap.Internal.Http.Server.Thread, Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.Types, System.FastLogger, Test.Common.Rot13, Test.Common.TestHandler if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.Linux if os(darwin) && !flag(portable) cpp-options: -DHAS_UNIX_SOCKETS -- if os(darwin) && !flag(portable) -- cpp-options: -DOSX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS -- other-modules: -- System.SendFile, -- System.SendFile.Darwin if os(freebsd) && !flag(portable) cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.FreeBSD build-depends: attoparsec, base, blaze-builder, bytestring, bytestring-builder, case-insensitive, clock, containers, directory, filepath, io-streams, io-streams-haproxy, lifted-base, mtl, network, old-locale, snap-core, text, time, transformers, unix-compat, vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts other-extensions: BangPatterns, CPP, MagicHash, Rank2Types, OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, PackageImports, ViewPatterns, ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving source-repository head type: git location: git://github.com/snapframework/snap-server.git snap-server-1.1.2.1/src/Control/Concurrent/0000755000000000000000000000000007346545000016641 5ustar0000000000000000snap-server-1.1.2.1/src/Control/Concurrent/Extended.hs0000644000000000000000000000747107346545000020746 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} -- | Handy functions that should really be merged into Control.Concurrent -- itself. module Control.Concurrent.Extended ( forkIOLabeledWithUnmaskBs , forkOnLabeledWithUnmaskBs ) where ------------------------------------------------------------------------------ import Control.Exception (mask_) import qualified Data.ByteString as B import GHC.Conc.Sync (ThreadId (..)) #ifdef LABEL_THREADS import Control.Concurrent (forkIOWithUnmask, forkOnWithUnmask, myThreadId) #if MIN_VERSION_base(4,18,0) import qualified Data.ByteString.Char8 as C8 import GHC.Conc (labelThread) #else import GHC.Base (labelThread#) #endif import Foreign.C.String (CString) import GHC.IO (IO (..)) import GHC.Ptr (Ptr (..)) #else import Control.Concurrent (forkIOWithUnmask, forkOnWithUnmask) #endif ------------------------------------------------------------------------------ -- | 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'. labelThreadBs :: ThreadId -> B.ByteString -> IO () #if MIN_VERSION_base(4,18,0) labelThreadBs tid = -- The 'labelThread#' signature changed: it now requires a UTF-8 encoded -- ByteArray#. labelThread tid . C8.unpack #else labelThreadBs tid bs = B.useAsCString bs $ labelThreadCString tid ------------------------------------------------------------------------------ -- | 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, () #) #endif #elif defined(TESTSUITE) labelMe !_ = return $! () #else labelMe _label = return $! () #endif snap-server-1.1.2.1/src/Snap/Http/0000755000000000000000000000000007346545000014717 5ustar0000000000000000snap-server-1.1.2.1/src/Snap/Http/Server.hs0000644000000000000000000003375207346545000016533 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ -- | The Snap HTTP server is a high performance 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 , rawHttpServe , module Snap.Http.Server.Config ) where ------------------------------------------------------------------------------ import Control.Applicative ((<$>), (<|>)) import Control.Concurrent (killThread, newEmptyMVar, newMVar, putMVar, readMVar, withMVar) import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception (SomeException, bracket, catch, finally, mask, mask_) import qualified Control.Exception.Lifted as L import Control.Monad (liftM, when) import Control.Monad.Trans (MonadIO) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Maybe (catMaybes, fromJust, fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Version (showVersion) import Data.Word (Word64) import Network.Socket (Socket, close) import Prelude (Bool (..), Eq (..), IO, Maybe (..), Monad (..), Show (..), String, const, flip, fst, id, mapM, mapM_, maybe, snd, unzip3, zip, ($), ($!), (++), (.)) import System.IO (hFlush, hPutStrLn, stderr) #ifndef PORTABLE import System.Posix.Env #endif ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder, toLazyByteString) ------------------------------------------------------------------------------ import qualified Paths_snap_server as V import Snap.Core (MonadSnap (..), Request, Response, Snap, rqClientAddr, rqHeaders, rqMethod, rqURI, rqVersion, rspStatus) -- Don't use explicit imports for Snap.Http.Server.Config because we're -- re-exporting everything. import Snap.Http.Server.Config import qualified Snap.Http.Server.Types as Ty import Snap.Internal.Debug (debug) import Snap.Internal.Http.Server.Config (ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets) import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler) import qualified Snap.Internal.Http.Server.Socket as Sock import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Http.Server.Types (AcceptFunc, ServerConfig, ServerHandler) import qualified Snap.Types.Headers as H import Snap.Util.GZip (withCompression) import Snap.Util.Proxy (behindProxy) import qualified Snap.Util.Proxy as Proxy import System.FastLogger (combinedLogEntry, logMsg, newLoggerWithCustomErrorFunction, stopLogger, timestampedLogEntry) ------------------------------------------------------------------------------ -- | A short string describing the Snap server version snapServerVersion :: ByteString snapServerVersion = S.pack $! showVersion V.version ------------------------------------------------------------------------------ rawHttpServe :: ServerHandler s -- ^ server handler -> ServerConfig s -- ^ server config -> [AcceptFunc] -- ^ listening server backends -> IO () rawHttpServe h cfg loops = do mvars <- mapM (const newEmptyMVar) loops mask $ \restore -> bracket (mapM runLoop $ mvars `zip` loops) (\mvTids -> do mapM_ (killThread . snd) mvTids mapM_ (readMVar . fst) mvTids) (const $ restore $ mapM_ readMVar mvars) where -- parents and children have a mutual suicide pact runLoop (mvar, loop) = do tid <- forkIOLabeledWithUnmaskBs "snap-server http master thread" $ \r -> (r $ httpAcceptLoop h cfg loop) `finally` putMVar mvar () return (mvar, tid) ------------------------------------------------------------------------------ -- | 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 (descrs, sockets, afuncs) <- unzip3 <$> listeners conf mapM_ (output . ("Listening on " ++) . S.unpack) descrs go conf sockets afuncs `finally` (mask_ $ do output "\nShutting down.." mapM_ (eatException . close) sockets) where eatException :: IO a -> IO () eatException act = let r0 = return $! () in (act >> r0) `catch` \(_::SomeException) -> r0 -------------------------------------------------------------------------- -- FIXME: this logging code *sucks* -------------------------------------------------------------------------- debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Error: " ++ S.unpack s -------------------------------------------------------------------------- logE :: Maybe (ByteString -> IO ()) -> Builder -> IO () logE elog b = let x = S.concat $ L.toChunks $ toLazyByteString b in (maybe debugE (\l s -> debugE s >> logE' l s) elog) x -------------------------------------------------------------------------- logE' :: (ByteString -> IO ()) -> ByteString -> IO () logE' logger s = (timestampedLogEntry s) >>= logger -------------------------------------------------------------------------- logA :: Maybe (ByteString -> IO ()) -> Request -> Response -> Word64 -> IO () logA alog = maybe (\_ _ _ -> return $! ()) logA' alog -------------------------------------------------------------------------- logA' logger req rsp cl = do let hdrs = rqHeaders req let host = rqClientAddr 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 = bshow (rqMethod req) let reql = S.intercalate " " [ method, rqURI req, ver ] let status = rspStatus rsp let referer = H.lookup "referer" hdrs let userAgent = fromMaybe "-" $ H.lookup "user-agent" hdrs msg <- combinedLogEntry host user reql status cl referer userAgent logger msg -------------------------------------------------------------------------- go conf sockets afuncs = do let tout = fromMaybe 60 $ getDefaultTimeout conf let shandler = snapToServerHandler handler setUnicodeLocale $ fromJust $ getLocale conf withLoggers (fromJust $ getAccessLog conf) (fromJust $ getErrorLog conf) $ \(alog, elog) -> do let scfg = Ty.setDefaultTimeout tout . Ty.setLocalHostname (fromJust $ getHostname conf) . Ty.setLogAccess (logA alog) . Ty.setLogError (logE elog) $ Ty.emptyServerConfig maybe (return $! ()) ($ mkStartupInfo sockets conf) (getStartupHook conf) rawHttpServe shandler scfg afuncs -------------------------------------------------------------------------- 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 $ S.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 -> IO [(ByteString, Socket, AcceptFunc)] listeners conf = TLS.withTLS $ do let fs = catMaybes [httpListener, httpsListener, unixListener] mapM (\(str, mkAfunc) -> do (sock, afunc) <- mkAfunc return $! (str, sock, afunc)) fs where httpsListener = do b <- getSSLBind conf p <- getSSLPort conf cert <- getSSLCert conf chainCert <- getSSLChainCert conf key <- getSSLKey conf return (S.concat [ "https://" , b , ":" , bshow p ], do (sock, ctx) <- TLS.bindHttps b p cert chainCert key return (sock, TLS.httpsAcceptFunc sock ctx) ) httpListener = do p <- getPort conf b <- getBind conf return (S.concat [ "http://" , b , ":" , bshow p ], do sock <- Sock.bindSocket b p if getProxyType conf == Just HaProxy then return (sock, Sock.haProxyAcceptFunc sock) else return (sock, Sock.httpAcceptFunc sock)) unixListener = do path <- getUnixSocket conf let accessMode = getUnixSocketAccessMode conf return (T.encodeUtf8 . T.pack $ "unix:" ++ path, do sock <- Sock.bindUnixSocket accessMode path return (sock, Sock.httpAcceptFunc sock)) ------------------------------------------------------------------------------ -- | 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 -> pickProxy ptype handler0) (getProxyType conf) pickProxy NoProxy = id pickProxy HaProxy = id -- we handle this case elsewhere pickProxy X_Forwarded_For = behindProxy Proxy.X_Forwarded_For ------------------------------------------------------------------------------ catch500 :: MonadSnap m => Config m a -> m () -> m () catch500 conf = flip L.catch $ fromJust $ getErrorHandler conf ------------------------------------------------------------------------------ compress :: MonadSnap m => Config m a -> m () -> m () compress conf = if fromJust $ getCompression conf then withCompression else id ------------------------------------------------------------------------------ -- | 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 handler = do conf <- commandLineConfig defaultConfig httpServe conf handler ------------------------------------------------------------------------------ -- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\". -- This doesn't work on Windows. setUnicodeLocale :: String -> IO () #ifndef PORTABLE setUnicodeLocale 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 setUnicodeLocale = const $ return () #endif ------------------------------------------------------------------------------ bshow :: (Show a) => a -> ByteString bshow = S.pack . show snap-server-1.1.2.1/src/Snap/Http/Server/0000755000000000000000000000000007346545000016165 5ustar0000000000000000snap-server-1.1.2.1/src/Snap/Http/Server/Config.hs0000644000000000000000000000420507346545000017727 0ustar0000000000000000------------------------------------------------------------------------------ -- | This module exports the 'Config' datatype, which you can use to configure -- the Snap HTTP server. -- module Snap.Http.Server.Config ( Config , ConfigLog(..) , ProxyType , 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 , getUnixSocket , getUnixSocketAccessMode , setAccessLog , setBind , setCompression , setDefaultTimeout , setErrorHandler , setErrorLog , setHostname , setLocale , setOther , setPort , setProxyType , setSSLBind , setSSLCert , setSSLKey , setSSLChainCert , setSSLPort , setVerbose , setUnixSocket , setUnixSocketAccessMode , setStartupHook , StartupInfo , getStartupSockets , getStartupConfig -- ** Proxy protocol selection , noProxy , xForwardedFor , haProxy ) where ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Config ------------------------------------------------------------------------------ -- | Configure Snap in direct / non-proxying mode. noProxy :: ProxyType noProxy = NoProxy ------------------------------------------------------------------------------ -- | Assert that Snap is running behind an HTTP proxy, and that the proxied -- connection information will be stored in the \"X-Forwarded-For\" or -- \"Forwarded-For\" HTTP headers. xForwardedFor :: ProxyType xForwardedFor = X_Forwarded_For ------------------------------------------------------------------------------ -- | Assert that Snap is running behind a proxy running the HaProxy protocol -- (see ). -- In this mode connections that don't obey the proxy protocol are rejected. haProxy :: ProxyType haProxy = HaProxy snap-server-1.1.2.1/src/Snap/Http/Server/Types.hs0000644000000000000000000002527307346545000017636 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Types used by the Snap HTTP Server. module Snap.Http.Server.Types ( ServerConfig , PerSessionData -- * ServerConfig , emptyServerConfig -- ** getters\/setters , getDefaultTimeout , getIsSecure , getLocalHostname , getLogAccess , getLogError , getNumAcceptLoops , getOnDataFinished , getOnEscape , getOnException , getOnNewRequest , getOnParse , getOnUserHandlerFinished , setDefaultTimeout , setIsSecure , setLocalHostname , setLogAccess , setLogError , setNumAcceptLoops , setOnDataFinished , setOnEscape , setOnException , setOnNewRequest , setOnParse , setOnUserHandlerFinished -- * PerSessionData -- ** getters , getTwiddleTimeout , isNewConnection , getLocalAddress , getLocalPort , getRemoteAddress , getRemotePort -- * HTTP lifecycle -- $lifecycle -- * Hooks -- $hooks , DataFinishedHook , EscapeSnapHook , ExceptionHook , ParseHook , NewRequestHook , UserHandlerFinishedHook -- * Handlers , SendFileHandler , ServerHandler , AcceptFunc -- * Socket types , SocketConfig(..) ) where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import Data.IORef (readIORef) import Data.Word (Word64) ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder) ------------------------------------------------------------------------------ import Snap.Core (Request, Response) import Snap.Internal.Http.Server.Types (AcceptFunc, DataFinishedHook, EscapeSnapHook, ExceptionHook, NewRequestHook, ParseHook, PerSessionData (_isNewConnection, _localAddress, _localPort, _remoteAddress, _remotePort, _twiddleTimeout), SendFileHandler, ServerConfig (..), ServerHandler, SocketConfig (..), UserHandlerFinishedHook) --------------------------- -- snap server lifecycle -- --------------------------- ------------------------------------------------------------------------------ -- $lifecycle -- -- 'Request' \/ 'Response' lifecycle for \"normal\" requests (i.e. without -- errors): -- -- 1. accept a new connection, set it up (e.g. with SSL) -- -- 2. create a 'PerSessionData' object -- -- 3. Enter the 'SessionHandler', which: -- -- 4. calls the 'NewRequestHook', making a new hookState object. -- -- 5. parses the HTTP request. If the session is over, we stop here. -- -- 6. calls the 'ParseHook' -- -- 7. enters the 'ServerHandler', which is provided by another part of the -- framework -- -- 8. the server handler passes control to the user handler -- -- 9. a 'Response' is produced, and the 'UserHandlerFinishedHook' is called. -- -- 10. the 'Response' is written to the client -- -- 11. the 'DataFinishedHook' is called. -- -- 12. we go to #3. ----------- -- hooks -- ----------- ------------------------------------------------------------------------------ -- $hooks -- #hooks# -- -- At various critical points in the HTTP lifecycle, the Snap server will call -- user-defined \"hooks\" that can be used for instrumentation or tracing of -- the process of building the HTTP response. The first hook called, the -- 'NewRequestHook', will generate a \"hookState\" object (having some -- user-defined abstract type), and this object will be passed to the rest of -- the hooks as the server handles the process of responding to the HTTP -- request. -- -- For example, you could pass a set of hooks to the Snap server that measured -- timings for each URI handled by the server to produce online statistics and -- metrics using something like @statsd@ (). ------------------------------------------------------------------------------ emptyServerConfig :: ServerConfig a emptyServerConfig = ServerConfig (\_ _ _ -> return $! ()) (\_ -> return $! ()) (\_ -> return $ error "undefined hook state") (\_ _ -> return $! ()) (\_ _ _ -> return $! ()) (\_ _ _ -> return $! ()) (\_ _ -> return $! ()) (\_ -> return $! ()) "localhost" 30 False 1 ------------------------------------------------------------------------------ getLogAccess :: ServerConfig hookState -> Request -> Response -> Word64 -> IO () getLogAccess sc = _logAccess sc ------------------------------------------------------------------------------ getLogError :: ServerConfig hookState -> Builder -> IO () getLogError sc = _logError sc ------------------------------------------------------------------------------ getOnNewRequest :: ServerConfig hookState -> NewRequestHook hookState getOnNewRequest sc = _onNewRequest sc ------------------------------------------------------------------------------ getOnParse :: ServerConfig hookState -> ParseHook hookState getOnParse sc = _onParse sc ------------------------------------------------------------------------------ getOnUserHandlerFinished :: ServerConfig hookState -> UserHandlerFinishedHook hookState getOnUserHandlerFinished sc = _onUserHandlerFinished sc ------------------------------------------------------------------------------ getOnDataFinished :: ServerConfig hookState -> DataFinishedHook hookState getOnDataFinished sc = _onDataFinished sc ------------------------------------------------------------------------------ getOnException :: ServerConfig hookState -> ExceptionHook hookState getOnException sc = _onException sc ------------------------------------------------------------------------------ getOnEscape :: ServerConfig hookState -> EscapeSnapHook hookState getOnEscape sc = _onEscape sc ------------------------------------------------------------------------------ getLocalHostname :: ServerConfig hookState -> ByteString getLocalHostname sc = _localHostname sc ------------------------------------------------------------------------------ getDefaultTimeout :: ServerConfig hookState -> Int getDefaultTimeout sc = _defaultTimeout sc ------------------------------------------------------------------------------ getIsSecure :: ServerConfig hookState -> Bool getIsSecure sc = _isSecure sc ------------------------------------------------------------------------------ getNumAcceptLoops :: ServerConfig hookState -> Int getNumAcceptLoops sc = _numAcceptLoops sc ------------------------------------------------------------------------------ setLogAccess :: (Request -> Response -> Word64 -> IO ()) -> ServerConfig hookState -> ServerConfig hookState setLogAccess s sc = sc { _logAccess = s } ------------------------------------------------------------------------------ setLogError :: (Builder -> IO ()) -> ServerConfig hookState -> ServerConfig hookState setLogError s sc = sc { _logError = s } ------------------------------------------------------------------------------ setOnNewRequest :: NewRequestHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnNewRequest s sc = sc { _onNewRequest = s } ------------------------------------------------------------------------------ setOnParse :: ParseHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnParse s sc = sc { _onParse = s } ------------------------------------------------------------------------------ setOnUserHandlerFinished :: UserHandlerFinishedHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnUserHandlerFinished s sc = sc { _onUserHandlerFinished = s } ------------------------------------------------------------------------------ setOnDataFinished :: DataFinishedHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnDataFinished s sc = sc { _onDataFinished = s } ------------------------------------------------------------------------------ setOnException :: ExceptionHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnException s sc = sc { _onException = s } ------------------------------------------------------------------------------ setOnEscape :: EscapeSnapHook hookState -> ServerConfig hookState -> ServerConfig hookState setOnEscape s sc = sc { _onEscape = s } ------------------------------------------------------------------------------ setLocalHostname :: ByteString -> ServerConfig hookState -> ServerConfig hookState setLocalHostname s sc = sc { _localHostname = s } ------------------------------------------------------------------------------ setDefaultTimeout :: Int -> ServerConfig hookState -> ServerConfig hookState setDefaultTimeout s sc = sc { _defaultTimeout = s } ------------------------------------------------------------------------------ setIsSecure :: Bool -> ServerConfig hookState -> ServerConfig hookState setIsSecure s sc = sc { _isSecure = s } ------------------------------------------------------------------------------ setNumAcceptLoops :: Int -> ServerConfig hookState -> ServerConfig hookState setNumAcceptLoops s sc = sc { _numAcceptLoops = s } ------------------------------------------------------------------------------ getTwiddleTimeout :: PerSessionData -> ((Int -> Int) -> IO ()) getTwiddleTimeout psd = _twiddleTimeout psd ------------------------------------------------------------------------------ isNewConnection :: PerSessionData -> IO Bool isNewConnection = readIORef . _isNewConnection ------------------------------------------------------------------------------ getLocalAddress :: PerSessionData -> ByteString getLocalAddress psd = _localAddress psd ------------------------------------------------------------------------------ getLocalPort :: PerSessionData -> Int getLocalPort psd = _localPort psd ------------------------------------------------------------------------------ getRemoteAddress :: PerSessionData -> ByteString getRemoteAddress psd = _remoteAddress psd ------------------------------------------------------------------------------ getRemotePort :: PerSessionData -> Int getRemotePort psd = _remotePort psd snap-server-1.1.2.1/src/Snap/Internal/Http/Server/0000755000000000000000000000000007346545000017741 5ustar0000000000000000snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Address.hs0000644000000000000000000001026507346545000021666 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.Address ( getHostAddr , getHostAddrImpl , getSockAddr , getSockAddrImpl , getAddress , getAddressImpl , AddressNotSupportedException(..) ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Exception (Exception, throwIO) import Control.Monad (liftM) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) import Network.Socket (AddrInfo (addrAddress, addrFamily, addrFlags, addrSocketType), AddrInfoFlag (AI_NUMERICSERV, AI_PASSIVE), Family (AF_INET, AF_INET6), HostName, NameInfoFlag (NI_NUMERICHOST), ServiceName, SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), SocketType (Stream), defaultHints, getAddrInfo, getNameInfo) ------------------------------------------------------------------------------ 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 = getHostAddrImpl getNameInfo ------------------------------------------------------------------------------ getHostAddrImpl :: ([NameInfoFlag] -> Bool -> Bool -> SockAddr -> IO (Maybe HostName, Maybe ServiceName)) -> SockAddr -> IO String getHostAddrImpl !_getNameInfo addr = (fromMaybe "" . fst) `liftM` _getNameInfo [NI_NUMERICHOST] True False addr ------------------------------------------------------------------------------ getAddress :: SockAddr -> IO (Int, ByteString) getAddress = getAddressImpl getHostAddr ------------------------------------------------------------------------------ getAddressImpl :: (SockAddr -> IO String) -> SockAddr -> IO (Int, ByteString) getAddressImpl !_getHostAddr addr = case addr of SockAddrInet p _ -> host (fromIntegral p) SockAddrInet6 p _ _ _ -> host (fromIntegral p) SockAddrUnix path -> return (-1, prefix path) #if MIN_VERSION_network(2,6,0) _ -> fail "Unsupported address type" #endif where prefix path = T.encodeUtf8 $! T.pack $ "unix:" ++ path host port = (,) port . S.pack <$> _getHostAddr addr ------------------------------------------------------------------------------ getSockAddr :: Int -> ByteString -> IO (Family, SockAddr) getSockAddr = getSockAddrImpl getAddrInfo ------------------------------------------------------------------------------ getSockAddrImpl :: (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]) -> Int -> ByteString -> IO (Family, SockAddr) getSockAddrImpl !_getAddrInfo p s = case () of !_ | s == "*" -> getAddrs isIPv4 (Just wildhints) Nothing (Just $ show p) | s == "::" -> getAddrs isIPv6 (Just wildhints) Nothing (Just $ show p) | otherwise -> getAddrs (const True) (Just hints) (Just $ S.unpack s) (Just $ show p) where isIPv4 ai = addrFamily ai == AF_INET isIPv6 ai = addrFamily ai == AF_INET6 getAddrs flt a b c = do ais <- filter flt <$> _getAddrInfo a b c 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) wildhints = hints { addrFlags = [AI_NUMERICSERV, AI_PASSIVE] } hints = defaultHints { addrFlags = [AI_NUMERICSERV] , addrSocketType = Stream } snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Clock.hs0000644000000000000000000000241307346545000021330 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Snap.Internal.Http.Server.Clock ( ClockTime , getClockTime , sleepFor , sleepSecs , fromSecs , toSecs ) where import Control.Concurrent (threadDelay) import qualified System.Clock as Clock type ClockTime = Clock.TimeSpec ------------------------------------------------------------------------------ sleepFor :: ClockTime -> IO () sleepFor t = threadDelay $ fromIntegral d where d = (Clock.nsec t `div` 1000) + (1000000 * Clock.sec t) ------------------------------------------------------------------------------ sleepSecs :: Double -> IO () sleepSecs = sleepFor . fromSecs ------------------------------------------------------------------------------ getClockTime :: IO ClockTime getClockTime = Clock.getTime Clock.Monotonic ------------------------------------------------------------------------------ fromSecs :: Double -> ClockTime fromSecs d = let (s, r) = properFraction d in Clock.TimeSpec s (truncate $! 1000000000 * r) ------------------------------------------------------------------------------ toSecs :: ClockTime -> Double toSecs t = fromIntegral (Clock.sec t) + fromIntegral (Clock.nsec t) / 1000000000.0 snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Common.hs0000644000000000000000000000241707346545000021531 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Common ( atomicModifyIORef' , eatException ) where import Control.Exception (SomeException, catch) import Control.Monad (void) import Prelude (IO, return, ($!)) #if MIN_VERSION_base(4,6,0) ------------------------------------------------------------------------------ import Data.IORef (atomicModifyIORef') #else ------------------------------------------------------------------------------ import Data.IORef (IORef, atomicModifyIORef) import Prelude (seq) ------------------------------------------------------------------------------ -- | Strict version of 'atomicModifyIORef'. This forces both the value stored -- in the 'IORef' as well as the value returned. atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef' ref f = do b <- atomicModifyIORef ref (\x -> let (a, b) = f x in (a, a `seq` b)) b `seq` return b #endif ------------------------------------------------------------------------------ eatException :: IO a -> IO () eatException m = void m `catch` f where f :: SomeException -> IO () f !_ = return $! () snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Config.hs0000644000000000000000000010030207346545000021476 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# 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 -- NOTE: also edit Snap.Http.Server.Config if you change these ( ConfigLog(..) , Config(..) , ProxyType(..) , emptyConfig , defaultConfig , commandLineConfig , extendedCommandLineConfig , completeConfig , optDescrs , fmapOpt , getAccessLog , getBind , getCompression , getDefaultTimeout , getErrorHandler , getErrorLog , getHostname , getLocale , getOther , getPort , getProxyType , getSSLBind , getSSLCert , getSSLChainCert , getSSLKey , getSSLPort , getVerbose , getStartupHook , getUnixSocket , getUnixSocketAccessMode , setAccessLog , setBind , setCompression , setDefaultTimeout , setErrorHandler , setErrorLog , setHostname , setLocale , setOther , setPort , setProxyType , setSSLBind , setSSLCert , setSSLChainCert , setSSLKey , setSSLPort , setVerbose , setUnixSocket , setUnixSocketAccessMode , setStartupHook , StartupInfo(..) , getStartupSockets , getStartupConfig -- * Private , emptyStartupInfo , setStartupSockets , setStartupConfig ) where ------------------------------------------------------------------------------ import Control.Exception (SomeException) import Control.Monad (when) import Data.Bits ((.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.CaseInsensitive as CI import Data.Function (on) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (isJust, isNothing) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid (..)) #endif import Data.Monoid (Last (Last, getLast)) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..)) #endif import qualified Data.Text as T import qualified Data.Text.Encoding as T #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable) #else import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp) #endif import Network.Socket (Socket) import Numeric (readOct, showOct) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute), OptDescr (..), getOpt, usageInfo) import System.Environment hiding (getEnv) #ifndef PORTABLE import Data.Char (isAlpha) import System.Posix.Env (getEnv) #endif import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder, byteString, stringUtf8, toLazyByteString) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort, rqParams, rqPostParams), emptyResponse, finishWith, getsRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus) import Snap.Internal.Debug (debug) ------------------------------------------------------------------------------ -- | FIXME -- -- Note: this type changed in snap-server 1.0.0.0. data ProxyType = NoProxy | HaProxy | X_Forwarded_For deriving (Show, Eq, Typeable) ------------------------------------------------------------------------------ -- | 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" ------------------------------------------------------------------------------ -- We should be using ServerConfig here. There needs to be a clearer -- separation between: -- -- * what the underlying code needs to configure itself -- -- * what the command-line processing does. -- -- The latter will provide "library" helper functions that operate on -- ServerConfig/etc in order to allow users to configure their own environment. -- -- -- Todo: -- -- * need a function :: -- CommandLineConfig -> IO [(ServerConfig hookState, AcceptFunc)] -- -- this will prep for another function that will spawn all of the -- accept loops with httpAcceptLoop. -- -- * all backends provide "Some -> Foo -> Config -> IO AcceptFunc" -- -- * add support for socket activation to command line, or delegate to -- different library? It's linux-only anyways, need to ifdef. It would be -- silly to depend on the socket-activation library for that one little -- function. -- -- * break config into multiple modules: -- -- * everything that modifies the snap handler (compression, proxy -- settings, error handler) -- -- * everything that directly modifies server settings (hostname / -- defaultTimeout / hooks / etc) -- -- * everything that configures backends (port/bind/ssl*) -- -- * everything that handles command line stuff -- -- * utility stuff -- -- Cruft that definitely must be removed: -- -- * ConfigLog -- this becomes a binary option on the command-line side (no -- logging or yes, to this file), but the ConfigIoLog gets zapped -- altogether. ------------------------------------------------------------------------------ -- | 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 , unixsocket :: Maybe FilePath , unixaccessmode :: Maybe Int , compression :: Maybe Bool , verbose :: Maybe Bool , errorHandler :: Maybe (SomeException -> m ()) , defaultTimeout :: Maybe Int , other :: Maybe a , 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 = mkTyCon3 "snap-server" "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 , "unixsocket: " ++ _unixsocket , "unixaccessmode: " ++ _unixaccessmode , "compression: " ++ _compression , "verbose: " ++ _verbose , "defaultTimeout: " ++ _defaultTimeout , "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 _proxyType = show $ proxyType c _unixsocket = show $ unixsocket c _unixaccessmode = case unixaccessmode c of Nothing -> "Nothing" Just s -> ("Just 0" ++) . showOct s $ [] ------------------------------------------------------------------------------ -- | Returns a completely empty 'Config'. Equivalent to 'mempty' from -- 'Config''s 'Monoid' instance. emptyConfig :: Config m a emptyConfig = mempty ------------------------------------------------------------------------------ instance Semigroup (Config m a) where a <> 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 , unixsocket = ov unixsocket , unixaccessmode = ov unixaccessmode , compression = ov compression , verbose = ov verbose , errorHandler = ov errorHandler , defaultTimeout = ov defaultTimeout , other = ov other , proxyType = ov proxyType , startupHook = ov startupHook } where ov :: (Config m a -> Maybe b) -> Maybe b ov f = getLast $! (mappend `on` (Last . f)) a b 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 , unixsocket = Nothing , unixaccessmode = Nothing , compression = Nothing , verbose = Nothing , errorHandler = Nothing , defaultTimeout = Nothing , other = Nothing , proxyType = Nothing , startupHook = Nothing } #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif ------------------------------------------------------------------------------ -- | 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 = Nothing , sslcert = Nothing , sslkey = Nothing , sslchaincert = Nothing , 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 -- | File path to unix socket. Must be absolute path, but allows for symbolic -- links. getUnixSocket :: Config m a -> Maybe FilePath getUnixSocket = unixsocket -- | Access mode for unix socket, by default is system specific. -- This should only be used to grant additional permissions to created -- socket file, and not to remove permissions set by default. -- The only portable way to limit access to socket is creating it in a -- directory with proper permissions set. -- -- Most BSD systems ignore access permissions on unix sockets. -- -- Note: This uses umask. There is a race condition if process creates other -- files at the same time as opening a unix socket with this option set. getUnixSocketAccessMode :: Config m a -> Maybe Int getUnixSocketAccessMode = unixaccessmode -- | 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 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 } setUnixSocket :: FilePath -> Config m a -> Config m a setUnixSocket x c = c { unixsocket = Just x } setUnixSocketAccessMode :: Int -> Config m a -> Config m a setUnixSocketAccessMode p c = c { unixaccessmode = Just ( p .&. 0o777) } 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 } 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 '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 unixValid = isJust $ unixsocket cfg noPort = isNothing (getPort cfg) && not sslValid && not unixValid 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 :: forall m a . 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 (Just . setConfig setProxyType . parseProxy . CI.mk) "X_Forwarded_For") $ concat [ "Set --proxy=X_Forwarded_For if your snap application \n" , "is behind an HTTP reverse proxy to ensure that \n" , "rqClientAddr is set properly.\n" , "Set --proxy=haproxy to use the haproxy protocol\n(" , "http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt)" , defaultC getProxyType ] , Option "" ["unix-socket"] (ReqArg (Just . setConfig setUnixSocket) "PATH") $ concat ["Absolute path to unix socket file. " , "File will be removed if already exists"] , Option "" ["unix-socket-mode"] (ReqArg (Just . setConfig setUnixSocketAccessMode . parseOctal) "MODE") $ concat ["Access mode for unix socket in octal, for example 0760.\n" ," Default is system specific."] , Option "h" ["help"] (NoArg Nothing) "display this help and exit" ] where parseProxy s | s == "NoProxy" = NoProxy | s == "X_Forwarded_For" = X_Forwarded_For | s == "haproxy" = HaProxy | otherwise = error $ concat [ "Error (--proxy): expected one of 'NoProxy', " , "'X_Forwarded_For', or 'haproxy'. Got '" , CI.original s , "'" ] parseOctal s = case readOct s of ((v, _):_) | v >= 0 && v <= 0o777 -> v _ -> error $ "Error (--unix-socket-mode): expected octal access mode" setConfig f c = f c mempty conf = defaultConfig `mappend` defaults defaultB :: (Config m a -> Maybe Bool) -> String -> String -> String defaultB f y n = (maybe "" (\b -> ", default " ++ if b then y else n) $ f conf) :: String defaultC :: (Show b) => (Config m a -> Maybe b) -> String defaultC f = maybe "" ((", default " ++) . show) $ f conf defaultO :: (Show b) => (Config m a -> Maybe b) -> String defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf ------------------------------------------------------------------------------ defaultErrorHandler :: MonadSnap m => SomeException -> m () defaultErrorHandler e = do debug "Snap.Http.Server.Config errorHandler:" req <- getsRequest blindParams let sm = smsg req debug $ toString sm logError sm finishWith $ setContentType "text/plain; charset=utf-8" . setContentLength (fromIntegral $ S.length msg) . setResponseStatus 500 "Internal Server Error" . setResponseBody errBody $ emptyResponse where blindParams r = r { rqPostParams = rmValues $ rqPostParams r , rqParams = rmValues $ rqParams r } rmValues = Map.map (const ["..."]) errBody os = Streams.write (Just msgB) os >> return os toByteString = S.concat . L.toChunks . toLazyByteString smsg req = toByteString $ requestErrorMessage req e msg = toByteString msgB msgB = mconcat [ byteString "A web handler threw an exception. Details:\n" , stringUtf8 $ show 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))] -- ^ Full list of command line options (combine -- yours with 'optDescrs' to extend Snap's default -- set of 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 ------------------------------------------------------------------------------ requestErrorMessage :: Request -> SomeException -> Builder requestErrorMessage req e = mconcat [ byteString "During processing of request from " , byteString $ rqClientAddr req , byteString ":" , fromShow $ rqClientPort req , byteString "\nrequest:\n" , fromShow $ show req , byteString "\n" , msgB ] where msgB = mconcat [ byteString "A web handler threw an exception. Details:\n" , fromShow e ] ------------------------------------------------------------------------------ fromShow :: Show a => a -> Builder fromShow = stringUtf8 . show snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Date.hs0000644000000000000000000000504007346545000021151 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Date ( getDateString , getLogDateString ) where ------------------------------------------------------------------------------ import Control.Exception (mask_) import Control.Monad (when) import Data.ByteString (ByteString) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Foreign.C.Types (CTime) import System.IO.Unsafe (unsafePerformIO) import System.PosixCompat.Time (epochTime) ------------------------------------------------------------------------------ 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 {-# NOINLINE dateState #-} ------------------------------------------------------------------------------ fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do !now <- epochTime !t1 <- formatHttpTime now !t2 <- formatLogTime now let !out = (t1, t2, now) return out ------------------------------------------------------------------------------ updateState :: DateState -> IO () updateState (DateState dateString logString time) = do (s1, s2, now) <- fetchTime writeIORef dateString $! s1 writeIORef logString $! s2 writeIORef time $! now 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 snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Parser.hs0000644000000000000000000003765007346545000021544 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} module Snap.Internal.Http.Server.Parser ( IRequest(..) , HttpParseException(..) , readChunkedTransferEncoding , writeChunkedTransferEncoding , parseRequest , parseFromStream , parseCookie , parseUrlEncoded , getStdContentLength , getStdHost , getStdTransferEncoding , getStdCookie , getStdContentType , getStdConnection ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Exception (Exception, throwIO) import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, takeTill) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (ByteString (..), c2w, memchr, w2c) #if MIN_VERSION_bytestring(0, 10, 6) import Data.ByteString.Internal (accursedUnutterablePerformIO) #else import Data.ByteString.Internal (inlinePerformIO) #endif import qualified Data.ByteString.Unsafe as S import Data.List (sort) import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (minusPtr, nullPtr, plusPtr) import Prelude hiding (take) ------------------------------------------------------------------------------ import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Data.ByteString.Builder (Builder) import System.IO.Streams (InputStream, OutputStream, Generator) import qualified System.IO.Streams as Streams import System.IO.Streams.Attoparsec (parseFromStream) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types (Method (..)) import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H ------------------------------------------------------------------------------ newtype StandardHeaders = StandardHeaders (V.Vector (Maybe ByteString)) type MStandardHeaders = MV.IOVector (Maybe ByteString) ------------------------------------------------------------------------------ contentLengthTag, hostTag, transferEncodingTag, cookieTag, contentTypeTag, connectionTag, nStandardHeaders :: Int contentLengthTag = 0 hostTag = 1 transferEncodingTag = 2 cookieTag = 3 contentTypeTag = 4 connectionTag = 5 nStandardHeaders = 6 ------------------------------------------------------------------------------ findStdHeaderIndex :: ByteString -> Int findStdHeaderIndex "content-length" = contentLengthTag findStdHeaderIndex "host" = hostTag findStdHeaderIndex "transfer-encoding" = transferEncodingTag findStdHeaderIndex "cookie" = cookieTag findStdHeaderIndex "content-type" = contentTypeTag findStdHeaderIndex "connection" = connectionTag findStdHeaderIndex _ = -1 ------------------------------------------------------------------------------ getStdContentLength, getStdHost, getStdTransferEncoding, getStdCookie, getStdConnection, getStdContentType :: StandardHeaders -> Maybe ByteString getStdContentLength (StandardHeaders v) = V.unsafeIndex v contentLengthTag getStdHost (StandardHeaders v) = V.unsafeIndex v hostTag getStdTransferEncoding (StandardHeaders v) = V.unsafeIndex v transferEncodingTag getStdCookie (StandardHeaders v) = V.unsafeIndex v cookieTag getStdContentType (StandardHeaders v) = V.unsafeIndex v contentTypeTag getStdConnection (StandardHeaders v) = V.unsafeIndex v connectionTag ------------------------------------------------------------------------------ newMStandardHeaders :: IO MStandardHeaders newMStandardHeaders = MV.replicate nStandardHeaders Nothing ------------------------------------------------------------------------------ -- | an internal version of the headers part of an HTTP request data IRequest = IRequest { iMethod :: !Method , iRequestUri :: !ByteString , iHttpVersion :: (Int, Int) , iRequestHeaders :: Headers , iStdHeaders :: StandardHeaders } ------------------------------------------------------------------------------ instance Eq IRequest where a == b = and [ iMethod a == iMethod b , iRequestUri a == iRequestUri b , iHttpVersion a == iHttpVersion b , sort (H.toList (iRequestHeaders a)) == sort (H.toList (iRequestHeaders b)) ] ------------------------------------------------------------------------------ instance Show IRequest where show (IRequest m u (major, minor) hdrs _) = concat [ show m , " " , show u , " " , show major , "." , show minor , " " , show hdrs ] ------------------------------------------------------------------------------ data HttpParseException = HttpParseException String deriving (Typeable, Show) instance Exception HttpParseException ------------------------------------------------------------------------------ {-# INLINE parseRequest #-} parseRequest :: InputStream ByteString -> IO IRequest parseRequest input = do line <- pLine input let (!mStr, !s) = bSp line let (!uri, !vStr) = bSp s let method = methodFromString mStr let !version = pVer vStr let (host, uri') = getHost uri let uri'' = if S.null uri' then "/" else uri' stdHdrs <- newMStandardHeaders MV.unsafeWrite stdHdrs hostTag host hdrs <- pHeaders stdHdrs input outStd <- StandardHeaders <$> V.unsafeFreeze stdHdrs return $! IRequest method uri'' version hdrs outStd where getHost s | "http://" `S.isPrefixOf` s = let s' = S.unsafeDrop 7 s (!host, !uri) = breakCh '/' s' in (Just $! host, uri) | "https://" `S.isPrefixOf` s = let s' = S.unsafeDrop 8 s (!host, !uri) = breakCh '/' s' in (Just $! host, uri) | otherwise = (Nothing, s) pVer s = if "HTTP/" `S.isPrefixOf` s then pVers (S.unsafeDrop 5 s) else (1, 0) bSp = splitCh ' ' pVers s = (c, d) where (!a, !b) = splitCh '.' s !c = unsafeFromNat a !d = unsafeFromNat b ------------------------------------------------------------------------------ pLine :: InputStream ByteString -> IO ByteString pLine input = go [] where throwNoCRLF = throwIO $ HttpParseException "parse error: expected line ending in crlf" throwBadCRLF = throwIO $ HttpParseException "parse error: got cr without subsequent lf" go !l = do !mb <- Streams.read input !s <- maybe throwNoCRLF return mb let !i = elemIndex '\r' s if i < 0 then noCRLF l s else case () of !_ | i+1 >= S.length s -> lastIsCR l s i | S.unsafeIndex s (i+1) == 10 -> foundCRLF l s i | otherwise -> throwBadCRLF foundCRLF l s !i1 = do let !i2 = i1 + 2 let !a = S.unsafeTake i1 s when (i2 < S.length s) $ do let !b = S.unsafeDrop i2 s Streams.unRead b input -- Optimize for the common case: dl is almost always "id" let !out = if null l then a else S.concat (reverse (a:l)) return out noCRLF l s = go (s:l) lastIsCR l s !idx = do !t <- Streams.read input >>= maybe throwNoCRLF return if S.null t then lastIsCR l s idx else do let !c = S.unsafeHead t if c /= 10 then throwBadCRLF else do let !a = S.unsafeTake idx s let !b = S.unsafeDrop 1 t when (not $ S.null b) $ Streams.unRead b input let !out = if null l then a else S.concat (reverse (a:l)) return out ------------------------------------------------------------------------------ splitCh :: Char -> ByteString -> (ByteString, ByteString) splitCh !c !s = if idx < 0 then (s, S.empty) else let !a = S.unsafeTake idx s !b = S.unsafeDrop (idx + 1) s in (a, b) where !idx = elemIndex c s {-# INLINE splitCh #-} ------------------------------------------------------------------------------ breakCh :: Char -> ByteString -> (ByteString, ByteString) breakCh !c !s = if idx < 0 then (s, S.empty) else let !a = S.unsafeTake idx s !b = S.unsafeDrop idx s in (a, b) where !idx = elemIndex c s {-# INLINE breakCh #-} ------------------------------------------------------------------------------ splitHeader :: ByteString -> (ByteString, ByteString) splitHeader !s = if idx < 0 then (s, S.empty) else let !a = S.unsafeTake idx s in (a, skipSp (idx + 1)) where !idx = elemIndex ':' s l = S.length s skipSp !i | i >= l = S.empty | otherwise = let c = S.unsafeIndex s i in if isLWS $ w2c c then skipSp $ i + 1 else S.unsafeDrop i s {-# INLINE splitHeader #-} ------------------------------------------------------------------------------ isLWS :: Char -> Bool isLWS c = c == ' ' || c == '\t' {-# INLINE isLWS #-} ------------------------------------------------------------------------------ pHeaders :: MStandardHeaders -> InputStream ByteString -> IO Headers pHeaders stdHdrs input = do hdrs <- H.unsafeFromCaseFoldedList <$> go [] return hdrs where go !list = do line <- pLine input if S.null line then return list else do let (!k0,!v) = splitHeader line let !k = toLower k0 vf <- pCont id let vs = vf [] let !v' = S.concat (v:vs) let idx = findStdHeaderIndex k when (idx >= 0) $ MV.unsafeWrite stdHdrs idx $! Just v' let l' = ((k, v'):list) go l' trimBegin = S.dropWhile isLWS pCont !dlist = do mbS <- Streams.peek input maybe (return dlist) (\s -> if not (S.null s) then if not $ isLWS $ w2c $ S.unsafeHead s then return dlist else procCont dlist else Streams.read input >> pCont dlist) mbS procCont !dlist = do line <- pLine input let !t = trimBegin line pCont (dlist . (" ":) . (t:)) ------------------------------------------------------------------------------ methodFromString :: ByteString -> Method methodFromString "GET" = GET methodFromString "POST" = POST methodFromString "HEAD" = HEAD methodFromString "PUT" = PUT methodFromString "DELETE" = DELETE methodFromString "TRACE" = TRACE methodFromString "OPTIONS" = OPTIONS methodFromString "CONNECT" = CONNECT methodFromString "PATCH" = PATCH methodFromString s = Method s ------------------------------------------------------------------------------ readChunkedTransferEncoding :: InputStream ByteString -> IO (InputStream ByteString) readChunkedTransferEncoding input = Streams.fromGenerator (consumeChunks input) ------------------------------------------------------------------------------ writeChunkedTransferEncoding :: OutputStream Builder -> IO (OutputStream Builder) writeChunkedTransferEncoding os = Streams.makeOutputStream f where f Nothing = do Streams.write (Just chunkedTransferTerminator) os Streams.write Nothing os f x = Streams.write (chunkedTransferEncoding `fmap` x) os --------------------- -- parse functions -- --------------------- ------------------------------------------------------------------------------ {- For a response body in chunked transfer encoding, iterate over the individual chunks, reading the size parameter, then looping over that chunk in bites of at most bUFSIZ, yielding them to the receiveResponse InputStream accordingly. -} consumeChunks :: InputStream ByteString -> Generator ByteString () consumeChunks i1 = do !n <- parseSize if n > 0 then do -- read one or more bytes, then loop to next chunk go n skipCRLF consumeChunks i1 else do -- NB: snap-server doesn't yet support chunked trailer parts -- (see RFC7230#sec4.1.2) -- consume final CRLF skipCRLF where go 0 = return () go !n = do (!x',!r) <- liftIO $ readN n i1 Streams.yield x' go r parseSize = do liftIO $ parseFromStream transferChunkSize i1 skipCRLF = do liftIO $ void (parseFromStream crlf i1) transferChunkSize :: Parser (Int) transferChunkSize = do !n <- hexadecimal -- skip over any chunk extensions (see RFC7230#sec4.1.1) void (takeTill (== '\r')) void crlf return n {- The chunk size coming down from the client is somewhat arbitrary; it's really just an indication of how many bytes need to be read before the next size marker or end marker - neither of which has anything to do with streaming on our side. Instead, we'll feed bytes into our InputStream at an appropriate intermediate size. -} bUFSIZ :: Int bUFSIZ = 32752 {- Read the specified number of bytes up to a maximum of bUFSIZ, returning a resultant ByteString and the number of bytes remaining. -} readN :: Int -> InputStream ByteString -> IO (ByteString, Int) readN n input = do !x' <- Streams.readExactly p input return (x', r) where !d = n - bUFSIZ !p = if d > 0 then bUFSIZ else n !r = if d > 0 then d else 0 ------------------------------------------------------------------------------ toLower :: ByteString -> ByteString toLower = S.map lower where lower c0 = let !c = c2w c0 in if 65 <= c && c <= 90 then w2c $! c + 32 else c0 ------------------------------------------------------------------------------ -- | A version of elemIndex that doesn't allocate a Maybe. (It returns -1 on -- not found.) elemIndex :: Char -> ByteString -> Int #if MIN_VERSION_bytestring(0, 10, 6) elemIndex c (PS !fp !start !len) = accursedUnutterablePerformIO $ #else elemIndex c (PS !fp !start !len) = inlinePerformIO $ #endif withForeignPtr fp $ \p0 -> do let !p = plusPtr p0 start q <- memchr p w8 (fromIntegral len) return $! if q == nullPtr then (-1) else q `minusPtr` p where !w8 = c2w c {-# INLINE elemIndex #-} snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Session.hs0000644000000000000000000010727607346545000021735 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Session ( httpAcceptLoop , httpSession , snapToServerHandler , BadRequestException(..) , LengthRequiredException(..) , TerminateSessionException(..) ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Arrow (first, second) import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar) import Control.Exception (AsyncException, Exception, Handler (..), SomeException (..)) import qualified Control.Exception as E import Control.Monad (join, unless, void, when, (>=>)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Unsafe as S import qualified Data.CaseInsensitive as CI import Data.Int (Int64) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe, isNothing) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif import Data.Monoid ((<>)) import Data.Time.Format (formatTime) import Data.Typeable (Typeable) import Data.Version (showVersion) import Data.Word (Word64, Word8) import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (pokeByteOff) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.Internal (Buffer, defaultChunkSize, newBuffer) import Data.ByteString.Builder.Prim (FixedPrim, primFixed, (>$<), (>*<)) import Data.ByteString.Builder.Prim.Internal (fixedPrim, size) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ import qualified Paths_snap_server as V import Snap.Core (EscapeSnap (..)) import Snap.Core (Snap, runSnap) import Snap.Internal.Core (fixupResponse) import Snap.Internal.Http.Server.Clock (getClockTime) import Snap.Internal.Http.Server.Common (eatException) import Snap.Internal.Http.Server.Date (getDateString) import Snap.Internal.Http.Server.Parser (IRequest (..), getStdConnection, getStdContentLength, getStdContentType, getStdCookie, getStdHost, getStdTransferEncoding, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) import Snap.Internal.Http.Server.Thread (SnapThread) import qualified Snap.Internal.Http.Server.Thread as Thread import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) import qualified Snap.Internal.Http.Server.TimeoutManager as TM import Snap.Internal.Http.Server.Types (AcceptFunc (..), PerSessionData (..), SendFileHandler, ServerConfig (..), ServerHandler) import Snap.Internal.Http.Types (Cookie (..), HttpVersion, Method (..), Request (..), Response (..), ResponseBody (..), StreamProc, getHeader, headers, rspBodyToEnum, updateHeaders) import Snap.Internal.Parsing (unsafeFromNat) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H import System.IO.Unsafe (unsafePerformIO) ------------------------------------------------------------------------------ data TerminateSessionException = TerminateSessionException SomeException deriving (Typeable, Show) instance Exception TerminateSessionException data BadRequestException = BadRequestException deriving (Typeable, Show) instance Exception BadRequestException data LengthRequiredException = LengthRequiredException deriving (Typeable, Show) instance Exception LengthRequiredException ------------------------------------------------------------------------------ snapToServerHandler :: Snap a -> ServerHandler hookState snapToServerHandler !snap !serverConfig !perSessionData !req = runSnap snap logErr tickle req where logErr = _logError serverConfig . byteString tickle = _twiddleTimeout perSessionData ------------------------------------------------------------------------------ mAX_HEADERS_SIZE :: Int64 mAX_HEADERS_SIZE = 256 * 1024 ------------------------------------------------------------------------------ -- | For each cpu, we store: -- * An accept thread -- * A TimeoutManager -- * An mvar to signal when the timeout thread is shutdown data EventLoopCpu = EventLoopCpu { _acceptThread :: SnapThread , _timeoutManager :: TimeoutManager } ------------------------------------------------------------------------------ -- | The main Snap webserver loop. Given a server handler, configuration, and a -- function to accept new connections, runs an HTTP loop forever over N -- threads, until a ThreadKilled exception is received. httpAcceptLoop :: forall hookState . ServerHandler hookState -- ^ server handler -> ServerConfig hookState -- ^ server config -> AcceptFunc -- ^ accept function -> IO () httpAcceptLoop serverHandler serverConfig acceptFunc = runLoops where -------------------------------------------------------------------------- logError = _logError serverConfig nLoops = _numAcceptLoops serverConfig defaultTimeout = _defaultTimeout serverConfig -------------------------------------------------------------------------- logException :: Exception e => e -> IO () logException e = logError $ mconcat [ byteString "got exception in httpAcceptFunc: " , fromShow e ] -------------------------------------------------------------------------- runLoops = E.bracket (mapM newLoop [0 .. (nLoops - 1)]) (mapM_ killLoop) (mapM_ waitLoop) -------------------------------------------------------------------------- loop :: TimeoutManager -> (forall a. IO a -> IO a) -> IO () loop tm loopRestore = eatException go where ---------------------------------------------------------------------- handlers = [ Handler $ \(e :: AsyncException) -> loopRestore (E.throwIO $! e) , Handler $ \(e :: SomeException) -> logException e >> go ] go = do (sendFileHandler, localAddress, localPort, remoteAddress, remotePort, readEnd, writeEnd, cleanup) <- runAcceptFunc acceptFunc loopRestore `E.catches` handlers let threadLabel = S.concat [ "snap-server: client " , remoteAddress , ":" , S.pack $ show remotePort ] thMVar <- newEmptyMVar th <- TM.register tm threadLabel $ \restore -> eatException $ prep thMVar sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd cleanup restore putMVar thMVar th go prep :: MVar TM.TimeoutThread -> SendFileHandler -> ByteString -> Int -> ByteString -> Int -> InputStream ByteString -> OutputStream ByteString -> IO () -> (forall a . IO a -> IO a) -> IO () prep thMVar sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd cleanup restore = do connClose <- newIORef False newConn <- newIORef True let twiddleTimeout = unsafePerformIO $ do th <- readMVar thMVar return $! TM.modify th let cleanupTimeout = readMVar thMVar >>= TM.cancel let !psd = PerSessionData connClose twiddleTimeout newConn sendFileHandler localAddress localPort remoteAddress remotePort readEnd writeEnd restore (session psd) `E.finally` cleanup `E.finally` cleanupTimeout -------------------------------------------------------------------------- session psd = do buffer <- newBuffer defaultChunkSize httpSession buffer serverHandler serverConfig psd -------------------------------------------------------------------------- newLoop cpu = E.mask_ $ do -- TODO(greg): move constant into config tm <- TM.initialize (fromIntegral defaultTimeout) 2 getClockTime let threadLabel = S.concat [ "snap-server: accept loop #" , S.pack $ show cpu ] tid <- Thread.forkOn threadLabel cpu $ loop tm return $! EventLoopCpu tid tm -------------------------------------------------------------------------- waitLoop (EventLoopCpu tid _) = Thread.wait tid -------------------------------------------------------------------------- killLoop ev = E.uninterruptibleMask_ $ do Thread.cancelAndWait tid TM.stop tm where tid = _acceptThread ev tm = _timeoutManager ev ------------------------------------------------------------------------------ httpSession :: forall hookState . Buffer -> ServerHandler hookState -> ServerConfig hookState -> PerSessionData -> IO () httpSession !buffer !serverHandler !config !sessionData = loop where -------------------------------------------------------------------------- defaultTimeout = _defaultTimeout config isSecure = _isSecure config localHostname = _localHostname config logAccess = _logAccess config logError = _logError config newRequestHook = _onNewRequest config parseHook = _onParse config userHandlerFinishedHook = _onUserHandlerFinished config dataFinishedHook = _onDataFinished config exceptionHook = _onException config escapeHook = _onEscape config -------------------------------------------------------------------------- forceConnectionClose = _forceConnectionClose sessionData isNewConnection = _isNewConnection sessionData localAddress = _localAddress sessionData localPort = _localPort sessionData remoteAddress = _remoteAddress sessionData remotePort = _remotePort sessionData readEnd = _readEnd sessionData tickle f = _twiddleTimeout sessionData f writeEnd = _writeEnd sessionData sendfileHandler = _sendfileHandler sessionData -------------------------------------------------------------------------- mkBuffer :: IO (OutputStream Builder) mkBuffer = Streams.unsafeBuilderStream (return buffer) writeEnd -------------------------------------------------------------------------- -- Begin HTTP session processing. loop :: IO () loop = do -- peek first to ensure startHook gets generated at the right time. readEndAtEof >>= (flip unless $ do hookState <- newRequestHook sessionData >>= newIORef -- parse HTTP request req <- receiveRequest parseHook hookState req processRequest hookState req) ------------------------------------------------------------------------------ readEndAtEof = Streams.read readEnd >>= maybe (return True) (\c -> if S.null c then readEndAtEof else Streams.unRead c readEnd >> return False) {-# INLINE readEndAtEof #-} -------------------------------------------------------------------------- -- Read the HTTP request from the socket, parse it, and pre-process it. receiveRequest :: IO Request receiveRequest = {-# SCC "httpSession/receiveRequest" #-} do readEnd' <- Streams.throwIfProducesMoreThan mAX_HEADERS_SIZE readEnd parseRequest readEnd' >>= toRequest {-# INLINE receiveRequest #-} -------------------------------------------------------------------------- toRequest :: IRequest -> IO Request toRequest !ireq = {-# SCC "httpSession/toRequest" #-} do -- HTTP spec section 14.23: "All Internet-based HTTP/1.1 servers MUST -- respond with a 400 (Bad Request) status code to any HTTP/1.1 request -- message which lacks a Host header field." -- -- Here we interpret this slightly more liberally: if an absolute URI -- including a hostname is given in the request line, we'll take that -- if there's no Host header. -- -- For HTTP/1.0 requests, we pick the configured local hostname by -- default. host <- maybe (if isHttp11 then badRequestWithNoHost else return localHostname) return mbHost -- Call setupReadEnd, which handles transfer-encoding: chunked or -- content-length restrictions, etc !readEnd' <- setupReadEnd -- Parse an application/x-www-form-urlencoded form, if it was sent (!readEnd'', postParams) <- parseForm readEnd' let allParams = Map.unionWith (++) queryParams postParams -- Decide whether the connection should be closed after the response is -- sent (stored in the forceConnectionClose IORef). checkConnectionClose version $ getStdConnection stdHdrs -- The request is now ready for processing. return $! Request host remoteAddress remotePort localAddress localPort localHost isSecure hdrs readEnd'' mbCL method version cookies pathInfo contextPath uri queryString allParams queryParams postParams where ---------------------------------------------------------------------- !method = iMethod ireq !version = iHttpVersion ireq !stdHdrs = iStdHeaders ireq !hdrs = iRequestHeaders ireq !isHttp11 = version >= (1, 1) !mbHost = getStdHost stdHdrs !localHost = fromMaybe localHostname mbHost mbCL = unsafeFromNat <$> getStdContentLength stdHdrs !isChunked = (CI.mk <$> getStdTransferEncoding stdHdrs) == Just "chunked" cookies = fromMaybe [] (getStdCookie stdHdrs >>= parseCookie) contextPath = "/" !uri = iRequestUri ireq queryParams = parseUrlEncoded queryString emptyParams = Map.empty ---------------------------------------------------------------------- (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $ S.break (== '?') uri ---------------------------------------------------------------------- dropLeadingSlash s = if S.null s then s else let !a = S.unsafeIndex s 0 in if a == 47 -- 47 == '/' then S.unsafeDrop 1 s else s {-# INLINE dropLeadingSlash #-} ---------------------------------------------------------------------- -- | We have to transform the read end of the socket, to limit the -- number of bytes read to the content-length, to decode chunked -- transfer encoding, or to immediately yield EOF if the request body -- is empty. setupReadEnd :: IO (InputStream ByteString) setupReadEnd = if isChunked then readChunkedTransferEncoding readEnd else maybe (const noContentLength) (Streams.takeBytes . fromIntegral) mbCL readEnd {-# INLINE setupReadEnd #-} ---------------------------------------------------------------------- -- | If a request is not in chunked transfer encoding and lacks a -- content-length, the request body is null string. noContentLength :: IO (InputStream ByteString) noContentLength = do when (method == POST || method == PUT) return411 Streams.fromList [] ---------------------------------------------------------------------- return411 = do let (major, minor) = version let resp = mconcat [ byteString "HTTP/" , fromShow major , char8 '.' , fromShow minor , byteString " 411 Length Required\r\n\r\n" , byteString "411 Length Required\r\n" , flush ] writeEndB <- mkBuffer Streams.write (Just resp) writeEndB Streams.write Nothing writeEndB terminateSession LengthRequiredException ---------------------------------------------------------------------- parseForm readEnd' = if hasForm then getForm else return (readEnd', emptyParams) where trimIt = fst . S.spanEnd (== ' ') . S.takeWhile (/= ';') . S.dropWhile (== ' ') mbCT = trimIt <$> getStdContentType stdHdrs hasForm = mbCT == Just "application/x-www-form-urlencoded" mAX_POST_BODY_SIZE = 1024 * 1024 getForm = do readEnd'' <- Streams.throwIfProducesMoreThan mAX_POST_BODY_SIZE readEnd' contents <- S.concat <$> Streams.toList readEnd'' let postParams = parseUrlEncoded contents finalReadEnd <- Streams.fromList [contents] return (finalReadEnd, postParams) ---------------------------------------------------------------------- checkConnectionClose version connection = do -- For HTTP/1.1: if there is an explicit Connection: close, we'll close -- the socket later. -- -- For HTTP/1.0: if there is no explicit Connection: Keep-Alive, -- close the socket later. let v = CI.mk <$> connection when ((version == (1, 1) && v == Just "close") || (version == (1, 0) && v /= Just "keep-alive")) $ writeIORef forceConnectionClose True -------------------------------------------------------------------------- {-# INLINE badRequestWithNoHost #-} badRequestWithNoHost :: IO a badRequestWithNoHost = do let msg = mconcat [ byteString "HTTP/1.1 400 Bad Request\r\n\r\n" , byteString "400 Bad Request: HTTP/1.1 request with no " , byteString "Host header\r\n" , flush ] writeEndB <- mkBuffer Streams.write (Just msg) writeEndB Streams.write Nothing writeEndB terminateSession BadRequestException -------------------------------------------------------------------------- {-# INLINE checkExpect100Continue #-} checkExpect100Continue req = when (getHeader "expect" req == Just "100-continue") $ do let v = if rqVersion req == (1,1) then "HTTP/1.1" else "HTTP/1.0" let hl = byteString v <> byteString " 100 Continue\r\n\r\n" <> flush os <- mkBuffer Streams.write (Just hl) os -------------------------------------------------------------------------- {-# INLINE processRequest #-} processRequest !hookState !req = {-# SCC "httpSession/processRequest" #-} do -- successfully parsed a request, so restart the timer tickle $ max defaultTimeout -- check for Expect: 100-continue checkExpect100Continue req b <- runServerHandler hookState req `E.catches` [ Handler $ escapeSnapHandler hookState , Handler $ catchUserException hookState "user handler" req ] if b then do writeIORef isNewConnection False -- the timer resets to its default value here. loop else return $! () -------------------------------------------------------------------------- {-# INLINE runServerHandler #-} runServerHandler !hookState !req = {-# SCC "httpSession/runServerHandler" #-} do (req0, rsp0) <- serverHandler config sessionData req userHandlerFinishedHook hookState req rsp0 -- check whether we should close the connection after sending the -- response let v = rqVersion req let is_1_0 = (v == (1,0)) cc <- if is_1_0 && (isNothing $ rspContentLength rsp0) then return $! True else readIORef forceConnectionClose -- skip unread portion of request body if rspTransformingRqBody is not -- true unless (rspTransformingRqBody rsp0) $ Streams.skipToEof (rqBody req) !date <- getDateString rsp1 <- fixupResponse req rsp0 let (!hdrs, !cc') = addDateAndServerHeaders is_1_0 date cc $ headers rsp1 let rsp = updateHeaders (const hdrs) rsp1 writeIORef forceConnectionClose cc' bytesSent <- sendResponse req rsp `E.catch` catchUserException hookState "sending-response" req dataFinishedHook hookState req rsp logAccess req0 rsp bytesSent return $! not cc' -------------------------------------------------------------------------- addDateAndServerHeaders !is1_0 !date !cc !hdrs = {-# SCC "addDateAndServerHeaders" #-} let (!hdrs', !newcc) = go [("date",date)] False cc $ H.unsafeToCaseFoldedList hdrs in (H.unsafeFromCaseFoldedList hdrs', newcc) where -- N.B.: here we know the date header has already been removed by -- "fixupResponse". go !l !seenServer !connClose [] = let !l1 = if seenServer then l else (("server", sERVER_HEADER):l) !l2 = if connClose then (("connection", "close"):l1) else l1 in (l2, connClose) go l _ c (x@("server",_):xs) = go (x:l) True c xs go l seenServer c (x@("connection", v):xs) | c = go l seenServer c xs | v == "close" || (is1_0 && v /= "keep-alive") = go l seenServer True xs | otherwise = go (x:l) seenServer c xs go l seenServer c (x:xs) = go (x:l) seenServer c xs -------------------------------------------------------------------------- escapeSnapHandler hookState (EscapeHttp escapeHandler) = do escapeHook hookState mkBuffer >>= escapeHandler tickle readEnd return False escapeSnapHandler _ (TerminateConnection e) = terminateSession e -------------------------------------------------------------------------- catchUserException :: IORef hookState -> ByteString -> Request -> SomeException -> IO a catchUserException hookState phase req e = do logError $ mconcat [ byteString "Exception leaked to httpSession during phase '" , byteString phase , byteString "': \n" , requestErrorMessage req e ] -- Note: the handler passed to httpSession needs to catch its own -- exceptions if it wants to avoid an ungracious exit here. eatException $ exceptionHook hookState e terminateSession e -------------------------------------------------------------------------- sendResponse :: Request -> Response -> IO Word64 sendResponse !req !rsp = {-# SCC "httpSession/sendResponse" #-} do let !v = rqVersion req let !hdrs' = renderCookies rsp (headers rsp) let !code = rspStatus rsp let body = rspBody rsp let needChunked = rqMethod req /= HEAD && isNothing (rspContentLength rsp) && code /= 204 && code /= 304 let (hdrs'', body', shouldClose) = if needChunked then noCL req hdrs' body else (hdrs', body, False) when shouldClose $ writeIORef forceConnectionClose $! True let hdrPrim = mkHeaderPrim v rsp hdrs'' let hlen = size hdrPrim let headerBuilder = primFixed hdrPrim $! () nBodyBytes <- case body' of Stream s -> whenStream headerBuilder hlen rsp s SendFile f Nothing -> whenSendFile headerBuilder rsp f 0 -- ignore end length here because we know we had a -- content-length, use that instead. SendFile f (Just (st, _)) -> whenSendFile headerBuilder rsp f st return $! nBodyBytes -------------------------------------------------------------------------- noCL :: Request -> Headers -> ResponseBody -> (Headers, ResponseBody, Bool) noCL req hdrs body = if v == (1,1) then let origBody = rspBodyToEnum body body' = \os -> do os' <- writeChunkedTransferEncoding os origBody os' in ( H.set "transfer-encoding" "chunked" hdrs , Stream body' , False) else -- We've already noted that we have to close the socket earlier in -- runServerHandler. (hdrs, body, True) where v = rqVersion req {-# INLINE noCL #-} -------------------------------------------------------------------------- -- | If the response contains a content-length, make sure the response body -- StreamProc doesn't yield more (or fewer) than the given number of bytes. limitRspBody :: Int -- ^ header length -> Response -- ^ response -> OutputStream ByteString -- ^ write end of socket -> IO (OutputStream ByteString) limitRspBody hlen rsp os = maybe (return os) f $ rspContentLength rsp where f cl = Streams.giveExactly (fromIntegral hlen + fromIntegral cl) os {-# INLINE limitRspBody #-} -------------------------------------------------------------------------- whenStream :: Builder -- ^ headers -> Int -- ^ header length -> Response -- ^ response -> StreamProc -- ^ output body -> IO Word64 -- ^ returns number of bytes written whenStream headerString hlen rsp body = do -- note: -- -- * precondition here is that we have a content-length and that we're -- not using chunked transfer encoding. -- -- * "headerString" includes http status line. -- -- If you're transforming the request body, you have to manage your own -- timeouts. let t = if rspTransformingRqBody rsp then return $! () else tickle $ max defaultTimeout writeEnd0 <- Streams.ignoreEof writeEnd (writeEnd1, getCount) <- Streams.countOutput writeEnd0 writeEnd2 <- limitRspBody hlen rsp writeEnd1 writeEndB <- Streams.unsafeBuilderStream (return buffer) writeEnd2 >>= Streams.contramapM (\x -> t >> return x) Streams.write (Just headerString) writeEndB writeEnd' <- body writeEndB Streams.write Nothing writeEnd' -- Just in case the user handler didn't. Streams.write Nothing writeEnd1 n <- getCount return $! fromIntegral n - fromIntegral hlen {-# INLINE whenStream #-} -------------------------------------------------------------------------- whenSendFile :: Builder -- ^ headers -> Response -- ^ response -> FilePath -- ^ file to serve -> Word64 -- ^ file start offset -> IO Word64 -- ^ returns number of bytes written whenSendFile headerString rsp filePath offset = do let !cl = fromJust $ rspContentLength rsp sendfileHandler buffer headerString filePath offset cl return cl {-# INLINE whenSendFile #-} -------------------------------------------------------------------------- mkHeaderLine :: HttpVersion -> Response -> FixedPrim () mkHeaderLine outVer r = case outCode of 200 | outVer == (1, 1) -> -- typo in bytestring here fixedPrim 17 $ const (void . cpBS "HTTP/1.1 200 OK\r\n") 200 | otherwise -> fixedPrim 17 $ const (void . cpBS "HTTP/1.0 200 OK\r\n") _ -> fixedPrim len $ const (void . line) where outCode = rspStatus r v = if outVer == (1,1) then "HTTP/1.1 " else "HTTP/1.0 " outCodeStr = S.pack $ show outCode space !op = do pokeByteOff op 0 (32 :: Word8) return $! plusPtr op 1 line = cpBS v >=> cpBS outCodeStr >=> space >=> cpBS reason >=> crlfPoke reason = rspStatusReason r len = 12 + S.length outCodeStr + S.length reason ------------------------------------------------------------------------------ mkHeaderPrim :: HttpVersion -> Response -> Headers -> FixedPrim () mkHeaderPrim v r hdrs = mkHeaderLine v r <+> headersToPrim hdrs ------------------------------------------------------------------------------ infixl 4 <+> (<+>) :: FixedPrim () -> FixedPrim () -> FixedPrim () p1 <+> p2 = ignore >$< p1 >*< p2 where ignore = join (,) ------------------------------------------------------------------------------ {-# INLINE headersToPrim #-} headersToPrim :: Headers -> FixedPrim () headersToPrim hdrs = fixedPrim len (const copy) where len = H.foldedFoldl' f 0 hdrs + 2 where f l k v = l + S.length k + S.length v + 4 copy = go $ H.unsafeToCaseFoldedList hdrs go [] !op = void $ crlfPoke op go ((k,v):xs) !op = do !op' <- cpBS k op pokeByteOff op' 0 (58 :: Word8) -- colon pokeByteOff op' 1 (32 :: Word8) -- space !op'' <- cpBS v $ plusPtr op' 2 crlfPoke op'' >>= go xs {-# INLINE cpBS #-} cpBS :: ByteString -> Ptr Word8 -> IO (Ptr Word8) cpBS s !op = S.unsafeUseAsCStringLen s $ \(cstr, clen) -> do let !cl = fromIntegral clen copyBytes op (castPtr cstr) cl return $! plusPtr op cl {-# INLINE crlfPoke #-} crlfPoke :: Ptr Word8 -> IO (Ptr Word8) crlfPoke !op = do pokeByteOff op 0 (13 :: Word8) -- cr pokeByteOff op 1 (10 :: Word8) -- lf return $! plusPtr op 2 ------------------------------------------------------------------------------ sERVER_HEADER :: ByteString sERVER_HEADER = S.concat ["Snap/", snapServerVersion] ------------------------------------------------------------------------------ snapServerVersion :: ByteString snapServerVersion = S.pack $ showVersion $ V.version ------------------------------------------------------------------------------ terminateSession :: Exception e => e -> IO a terminateSession = E.throwIO . TerminateSessionException . SomeException ------------------------------------------------------------------------------ requestErrorMessage :: Request -> SomeException -> Builder requestErrorMessage req e = mconcat [ byteString "During processing of request from " , byteString $ rqClientAddr req , byteString ":" , fromShow $ rqClientPort req , byteString "\nrequest:\n" , fromShow $ show req , byteString "\n" , msgB ] where msgB = mconcat [ byteString "A web handler threw an exception. Details:\n" , fromShow e ] ------------------------------------------------------------------------------ -- | 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 = S.pack . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" ------------------------------------------------------------------------------ renderCookies :: Response -> Headers -> Headers renderCookies r hdrs | null cookies = hdrs | otherwise = foldl' (\m v -> H.unsafeInsert "set-cookie" v m) hdrs cookies where cookies = fmap cookieToBS . Map.elems $ rspCookies r ------------------------------------------------------------------------------ fromShow :: Show a => a -> Builder fromShow = stringUtf8 . show snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Socket.hs0000644000000000000000000002037007346545000021527 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Socket ( bindSocket , bindSocketImpl , bindUnixSocket , httpAcceptFunc , haProxyAcceptFunc , sendFileFunc , acceptAndInitialize ) where ------------------------------------------------------------------------------ import Control.Exception (bracketOnError, finally, throwIO) import Control.Monad (when) import Data.Bits (complement, (.&.)) import Data.ByteString.Char8 (ByteString) import Network.Socket (Socket, SocketOption (NoDelay, ReuseAddr), accept, close, getSocketName, setSocketOption, socket) import qualified Network.Socket as N #ifdef HAS_SENDFILE import Network.Socket (fdSocket) import System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, openFd) import System.Posix.Types (Fd (..)) import System.SendFile (sendFile, sendHeaders) #else import Data.ByteString.Builder (byteString) import Data.ByteString.Builder.Extra (flush) import Network.Socket.ByteString (sendAll) #endif #ifdef HAS_UNIX_SOCKETS import Control.Exception (bracket) import qualified Control.Exception as E (catch) import System.FilePath (isRelative) import System.IO.Error (isDoesNotExistError) import System.Posix.Files (accessModes, removeLink, setFileCreationMask) #endif ------------------------------------------------------------------------------ import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Address (AddressNotSupportedException (..), getAddress, getSockAddr) import Snap.Internal.Http.Server.Types (AcceptFunc (..), SendFileHandler) import qualified System.IO.Streams.Network.HAProxy as HA ------------------------------------------------------------------------------ bindSocket :: ByteString -> Int -> IO Socket bindSocket = bindSocketImpl setSocketOption bind N.listen where #if MIN_VERSION_network(2,7,0) bind = N.bind #else bind = N.bindSocket #endif {-# INLINE bindSocket #-} ------------------------------------------------------------------------------ bindSocketImpl :: (Socket -> SocketOption -> Int -> IO ()) -- ^ mock setSocketOption -> (Socket -> N.SockAddr -> IO ()) -- ^ bindSocket -> (Socket -> Int -> IO ()) -- ^ listen -> ByteString -> Int -> IO Socket bindSocketImpl _setSocketOption _bindSocket _listen bindAddr bindPort = do (family, addr) <- getSockAddr bindPort bindAddr bracketOnError (socket family N.Stream 0) N.close $ \sock -> do _setSocketOption sock ReuseAddr 1 _setSocketOption sock NoDelay 1 _bindSocket sock addr _listen sock 150 return $! sock bindUnixSocket :: Maybe Int -> String -> IO Socket #if HAS_UNIX_SOCKETS bindUnixSocket mode path = do when (isRelative path) $ throwIO $ AddressNotSupportedException $! "Refusing to bind unix socket to non-absolute path: " ++ path bracketOnError (socket N.AF_UNIX N.Stream 0) N.close $ \sock -> do E.catch (removeLink path) $ \e -> when (not $ isDoesNotExistError e) $ throwIO e case mode of Nothing -> bind sock (N.SockAddrUnix path) Just mode' -> bracket (setFileCreationMask $ modeToMask mode') setFileCreationMask (const $ bind sock (N.SockAddrUnix path)) N.listen sock 150 return $! sock where #if MIN_VERSION_network(2,7,0) bind = N.bind #else bind = N.bindSocket #endif modeToMask p = accessModes .&. complement (fromIntegral p) #else bindUnixSocket _ path = throwIO (AddressNotSupportedException $ "unix:" ++ path) #endif ------------------------------------------------------------------------------ -- TODO(greg): move buffer size configuration into config bUFSIZ :: Int bUFSIZ = 4064 ------------------------------------------------------------------------------ acceptAndInitialize :: Socket -- ^ bound socket -> (forall b . IO b -> IO b) -> ((Socket, N.SockAddr) -> IO a) -> IO a acceptAndInitialize boundSocket restore f = bracketOnError (restore $ accept boundSocket) (close . fst) f ------------------------------------------------------------------------------ haProxyAcceptFunc :: Socket -- ^ bound socket -> AcceptFunc haProxyAcceptFunc boundSocket = AcceptFunc $ \restore -> acceptAndInitialize boundSocket restore $ \(sock, saddr) -> do (readEnd, writeEnd) <- Streams.socketToStreamsWithBufferSize bUFSIZ sock localPInfo <- HA.socketToProxyInfo sock saddr pinfo <- HA.decodeHAProxyHeaders localPInfo readEnd (localPort, localHost) <- getAddress $ HA.getDestAddr pinfo (remotePort, remoteHost) <- getAddress $ HA.getSourceAddr pinfo let cleanup = Streams.write Nothing writeEnd `finally` close sock return $! ( sendFileFunc sock , localHost , localPort , remoteHost , remotePort , readEnd , writeEnd , cleanup ) ------------------------------------------------------------------------------ httpAcceptFunc :: Socket -- ^ bound socket -> AcceptFunc httpAcceptFunc boundSocket = AcceptFunc $ \restore -> acceptAndInitialize boundSocket restore $ \(sock, remoteAddr) -> do localAddr <- getSocketName sock (localPort, localHost) <- getAddress localAddr (remotePort, remoteHost) <- getAddress remoteAddr (readEnd, writeEnd) <- Streams.socketToStreamsWithBufferSize bUFSIZ sock let cleanup = Streams.write Nothing writeEnd `finally` close sock return $! ( sendFileFunc sock , localHost , localPort , remoteHost , remotePort , readEnd , writeEnd , cleanup ) ------------------------------------------------------------------------------ sendFileFunc :: Socket -> SendFileHandler #ifdef HAS_SENDFILE sendFileFunc sock !_ builder fPath offset nbytes = bracket acquire closeFd go where #if MIN_VERSION_unix(2,8,0) acquire = openFd fPath ReadOnly defaultFileFlags #else acquire = openFd fPath ReadOnly Nothing defaultFileFlags #endif #if MIN_VERSION_network(3,0,0) go fileFd = do sockFd <- Fd `fmap` fdSocket sock sendHeaders builder sockFd sendFile sockFd fileFd offset nbytes #else go fileFd = do let sockFd = Fd $ fdSocket sock sendHeaders builder sockFd sendFile sockFd fileFd offset nbytes #endif #else sendFileFunc sock buffer builder fPath offset nbytes = Streams.unsafeWithFileAsInputStartingAt (fromIntegral offset) fPath $ \fileInput0 -> do fileInput <- Streams.takeBytes (fromIntegral nbytes) fileInput0 >>= Streams.map byteString input <- Streams.fromList [builder] >>= flip Streams.appendInputStream fileInput output <- Streams.makeOutputStream sendChunk >>= Streams.unsafeBuilderStream (return buffer) Streams.supply input output Streams.write (Just flush) output where sendChunk (Just s) = sendAll sock s sendChunk Nothing = return $! () #endif snap-server-1.1.2.1/src/Snap/Internal/Http/Server/TLS.hs0000644000000000000000000001416507346545000020746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ module Snap.Internal.Http.Server.TLS ( TLSException(..) , withTLS , bindHttps , httpsAcceptFunc , sendFileFunc ) where ------------------------------------------------------------------------------ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Typeable (Typeable) import Network.Socket (Socket) #ifdef OPENSSL import Control.Exception (Exception, bracketOnError, finally, onException, throwIO) import Control.Monad (when) import Data.ByteString.Builder (byteString) import qualified Network.Socket as Socket import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, not, ($), ($!)) import Snap.Internal.Http.Server.Address (getAddress) import Snap.Internal.Http.Server.Socket (acceptAndInitialize, bindSocket) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.SSL as SStreams #else import Control.Exception (Exception, throwIO) import Prelude (Bool, FilePath, IO, Int, Show, id, ($)) #endif ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Types (AcceptFunc (..), SendFileHandler) ------------------------------------------------------------------------------ data TLSException = TLSException S.ByteString deriving (Show, Typeable) instance Exception TLSException #ifndef OPENSSL type SSLContext = () type SSL = () ------------------------------------------------------------------------------ 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." ] ------------------------------------------------------------------------------ withTLS :: IO a -> IO a withTLS = id ------------------------------------------------------------------------------ barf :: IO a barf = throwIO sslNotSupportedException ------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO (Socket, SSLContext) bindHttps _ _ _ _ _ = barf ------------------------------------------------------------------------------ httpsAcceptFunc :: Socket -> SSLContext -> AcceptFunc httpsAcceptFunc _ _ = AcceptFunc $ \restore -> restore barf ------------------------------------------------------------------------------ sendFileFunc :: SSL -> Socket -> SendFileHandler sendFileFunc _ _ _ _ _ _ _ = barf #else ------------------------------------------------------------------------------ withTLS :: IO a -> IO a withTLS = withOpenSSL ------------------------------------------------------------------------------ bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO (Socket, SSLContext) bindHttps bindAddress bindPort cert chainCert key = withTLS $ bracketOnError (bindSocket bindAddress bindPort) Socket.close $ \sock -> do ctx <- SSL.context SSL.contextSetPrivateKeyFile ctx key if chainCert then SSL.contextSetCertificateChainFile ctx cert else SSL.contextSetCertificateFile ctx cert certOK <- SSL.contextCheckPrivateKey ctx when (not certOK) $ do throwIO $ TLSException certificateError return (sock, ctx) where certificateError = "OpenSSL says that the certificate doesn't match the private key!" ------------------------------------------------------------------------------ httpsAcceptFunc :: Socket -> SSLContext -> AcceptFunc httpsAcceptFunc boundSocket ctx = AcceptFunc $ \restore -> acceptAndInitialize boundSocket restore $ \(sock, remoteAddr) -> do localAddr <- Socket.getSocketName sock (localPort, localHost) <- getAddress localAddr (remotePort, remoteHost) <- getAddress remoteAddr ssl <- restore (SSL.connection ctx sock) restore (SSL.accept ssl) `onException` Socket.close sock (readEnd, writeEnd) <- SStreams.sslToStreams ssl let cleanup = (do Streams.write Nothing writeEnd SSL.shutdown ssl $! SSL.Unidirectional) `finally` Socket.close sock return $! ( sendFileFunc ssl , localHost , localPort , remoteHost , remotePort , readEnd , writeEnd , cleanup ) ------------------------------------------------------------------------------ sendFileFunc :: SSL -> SendFileHandler sendFileFunc ssl buffer builder fPath offset nbytes = do Streams.unsafeWithFileAsInputStartingAt (fromIntegral offset) fPath $ \fileInput0 -> do fileInput <- Streams.takeBytes (fromIntegral nbytes) fileInput0 >>= Streams.map byteString input <- Streams.fromList [builder] >>= flip Streams.appendInputStream fileInput output <- Streams.makeOutputStream sendChunk >>= Streams.unsafeBuilderStream (return buffer) Streams.supply input output Streams.write Nothing output where sendChunk (Just s) = SSL.write ssl s sendChunk Nothing = return $! () #endif snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Thread.hs0000644000000000000000000000721007346545000021504 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module Snap.Internal.Http.Server.Thread ( SnapThread , fork , forkOn , cancel , wait , cancelAndWait , isFinished ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, readMVar) #if MIN_VERSION_base(4,7,0) import Control.Concurrent (tryReadMVar) #else import Control.Concurrent (tryTakeMVar) import Control.Monad (when) import Data.Maybe (fromJust, isJust) #endif import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs, forkOnLabeledWithUnmaskBs) import qualified Control.Exception as E import Control.Monad (void) import qualified Data.ByteString.Char8 as B import GHC.Exts (inline) #if !MIN_VERSION_base(4,7,0) tryReadMVar :: MVar a -> IO (Maybe a) tryReadMVar mv = do m <- tryTakeMVar mv when (isJust m) $ putMVar mv (fromJust m) return m #endif ------------------------------------------------------------------------------ data SnapThread = SnapThread { _snapThreadId :: {-# UNPACK #-} !ThreadId , _snapThreadFinished :: {-# UNPACK #-} !(MVar ()) } instance Show SnapThread where show = show . _snapThreadId ------------------------------------------------------------------------------ forkOn :: B.ByteString -- ^ thread label -> Int -- ^ capability -> ((forall a . IO a -> IO a) -> IO ()) -- ^ user thread action, taking -- a restore function -> IO SnapThread forkOn label cap action = do mv <- newEmptyMVar E.uninterruptibleMask_ $ do tid <- forkOnLabeledWithUnmaskBs label cap (wrapAction mv action) return $! SnapThread tid mv ------------------------------------------------------------------------------ fork :: B.ByteString -- ^ thread label -> ((forall a . IO a -> IO a) -> IO ()) -- ^ user thread action, taking -- a restore function -> IO SnapThread fork label action = do mv <- newEmptyMVar E.uninterruptibleMask_ $ do tid <- forkIOLabeledWithUnmaskBs label (wrapAction mv action) return $! SnapThread tid mv ------------------------------------------------------------------------------ cancel :: SnapThread -> IO () cancel = killThread . _snapThreadId ------------------------------------------------------------------------------ wait :: SnapThread -> IO () wait = void . readMVar . _snapThreadFinished ------------------------------------------------------------------------------ cancelAndWait :: SnapThread -> IO () cancelAndWait t = cancel t >> wait t ------------------------------------------------------------------------------ isFinished :: SnapThread -> IO Bool isFinished t = maybe False (const True) <$> tryReadMVar (_snapThreadFinished t) ------------------------------------------------------------------------------ -- Internal functions follow ------------------------------------------------------------------------------ wrapAction :: MVar () -> ((forall a . IO a -> IO a) -> IO ()) -> ((forall a . IO a -> IO a) -> IO ()) wrapAction mv action restore = (action restore >> inline exit) `E.catch` onEx where onEx :: E.SomeException -> IO () onEx !_ = inline exit exit = E.uninterruptibleMask_ (putMVar mv $! ()) snap-server-1.1.2.1/src/Snap/Internal/Http/Server/TimeoutManager.hs0000644000000000000000000002006107346545000023215 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.TimeoutManager ( TimeoutManager , TimeoutThread , initialize , stop , register , tickle , set , modify , cancel ) where ------------------------------------------------------------------------------ import Control.Exception (evaluate, finally) import qualified Control.Exception as E import Control.Monad (Monad (return, (>>=)), mapM_, void, when) import qualified Data.ByteString.Char8 as S import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Prelude (Bool, Double, IO, Int, Show (..), const, fromIntegral, max, null, otherwise, round, ($), ($!), (+), (++), (-), (.), (<=), (==)) ------------------------------------------------------------------------------ import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar, takeMVar, tryPutMVar) ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Clock (ClockTime) import qualified Snap.Internal.Http.Server.Clock as Clock import Snap.Internal.Http.Server.Common (atomicModifyIORef', eatException) import qualified Snap.Internal.Http.Server.Thread as T ------------------------------------------------------------------------------ type State = ClockTime canceled :: State canceled = 0 isCanceled :: State -> Bool isCanceled = (== 0) ------------------------------------------------------------------------------ data TimeoutThread = TimeoutThread { _thread :: !T.SnapThread , _state :: !(IORef State) , _hGetTime :: !(IO ClockTime) } instance Show TimeoutThread where show = show . _thread ------------------------------------------------------------------------------ -- | Given a 'State' value and the current time, apply the given modification -- function to the amount of time remaining. -- smap :: ClockTime -> (ClockTime -> ClockTime) -> State -> State smap now f deadline | isCanceled deadline = deadline | otherwise = t' where remaining = max 0 (deadline - now) newremaining = f remaining t' = now + newremaining ------------------------------------------------------------------------------ data TimeoutManager = TimeoutManager { _defaultTimeout :: !ClockTime , _pollInterval :: !ClockTime , _getTime :: !(IO ClockTime) , _threads :: !(IORef [TimeoutThread]) , _morePlease :: !(MVar ()) , _managerThread :: !(MVar T.SnapThread) } ------------------------------------------------------------------------------ -- | Create a new TimeoutManager. initialize :: Double -- ^ default timeout -> Double -- ^ poll interval -> IO ClockTime -- ^ function to get current time -> IO TimeoutManager initialize defaultTimeout interval getTime = E.uninterruptibleMask_ $ do conns <- newIORef [] mp <- newEmptyMVar mthr <- newEmptyMVar let tm = TimeoutManager (Clock.fromSecs defaultTimeout) (Clock.fromSecs interval) getTime conns mp mthr thr <- T.fork "snap-server: timeout manager" $ managerThread tm putMVar mthr thr return tm ------------------------------------------------------------------------------ -- | Stop a TimeoutManager. stop :: TimeoutManager -> IO () stop tm = readMVar (_managerThread tm) >>= T.cancelAndWait ------------------------------------------------------------------------------ wakeup :: TimeoutManager -> IO () wakeup tm = void $ tryPutMVar (_morePlease tm) $! () ------------------------------------------------------------------------------ -- | Register a new thread with the TimeoutManager. register :: TimeoutManager -- ^ manager to register -- with -> S.ByteString -- ^ thread label -> ((forall a . IO a -> IO a) -> IO ()) -- ^ thread action to run -> IO TimeoutThread register tm label action = do now <- getTime let !state = now + defaultTimeout stateRef <- newIORef state th <- E.uninterruptibleMask_ $ do t <- T.fork label action let h = TimeoutThread t stateRef getTime atomicModifyIORef' threads (\x -> (h:x, ())) >>= evaluate return $! h wakeup tm return th where getTime = _getTime tm threads = _threads 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 :: TimeoutThread -> Int -> IO () tickle th = modify th . max {-# INLINE tickle #-} ------------------------------------------------------------------------------ -- | Set the timeout on a connection to be N seconds into the future. set :: TimeoutThread -> Int -> IO () set th = modify th . const {-# INLINE set #-} ------------------------------------------------------------------------------ -- | Modify the timeout with the given function. modify :: TimeoutThread -> (Int -> Int) -> IO () modify th f = do now <- getTime state <- readIORef stateRef let !state' = smap now f' state writeIORef stateRef state' where f' !x = Clock.fromSecs $! fromIntegral $ f $ round $ Clock.toSecs x getTime = _hGetTime th stateRef = _state th {-# INLINE modify #-} ------------------------------------------------------------------------------ -- | Cancel a timeout. cancel :: TimeoutThread -> IO () cancel h = E.uninterruptibleMask_ $ do writeIORef (_state h) canceled T.cancel $ _thread h {-# INLINE cancel #-} ------------------------------------------------------------------------------ managerThread :: TimeoutManager -> (forall a. IO a -> IO a) -> IO () managerThread tm restore = restore loop `finally` cleanup where cleanup = E.uninterruptibleMask_ $ eatException (readIORef threads >>= destroyAll) -------------------------------------------------------------------------- getTime = _getTime tm morePlease = _morePlease tm pollInterval = _pollInterval tm threads = _threads tm -------------------------------------------------------------------------- loop = do now <- getTime E.uninterruptibleMask $ \restore' -> do handles <- atomicModifyIORef' threads (\x -> ([], x)) if null handles then do restore' $ takeMVar morePlease else do handles' <- processHandles now handles atomicModifyIORef' threads (\x -> (handles' ++ x, ())) >>= evaluate Clock.sleepFor pollInterval loop -------------------------------------------------------------------------- processHandles now handles = go handles [] where go [] !kept = return $! kept go (x:xs) !kept = do !state <- readIORef $ _state x !kept' <- if isCanceled state then do b <- T.isFinished (_thread x) return $! if b then kept else (x:kept) else do when (state <= now) $ do T.cancel (_thread x) writeIORef (_state x) canceled return (x:kept) go xs kept' -------------------------------------------------------------------------- destroyAll xs = do mapM_ (T.cancel . _thread) xs mapM_ (T.wait . _thread) xs snap-server-1.1.2.1/src/Snap/Internal/Http/Server/Types.hs0000644000000000000000000001744007346545000021407 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ -- | Types internal to the implementation of the Snap HTTP server. module Snap.Internal.Http.Server.Types ( ServerConfig(..) , PerSessionData(..) , DataFinishedHook , EscapeSnapHook , ExceptionHook , ParseHook , NewRequestHook , UserHandlerFinishedHook -- * Handlers , SendFileHandler , ServerHandler , AcceptFunc(..) -- * Socket types , SocketConfig(..) ) where ------------------------------------------------------------------------------ import Control.Exception (SomeException) import Data.ByteString (ByteString) import Data.IORef (IORef) import Data.Word (Word64) import Network.Socket (Socket) ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder) import Data.ByteString.Builder.Internal (Buffer) import System.IO.Streams (InputStream, OutputStream) ------------------------------------------------------------------------------ import Snap.Core (Request, Response) ------------------------------------------------------------------------------ -- | The 'NewRequestHook' is called once processing for an HTTP request begins, -- i.e. after the connection has been accepted and we know that there's data -- available to read from the socket. The IORef passed to the hook initially -- contains a bottom value that will throw an exception if evaluated. type NewRequestHook hookState = PerSessionData -> IO hookState -- | The 'ParseHook' is called after the HTTP Request has been parsed by the -- server, but before the user handler starts running. type ParseHook hookState = IORef hookState -> Request -> IO () -- | The 'UserHandlerFinishedHook' is called once the user handler has finished -- running, but before the data for the HTTP response starts being sent to the -- client. type UserHandlerFinishedHook hookState = IORef hookState -> Request -> Response -> IO () -- | The 'DataFinishedHook' is called once the server has finished sending the -- HTTP response to the client. type DataFinishedHook hookState = IORef hookState -> Request -> Response -> IO () -- | The 'ExceptionHook' is called if an exception reaches the toplevel of the -- server, i.e. if an exception leaks out of the user handler or if an -- exception is raised during the sending of the HTTP response data. type ExceptionHook hookState = IORef hookState -> SomeException -> IO () -- | The 'EscapeSnapHook' is called if the user handler escapes the HTTP -- session, e.g. for websockets. type EscapeSnapHook hookState = IORef hookState -> IO () --------------------- -- data structures -- --------------------- ------------------------------------------------------------------------------ -- | Data and services that all HTTP response handlers share. -- data ServerConfig hookState = ServerConfig { _logAccess :: !(Request -> Response -> Word64 -> IO ()) , _logError :: !(Builder -> IO ()) , _onNewRequest :: !(NewRequestHook hookState) , _onParse :: !(ParseHook hookState) , _onUserHandlerFinished :: !(UserHandlerFinishedHook hookState) , _onDataFinished :: !(DataFinishedHook hookState) , _onException :: !(ExceptionHook hookState) , _onEscape :: !(EscapeSnapHook hookState) -- | will be overridden by a @Host@ header if it appears. , _localHostname :: !ByteString , _defaultTimeout :: {-# UNPACK #-} !Int , _isSecure :: !Bool -- | Number of accept loops to spawn. , _numAcceptLoops :: {-# UNPACK #-} !Int } ------------------------------------------------------------------------------ -- | All of the things a session needs to service a single HTTP request. data PerSessionData = PerSessionData { -- | If the bool stored in this IORef becomes true, the server will close -- the connection after the current request is processed. _forceConnectionClose :: {-# UNPACK #-} !(IORef Bool) -- | An IO action to modify the current request timeout. , _twiddleTimeout :: !((Int -> Int) -> IO ()) -- | The value stored in this IORef is True if this request is the first -- on a new connection, and False if it is a subsequent keep-alive -- request. , _isNewConnection :: !(IORef Bool) -- | The function called when we want to use @sendfile().@ , _sendfileHandler :: !SendFileHandler -- | The server's idea of its local address. , _localAddress :: !ByteString -- | The listening port number. , _localPort :: {-# UNPACK #-} !Int -- | The address of the remote user. , _remoteAddress :: !ByteString -- | The remote user's port. , _remotePort :: {-# UNPACK #-} !Int -- | The read end of the socket connection. , _readEnd :: !(InputStream ByteString) -- | The write end of the socket connection. , _writeEnd :: !(OutputStream ByteString) } ------------------------------------------------------------------------------ newtype AcceptFunc = AcceptFunc { runAcceptFunc :: (forall a . IO a -> IO a) -- exception restore function -> IO ( SendFileHandler -- what to do on sendfile , ByteString -- local address , Int -- local port , ByteString -- remote address , Int -- remote port , InputStream ByteString -- socket read end , OutputStream ByteString -- socket write end , IO () -- cleanup action ) } -------------------- -- function types -- -------------------- ------------------------------------------------------------------------------ -- | This function, provided to the web server internals from the outside, is -- responsible for producing a 'Response' once the server has parsed the -- 'Request'. -- type ServerHandler hookState = ServerConfig hookState -- ^ global server config -> PerSessionData -- ^ per-connection data -> Request -- ^ HTTP request object -> IO (Request, Response) ------------------------------------------------------------------------------ -- | A 'SendFileHandler' is called if the user handler requests that a file be -- sent using @sendfile()@ on systems that support it (Linux, Mac OSX, and -- FreeBSD). type SendFileHandler = Buffer -- ^ builder buffer -> Builder -- ^ status line and headers -> FilePath -- ^ file to send -> Word64 -- ^ start offset -> Word64 -- ^ number of bytes -> IO () ------------------------------- -- types for server backends -- ------------------------------- ------------------------------------------------------------------------------ -- | Either the server should start listening on the given interface \/ port -- combination, or the server should start up with a 'Socket' that has already -- had @bind()@ and @listen()@ called on it. data SocketConfig = StartListening ByteString Int | PreBound Socket snap-server-1.1.2.1/src/System/0000755000000000000000000000000007346545000014363 5ustar0000000000000000snap-server-1.1.2.1/src/System/FastLogger.hs0000644000000000000000000002612607346545000016763 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger ( Logger , timestampedLogEntry , combinedLogEntry , newLogger , newLoggerWithCustomErrorFunction , withLogger , withLoggerWithCustomErrorFunction , stopLogger , logMsg ) where ------------------------------------------------------------------------------ import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar, withMVar) import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception (AsyncException, Handler (..), IOException, SomeException, bracket, catch, catches, mask_) import Control.Monad (unless, void, when) import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString, toLazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Monoid (mappend, mconcat, mempty) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Word (Word64) import Prelude (Eq (..), FilePath, IO, Int, Maybe, Monad (..), Num (..), Ord (..), Show (..), mapM_, maybe, ($), ($!), (++), (.), (||)) import System.IO (IOMode (AppendMode), hClose, hFlush, openFile, stderr, stdout) import System.PosixCompat.Time (epochTime) ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Common (atomicModifyIORef') import Snap.Internal.Http.Server.Date (getLogDateString) ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | Creates a Logger and passes it into the given function, cleaning up -- with \"stopLogger\" afterwards. withLogger :: FilePath -- ^ log file to use -> (Logger -> IO a) -> IO a withLogger f = bracket (newLogger f) stopLogger ------------------------------------------------------------------------------ -- | Creates a Logger with \"newLoggerWithCustomErrorFunction\" and passes it -- into the given function, cleaning up with \"stopLogger\" afterwards. withLoggerWithCustomErrorFunction :: (ByteString -> IO ()) -- ^ logger uses this action to log any -- error messages of its own -> FilePath -- ^ log file to use -> (Logger -> IO a) -> IO a withLoggerWithCustomErrorFunction e f = bracket (newLoggerWithCustomErrorFunction e f) stopLogger ------------------------------------------------------------------------------ -- FIXME: can be a builder, and we could even use the same trick we use for -- HTTP -- -- | Prepares a log message with the time prepended. timestampedLogEntry :: ByteString -> IO ByteString timestampedLogEntry msg = do timeStr <- getLogDateString return $! S.concat $ L.toChunks $ toLazyByteString $ mconcat [ char8 '[' , byteString timeStr , byteString "] " , byteString msg ] ------------------------------------------------------------------------------ -- FIXME: builder -- -- | 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 -> Word64 -- ^ 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 !numBytes !mbReferer !ua = do timeStr <- getLogDateString let !l = [ byteString host , byteString " - " , user , byteString " [" , byteString timeStr , byteString "] \"" , byteString req , byteString "\" " , fromShow status , space , fromShow numBytes , space , referer , byteString " \"" , byteString ua , quote ] return $! S.concat . L.toChunks $ toLazyByteString $ mconcat l where dash = char8 '-' quote = char8 '\"' space = char8 ' ' user = maybe dash byteString mbUser referer = maybe dash (\s -> mconcat [ quote , byteString 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' = byteString s `mappend` char8 '\n' atomicModifyIORef' (_queuedMessages lg) $ \d -> (d `mappend` s',()) void $ tryPutMVar (_dataWaiting lg) () ------------------------------------------------------------------------------ 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 loop `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do logInternalError $ "logger got exception: " ++ Prelude.show e ++ "\n" threadDelay 20000000 go (href, lastOpened) ] where loop = waitFlushDelay (href, lastOpened) >> loop -------------------------------------------------------------------------- initialize = do lh <- openIt href <- newIORef lh t <- epochTime 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 <- epochTime 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 ------------------------------------------------------------------------------ fromShow :: Show a => a -> Builder fromShow = stringUtf8 . show snap-server-1.1.2.1/src/System/SendFile.hsc0000644000000000000000000000740407346545000016560 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | Snap's unified interface to sendfile. -- Modified from sendfile 0.6.1 module System.SendFile ( sendFile , sendFileMode , sendHeaders , sendHeadersImpl ) where #include ------------------------------------------------------------------------------ import Control.Concurrent (threadWaitWrite) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Unsafe as S import Data.Word (Word64) import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CChar (..), CInt (..), CSize (..)) #else import Foreign.C.Types (CChar, CInt, CSize) #endif import Foreign.Ptr (Ptr, plusPtr) #if __GLASGOW_HASKELL__ >= 703 import System.Posix.Types (Fd (..)) #else import System.Posix.Types (COff, CSsize, Fd) #endif ------------------------------------------------------------------------------ import Data.ByteString.Builder (Builder, toLazyByteString) ------------------------------------------------------------------------------ #if defined(LINUX) import qualified System.SendFile.Linux as SF #elif defined(FREEBSD) import qualified System.SendFile.FreeBSD as SF #elif defined(OSX) import qualified System.SendFile.Darwin as SF #endif ------------------------------------------------------------------------------ sendFile :: Fd -- ^ out fd (i.e. the socket) -> Fd -- ^ in fd (i.e. the file) -> Word64 -- ^ offset in bytes -> Word64 -- ^ count in bytes -> IO () sendFile out_fd in_fd = go where go offs count | offs `seq` count <= 0 = return $! () | otherwise = do nsent <- fromIntegral `fmap` SF.sendFile out_fd in_fd offs count go (offs + nsent) (count - nsent) ------------------------------------------------------------------------------ sendFileMode :: String sendFileMode = SF.sendFileMode ------------------------------------------------------------------------------ {-# INLINE sendHeaders #-} sendHeaders :: Builder -> Fd -> IO () sendHeaders = sendHeadersImpl c_send threadWaitWrite ------------------------------------------------------------------------------ {-# INLINE sendHeadersImpl #-} sendHeadersImpl :: (Fd -> Ptr CChar -> CSize -> CInt -> IO CSize) -> (Fd -> IO ()) -> Builder -> Fd -> IO () sendHeadersImpl sendFunc waitFunc headers fd = sendFunc `seq` waitFunc `seq` S.unsafeUseAsCStringLen (S.concat $ L.toChunks $ toLazyByteString headers) $ \(cstr, clen) -> go cstr (fromIntegral clen) where #if defined(LINUX) flags = (#const MSG_MORE) #else flags = 0 #endif go cstr clen | cstr `seq` clen <= 0 = return $! () | otherwise = do nsent <- throwErrnoIfMinus1RetryMayBlock "sendHeaders" (sendFunc fd cstr clen flags) (waitFunc fd) let cstr' = plusPtr cstr (fromIntegral nsent) go cstr' (clen - nsent) ------------------------------------------------------------------------------ foreign import ccall unsafe "sys/socket.h send" c_send :: Fd -> Ptr CChar -> CSize -> CInt -> IO CSize snap-server-1.1.2.1/src/System/SendFile/0000755000000000000000000000000007346545000016054 5ustar0000000000000000snap-server-1.1.2.1/src/System/SendFile/FreeBSD.hsc0000644000000000000000000000553207346545000017772 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | FreeBSD system-dependent code for 'sendfile'. module System.SendFile.FreeBSD ( sendFile , sendFileImpl , sendFileMode ) where ------------------------------------------------------------------------------ import Control.Concurrent (threadWaitWrite) import Data.Int import Data.Word import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock_) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt (..), CSize (..)) #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 :: Fd -> Fd -> Word64 -> Word64 -> IO Int64 sendFile = sendFileImpl c_sendfile_freebsd threadWaitWrite {-# INLINE sendFile #-} ------------------------------------------------------------------------------ sendFileImpl :: (Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt) -> (Fd -> IO ()) -> Fd -> Fd -> Word64 -> Word64 -> IO Int64 sendFileImpl !rawSendFile !wait out_fd in_fd off count | count == 0 = return 0 | otherwise = alloca $ \pbytes -> do sbytes <- sendfile rawSendFile wait out_fd in_fd (fromIntegral off) (fromIntegral count) pbytes return $ fromIntegral sbytes ------------------------------------------------------------------------------ sendfile :: (Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt) -> (Fd -> IO ()) -> Fd -> Fd -> COff -> CSize -> Ptr COff -> IO COff sendfile rawSendFile wait out_fd in_fd off count pbytes = do throwErrnoIfMinus1RetryMayBlock_ "sendfile" (rawSendFile in_fd out_fd off count nullPtr pbytes 0) (wait out_fd) peek pbytes ------------------------------------------------------------------------------ -- 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 ------------------------------------------------------------------------------ sendFileMode :: String sendFileMode = "FREEBSD_SENDFILE" snap-server-1.1.2.1/src/System/SendFile/Linux.hsc0000644000000000000000000000534307346545000017657 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ -- | Linux system-dependent code for 'sendfile'. module System.SendFile.Linux ( sendFile , sendFileImpl , sendFileMode ) where ------------------------------------------------------------------------------ import Control.Concurrent (threadWaitWrite) import Data.Int (Int64) import Data.Word (Word64) import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt (..), CSize (..)) #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 (COff (..), CSsize (..), Fd (..)) #else import System.Posix.Types (COff, CSsize, Fd) #endif ------------------------------------------------------------------------------ sendFile :: Fd -> Fd -> Word64 -> Word64 -> IO Int64 sendFile = sendFileImpl c_sendfile threadWaitWrite {-# INLINE sendFile #-} ------------------------------------------------------------------------------ sendFileImpl :: (Fd -> Fd -> Ptr COff -> CSize -> IO CSsize) -> (Fd -> IO ()) -> Fd -> Fd -> Word64 -> Word64 -> IO Int64 sendFileImpl !raw_sendfile !wait out_fd in_fd off count | count <= 0 = return 0 | off == 0 = do nsent <- sendfile raw_sendfile wait out_fd in_fd nullPtr bytes return $! fromIntegral nsent | otherwise = alloca $ \poff -> do poke poff (fromIntegral off) nsent <- sendfile raw_sendfile wait out_fd in_fd poff bytes return $! fromIntegral nsent where bytes = fromIntegral count {-# INLINE sendFileImpl #-} ------------------------------------------------------------------------------ sendfile :: (Fd -> Fd -> Ptr COff -> CSize -> IO CSsize) -> (Fd -> IO ()) -> Fd -> Fd -> Ptr COff -> CSize -> IO CSsize sendfile raw_sendfile wait out_fd in_fd poff bytes = throwErrnoIfMinus1RetryMayBlock "sendfile" (raw_sendfile out_fd in_fd poff bytes) (wait out_fd) {-# INLINE sendfile #-} ------------------------------------------------------------------------------ -- sendfile64 gives LFS support foreign import ccall unsafe "sys/sendfile.h sendfile64" c_sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize ------------------------------------------------------------------------------ sendFileMode :: String sendFileMode = "LINUX_SENDFILE" snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Address/0000755000000000000000000000000007346545000021516 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Address/Tests.hs0000644000000000000000000000567007346545000023164 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Address.Tests (tests) where ------------------------------------------------------------------------------ import Network.Socket (Family (AF_INET, AF_INET6), SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix)) ------------------------------------------------------------------------------ import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertEqual) ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Address (AddressNotSupportedException (..), getAddress, getAddressImpl, getHostAddrImpl, getSockAddr, getSockAddrImpl) import Snap.Test.Common (coverShowInstance, coverTypeableInstance, expectException) ------------------------------------------------------------------------------ tests :: [Test] tests = [ testGetNameInfoFails , testGetAddressUnix , testGetAddressIPv6 , testGetSockAddr , testTrivials ] ------------------------------------------------------------------------------ testGetNameInfoFails :: Test testGetNameInfoFails = testCase "address/getNameInfo-fails" $ do x <- getHostAddrImpl (\_ _ _ _ -> return (Nothing, Nothing)) undefined assertEqual "when getNameInfo fails, getHostAddr should return empty" "" x ------------------------------------------------------------------------------ testGetAddressUnix :: Test testGetAddressUnix = testCase "address/getAddress-unix-socket" $ do (port, addr) <- getAddress $ SockAddrUnix "/foo/bar" assertEqual "unix port" (-1) port assertEqual "unix address" "unix:/foo/bar" addr ------------------------------------------------------------------------------ testGetAddressIPv6 :: Test testGetAddressIPv6 = testCase "address/getAddress-IPv6" $ do let x = SockAddrInet6 10 0 (0,0,0,0) 0 (y, _) <- getAddressImpl (const $ return "") x assertEqual "ipv6 port" 10 y ------------------------------------------------------------------------------ testGetSockAddr :: Test testGetSockAddr = testCase "address/getSockAddr" $ do (f1, a1) <- getSockAddr 10 "*" assertEqual "" f1 AF_INET assertEqual "" a1 $ SockAddrInet 10 iNADDR_ANY (f2, a2) <- getSockAddr 10 "::" assertEqual "" f2 AF_INET6 assertEqual "" a2 $ SockAddrInet6 10 0 iN6ADDR_ANY 0 expectException $ getSockAddrImpl (\_ _ _ -> return []) 10 "foo" where iNADDR_ANY = 0 iN6ADDR_ANY = (0,0,0,0) ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "address/trivials" $ do coverTypeableInstance (undefined :: AddressNotSupportedException) coverShowInstance (AddressNotSupportedException "ok") snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Parser/0000755000000000000000000000000007346545000021365 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Parser/Tests.hs0000644000000000000000000002327007346545000023027 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Parser.Tests (tests) where ------------------------------------------------------------------------------ import Control.Monad (liftM) import Control.Parallel.Strategies (rdeepseq, using) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List (sort) import qualified Data.Map as Map import Data.Monoid (mconcat) import Text.Printf (printf) ------------------------------------------------------------------------------ import Data.ByteString.Builder (byteString, toLazyByteString) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (assertEqual) import Test.QuickCheck (Arbitrary (arbitrary)) import Test.QuickCheck.Monadic (forAllM, monadicIO) import qualified Test.QuickCheck.Monadic as QC ------------------------------------------------------------------------------ import Snap.Internal.Debug (debug) import Snap.Internal.Http.Server.Parser (HttpParseException (..), IRequest (IRequest, iMethod, iRequestHeaders, iStdHeaders), getStdHost, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding) import Snap.Internal.Http.Types (Cookie (Cookie), Method (CONNECT, DELETE, GET, HEAD, Method, OPTIONS, PATCH, POST, PUT, TRACE)) import Snap.Test.Common (coverEqInstance, coverShowInstance, coverTypeableInstance, expectException) import qualified Snap.Types.Headers as H import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ tests :: [Test] tests = [ testShow , testCookie , testChunked , testNull , testPartial , testParseError , testFormEncoded , testTrivials , testMethods , testSimpleParse , testSimpleParseErrors , testWriteChunkedTransferEncoding ] ------------------------------------------------------------------------------ testShow :: Test testShow = testCase "parser/show" $ do let i = IRequest GET "/" (1, 1) H.empty undefined let !b = show i `using` rdeepseq return $ b `seq` () ------------------------------------------------------------------------------ testNull :: Test testNull = testCase "parser/shortParse" $ expectException (Streams.fromList [] >>= parseRequest) ------------------------------------------------------------------------------ testPartial :: Test testPartial = testCase "parser/partial" $ expectException (Streams.fromList ["GET / "] >>= parseRequest) ------------------------------------------------------------------------------ testParseError :: Test testParseError = testCase "parser/error" $ do expectException (Streams.fromList ["ZZZZZZZZZ"] >>= parseRequest) expectException (Streams.fromList ["GET / HTTP/1.1"] >>= parseRequest) expectException (Streams.fromList ["GET / HTTP/x.z\r\n\r\n"] >>= parseRequest) ------------------------------------------------------------------------------ -- | 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 $ printf "%x" $ S.length s f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"]) ------------------------------------------------------------------------------ -- | ensure that running 'readChunkedTransferEncoding' against -- 'transferEncodingChunked' returns the original string testChunked :: Test testChunked = testProperty "parser/chunkedTransferEncoding" $ monadicIO $ forAllM arbitrary prop_chunked where prop_chunked s = QC.run $ do debug "==============================" debug $ "input is " ++ show s debug $ "chunked is " ++ show chunked debug "------------------------------" out <- Streams.fromList (L.toChunks chunked) >>= readChunkedTransferEncoding >>= Streams.toList >>= return . L.fromChunks assertEqual "chunked" s out debug "==============================\n" where chunked = transferEncodingChunked s ------------------------------------------------------------------------------ testWriteChunkedTransferEncoding :: Test testWriteChunkedTransferEncoding = testCase "parser/writeChunked" $ do (os, getList) <- Streams.listOutputStream os' <- writeChunkedTransferEncoding os Streams.fromList [byteString "ok"] >>= Streams.connectTo os' Streams.write Nothing os' s <- liftM (toLazyByteString . mconcat) getList assertEqual "chunked" "002\r\nok\r\n0\r\n\r\n" s ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "parser/trivials" $ do coverTypeableInstance (undefined :: HttpParseException) coverShowInstance (HttpParseException "ok") coverEqInstance (IRequest GET "" (0, 0) H.empty undefined) ------------------------------------------------------------------------------ testMethods :: Test testMethods = testCase "parser/methods" $ mapM_ testOne ms where ms = [ GET, POST, HEAD, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH , Method "ZZZ" ] mToStr (Method m) = m mToStr m = S.pack $ show m restOfRequest = [ " / HTTP/1.1\r\nz:b\r\nq:\r\nw\r\n", "foo: ", "bar" , "\r\n baz\r\n\r\n" ] testOne m = let s = mToStr m in Streams.fromList (s:restOfRequest) >>= parseRequest >>= checkMethod m checkMethod m i = do assertEqual "method" m $ iMethod i let expected = sort [ ("z", "b") , ("q", "") , ("w", "") , ("foo", "bar baz") ] assertEqual "hdrs" expected $ sort $ H.toList $ iRequestHeaders i ------------------------------------------------------------------------------ testSimpleParse :: Test testSimpleParse = testCase "parser/simpleParse" $ do Streams.fromList ["GET / HTTP/1.1\r\n\r\n"] >>= parseRequest >>= assertEqual "simple0" (IRequest GET "/" (1, 1) H.empty undefined) Streams.fromList ["GET http://foo.com/ HTTP/1.1\r\n\r\n"] >>= parseRequest >>= assertEqual "simple1" (IRequest GET "/" (1, 1) H.empty undefined) z <- Streams.fromList ["GET http://foo.com HTTP/1.1\r\n\r\n"] >>= parseRequest assertEqual "simple2" z (IRequest GET "/" (1, 1) H.empty undefined) assertEqual "simple2-host" (Just "foo.com") (getStdHost $ iStdHeaders z) z2 <- Streams.fromList ["GET https://foo.com/ HTTP/1.1\r\n\r\n"] >>= parseRequest assertEqual "simpleHttps" (IRequest GET "/" (1, 1) H.empty undefined) z2 assertEqual "simpleHttps-2" (Just "foo.com") (getStdHost $ iStdHeaders z2) Streams.fromList ["GET / HTTP/1.1\r\nz:b\r\n", "", "\r\n"] >>= parseRequest >>= assertEqual "simple4" (IRequest GET "/" (1, 1) (H.fromList [("z", "b")]) undefined) Streams.fromList [ "GET / HTTP/1.1\r\na:a\r", "\nz:b\r\n", "" , "\r\n" ] >>= parseRequest >>= assertEqual "simple5" (IRequest GET "/" (1, 1) (H.fromList [("a", "a"), ("z", "b")]) undefined) Streams.fromList ["GET /\r\n\r\n"] >>= parseRequest >>= assertEqual "simple6" (IRequest GET "/" (1, 0) H.empty undefined) Streams.fromList ["G", "ET", " /\r", "\n\r", "", "\n"] >>= parseRequest >>= assertEqual "simple7" (IRequest GET "/" (1, 0) H.empty undefined) ------------------------------------------------------------------------------ testSimpleParseErrors :: Test testSimpleParseErrors = testCase "parser/simpleParseErrors" $ do expectException ( Streams.fromList ["\r\nGET / HTTP/1.1\r\nz:b\r\n \r\n"] >>= parseRequest) expectException ( Streams.fromList ["\r\nGET / HTTP/1.1\r\nz:b\r "] >>= parseRequest) expectException ( Streams.fromList ["\r\nGET / HTTP/1.1\r"] >>= parseRequest) expectException ( Streams.fromList ["\r\nGET / HTTP/1.1\r", "", "foo\nz:b\r "] >>= parseRequest) snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Session/0000755000000000000000000000000007346545000021554 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Session/Tests.hs0000644000000000000000000011676007346545000023225 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Session.Tests (tests) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Control.Concurrent (MVar, forkIO, killThread, modifyMVar_, myThreadId, newChan, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, threadDelay, throwTo, withMVar) import Control.Exception.Lifted (AsyncException (ThreadKilled), Exception, SomeException (..), bracket, catch, evaluate, mask, throwIO, try) import Control.Monad (forM_, liftM, replicateM_, void, when, (>=>)) import Control.Monad.State.Class (modify) import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.Internal (newBuffer) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.CaseInsensitive as CI import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import Data.Maybe (isNothing) import Data.Monoid (mappend) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Typeable (Typeable) import Data.Word (Word64) import qualified Network.Http.Client as Http import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Concurrent as Streams import qualified System.IO.Streams.Debug as Streams import System.Timeout (timeout) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import qualified Test.Framework.Runners.Console as Console import Test.HUnit (assertBool, assertEqual) ------------------------------------------------------------------------------ import Snap.Core (Cookie (Cookie, cookieName, cookieValue), Request (rqContentLength, rqCookies, rqHostName, rqLocalHostname, rqPathInfo, rqQueryString, rqURI), Snap, addResponseCookie, escapeHttp, getHeader, getRequest, getsRequest, modifyResponse, readRequestBody, rqParam, rqPostParam, rqQueryParam, sendFile, sendFilePartial, setContentLength, setHeader, setResponseBody, setResponseStatus, terminateConnection, writeBS, writeBuilder, writeLBS) import Snap.Http.Server.Types (emptyServerConfig, getDefaultTimeout, getIsSecure, getLocalAddress, getLocalHostname, getLocalPort, getLogAccess, getLogError, getNumAcceptLoops, getOnDataFinished, getOnEscape, getOnException, getOnNewRequest, getOnParse, getOnUserHandlerFinished, getRemoteAddress, getRemotePort, getTwiddleTimeout, isNewConnection, setDefaultTimeout, setIsSecure, setLocalHostname, setLogAccess, setLogError, setNumAcceptLoops, setOnDataFinished, setOnEscape, setOnException, setOnNewRequest, setOnParse, setOnUserHandlerFinished) import Snap.Internal.Http.Server.Date (getLogDateString) import Snap.Internal.Http.Server.Session (BadRequestException (..), LengthRequiredException (..), TerminateSessionException (..), httpAcceptLoop, httpSession, snapToServerHandler) import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Http.Server.Types (AcceptFunc (AcceptFunc), PerSessionData (PerSessionData, _isNewConnection), SendFileHandler, ServerConfig (_logError)) import Snap.Test (RequestBuilder) import qualified Snap.Test as T import Snap.Test.Common (coverShowInstance, coverTypeableInstance, expectException) #ifdef OPENSSL import qualified Network.Socket as N #endif ------------------------------------------------------------------------------ tests :: [Test] tests = [ testPong , testPong1_0 , testDateHeaderDeleted , testServerHeader , testBadParses , testEof , testHttp100 , testNoHost , testNoHost1_0 , testChunkedRequest , testQueryParams , testPostParams , testPostParamsReplacementBody , testCookie , testSetCookie , testUserException , testUserBodyException , testEscape , testPostWithoutLength , testWeirdMissingSlash , testOnlyQueryString , testConnectionClose , testUserTerminate , testSendFile , testBasicAcceptLoop , testTrivials #ifdef OPENSSL , testTLSKeyMismatch #else , testCoverTLSStubs #endif ] ------------------------------------------------------------------------------ #ifdef OPENSSL testTLSKeyMismatch :: Test testTLSKeyMismatch = testCase "session/tls-key-mismatch" $ do expectException $ bracket (TLS.bindHttps "127.0.0.1" (fromIntegral N.aNY_PORT) "test/cert.pem" False "test/bad_key.pem") (N.close . fst) (const $ return ()) expectException $ bracket (TLS.bindHttps "127.0.0.1" (fromIntegral N.aNY_PORT) "test/cert.pem" True "test/bad_key.pem") (N.close . fst) (const $ return ()) #else testCoverTLSStubs :: Test testCoverTLSStubs = testCase "session/tls-stubs" $ do expectException $ TLS.bindHttps "127.0.0.1" 9999 "test/cert.pem" False "test/key.pem" expectException $ TLS.bindHttps "127.0.0.1" 9999 "test/cert.pem" True "test/key.pem" let (AcceptFunc afunc) = TLS.httpsAcceptFunc undefined undefined expectException $ mask $ \restore -> afunc restore let u = undefined expectException $ TLS.sendFileFunc u u u u u u u #endif ------------------------------------------------------------------------------ testPong :: Test testPong = testCase "session/pong" $ do do [(resp, body)] <- runRequestPipeline [return ()] snap1 assertEqual "code1" 200 $ Http.getStatusCode resp assertEqual "body1" pong body assertEqual "chunked1" Nothing $ Http.getHeader resp "Transfer-Encoding" do [(resp, body)] <- runRequestPipeline [return ()] snap2 assertEqual "code2" 200 $ Http.getStatusCode resp assertEqual "body2" pong body assertEqual "chunked2" (Just $ CI.mk "chunked") $ fmap CI.mk $ Http.getHeader resp "Transfer-Encoding" -- test pipelining do [_, (resp, body)] <- runRequestPipeline [return (), return ()] snap3 assertEqual "code3" 233 $ Http.getStatusCode resp assertEqual "reason3" "ZOMG" $ Http.getStatusMessage resp assertEqual "body3" pong body assertEqual "chunked3" Nothing $ Http.getHeader resp "Transfer-Encoding" do [_, (resp, body)] <- runRequestPipeline [http_1_0, http_1_0] snap3 assertEqual "code4" 233 $ Http.getStatusCode resp assertEqual "reason4" "ZOMG" $ Http.getStatusMessage resp assertEqual "body4" pong body assertEqual "chunked4" Nothing $ Http.getHeader resp "Transfer-Encoding" where http_1_0 = do T.setHttpVersion (1, 0) T.setHeader "Connection" "keep-alive" pong = "PONG" snap1 = writeBS pong >> modifyResponse (setContentLength 4) snap2 = do cookies <- getsRequest rqCookies if null cookies then writeBS pong else writeBS "wat" snap3 = do modifyResponse (setResponseStatus 233 "ZOMG" . setContentLength 4) writeBS pong ------------------------------------------------------------------------------ testPong1_0 :: Test testPong1_0 = testCase "session/pong1_0" $ do req <- makeRequest (T.setHttpVersion (1, 0) >> T.setHeader "Connection" "zzz") out <- getSessionOutput [req] $ writeBS "PONG" assertBool "200 ok" $ S.isPrefixOf "HTTP/1.0 200 OK\r\n" out assertBool "PONG" $ S.isSuffixOf "\r\n\r\nPONG" out ------------------------------------------------------------------------------ testDateHeaderDeleted :: Test testDateHeaderDeleted = testCase "session/dateHeaderDeleted" $ do [(resp, _)] <- runRequestPipeline [mkRq] snap assertBool "date header" $ Just "plop" /= Http.getHeader resp "Date" [_, (resp2, _)] <- runRequestPipeline [mkRq2, mkRq2] snap assertBool "date header 2" $ Just "plop" /= Http.getHeader resp2 "Date" where snap = do modifyResponse (setHeader "Date" "plop" . setHeader "Connection" "ok" . setContentLength 4) writeBS "PONG" mkRq = do T.setHttpVersion (1,0) T.setHeader "fnargle" "plop" T.setHeader "Content-Length" "0" T.setHeader "Connection" "keep-alive" mkRq2 = do T.setHeader "fnargle" "plop" T.setHeader "Content-Length" "0" T.setHeader "Connection" "keep-alive" ------------------------------------------------------------------------------ testServerHeader :: Test testServerHeader = testCase "session/serverHeader" $ do [(resp, _)] <- runRequestPipeline [return ()] snap assertEqual "server" (Just "blah") $ Http.getHeader resp "Server" where snap = modifyResponse $ setHeader "Server" "blah" ------------------------------------------------------------------------------ testBadParses :: Test testBadParses = testGroup "session/badParses" [ check 1 "Not an HTTP Request" , check 2 $ S.concat [ "GET / HTTP/1.1\r\n" , "&*%^(*&*@YS\r\n\r324932\n)" ] , check 3 "\n" ] where check :: Int -> ByteString -> Test check n txt = testCase ("session/badParses/" ++ show n) $ expectException $ getSessionOutput [txt] (return ()) ------------------------------------------------------------------------------ testEof :: Test testEof = testCase "session/eof" $ do l <- runRequestPipeline [] snap assertBool "eof1" $ null l out <- getSessionOutput [""] snap assertEqual "eof2" "" out where snap = writeBS "OK" ------------------------------------------------------------------------------ testHttp100 :: Test testHttp100 = testCase "session/expect100" $ do req <- makeRequest expect100 out <- getSessionOutput [req] (writeBS "OK") assertBool "100-continue" $ S.isPrefixOf "HTTP/1.1 100 Continue\r\n\r\nHTTP/1.1 200 OK" out req2 <- makeRequest expect100_2 out2 <- getSessionOutput [req2] (writeBS "OK") assertBool "100-continue-2" $ S.isPrefixOf "HTTP/1.0 100 Continue\r\n\r\nHTTP/1.0 200 OK" out2 where expect100 = do queryGetParams T.setHeader "Expect" "100-continue" expect100_2 = do T.setHttpVersion (1, 0) queryGetParams T.setHeader "Expect" "100-continue" ------------------------------------------------------------------------------ testNoHost :: Test testNoHost = testCase "session/noHost" $ expectException $ getSessionOutput ["GET / HTTP/1.1\r\n\r\n"] (writeBS "OK") ------------------------------------------------------------------------------ testNoHost1_0 :: Test testNoHost1_0 = testCase "session/noHost1_0" $ do out <- getSessionOutput ["GET / HTTP/1.0\r\n\r\n"] snap1 assertBool "no host 1.0" $ S.isSuffixOf "\r\nbackup-localhost" out out2 <- getSessionOutput ["GET / HTTP/1.0\r\n\r\n"] snap2 assertBool "no host 1.0-2" $ S.isSuffixOf "\r\nbackup-localhost" out2 where snap1 = getRequest >>= writeBS . rqHostName snap2 = getRequest >>= writeBS . rqLocalHostname ------------------------------------------------------------------------------ testChunkedRequest :: Test testChunkedRequest = testCase "session/chunkedRequest" $ do [(_, body)] <- runRequestPipeline [chunked] snap assertEqual "chunked" "ok" body where snap = do m <- liftM (getHeader "Transfer-Encoding") getRequest if m == Just "chunked" then readRequestBody 2048 >>= writeLBS else writeBS "not ok" chunked = do T.put "/" "text/plain" "ok" T.setHeader "Transfer-Encoding" "chunked" ------------------------------------------------------------------------------ testQueryParams :: Test testQueryParams = testCase "session/queryParams" $ do [(_, body)] <- runRequestPipeline [queryGetParams] snap assertEqual "queryParams" expected body where expected = S.unlines [ "param1=abc,def" , "param2=def" , "param1=abc,def" , "ok" ] snap = do rq <- getRequest let (Just l) = rqParam "param1" rq writeBS $ S.concat [ "param1=" , S.intercalate "," l , "\n" ] let (Just m) = rqParam "param2" rq writeBS $ S.concat [ "param2=" , S.intercalate "," m , "\n"] let (Just l') = rqQueryParam "param1" rq writeBS $ S.concat [ "param1=" , S.intercalate "," l' , "\n" ] let z = if isNothing $ rqPostParam "param1" rq then "ok\n" else "bad\n" writeBS z return () ------------------------------------------------------------------------------ testPostParams :: Test testPostParams = testCase "session/postParams" $ do [(_, body)] <- runRequestPipeline [queryPostParams] snap assertEqual "postParams" expected body where expected = S.unlines [ "param1=abc,abc" , "param2=def ,zzz" , "param1=abc,abc" , "ok" , "param2=zzz" ] snap = do rq <- getRequest let (Just l) = rqParam "param1" rq writeBS $ S.concat [ "param1=" , S.intercalate "," l , "\n" ] let (Just m) = rqParam "param2" rq writeBS $ S.concat [ "param2=" , S.intercalate "," m , "\n"] let (Just l') = rqQueryParam "param1" rq writeBS $ S.concat [ "param1=" , S.intercalate "," l' , "\n" ] let z = if isNothing $ rqPostParam "param1" rq then "ok\n" else "bad\n" writeBS z let (Just p) = rqPostParam "param2" rq writeBS $ S.concat [ "param2=" , S.intercalate "," p , "\n" ] return () ------------------------------------------------------------------------------ testPostParamsReplacementBody :: Test testPostParamsReplacementBody = testCase "session/postParamsReplacementBody" $ do [(_, body)] <- runRequestPipeline [queryPostParams] snap assertEqual "postParams" expected body where expected = "param2=zzz" snap = readRequestBody 2048 >>= writeLBS ------------------------------------------------------------------------------ testCookie :: Test testCookie = testCase "session/cookie" $ do [(_, body)] <- runRequestPipeline [queryGetParams] snap assertEqual "cookie" expected body where expected = S.unlines [ "foo" , "bar" ] snap = do cookies <- liftM rqCookies getRequest forM_ cookies $ \cookie -> do writeBS $ S.unlines [ cookieName cookie , cookieValue cookie ] ------------------------------------------------------------------------------ testSetCookie :: Test testSetCookie = testCase "session/setCookie" $ do mapM_ runTest $ zip3 [1..] expecteds cookies where runTest (n, expected, cookie) = do [(resp, _)] <- runRequestPipeline [queryGetParams] $ snap cookie assertEqual ("cookie" ++ show (n :: Int)) (Just expected) (Http.getHeader resp "Set-Cookie") expecteds = [ S.intercalate "; " [ "foo=bar" , "path=/" , "expires=Thu, 01-Jan-1970 00:16:40 GMT" , "domain=localhost" ] , "foo=bar" , "foo=bar; Secure; HttpOnly" ] cookies = [ Cookie "foo" "bar" (Just $ posixSecondsToUTCTime 1000) (Just "localhost") (Just "/") False False , Cookie "foo" "bar" Nothing Nothing Nothing False False , Cookie "foo" "bar" Nothing Nothing Nothing True True ] snap cookie = do modifyResponse $ addResponseCookie cookie ------------------------------------------------------------------------------ testUserException :: Test testUserException = testCase "session/userException" $ do expectException $ runRequestPipeline [queryGetParams] snap where snap = throwIO TestException ------------------------------------------------------------------------------ testUserBodyException :: Test testUserBodyException = testCase "session/userBodyException" $ do expectException $ runRequestPipeline [queryGetParams] snap where snap = modifyResponse $ setResponseBody $ \os -> do Streams.write (Just (byteString "hi" `mappend` flush)) os throwIO TestException ------------------------------------------------------------------------------ testEscape :: Test testEscape = testCase "session/testEscape" $ do req <- makeRequest (return ()) out <- getSessionOutput [req, "OK?"] snap assertEqual "escape" "OK" out where snap = escapeHttp $ \tickle readEnd writeEnd -> do l <- Streams.toList readEnd tickle (max 20) let s = if l == ["OK?"] then "OK" else S.append "BAD: " $ S.pack $ show l Streams.write (Just $ byteString s) writeEnd Streams.write Nothing writeEnd ------------------------------------------------------------------------------ testPostWithoutLength :: Test testPostWithoutLength = testCase "session/postWithoutLength" $ do let req = S.concat [ "POST / HTTP/1.1\r\nHost: localhost\r\n\r\n" , "Blah blah blah blah blah" ] is <- Streams.fromList [req] (os, getInput) <- listOutputStream expectException $ runSession is os (return ()) out <- liftM S.concat getInput assertBool "post without length" $ S.isPrefixOf "HTTP/1.1 411 Length Required" out ------------------------------------------------------------------------------ testWeirdMissingSlash :: Test testWeirdMissingSlash = testCase "session/weirdMissingSlash" $ do do let req = "GET foo/bar?z HTTP/1.0\r\n\r\n" out <- getSessionOutput [req] snap assertBool "missing slash" $ expected1 `S.isSuffixOf` out do let req = "GET /foo/bar?z HTTP/1.0\r\n\r\n" out <- getSessionOutput [req] snap assertBool "with slash" $ expected2 `S.isSuffixOf` out where expected1 = S.concat [ "\r\n\r\n" , "foo/bar?z\n" , "foo/bar\n" , "z\n" ] expected2 = S.concat [ "\r\n\r\n" , "/foo/bar?z\n" , "foo/bar\n" , "z\n" ] p s = writeBuilder $ byteString s `mappend` char8 '\n' snap = do rq <- getRequest p $ rqURI rq p $ rqPathInfo rq p $ rqQueryString rq ------------------------------------------------------------------------------ testOnlyQueryString :: Test testOnlyQueryString = testCase "session/onlyQueryString" $ do do let req = "GET ?z HTTP/1.0\r\n\r\n" out <- getSessionOutput [req] snap assertBool "missing slash" $ expected `S.isSuffixOf` out where expected = S.concat [ "\r\n\r\n" , "?z\n" , "\n" , "z\n" ] p s = writeBuilder $ byteString s `mappend` char8 '\n' snap = do rq <- getRequest p $ rqURI rq p $ rqPathInfo rq p $ rqQueryString rq ------------------------------------------------------------------------------ testConnectionClose :: Test testConnectionClose = testCase "session/connectionClose" $ do do [(resp, _)] <- runRequestPipeline [return (), return ()] snap assertEqual "close1" (Just $ CI.mk "close") $ fmap CI.mk $ Http.getHeader resp "Connection" do [(resp, _)] <- runRequestPipeline [http1_0, http1_0] snap assertEqual "close2" (Just $ CI.mk "close") $ fmap CI.mk $ Http.getHeader resp "Connection" do [(resp, _)] <- runRequestPipeline [http1_0_2, http1_0] (return ()) assertEqual "close3" (Just $ CI.mk "close") $ fmap CI.mk $ Http.getHeader resp "Connection" where http1_0 = T.setHttpVersion (1, 0) http1_0_2 = T.setHttpVersion (1, 0) >> T.setHeader "Connection" "fnargle" snap = modifyResponse $ setHeader "Connection" "close" ------------------------------------------------------------------------------ testUserTerminate :: Test testUserTerminate = testCase "session/userTerminate" $ do expectException $ runRequestPipeline [return ()] snap where snap = terminateConnection TestException ------------------------------------------------------------------------------ testSendFile :: Test testSendFile = testCase "session/sendFile" $ do [(_, out1)] <- runRequestPipeline [return ()] snap1 [(_, out2)] <- runRequestPipeline [return ()] snap2 assertEqual "sendfile1" "TESTING 1-2-3\n" out1 assertEqual "sendfile2" "EST" out2 where snap1 = sendFile "test/dummy.txt" snap2 = sendFilePartial "test/dummy.txt" (1,4) ------------------------------------------------------------------------------ testBasicAcceptLoop :: Test testBasicAcceptLoop = testCase "session/basicAcceptLoop" $ replicateM_ 1000 $ do outputs <- runAcceptLoop [return ()] (return ()) let [Output out] = outputs void (evaluate out) `catch` \(e::SomeException) -> do throwIO e assertBool "basic accept" $ S.isPrefixOf "HTTP/1.1 200 OK\r\n" out ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "session/trivials" $ do coverShowInstance $ TerminateSessionException $ SomeException BadRequestException coverShowInstance LengthRequiredException coverShowInstance BadRequestException coverShowInstance $ TLS.TLSException "ok" coverTypeableInstance (undefined :: TerminateSessionException) coverTypeableInstance (undefined :: BadRequestException) coverTypeableInstance (undefined :: LengthRequiredException) coverTypeableInstance (undefined :: TLS.TLSException) expectException (getOnNewRequest emptyServerConfig undefined >>= evaluate) is <- Streams.fromList [] (os, _) <- Streams.listOutputStream psd <- makePerSessionData is os isNewConnection psd >>= assertEqual "new connection" False -- cover getters let !_ = getTwiddleTimeout psd let !_ = getRemotePort psd let !_ = getRemoteAddress psd let !_ = getLocalPort psd let !_ = getLocalAddress psd getOnParse emptyServerConfig undefined undefined getOnEscape emptyServerConfig undefined getOnException emptyServerConfig undefined undefined getOnDataFinished emptyServerConfig undefined undefined undefined getOnUserHandlerFinished emptyServerConfig undefined undefined undefined getLogError emptyServerConfig undefined getLogAccess emptyServerConfig undefined undefined undefined let !_ = getLogError emptyServerConfig let !_ = getLocalHostname emptyServerConfig let !_ = getDefaultTimeout emptyServerConfig let !_ = getNumAcceptLoops emptyServerConfig let !_ = getIsSecure emptyServerConfig !x <- getLogDateString threadDelay $ 2 * seconds !y <- getLogDateString assertBool (concat ["log dates: ", show x, ", ", show y]) $ x /= y --------------------- -- query fragments -- --------------------- ------------------------------------------------------------------------------ queryGetParams :: RequestBuilder IO () queryGetParams = do T.get "/foo/bar.html" $ Map.fromList [ ("param1", ["abc", "def"]) , ("param2", ["def"]) ] T.addCookies [ Cookie "foo" "bar" Nothing (Just "localhost") (Just "/") False False ] modify $ \rq -> rq { rqContentLength = Just 0 } ------------------------------------------------------------------------------ queryPostParams :: RequestBuilder IO () queryPostParams = do T.postUrlEncoded "/" $ Map.fromList [ ("param2", ["zzz"]) ] T.setQueryStringRaw "param1=abc¶m2=def%20+¶m1=abc" ----------------------- -- utility functions -- ----------------------- ------------------------------------------------------------------------------ _run :: [Test] -> IO () _run l = Console.defaultMainWithArgs l ["--plain"] ------------------------------------------------------------------------------ -- | Given a request builder, produce the HTTP request as a ByteString. makeRequest :: RequestBuilder IO a -> IO ByteString makeRequest = (T.buildRequest . void) >=> T.requestToString ------------------------------------------------------------------------------ mockSendFileHandler :: OutputStream ByteString -> SendFileHandler mockSendFileHandler os !_ hdrs fp start nbytes = do let hstr = toByteString hdrs Streams.write (Just hstr) os Streams.withFileAsInputStartingAt (fromIntegral start) fp $ Streams.takeBytes (fromIntegral nbytes) >=> Streams.supplyTo os Streams.write Nothing os ------------------------------------------------------------------------------ -- | Fill in a 'PerSessionData' with some dummy values. makePerSessionData :: InputStream ByteString -> OutputStream ByteString -> IO PerSessionData makePerSessionData readEnd writeEnd = do forceConnectionClose <- newIORef False let twiddleTimeout f = let z = f 0 in z `seq` return $! () let localAddress = "127.0.0.1" let remoteAddress = "127.0.0.1" let remotePort = 43321 newConnectionRef <- newIORef False let psd = PerSessionData forceConnectionClose twiddleTimeout newConnectionRef (mockSendFileHandler writeEnd) localAddress 80 remoteAddress remotePort readEnd writeEnd return psd ------------------------------------------------------------------------------ -- | Make a pipe -- the two Input/OutputStream pairs will communicate with each -- other from separate threads by using 'Chan's. makePipe :: PipeFunc makePipe = do chan1 <- newChan chan2 <- newChan clientReadEnd <- Streams.chanToInput chan1 clientWriteEnd <- Streams.chanToOutput chan2 >>= Streams.contramapM (evaluate . S.copy) serverReadEnd <- Streams.chanToInput chan2 serverWriteEnd <- Streams.chanToOutput chan1 >>= Streams.contramapM (evaluate . S.copy) return ((clientReadEnd, clientWriteEnd), (serverReadEnd, serverWriteEnd)) ------------------------------------------------------------------------------ -- | Make a pipe -- the two Input/OutputStream pairs will communicate with each -- other from separate threads by using 'Chan's. Data moving through the -- streams will be logged to stdout. _makeDebugPipe :: ByteString -> PipeFunc _makeDebugPipe name = do chan1 <- newChan chan2 <- newChan clientReadEnd <- Streams.chanToInput chan1 >>= Streams.debugInputBS (S.append name "/client-rd") Streams.stderr clientWriteEnd <- Streams.chanToOutput chan2 >>= Streams.debugOutputBS (S.append name "/client-wr") Streams.stderr >>= Streams.contramapM (evaluate . S.copy) serverReadEnd <- Streams.chanToInput chan2 >>= Streams.debugInputBS (S.append name "/server-rd") Streams.stderr serverWriteEnd <- Streams.chanToOutput chan1 >>= Streams.debugOutputBS (S.append name "/server-wr") Streams.stderr >>= Streams.contramapM (evaluate . S.copy) return ((clientReadEnd, clientWriteEnd), (serverReadEnd, serverWriteEnd)) ------------------------------------------------------------------------------ type PipeFunc = IO ( (InputStream ByteString, OutputStream ByteString) , (InputStream ByteString, OutputStream ByteString) ) ------------------------------------------------------------------------------ -- | Given a bunch of requests, convert them to bytestrings and pipeline them -- into the 'httpSession' code, recording the results. runRequestPipeline :: [T.RequestBuilder IO ()] -> Snap b -> IO [(Http.Response, ByteString)] runRequestPipeline = runRequestPipelineDebug makePipe ------------------------------------------------------------------------------ -- | Given a bunch of requests, convert them to bytestrings and pipeline them -- into the 'httpSession' code, recording the results. runRequestPipelineDebug :: PipeFunc -> [T.RequestBuilder IO ()] -> Snap b -> IO [(Http.Response, ByteString)] runRequestPipelineDebug pipeFunc rbs handler = dieIfTimeout $ do ((clientRead, clientWrite), (serverRead, serverWrite)) <- pipeFunc sigClient <- newEmptyMVar results <- newMVar [] forM_ rbs $ makeRequest >=> flip Streams.write clientWrite . Just Streams.write Nothing clientWrite myTid <- myThreadId conn <- Http.makeConnection "localhost" (return ()) clientWrite clientRead bracket (do ctid <- mask $ \restore -> forkIO $ clientThread restore myTid clientRead conn results sigClient stid <- forkIO $ serverThread myTid serverRead serverWrite return (ctid, stid)) (\(ctid, stid) -> mapM_ killThread [ctid, stid]) (\_ -> await sigClient) readMVar results where await sig = takeMVar sig >>= either throwIO (const $ return ()) serverThread myTid serverRead serverWrite = do runSession serverRead serverWrite handler `catch` \(e :: SomeException) -> throwTo myTid e clientThread restore myTid clientRead conn results sig = (try (restore loop) >>= putMVar (sig :: MVar (Either SomeException ()))) `catch` \(e :: SomeException) -> throwTo myTid e where loop = do eof <- Streams.atEOF clientRead if eof then return () else do (resp, body) <- Http.receiveResponse conn $ \rsp istr -> do !out <- liftM S.concat $ Streams.toList istr return (rsp, out) modifyMVar_ results (return . (++ [(resp, body)])) loop ------------------------------------------------------------------------------ getSessionOutput :: [ByteString] -> Snap a -> IO ByteString getSessionOutput input snap = do is <- Streams.fromList input >>= Streams.mapM (evaluate . S.copy) (os0, getList) <- Streams.listOutputStream os <- Streams.contramapM (evaluate . S.copy) os0 runSession is os snap liftM S.concat getList ------------------------------------------------------------------------------ runSession :: InputStream ByteString -> OutputStream ByteString -> Snap a -> IO () runSession readEnd writeEnd handler = do buffer <- newBuffer 64000 perSessionData <- makePerSessionData readEnd writeEnd httpSession buffer (snapToServerHandler handler) (makeServerConfig ()) perSessionData Streams.write Nothing writeEnd ------------------------------------------------------------------------------ makeServerConfig :: hookState -> ServerConfig hookState makeServerConfig hs = setOnException onEx . setOnNewRequest onStart . setLogError logErr . setLogAccess logAccess . setOnDataFinished onDataFinished . setOnEscape onEscape . setOnUserHandlerFinished onUserHandlerFinished . setDefaultTimeout 10 . setLocalHostname "backup-localhost" . setIsSecure False . setNumAcceptLoops 1 . setOnParse onParse $ emptyServerConfig where onStart !psd = do void $ readIORef (_isNewConnection psd) >>= evaluate return hs logAccess !_ !_ !_ = return $! () logErr !e = void $ evaluate $ toByteString e onParse !_ !_ = return $! () onUserHandlerFinished !_ !_ !_ = return $! () onDataFinished !_ !_ !_ = return $! () onEx !_ !e = throwIO e onEscape !_ = return $! () ------------------------------------------------------------------------------ listOutputStream :: IO (OutputStream ByteString, IO [ByteString]) listOutputStream = do (os, out) <- Streams.listOutputStream os' <- Streams.contramapM (evaluate . S.copy) os return (os', out) ------------------------------------------------------------------------------ data TestException = TestException deriving (Typeable, Show) instance Exception TestException ------------------------------------------------------------------------------ data Result = SendFile ByteString FilePath Word64 Word64 | Output ByteString deriving (Eq, Ord, Show) ------------------------------------------------------------------------------ runAcceptLoop :: [T.RequestBuilder IO ()] -> Snap a -> IO [Result] runAcceptLoop requests snap = dieIfTimeout $ do -- make sure we don't log error on ThreadKilled. (_, errs') <- run afuncSuicide assertBool ("errs': " ++ show errs') $ null errs' -- make sure we gobble IOException. count <- newIORef 0 (_, errs'') <- run $ afuncIOException count assertBool ("errs'': " ++ show errs'') $ length errs'' == 2 liftM fst $ run acceptFunc where -------------------------------------------------------------------------- run afunc = do reqStreams <- Streams.fromList requests >>= Streams.mapM makeRequest >>= Streams.lockingInputStream outputs <- newMVar [] lock <- newMVar () err <- newMVar [] httpAcceptLoop (snapToServerHandler snap) (config err) $ afunc reqStreams outputs lock out <- takeMVar outputs errs <- takeMVar err return (out, errs) -------------------------------------------------------------------------- config mvar = (makeServerConfig ()) { _logError = \b -> let !s = toByteString b in modifyMVar_ mvar $ \xs -> do void (evaluate s) return (xs ++ [s]) } -------------------------------------------------------------------------- afuncSuicide :: InputStream ByteString -> MVar [Result] -> MVar () -> AcceptFunc afuncSuicide _ _ lock = AcceptFunc $ \restore -> restore $ withMVar lock (\_ -> throwIO ThreadKilled) -------------------------------------------------------------------------- afuncIOException :: IORef Int -> InputStream ByteString -> MVar [Result] -> MVar () -> AcceptFunc afuncIOException ref _ _ lock = AcceptFunc $ \restore -> restore $ withMVar lock $ const $ do x <- readIORef ref writeIORef ref $! x + 1 if x >= 2 then throwIO ThreadKilled else throwIO $ userError "hello" -------------------------------------------------------------------------- acceptFunc :: InputStream ByteString -> MVar [Result] -> MVar () -> AcceptFunc acceptFunc inputStream output lock = AcceptFunc $ \restore -> restore $ do void $ takeMVar lock b <- atEOF when b $ myThreadId >>= killThread os <- Streams.makeOutputStream out >>= Streams.contramap S.copy return (sendFileFunc, "localhost", 80, "localhost", 55555, inputStream, os, putMVar lock ()) where atEOF = Streams.peek inputStream >>= maybe (return True) f where f x | S.null x = do void $ Streams.read inputStream atEOF | otherwise = return False out (Just s) | S.null s = return () out (Just s) = modifyMVar_ output $ return . (++ [Output s]) out Nothing = return () sendFileFunc !_ !bldr !fp !st !end = modifyMVar_ output $ return . (++ [(SendFile (toByteString bldr) fp st end)]) ------------------------------------------------------------------------------ dieIfTimeout :: IO a -> IO a dieIfTimeout m = timeout (10 * seconds) m >>= maybe (error "timeout") return ------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) ------------------------------------------------------------------------------ toByteString :: Builder -> S.ByteString toByteString = S.concat . L.toChunks . toLazyByteString snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Socket/0000755000000000000000000000000007346545000021361 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Internal/Http/Server/Socket/Tests.hs0000644000000000000000000001532207346545000023022 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Socket.Tests (tests) where ------------------------------------------------------------------------------ import Control.Applicative ((<$>)) import qualified Network.Socket as N ------------------------------------------------------------------------------ import Control.Concurrent (forkIO, killThread, newEmptyMVar, putMVar, readMVar, takeMVar) import qualified Control.Exception as E import Data.IORef (newIORef, readIORef, writeIORef) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertEqual) ------------------------------------------------------------------------------ import qualified Snap.Internal.Http.Server.Socket as Sock import Snap.Test.Common (eatException, expectException, withSock) ------------------------------------------------------------------------------ #ifdef HAS_UNIX_SOCKETS import System.Directory (getTemporaryDirectory) import System.FilePath (()) import qualified System.Posix as Posix # if !MIN_VERSION_unix(2,6,0) import Control.Monad.State (replicateM) import Control.Monad.Trans.State.Strict as State import qualified Data.Vector.Unboxed as V import System.Directory (createDirectoryIfMissing) import System.Random (StdGen, newStdGen, randomR) # endif #else import Snap.Internal.Http.Server.Address (AddressNotSupportedException) #endif ------------------------------------------------------------------------------ #ifdef HAS_UNIX_SOCKETS mkdtemp :: String -> IO FilePath # if MIN_VERSION_unix(2,6,0) mkdtemp = Posix.mkdtemp # else tMPCHARS :: V.Vector Char tMPCHARS = V.fromList $! ['a'..'z'] ++ ['0'..'9'] mkdtemp template = do suffix <- newStdGen >>= return . State.evalState (chooseN 8 tMPCHARS) let dir = template ++ suffix createDirectoryIfMissing False dir return dir where choose :: V.Vector Char -> State.State StdGen Char choose v = do let sz = V.length v idx <- State.state $ randomR (0, sz - 1) return $! (V.!) v idx chooseN :: Int -> V.Vector Char -> State.State StdGen String chooseN n v = replicateM n $ choose v #endif #endif ------------------------------------------------------------------------------ tests :: [Test] tests = [ testUnixSocketBind #if !MIN_VERSION_network(3,0,0) , testAcceptFailure , testSockClosedOnListenException #endif ] ------------------------------------------------------------------------------ -- TODO: fix these tests which rely on deprecated socket apis #if !MIN_VERSION_network(3,0,0) testSockClosedOnListenException :: Test testSockClosedOnListenException = testCase "socket/closedOnListenException" $ do ref <- newIORef Nothing expectException $ Sock.bindSocketImpl (sso ref) bs ls "127.0.0.1" 4444 (Just sock) <- readIORef ref let (N.MkSocket _ _ _ _ mvar) = sock readMVar mvar >>= assertEqual "socket closed" N.Closed where sso ref sock _ _ = do let (N.MkSocket _ _ _ _ mvar) = sock readMVar mvar >>= assertEqual "socket not connected" N.NotConnected writeIORef ref (Just sock) >> fail "set socket option" bs _ _ = fail "bindsocket" ls _ _ = fail "listen" ------------------------------------------------------------------------------ testAcceptFailure :: Test testAcceptFailure = testCase "socket/acceptAndInitialize" $ do sockmvar <- newEmptyMVar donemvar <- newEmptyMVar E.bracket (Sock.bindSocket "127.0.0.1" $ fromIntegral N.aNY_PORT) (N.close) (\s -> do p <- fromIntegral <$> N.socketPort s forkIO $ server s sockmvar donemvar E.bracket (forkIO $ client p) (killThread) (\_ -> do csock <- takeMVar sockmvar takeMVar donemvar N.isConnected csock >>= assertEqual "closed" False ) ) where server sock sockmvar donemvar = serve `E.finally` putMVar donemvar () where serve = eatException $ E.mask $ \restore -> Sock.acceptAndInitialize sock restore $ \(csock, _) -> do putMVar sockmvar csock fail "error" client port = withSock port (const $ return ()) #endif testUnixSocketBind :: Test #ifdef HAS_UNIX_SOCKETS testUnixSocketBind = testCase "socket/unixSocketBind" $ withSocketPath $ \path -> do #if !MIN_VERSION_network(3,0,0) E.bracket (Sock.bindUnixSocket Nothing path) N.close $ \sock -> do N.isListening sock >>= assertEqual "listening" True #endif expectException $ E.bracket (Sock.bindUnixSocket Nothing "a/relative/path") N.close doNothing expectException $ E.bracket (Sock.bindUnixSocket Nothing "/relative/../path") N.close doNothing expectException $ E.bracket (Sock.bindUnixSocket Nothing "/hopefully/not/existing/path") N.close doNothing #ifdef LINUX -- Most (all?) BSD systems ignore access mode on unix sockets. -- Should we still check it? -- This is pretty much for 100% coverage expectException $ E.bracket (Sock.bindUnixSocket Nothing "/") N.close doNothing let mode = 0o766 E.bracket (Sock.bindUnixSocket (Just mode) path) N.close $ \_ -> do -- Should check sockFd instead of path? sockMode <- fmap Posix.fileMode $ Posix.getFileStatus path assertEqual "access mode" (fromIntegral mode) $ Posix.intersectFileModes Posix.accessModes sockMode #endif where doNothing _ = return () withSocketPath act = do tmpRoot <- getTemporaryDirectory tmpDir <- mkdtemp $ tmpRoot "snap-server-test-" let path = tmpDir "unixSocketBind.sock" E.finally (act path) $ do eatException $ Posix.removeLink path eatException $ Posix.removeDirectory tmpDir #else testUnixSocketBind = testCase "socket/unixSocketBind" $ do caught <- E.catch (Sock.bindUnixSocket Nothing "/tmp/snap-sock.sock" >> return False) $ \(e :: AddressNotSupportedException) -> length (show e) `seq` return True assertEqual "not supported" True caught #endif snap-server-1.1.2.1/test/Snap/Internal/Http/Server/TimeoutManager/0000755000000000000000000000000007346545000023052 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Internal/Http/Server/TimeoutManager/Tests.hs0000644000000000000000000001171707346545000024517 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.TimeoutManager.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.Thread (forkIO, result) import qualified Control.Exception as E import Control.Monad (replicateM) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (isJust) ------------------------------------------------------------------------------ import qualified Snap.Internal.Http.Server.Clock as Clock import qualified Snap.Internal.Http.Server.TimeoutManager as TM import System.Timeout (timeout) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertBool, assertEqual) ------------------------------------------------------------------------------ tests :: [Test] tests = [ testOneTimeout , testSlowToDie , testOneTimeoutAfterInactivity , testCancel , testTickle ] ------------------------------------------------------------------------------ register :: IO () -> TM.TimeoutManager -> IO TM.TimeoutThread register m t = TM.register t "test" $ \restore -> restore (Clock.sleepSecs 9000) `E.finally` m ------------------------------------------------------------------------------ testOneTimeout :: Test testOneTimeout = testCase "timeout/oneTimeout" $ repeatedly $ do mgr <- TM.initialize 1 0.1 Clock.getClockTime oneTimeout mgr ------------------------------------------------------------------------------ testSlowToDie :: Test testSlowToDie = testCase "timeout/slowToDie" $ repeatedly $ do mgr <- TM.initialize 1 0.1 Clock.getClockTime r <- newIORef False s <- newIORef False _ <- register (writeIORef r True >> Clock.sleepSecs 3 >> writeIORef s True) mgr Clock.sleepSecs 1.5 readIORef r >>= assertEqual "started to die" True readIORef s >>= assertEqual "not dead yet" False Clock.sleepSecs 3 readIORef s >>= assertEqual "dead" True ------------------------------------------------------------------------------ testOneTimeoutAfterInactivity :: Test testOneTimeoutAfterInactivity = testCase "timeout/oneTimeoutAfterInactivity" $ repeatedly $ do mgr <- TM.initialize 1 0.1 Clock.getClockTime Clock.sleepSecs 3 oneTimeout mgr ------------------------------------------------------------------------------ repeatedly :: IO () -> IO () repeatedly m = dieIfTimeout $ do results <- replicateM 40 (forkIO m) >>= sequence . map snd mapM_ result results ------------------------------------------------------------------------------ oneTimeout :: TM.TimeoutManager -> IO () oneTimeout mgr = do mv <- newEmptyMVar _ <- register (putMVar mv ()) mgr m <- timeout (3*seconds) $ takeMVar mv assertBool "timeout fired" $ isJust m Clock.sleepSecs 2 TM.stop mgr ------------------------------------------------------------------------------ testTickle :: Test testTickle = testCase "timeout/tickle" $ repeatedly $ do mgr <- TM.initialize 5 0.1 Clock.getClockTime ref <- newIORef (0 :: Int) h <- register (writeIORef ref 1) mgr E.evaluate (length $ show h) Clock.sleepSecs 1 b0 <- readIORef ref assertEqual "b0" 0 b0 TM.tickle h 3 Clock.sleepSecs 1 b1 <- readIORef ref assertEqual "b1" 0 b1 Clock.sleepSecs 5 b2 <- readIORef ref assertEqual "b2" 1 b2 TM.stop mgr ------------------------------------------------------------------------------ testCancel :: Test testCancel = testCase "timeout/cancel" $ repeatedly $ do mgr <- TM.initialize 3 0.1 Clock.getClockTime ref <- newIORef (0 :: Int) h <- register (writeIORef ref 1) mgr Clock.sleepSecs 1 readIORef ref >>= assertEqual "b0" 0 TM.cancel h TM.tickle h 10 -- make sure tickle ignores cancelled times Clock.sleepSecs 2 readIORef ref >>= assertEqual "b1" 1 Clock.sleepSecs 2 h' <- register (writeIORef ref 2) mgr _ <- register (return ()) mgr TM.set h' 1 Clock.sleepSecs 2 readIORef ref >>= assertEqual "b2" 2 _ <- register (writeIORef ref 3) mgr hs <- replicateM 1000 $! register (return ()) mgr mapM TM.cancel hs TM.stop mgr Clock.sleepSecs 1 readIORef ref >>= assertEqual "b3" 3 ------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) ------------------------------------------------------------------------------ dieIfTimeout :: IO a -> IO a dieIfTimeout m = timeout (30 * seconds) m >>= maybe (error "timeout") return snap-server-1.1.2.1/test/Snap/Test/0000755000000000000000000000000007346545000015107 5ustar0000000000000000snap-server-1.1.2.1/test/Snap/Test/Common.hs0000644000000000000000000001371607346545000016703 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ module Snap.Test.Common where ------------------------------------------------------------------------------ import Control.DeepSeq (deepseq) import Control.Exception.Lifted (SomeException (..), catch, evaluate, finally, try) import Control.Monad (liftM, replicateM) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Control (MonadBaseControl) import Data.ByteString.Builder (byteString, toLazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L import Data.Monoid (Monoid (mappend, mempty)) import Data.Typeable (Typeable, typeOf) import Network.Socket (Socket) import qualified Network.Socket as N hiding (recv) import System.Timeout (timeout) import Test.HUnit (assertFailure) import Test.QuickCheck (Arbitrary (arbitrary), choose) import qualified Network.Socket.ByteString as N #if !(MIN_VERSION_base(4,6,0)) import Prelude hiding (catch) #endif ------------------------------------------------------------------------------ instance Arbitrary S.ByteString where arbitrary = liftM S.pack 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 (z::SomeException) -> length (show z) `seq` 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 (N.addrAddress . Prelude.head) $ N.getAddrInfo (Just myHints) (Just "127.0.0.1") (Just $ show port) sock <- N.socket N.AF_INET N.Stream N.defaultProtocol N.connect sock addr go sock `finally` close sock where #if MIN_VERSION_network(2,7,0) close = N.close #else close = N.sClose #endif myHints = N.defaultHints { N.addrFlags = [ N.AI_NUMERICHOST ] } ------------------------------------------------------------------------------ recvAll :: Socket -> IO ByteString recvAll sock = do b <- f mempty sock return $! S.concat $ L.toChunks $ toLazyByteString b where f b sk = do s <- N.recv sk 100000 if S.null s then return b else f (b `mappend` byteString s) sk ------------------------------------------------------------------------------ ditchHeaders :: [ByteString] -> [ByteString] ditchHeaders ("":xs) = xs ditchHeaders ("\r":xs) = xs ditchHeaders (_:xs) = ditchHeaders xs ditchHeaders [] = [] ------------------------------------------------------------------------------ forceSameType :: a -> a -> a forceSameType _ a = a ------------------------------------------------------------------------------ -- | Kill the false negative on derived show instances. coverShowInstance :: (Monad m, Show a) => a -> m () coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return () where a = showsPrec 0 x "" b = show x c = showList [x] "" ------------------------------------------------------------------------------ coverReadInstance :: (MonadIO m, Read a) => a -> m () coverReadInstance x = do liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 "" liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList "" ------------------------------------------------------------------------------ coverEqInstance :: (Monad m, Eq a) => a -> m () coverEqInstance x = a `seq` b `seq` return () where a = x == x b = x /= x ------------------------------------------------------------------------------ coverOrdInstance :: (Monad m, Ord a) => a -> m () coverOrdInstance x = a `deepseq` b `deepseq` return () where a = [ x < x , x >= x , x > x , x <= x , compare x x == EQ ] b = min a $ max a a ------------------------------------------------------------------------------ coverTypeableInstance :: (Monad m, Typeable a) => a -> m () coverTypeableInstance a = typeOf a `seq` return () ------------------------------------------------------------------------------ eatException :: (MonadBaseControl IO m) => m a -> m () eatException a = (a >> return ()) `catch` handler where handler :: (MonadBaseControl IO m) => SomeException -> m () handler _ = return () ------------------------------------------------------------------------------ timeoutIn :: Int -> IO a -> IO a timeoutIn n m = timeout (n * 1000000) m >>= maybe (fail "timeout") return snap-server-1.1.2.1/test/System/SendFile/0000755000000000000000000000000007346545000016244 5ustar0000000000000000snap-server-1.1.2.1/test/System/SendFile/Tests.hs0000644000000000000000000002403507346545000017706 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} module System.SendFile.Tests (tests) where ------------------------------------------------------------------------------ import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar) import Control.Exception (evaluate) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S import Foreign.C.Error (Errno (..), eAGAIN, eCONNRESET, eOK) import Foreign.C.Types (CChar, CInt (..), CSize) import Foreign.Storable (peek) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertEqual) ------------------------------------------------------------------------------ import Snap.Test.Common (expectException) import qualified System.SendFile as SF #if defined(LINUX) import Control.Monad (void) import Foreign.Ptr (Ptr, nullPtr) import System.Posix.Types (COff, CSsize, Fd) import qualified System.SendFile.Linux as SFI #elif defined(FREEBSD) import Control.Monad (void) import Foreign.Ptr (Ptr) import Foreign.Storable import System.Posix.Types (COff, Fd) import qualified System.SendFile.FreeBSD as SFI #elif defined(OSX) import Control.Monad (void, when) import Foreign.Ptr (Ptr) import Foreign.Storable (poke) import System.Posix.Types (COff, Fd) import qualified System.SendFile.Darwin as SFI #endif ------------------------------------------------------------------------------ tests :: [Test] tests = [ testSendHeaders , testSendHeaderCrash , testSendFile , testSendFileCrash , testSendFileZero , testTrivials ] ------------------------------------------------------------------------------ testSendHeaders :: Test testSendHeaders = testCase "sendfile/sendHeaders" $ do callLog <- newMVar [] sampleData <- newMVar sampleActions nWaits <- newMVar (0 :: Int) let bumpWaits = \x -> x `seq` modifyMVar_ nWaits (return . (+1)) SF.sendHeadersImpl (sendHeadersMockSendFunc sampleData callLog) bumpWaits builder 100 [c1, c2, c3] <- readMVar callLog assertEqual "sendHeaders1" c1 c2 assertEqual "sendHeaders2" 8 (_sz c3) readMVar nWaits >>= assertEqual "sendHeaders3" 1 where builder = byteString $ S.replicate 10 ' ' sampleActions = [ c_set_errno eAGAIN >> return (-1) , return 2 , return 8 ] ------------------------------------------------------------------------------ testSendHeaderCrash :: Test testSendHeaderCrash = testCase "sendfile/sendHeaders/crash" $ do callLog <- newMVar [] sampleData <- newMVar sampleActions nWaits <- newMVar (0 :: Int) let bumpWaits = \x -> x `seq` modifyMVar_ nWaits (return . (+1)) expectException $ SF.sendHeadersImpl (sendHeadersMockSendFunc sampleData callLog) bumpWaits builder 100 where builder = byteString $ S.replicate 10 ' ' sampleActions = [ c_set_errno eCONNRESET >> return (-1) ] ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "sendfile/trivials" $ void (evaluate $ length SF.sendFileMode) ------------------------------------------------------------------------------ data SendHeadersCallLog = SendHeadersCallLog { _fd :: Fd , _str :: Ptr CChar , _sz :: CSize , _flags :: CInt } deriving (Eq, Show, Ord) ------------------------------------------------------------------------------ sendHeadersMockSendFunc :: MVar [IO CSize] -- ^ sample outputs -> MVar [SendHeadersCallLog] -- ^ log of calls -> Fd -> Ptr CChar -> CSize -> CInt -> IO CSize sendHeadersMockSendFunc sampleData callLog !fd !cstr !clen !flags = do modifyMVar_ callLog (return . (++ [SendHeadersCallLog fd cstr clen flags])) x <- modifyMVar sampleData $ \xs -> return $! if null xs then ([], return Nothing) else (tail xs, fmap Just $! head xs) x >>= maybe (c_set_errno eCONNRESET >> return (-1)) (return) foreign import ccall unsafe "set_errno" c_set_errno :: Errno -> IO () ------------------------------------------------------------------------------ -- Testing for internal sendfile via dep injection #if defined(LINUX) data SendFileCallLog = SendFileCallLog { _sf_fd1 :: Fd , _sf_fd2 :: Fd , _sf_off :: COff , _sf_sz :: CSize } deriving (Eq, Show, Ord) ------------------------------------------------------------------------------ sendFileMockSendFunc :: MVar [IO CSize] -- ^ sample outputs -> MVar [SendFileCallLog] -- ^ log of calls -> Fd -> Fd -> Ptr COff -> CSize -> IO CSsize sendFileMockSendFunc sampleData callLog !fd1 !fd2 !cstr !clen = do cp <- if cstr == nullPtr then return (-1) else peek cstr modifyMVar_ callLog (return . (++ [SendFileCallLog fd1 fd2 cp clen])) x <- modifyMVar sampleData $ \xs -> return $! if null xs then ([], return Nothing) else (tail xs, fmap Just $! head xs) x >>= maybe (c_set_errno eCONNRESET >> return (-1)) (return . fromIntegral) #elif defined(FREEBSD) data SendFileCallLog = SendFileCallLog { _sf_fd1 :: Fd , _sf_fd2 :: Fd , _sf_off :: COff , _sf_sz :: CSize } deriving (Eq, Show, Ord) ------------------------------------------------------------------------------ sendFileMockSendFunc :: MVar [IO CInt] -- ^ sample outputs -> MVar [SendFileCallLog] -- ^ log of calls -> Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt sendFileMockSendFunc sampleData callLog !fd1 !fd2 !off !clen !_ !pbytes !_ = do modifyMVar_ callLog (return . (++ [SendFileCallLog fd1 fd2 off clen])) x <- modifyMVar sampleData $ \xs -> return $! if null xs then ([], return Nothing) else (tail xs, fmap Just $! head xs) x >>= maybe (c_set_errno eCONNRESET >> return (-1)) return #elif defined(OSX) data SendFileCallLog = SendFileCallLog { _sf_fd1 :: Fd , _sf_fd2 :: Fd , _sf_off :: COff , _sf_sz :: COff } deriving (Eq, Show, Ord) ------------------------------------------------------------------------------ sendFileMockSendFunc :: MVar [IO CInt] -- ^ sample outputs -> MVar [SendFileCallLog] -- ^ log of calls -> Fd -> Fd -> COff -> Ptr COff -> IO CInt sendFileMockSendFunc sampleData callLog !fd1 !fd2 !off !pnbytes = do !clen <- peek pnbytes modifyMVar_ callLog (return . (++ [SendFileCallLog fd1 fd2 off clen])) x <- modifyMVar sampleData $ \xs -> return $! if null xs then ([], return Nothing) else (tail xs, fmap Just $! head xs) x >>= maybe (c_set_errno eCONNRESET >> return (-1)) (\l -> do when (l > 0) (poke pnbytes (fromIntegral l)) return l) #endif ------------------------------------------------------------------------------ testSendFile :: Test testSendFile = testCase "sendfile/sendfile-impl" $ do callLog <- newMVar [] sampleData <- newMVar sampleActions nWaits <- newMVar (0 :: Int) let bumpWaits = \x -> x `seq` modifyMVar_ nWaits (return . (+1)) SFI.sendFileImpl (sendFileMockSendFunc sampleData callLog) bumpWaits 100 101 0 10 [c1, c2] <- readMVar callLog assertEqual "sendFile1" c1 c2 assertEqual "sendFile2" 10 (_sf_sz c2) readMVar nWaits >>= assertEqual "sendFile3" 1 modifyMVar_ callLog $ const $ return [] modifyMVar_ nWaits $ const $ return 0 modifyMVar_ sampleData $ const $ return sampleActions2 SFI.sendFileImpl (sendFileMockSendFunc sampleData callLog) bumpWaits 100 101 1 9 [_, c4] <- readMVar callLog readMVar nWaits >>= assertEqual "nwaits-2" 1 assertEqual "sendFile3" 9 (_sf_sz c4) assertEqual "sendFile3-off" 1 (_sf_off c4) where sampleActions = [ c_set_errno eAGAIN >> return (-1) , c_set_errno eOK >> return 2 ] sampleActions2 = [ c_set_errno eAGAIN >> return (-1) , c_set_errno eOK >> return 2 ] ------------------------------------------------------------------------------ testSendFileZero :: Test testSendFileZero = testCase "sendfile/sendfile-zero" $ do callLog <- newMVar [] sampleData <- newMVar sampleActions nWaits <- newMVar (0 :: Int) let bumpWaits = \x -> x `seq` modifyMVar_ nWaits (return . (+1)) c <- SFI.sendFileImpl (sendFileMockSendFunc sampleData callLog) bumpWaits 100 101 0 0 readMVar callLog >>= assertEqual "empty call log" [] readMVar nWaits >>= assertEqual "no waits" 0 assertEqual "no bytes read" 0 c where sampleActions = [ c_set_errno eAGAIN >> return (-1) , c_set_errno eOK >> return 2 ] ------------------------------------------------------------------------------ testSendFileCrash :: Test testSendFileCrash = testCase "sendfile/sendFile/crash" $ do callLog <- newMVar [] sampleData <- newMVar sampleActions nWaits <- newMVar (0 :: Int) let bumpWaits = \x -> x `seq` modifyMVar_ nWaits (return . (+1)) expectException $ SFI.sendFileImpl (sendFileMockSendFunc sampleData callLog) bumpWaits 100 101 0 10 where sampleActions = [ c_set_errno eCONNRESET >> return (-1) ] snap-server-1.1.2.1/test/Test/0000755000000000000000000000000007346545000014206 5ustar0000000000000000snap-server-1.1.2.1/test/Test/Blackbox.hs0000644000000000000000000006322407346545000016276 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Blackbox ( tests , haTests , ssltests , startTestServers ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Arrow (first) import Control.Concurrent (MVar, ThreadId, forkIO, forkIOWithUnmask, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar) import Control.Exception (bracket, bracketOnError, finally, mask_) import Control.Monad (forM_, forever, void, when) import qualified Data.ByteString.Base16 as B16 import Data.ByteString.Builder (byteString) 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 qualified Data.CaseInsensitive as CI import Data.List (sort) import Data.Monoid (Monoid (mconcat, mempty)) import qualified Network.Http.Client as HTTP import qualified Network.Http.Types as HTTP import qualified Network.Socket as N import qualified Network.Socket.ByteString as NB import Prelude (Bool (..), Eq (..), IO, Int, Maybe (..), Show (..), String, concat, concatMap, const, dropWhile, elem, flip, fromIntegral, fst, head, id, map, mapM_, maybe, min, not, null, otherwise, putStrLn, replicate, return, reverse, uncurry, ($), ($!), (*), (++), (.), (^)) import qualified Prelude ------------------------------------------------------------------------------ #ifdef OPENSSL import qualified OpenSSL.Session as SSL #endif import qualified System.IO.Streams as Streams import System.Timeout (timeout) import Test.Framework (Test, TestOptions' (topt_maximum_generated_tests), plusTestOptions) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test, path) import Test.QuickCheck (Arbitrary (arbitrary)) import Test.QuickCheck.Monadic (forAllM, monadicIO) import qualified Test.QuickCheck.Monadic as QC import qualified Test.QuickCheck.Property as QC ------------------------------------------------------------------------------ import Snap.Internal.Debug (debug) import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler) import qualified Snap.Internal.Http.Server.Socket as Sock import qualified Snap.Internal.Http.Server.TLS as TLS import qualified Snap.Internal.Http.Server.Types as Types import Snap.Test.Common (ditchHeaders, eatException, expectExceptionBeforeTimeout, recvAll, timeoutIn, withSock) import Test.Common.Rot13 (rot13) import Test.Common.TestHandler (testHandler) ------------------------------------------------------------------------------ tests :: Int -> [Test] tests port = map (\f -> f False port "") testFunctions ssltests :: Maybe Int -> [Test] ssltests = maybe [] httpsTests where httpsTests port = map (\f -> f True port sslname) testFunctions sslname = "ssl/" haTests :: Int -> [Test] haTests port = [ testHaProxy port , testHaProxyLocal port , testHaProxyFileServe port ] 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 , testHasDateHeader , testServerHeader , testFileServe , testTimelyRedirect , testChunkedHead ] ------------------------------------------------------------------------------ startServer :: Types.ServerConfig hookState -> IO a -> (a -> N.Socket) -> (a -> Types.AcceptFunc) -> IO (ThreadId, Int, MVar ()) startServer config bind projSock afunc = bracketOnError bind (N.close . projSock) forkServer where forkServer a = do mv <- newEmptyMVar port <- fromIntegral <$> N.socketPort (projSock a) tid <- forkIO $ eatException $ (httpAcceptLoop (snapToServerHandler testHandler) config (afunc a) `finally` putMVar mv ()) return (tid, port, mv) ------------------------------------------------------------------------------ -- | Returns the thread the server is running in as well as the port it is -- listening on. data TestServerType = NormalTest | ProxyTest | SSLTest deriving (Show) startTestSocketServer :: TestServerType -> IO (ThreadId, Int, MVar ()) startTestSocketServer serverType = do putStrLn $ "Blackbox: starting " ++ show serverType ++ " server" case serverType of NormalTest -> startServer emptyServerConfig bindSock id Sock.httpAcceptFunc ProxyTest -> startServer emptyServerConfig bindSock id Sock.haProxyAcceptFunc SSLTest -> startServer emptyServerConfig bindSSL fst (uncurry TLS.httpsAcceptFunc) where #if MIN_VERSION_network(2,7,0) anyport = N.defaultPort #else anyport = N.aNY_PORT #endif bindSSL = do sockCtx <- TLS.bindHttps "127.0.0.1" (fromIntegral anyport) "test/cert.pem" False "test/key.pem" #ifdef OPENSSL -- Set client code not to verify HTTP.modifyContextSSL $ \ctx -> do SSL.contextSetVerificationMode ctx SSL.VerifyNone return ctx #endif return sockCtx bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral anyport) logAccess !_ !_ !_ = return () logError !_ = return () onStart !_ = return () onParse !_ !_ = return () onUserHandlerFinished !_ !_ !_ = return () onDataFinished !_ !_ !_ = return () onExceptionHook !_ !_ = return () onEscape !_ = return () emptyServerConfig = Types.ServerConfig logAccess logError onStart onParse onUserHandlerFinished onDataFinished onExceptionHook onEscape "localhost" 6 False 1 ------------------------------------------------------------------------------ waitabit :: IO () waitabit = threadDelay $ 2*seconds ------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) ------------------------------------------------------------------------------ fetch :: ByteString -> IO ByteString fetch url = HTTP.get url HTTP.concatHandler' ------------------------------------------------------------------------------ fetchWithHeaders :: ByteString -> IO (ByteString, [(CI ByteString, ByteString)]) fetchWithHeaders url = HTTP.get url h where h resp is = do let hdrs = map (first CI.mk) $ HTTP.retrieveHeaders $ HTTP.getHeaders resp body <- HTTP.concatHandler' resp is return (body, hdrs) ------------------------------------------------------------------------------ slowTestOptions :: Bool -> TestOptions' Maybe slowTestOptions ssl = if ssl then mempty { topt_maximum_generated_tests = Just 75 } else mempty { topt_maximum_generated_tests = Just 300 } ------------------------------------------------------------------------------ -- 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 ------------------------------------------------------------------------------ -- 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 ------------------------------------------------------------------------------ -- 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 NB.sendAll sock "GET /" waitabit NB.sendAll sock "pong HTTP/1.1\r\n" NB.sendAll sock "Host: 127.0.0.1\r\n" NB.sendAll sock "Content-Length: 0\r\n" NB.sendAll sock "Connection: close\r\n\r\n" resp <- recvAll sock let s = head $ ditchHeaders $ S.lines resp assertEqual "pong response" "PONG" s ------------------------------------------------------------------------------ -- 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 NB.sendAll sock "POST /echo HTTP/1.1\r\n" NB.sendAll sock "Host: 127.0.0.1\r\n" NB.sendAll sock "Content-Length: 2500000\r\n" NB.sendAll sock "Connection: close\r\n\r\n" b <- expectExceptionBeforeTimeout (loris sock) 30 assertBool "didn't catch slow loris attack" b loris sock = forever $ do NB.sendAll sock "." waitabit ------------------------------------------------------------------------------ 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 $ HTTP.post (S.pack uri) "text/plain" (Streams.write (Just $ byteString txt)) HTTP.concatHandler' QC.assert $ txt == rot13 doc ------------------------------------------------------------------------------ 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 $ S.pack uri debug $ "response was " ++ show rsp return rsp ------------------------------------------------------------------------------ testPong :: Bool -> Int -> String -> Test testPong ssl port name = testCase (name ++ "blackbox/pong") $ do doc <- doPong ssl port assertEqual "pong response" "PONG" doc ------------------------------------------------------------------------------ testHasDateHeader :: Bool -> Int -> String -> Test testHasDateHeader ssl port name = testCase (name ++ "blackbox/hasDateHdr") $ do let !url = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/pong" (rsp, hdrs) <- fetchWithHeaders $ S.pack url let hasDate = "date" `elem` map fst hdrs when (not hasDate) $ do putStrLn "server not sending dates:" forM_ hdrs $ \(k,v) -> S.putStrLn $ S.concat [CI.original k, ": ", v] assertBool "has date" hasDate assertEqual "pong response" "PONG" rsp ------------------------------------------------------------------------------ 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 NB.sendAll sock $ S.concat [ "HEAD /chunked HTTP/1.1\r\n" , "Host: localhost\r\n" , "\r\n" ] s <- NB.recv sock 4096 assertBool (concat [ "no body: received '" , S.unpack s , "'" ]) $ 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: 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 -> NB.sendAll sock "GET /pong HTTP/1.1\r\n" doc <- doPong ssl port assertEqual "pong response" "PONG" doc ------------------------------------------------------------------------------ -- TODO: no ssl here -- test server's ability to trap/recover from IO errors testTimelyRedirect :: Bool -> Int -> String -> Test testTimelyRedirect ssl port name = testCase (name ++ "blackbox/testTimelyRedirect") $ if ssl then return () else runIt where runIt = do m <- timeout (5*seconds) go maybe (assertFailure "timeout") (const $ return ()) m go = do withSock port $ \sock -> do NB.sendAll sock $ S.concat [ "GET /redirect HTTP/1.1\r\n" , "Host: localhost\r\n\r\n" ] resp <- NB.recv sock 100000 assertBool "wasn't code 302" $ S.isInfixOf "302" resp assertBool "didn't have content length" $ S.isInfixOf "content-length: 0" resp ------------------------------------------------------------------------------ -- 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 NB.sendAll sock "GET /bigresponse HTTP/1.1\r\n" NB.sendAll sock "Host: 127.0.0.1\r\n" NB.sendAll sock "Content-Length: 0\r\n" NB.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 ------------------------------------------------------------------------------ testHaProxy :: Int -> Test testHaProxy port = testCase "blackbox/haProxy" runIt where runIt = withSock port $ \sock -> do m <- timeout (120*seconds) $ go sock maybe (assertFailure "timeout") (const $ return ()) m go sock = do NB.sendAll sock $ S.concat [ "PROXY TCP4 1.2.3.4 5.6.7.8 1234 5678\r\n" , "GET /remoteAddrPort HTTP/1.1\r\n" , "Host: 127.0.0.1\r\n" , "Content-Length: 0\r\n" , "Connection: close\r\n\r\n" ] resp <- recvAll sock let s = head $ ditchHeaders $ S.lines resp when (s /= "1.2.3.4:1234") $ S.putStrLn s assertEqual "haproxy response" "1.2.3.4:1234" s ------------------------------------------------------------------------------ testHaProxyFileServe :: Int -> Test testHaProxyFileServe port = testCase "blackbox/haProxyFileServe" runIt where runIt = withSock port $ \sock -> do m <- timeout (120*seconds) $ go sock maybe (assertFailure "timeout") (const $ return ()) m go sock = do NB.sendAll sock $ S.concat [ "PROXY UNKNOWN\r\n" , "GET /fileserve/hello.txt HTTP/1.1\r\n" , "Host: 127.0.0.1\r\n" , "Content-Length: 0\r\n" , "Connection: close\r\n\r\n" ] resp <- recvAll sock let s = head $ ditchHeaders $ S.lines resp assertEqual "haproxy response" "hello world" s ------------------------------------------------------------------------------ testHaProxyLocal :: Int -> Test testHaProxyLocal port = testCase "blackbox/haProxyLocal" runIt where #if MIN_VERSION_network(2,7,0) anyport = N.defaultPort #else anyport = N.aNY_PORT #endif remoteAddrServer :: N.Socket -> MVar (Maybe String) -> (forall a . IO a -> IO a) -> IO () remoteAddrServer ssock mvar restore = timeoutIn 10 $ flip finally (tryPutMVar mvar Nothing) $ bracket (restore $ N.accept ssock) (eatException . N.close . fst) (\(_, peer) -> putMVar mvar $! Just $! show peer) slurp p input = timeoutIn 10 $ withSock p $ \sock -> do NB.sendAll sock input recvAll sock determineSourceInterfaceAddr = timeoutIn 10 $ bracket (Sock.bindSocket "127.0.0.1" (fromIntegral anyport)) (eatException . N.close) (\ssock -> do mv <- newEmptyMVar svrPort <- fromIntegral <$> N.socketPort ssock bracket (mask_ $ forkIOWithUnmask $ remoteAddrServer ssock mv) (eatException . killThread) (const $ do void $ slurp svrPort "" (Just s) <- takeMVar mv return $! fst $ S.breakEnd (==':') $ S.pack s)) runIt = do saddr <- determineSourceInterfaceAddr resp <- slurp port $ S.concat [ "PROXY UNKNOWN\r\n" , "GET /remoteAddrPort HTTP/1.1\r\n" , "Host: 127.0.0.1\r\n" , "Content-Length: 0\r\n" , "Connection: close\r\n\r\n" ] let s = head $ ditchHeaders $ S.lines resp when (not $ S.isPrefixOf saddr s) $ S.putStrLn s assertBool "haproxy response" $ S.isPrefixOf saddr s ------------------------------------------------------------------------------ -- 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 <- fetch $ S.pack uri let expected = S.concat $ replicate 10 ".\n" assertEqual "response equal" expected doc ------------------------------------------------------------------------------ testFileServe :: Bool -> Int -> String -> Test testFileServe ssl port name = testCase (name ++ "blackbox/fileserve") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/fileserve/hello.txt" doc <- fetch $ S.pack uri let expected = "hello world\n" assertEqual "response equal" expected 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 = S.pack $ concat [ if ssl then "https" else "http" , "://127.0.0.1:" , show port , "/upload/handle" ] let txt = response kvps doc0 <- QC.run $ HTTP.withConnection (HTTP.establishConnection uri) $ \conn -> do req <- HTTP.buildRequest $ do HTTP.http HTTP.POST uri mapM_ (uncurry HTTP.setHeader) hdrs HTTP.sendRequest conn req (Streams.write $ Just $ mconcat $ map byteString $ L.toChunks $ body kvps) HTTP.receiveResponse conn HTTP.concatHandler' let doc = L.fromChunks [doc0] 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 ------------------------------------------------------------------------------ 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 $ HTTP.post (S.pack uri) "text/plain" (Streams.write (Just $ byteString txt)) HTTP.concatHandler' QC.assert $ txt == doc ------------------------------------------------------------------------------ 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" HTTP.get (S.pack uri) $ \resp _ -> do let serverHeader = HTTP.getHeader resp "server" assertEqual "server header" (Just "foo") serverHeader ------------------------------------------------------------------------------ startTestServers :: IO ((ThreadId, Int, MVar ()), (ThreadId, Int, MVar ()), Maybe (ThreadId, Int, MVar ())) startTestServers = do x <- startTestSocketServer NormalTest y <- startTestSocketServer ProxyTest #ifdef OPENSSL z <- startTestSocketServer SSLTest return (x, y, Just z) #else return (x, y, Nothing) #endif snap-server-1.1.2.1/test/Test/Common/0000755000000000000000000000000007346545000015436 5ustar0000000000000000snap-server-1.1.2.1/test/Test/Common/Rot13.hs0000644000000000000000000000143407346545000016704 0ustar0000000000000000module Test.Common.Rot13 (rot13) where ---------------------------------------------------------------------------- import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.Char( ord, isAsciiUpper, isAsciiLower, isAlpha, chr ) ------------------------------------------------------------------------------ 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-1.1.2.1/test/Test/Common/TestHandler.hs0000644000000000000000000001667007346545000020221 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Test.Common.TestHandler (testHandler) where ------------------------------------------------------------------------------ import Control.Concurrent (threadDelay) import Control.Exception (throwIO) import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List (sort) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid (Monoid (mappend, mconcat, mempty)) ------------------------------------------------------------------------------ import Snap.Core (Request (rqParams, rqURI), Snap, getParam, getRequest, logError, modifyResponse, redirect, route, rqClientAddr, rqClientPort, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setTimeout, transformRequestBody, writeBS, writeBuilder, writeLBS) import Snap.Internal.Debug () import Snap.Util.FileServe (serveDirectory) import Snap.Util.FileUploads (PartInfo (partContentType, partFileName), allowWithMaximumSize, defaultUploadPolicy, disallow, handleFileUploads) import Snap.Util.GZip (noCompression, withCompression) import System.Directory (createDirectoryIfMissing) import System.IO.Streams (OutputStream) import qualified System.IO.Streams as Streams 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" 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 -> OutputStream Builder -> IO (OutputStream Builder) trickleOutput n os = do Streams.fromList dots >>= Streams.mapM f >>= Streams.supplyTo os return os where dots = replicate n ".\n" f x = threadDelay 1000000 >> return (byteString x `mappend` flush) ------------------------------------------------------------------------------ pongHandler :: Snap () pongHandler = modifyResponse $ setResponseBody body . setContentType "text/plain" . setContentLength 4 where body os = do Streams.write (Just $ byteString "PONG") os return os echoUriHandler :: Snap () echoUriHandler = do req <- getRequest writeBS $ rqURI req echoHandler :: Snap () echoHandler = transformRequestBody return rot13Handler :: Snap () rot13Handler = transformRequestBody (Streams.map rot13) bigResponseHandler :: Snap () bigResponseHandler = do let sz = 4000000 let s = L.take sz $ L.cycle $ L.fromChunks [S.replicate 400000 '.'] modifyResponse $ setContentLength $ fromIntegral 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 logError "uploadHandler" liftIO $ createDirectoryIfMissing True tmpdir files <- handleFileUploads tmpdir defaultUploadPolicy partPolicy hndl 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 where f p = fromMaybe "-" $ partFileName p hndl _ (Left e) = throwIO e hndl partInfo (Right fp) = do !c <- liftIO $ S.readFile fp return $! (f partInfo, c) builder _ [] = mempty builder ty ((k,v):xs) = mconcat [ byteString ty , byteString ":\n" , byteString k , byteString "\nValue:\n" , byteString v , byteString "\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" remoteAddrPort :: Snap () remoteAddrPort = do rq <- getRequest let addr = rqClientAddr rq let port = rqClientPort rq let out = S.concat [ addr, ":", S.pack (show port) ] modifyResponse $ setContentLength $ fromIntegral $ S.length out writeBS out testHandler :: Snap () testHandler = withCompression $ route [ ("pong" , pongHandler ) , ("redirect" , redirect "/pong" ) , ("echo" , echoHandler ) , ("rot13" , rot13Handler ) , ("echoUri" , echoUriHandler ) , ("remoteAddrPort" , remoteAddrPort ) , ("fileserve" , noCompression >> 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-1.1.2.1/test/0000755000000000000000000000000007346545000013267 5ustar0000000000000000snap-server-1.1.2.1/test/TestSuite.hs0000644000000000000000000000610107346545000015552 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Concurrent (killThread, takeMVar) import qualified Control.Exception as E import Control.Monad (liftM) import Data.Maybe (maybeToList) #if !MIN_VERSION_network(2,7,0) import Network (withSocketsDo) #endif import System.Environment import Test.Framework (defaultMain, testGroup) ------------------------------------------------------------------------------ import qualified Snap.Internal.Http.Server.TLS as TLS ------------------------------------------------------------------------------ import qualified Snap.Internal.Http.Server.Address.Tests as Address import qualified Snap.Internal.Http.Server.Parser.Tests as Parser import qualified Snap.Internal.Http.Server.Session.Tests as Session import qualified Snap.Internal.Http.Server.Socket.Tests as Socket import qualified Snap.Internal.Http.Server.TimeoutManager.Tests as TimeoutManager import Snap.Test.Common (eatException) #ifdef HAS_SENDFILE import qualified System.SendFile.Tests as SendFile #endif import qualified Test.Blackbox #if MIN_VERSION_network(2,7,0) withSocketsDo :: IO a -> IO a withSocketsDo = id #endif ------------------------------------------------------------------------------ main :: IO () main = withSocketsDo $ TLS.withTLS $ eatException $ E.bracket (Test.Blackbox.startTestServers) cleanup (\tinfos -> do let blackboxTests = bbox tinfos defaultMain $ tests ++ blackboxTests ) where cleanup (x, y, m) = do let backends = [x, y] ++ maybeToList m mapM_ (killThread . (\(a, _, _) -> a)) backends mapM_ (takeMVar . (\(_, _, a) -> a)) backends bbox ((_, port, _), (_, port2, _), m) = [ testGroup "Blackbox" $ concat [ Test.Blackbox.tests port , Test.Blackbox.haTests port2 , Test.Blackbox.ssltests $ fmap (\(_,x,_) -> x) m ] ] tests = [ testGroup "Address" Address.tests , testGroup "Parser" Parser.tests #ifdef HAS_SENDFILE , testGroup "SendFile" SendFile.tests #endif , testGroup "Server" Session.tests , testGroup "Socket" Socket.tests , testGroup "TimeoutManager" TimeoutManager.tests ] ------------------------------------------------------------------------------ sslPort :: Int -> Maybe Int #ifdef OPENSSL sslPort sp = Just (sp + 100) #else sslPort _ = Nothing #endif ports :: Int -> (Int, Maybe Int) ports sp = (sp, sslPort sp) getStartPort :: IO Int getStartPort = (liftM read (getEnv "STARTPORT") >>= E.evaluate) `E.catch` \(_::E.SomeException) -> return 8111 snap-server-1.1.2.1/test/bad_key.pem0000644000000000000000000000157307346545000015376 0ustar0000000000000000-----BEGIN RSA PRIVATE KEY----- MIICXgIBAAKBgQDHFq5lSdMZ9yXCn/m/GPgBPq0WnKHZf0fje1CV08n5Acge28ze lUdofKEWCbuw4RE7P8OKPwH/bzcLCQSVaL3G1ehQAG5eOUzA6tkGVbT8MEW4vEed kG0SEVgcYHt2h3jFM9YVd9ojMxj1XuIykmjtinG1ThaYcHPFZgOfRr0oXwIDAQAB AoGBAIr+p9UpfIvFRASkYd3sFdQXpwqBYnIR7ePBBVsFWR5TAx+gP2ErAYbOdDyJ oRN1nu0psGBFaySlxd0bd6rETLFXMWbA0uDJcqASrlsOhsbhgPH7aExYfAi7eX8h fAwD//j2E1sS6WvNWu0YANKR2yrM9R0vcbt0GF7hlmyV7lhRAkEA+6DCI6NfbdvR jkvaxzOdC9jY/eBI9a4BbyjPLUSlTuQsGrp6s0Sj1LOQscItzqkPSutugM3f1dlG lqq31/fnqQJBAMqMOknRBlOZY8DBfCorvNXAjIenoqlqE1D4yTL+tE5C3zEyvTcF zPAaX220vf1OkL1bX4jKUxx8uXIqiYND9McCQQCWoWWWc9qMqUqJJF+TYBJjRSyg zeLfL4ssQAHF15Id5/l/BqLtLenlKpkz0EobrJi7ALTl5lhYa/kVuJzVbFIBAkEA shE17U9mUHi5yexQTILHMORmp5wo1Of8s2ME/2ANBACmV4pT7ttiXHPTEY+kt90q Qk7iXlABYToFjuj2nABSYQJAO6W9P18mM2p6vkiBuNReW6VN/ftYqq5TLK3hXh2Q 0d5v0eW9ce7CiQueH5kxq44EVVTIDiVLe2pk+BQIntMC8w== -----END RSA PRIVATE KEY----- snap-server-1.1.2.1/test/cbits/0000755000000000000000000000000007346545000014373 5ustar0000000000000000snap-server-1.1.2.1/test/cbits/errno_util.c0000644000000000000000000000007307346545000016721 0ustar0000000000000000#include void set_errno(int e) { errno = e; } snap-server-1.1.2.1/test/cert.pem0000644000000000000000000000150207346545000014725 0ustar0000000000000000-----BEGIN CERTIFICATE----- MIICOzCCAaQCCQChUcwtek3F7DANBgkqhkiG9w0BAQUFADBiMQswCQYDVQQGEwJD SDEPMA0GA1UECAwGWnVyaWNoMQ8wDQYDVQQHDAZadXJpY2gxFzAVBgNVBAoMDlNu YXAgRnJhbWV3b3JrMRgwFgYDVQQDDA9HcmVnb3J5IENvbGxpbnMwHhcNMTAxMjEx MTk1MjA0WhcNMzgwNDI3MTk1MjA0WjBiMQswCQYDVQQGEwJDSDEPMA0GA1UECAwG WnVyaWNoMQ8wDQYDVQQHDAZadXJpY2gxFzAVBgNVBAoMDlNuYXAgRnJhbWV3b3Jr MRgwFgYDVQQDDA9HcmVnb3J5IENvbGxpbnMwgZ8wDQYJKoZIhvcNAQEBBQADgY0A MIGJAoGBAMcWrmVJ0xn3JcKf+b8Y+Bs+rRacodl/R+N7UJXTyfkByB7bzN6VR2h8 oRYJu7DhETs/w4o/Af9vNwsJBJVovcbV6FAAbl45TMDq2QZVtPwwTDi8R52QbRIR WBxge3aHeMUz1hV32iMzGPVe4jKSaO2KcbVOFphwc8VmA59GvShfAgMBAAEwDQYJ KoZIhvcNAQEFBQADgYEAXsRchaVlL4RP5V+r1npL7n4W3Ge2O7F+fQ2dX6tNyqeo tMAdc6wYahg3m+PejWASVCh0vVEjBx2WYOMRPsmk/DYLUi4UwZYPrvZtbfSbMrD+ mYmZhqCDM4316qAg5OwcTON3+VZXMwbXCVM+vUCvZIw4xh6ywNjvuQjCzy7oKMg= -----END CERTIFICATE----- snap-server-1.1.2.1/test/dummy.txt0000644000000000000000000000001607346545000015160 0ustar0000000000000000TESTING 1-2-3 snap-server-1.1.2.1/test/key.pem0000644000000000000000000000157307346545000014570 0ustar0000000000000000-----BEGIN RSA PRIVATE KEY----- MIICXgIBAAKBgQDHFq5lSdMZ9yXCn/m/GPgbPq0WnKHZf0fje1CV08n5Acge28ze lUdofKEWCbuw4RE7P8OKPwH/bzcLCQSVaL3G1ehQAG5eOUzA6tkGVbT8MEw4vEed kG0SEVgcYHt2h3jFM9YVd9ojMxj1XuIykmjtinG1ThaYcHPFZgOfRr0oXwIDAQAB AoGBAIr+p9UpfIvFRASkYd3sFdQXpwqBYnIR7ePBBVsFWR5TAx+gP2ErAYbOdDyJ oRN1nu0psGBFaySlxd0bd6rETLFXMWbA0uDJcqASrlsOhsbhgPH7aExYfAi7eX8h FAwD//j2E1sS6WvNWu0YANKR2yrM9R0vcbt0GF7hlmyV7lhRAkEA+6DCI6nfbdvR jkvaxzOdC9jY/eBI9a4BbyjPLUSlTuQsGrp6s0Sj1LOQscItzqkPSutugM3f1dlG lqq31/fnqQJBAMqMOknRBlOZY8DBfCorvNXAjIenoqlqE1D4yTL+tE5C3zEyvTcF jPAaX220vf1OkL1bX4jKUxx8uXIqiYND9McCQQCWoWWWc9qMqUqJJF+TYBJjRSyg zeLfL4ssQAHF15Id5/l/BqLtLenlKpkz0EobrJi7ALTl5lhYa/kVuJzVbFIBAkEA shE17U9mUHi5yexQTILHMORmp5wo1Of8s2ME/2ANBACmV4pT7ttiXHPTEY+kt90q Qk7iXlABYToFjuj2nABSYQJAO6W9P18mM2p6vkiBuNReW6VN/ftYqq5TLK3hXh2Q 0d5v0eW9ce7CiQueH5kxq44EVVTIDiVLe2pk+BQIntMC8w== -----END RSA PRIVATE KEY----- snap-server-1.1.2.1/testserver/0000755000000000000000000000000007346545000014516 5ustar0000000000000000snap-server-1.1.2.1/testserver/Main.hs0000644000000000000000000000101707346545000015735 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} module Main where import Control.Concurrent import Control.Exception (finally) import Snap.Http.Server import Test.Common.TestHandler {- /pong /fileserve /echo pipelined POST requests slowloris attack / timeout test -} main :: IO () main = do m <- newEmptyMVar forkIO $ go m takeMVar m return () where go m = quickHttpServe testHandler `finally` putMVar m () snap-server-1.1.2.1/testserver/static/0000755000000000000000000000000007346545000016005 5ustar0000000000000000snap-server-1.1.2.1/testserver/static/hello.txt0000644000000000000000000000001407346545000017644 0ustar0000000000000000hello world