snap-server 0.4.3 → 1.1.2.1
raw patch · 86 files changed
Files
- CONTRIBUTORS +2/−0
- LICENSE +2/−2
- README.SNAP.md +8/−9
- README.md +13/−32
- Setup.hs +0/−3
- benchmark/Benchmark.hs +7/−0
- benchmark/Snap/Internal/Http/Parser/Benchmark.hs +27/−0
- benchmark/Snap/Internal/Http/Parser/Data.hs +26/−0
- extra/haddock.css +0/−436
- extra/hscolour.css +0/−15
- extra/logo.gif binary
- haddock.sh +0/−10
- pong/Main.hs +80/−0
- snap-server.cabal +484/−98
- src/Control/Concurrent/Extended.hs +106/−0
- src/Data/Concurrent/HashMap.hs +0/−237
- src/Data/Concurrent/HashMap/Internal.hs +0/−16
- src/Snap/Http/Server.hs +264/−69
- src/Snap/Http/Server/Config.hs +66/−536
- src/Snap/Http/Server/Types.hs +319/−0
- src/Snap/Internal/Http/Parser.hs +0/−278
- src/Snap/Internal/Http/Server.hs +0/−935
- src/Snap/Internal/Http/Server/Address.hs +111/−0
- src/Snap/Internal/Http/Server/Backend.hs +0/−96
- src/Snap/Internal/Http/Server/Clock.hs +44/−0
- src/Snap/Internal/Http/Server/Common.hs +40/−0
- src/Snap/Internal/Http/Server/Config.hs +856/−0
- src/Snap/Internal/Http/Server/Date.hs +37/−87
- src/Snap/Internal/Http/Server/GnuTLS.hs +0/−392
- src/Snap/Internal/Http/Server/HttpPort.hs +0/−121
- src/Snap/Internal/Http/Server/LibevBackend.hs +0/−736
- src/Snap/Internal/Http/Server/ListenHelpers.hs +0/−84
- src/Snap/Internal/Http/Server/Parser.hs +460/−0
- src/Snap/Internal/Http/Server/Session.hs +832/−0
- src/Snap/Internal/Http/Server/SimpleBackend.hs +0/−327
- src/Snap/Internal/Http/Server/Socket.hs +208/−0
- src/Snap/Internal/Http/Server/TLS.hs +165/−0
- src/Snap/Internal/Http/Server/Thread.hs +107/−0
- src/Snap/Internal/Http/Server/TimeoutManager.hs +152/−93
- src/Snap/Internal/Http/Server/Types.hs +185/−0
- src/Snap/Internal/Http/Server/gnutls_helpers.c +0/−17
- src/System/FastLogger.hs +161/−87
- src/System/SendFile.hs +0/−26
- src/System/SendFile.hsc +105/−0
- src/System/SendFile/Darwin.hsc +0/−45
- src/System/SendFile/FreeBSD.hsc +61/−27
- src/System/SendFile/Linux.hsc +64/−29
- test/Snap/Internal/Http/Server/Address/Tests.hs +73/−0
- test/Snap/Internal/Http/Server/Parser/Tests.hs +249/−0
- test/Snap/Internal/Http/Server/Session/Tests.hs +1018/−0
- test/Snap/Internal/Http/Server/Socket/Tests.hs +171/−0
- test/Snap/Internal/Http/Server/TimeoutManager/Tests.hs +136/−0
- test/Snap/Test/Common.hs +174/−0
- test/System/SendFile/Tests.hs +262/−0
- test/Test/Blackbox.hs +697/−0
- test/Test/Common/Rot13.hs +24/−0
- test/Test/Common/TestHandler.hs +193/−0
- test/TestSuite.hs +83/−0
- test/bad_key.pem +15/−0
- test/benchmark/Benchmark.hs +0/−7
- test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs +0/−30
- test/benchmark/Snap/Internal/Http/Parser/Data.hs +0/−24
- test/cbits/errno_util.c +5/−0
- test/cert.pem +14/−0
- test/common/Paths_snap_server.hs +0/−9
- test/common/Snap/Test/Common.hs +0/−89
- test/common/Test/Common/Rot13.hs +0/−19
- test/common/Test/Common/TestHandler.hs +0/−151
- test/data/fileServe/foo.bin +0/−1
- test/data/fileServe/foo.bin.bin.bin +0/−1
- test/data/fileServe/foo.html +0/−1
- test/data/fileServe/foo.txt +0/−1
- test/dummy.txt +1/−0
- test/key.pem +15/−0
- test/pongserver/Main.hs +0/−34
- test/runTestsAndCoverage.sh +0/−58
- test/snap-server-testsuite.cabal +0/−234
- test/suite/Snap/Internal/Http/Parser/Tests.hs +0/−171
- test/suite/Snap/Internal/Http/Server/Tests.hs +0/−960
- test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs +0/−76
- test/suite/Test/Blackbox.hs +0/−381
- test/suite/TestSuite.hs +0/−78
- test/testserver/Main.hs +0/−36
- test/testserver/static/hello.txt +0/−1
- testserver/Main.hs +36/−0
- testserver/static/hello.txt +1/−0
CONTRIBUTORS view
@@ -3,5 +3,7 @@ Shu-yu Guo <shu@rfrn.org> Carl Howells <chowells79@gmail.com> John Lenz <jlenz2@math.uiuc.edu>+Herbert Valerio Riedel <hvriedel@gmail.com> James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jacob@stanley.io>+Jurriën Stutterheim <j.stutterheim@me.com>
LICENSE view
@@ -1,5 +1,5 @@-Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)-Copyright (c) 2010, Google, Inc.+Copyright (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
README.SNAP.md view
@@ -11,19 +11,18 @@ The Snap core system consists of: - * a high-speed HTTP server, with an optional high-concurrency backend using- the [libev](http://software.schmorp.de/pkg/libev.html) library- * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on- [expat](http://expat.sourceforge.net/) (via- [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to- bind Haskell functionality to XML tags without getting PHP-style tag soup- all over your pants+ * 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 Snow Leopard, and is reported to work on Windows.+tested on Linux and Mac OSX, and is reported to work on Windows. Snap Philosophy
README.md view
@@ -1,25 +1,16 @@ Snap Framework HTTP Server Library ---------------------------------- +[](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, epoll-enabled, iteratee-based web-server library written in Haskell. Together with the `snap-core` library upon-which it depends, it provides a clean and efficient Haskell programming-interface to the HTTP protocol. Higher-level facilities for building web-applications (like user/session management, component interfaces, data-modeling, etc.) are not yet implemented, so this release will mostly be of-interest for those who:-- * need a fast and minimal HTTP API at roughly the same level of abstraction- as Java servlets,--or-- * are interested in contributing to the Snap Framework project.-+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 --------------------@@ -31,12 +22,8 @@ ### Optional dependencies -The `snap-server` library can optionally use the-[libev](http://software.schmorp.de/pkg/libev.html) for high-speed, O(1)-scalable socket event processing.- If you would like SSL support, `snap-server` requires the-[gnutls](http://www.gnu.org/software/gnutls/) library.+[openssl](http://www.openssl.org/) library. ## Building snap-server@@ -46,17 +33,11 @@ cabal install -to get the "stock" version of Snap. If you would like to try the optional-`libev` backend, pass the `libev` flag to `cabal install`:-- cabal install -flibev--And if you would like SSL support, pass the `gnutls` flag to `cabal install`:+to install snap-server. - cabal install -fgnutls+If you would like SSL support, pass the `openssl` flag to `cabal install`: -Note that the "`-flibev`" and "`-fgnutls`" flags are not mutually-exclusive,-and if you would like you can use them together.+ cabal install -fopenssl ## Building the Haddock Documentation@@ -75,12 +56,12 @@ `cd` into the `test/` directory and run $ cabal configure # for the stock backend, or..- $ cabal configure -flibev # for the libev backend, and/or..- $ cabal configure -fgnutls # for the SSL backend+ $ cabal configure -fopenssl # for the SSL backend+ $ cabal build From here you can invoke the testsuite by running: - $ ./runTestsAndCoverage.sh + $ ./runTestsAndCoverage.sh The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
+ benchmark/Benchmark.hs view
@@ -0,0 +1,7 @@+module Main where++import Criterion.Main+import qualified Snap.Internal.Http.Parser.Benchmark as PB++main :: IO ()+main = defaultMain [ PB.benchmarks ]
+ benchmark/Snap/Internal/Http/Parser/Benchmark.hs view
@@ -0,0 +1,27 @@+{-# 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+ ]
+ benchmark/Snap/Internal/Http/Parser/Data.hs view
@@ -0,0 +1,26 @@+{-# 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."]
− extra/haddock.css
@@ -1,436 +0,0 @@-/* -------- Global things --------- */--HTML {- background-color: #f0f3ff;- width: 100%;-}--BODY { - -moz-border-radius:5px;- -webkit-border-radius:5px;- width: 50em;- margin: 2em auto;- padding: 0;- background-color: #ffffff;- color: #000000;- font-size: 110%;- font-family: Georgia, serif;- }--A:link { color: #5200A3; text-decoration: none }-A:visited { color: #5200A3; text-decoration: none }-A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; }--TABLE.vanilla {- width: 100%;- border-width: 0px;- /* I can't seem to specify cellspacing or cellpadding properly using CSS... */-}--DL {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- letter-spacing: -0.01em;- margin: 0;-}--.vanilla .vanilla dl { font-size: 80%; }-.vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; }--TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL {- padding: 0 30px 0 34px;-}--TABLE.vanilla2 {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- border-width: 0px;-}--/* <TT> font is a little too small in MSIE */-TT, PRE, CODE {- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;- font-size: 90%;-}--LI P { margin: 0pt } --P { margin-top: 0; margin-bottom: 0.75em; }--TD {- border-width: 0px;-}--TABLE.narrow {- border-width: 0px;-}--TD.s8 { height: 0; margin:0; padding: 0 }-TD.s15 { height: 20px; }--SPAN.keyword { text-decoration: underline; }--/* Resize the buttom image to match the text size */-IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em }--/* --------- Contents page ---------- */--DIV.node {- padding-left: 3em;-}--DIV.cnode {- padding-left: 1.75em;-}--SPAN.pkg {- position: absolute;- left: 50em;-}--/* --------- Documentation elements ---------- */--TD FONT { font-weight: bold; letter-spacing: -0.02em; }--TD.children {- padding-left: 25px;- }--TD.synopsis {- padding: 2px;- background-color: #f0f0f0;- font-size: 80%;- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;-- }--TD.decl { - padding: 4px 8px;- background-color: #FAFAFA; - border-bottom: #F2F2F2 solid 1px;- border-top: #FCFCFC solid 1px;- font-size: 80%;- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;-- vertical-align: top;- }--TD.decl TD.decl {- font-size: 100%;- padding: 4px 0;- border: 0;-}--TD.topdecl {- padding: 20px 30px 0.5ex 30px;- font-size: 80%;- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;-;- vertical-align: top;-}--.vanilla .vanilla .vanilla .topdecl {- padding-left: 0;- padding-right: 0;-}--.vanilla .vanilla .vanilla {- padding-left: 30px;-}--.decl .vanilla {- padding-left: 0px !important;-}--.body .vanilla .body {- padding-left: 0;- padding-right: 0;-}--.body .vanilla .body .decl {- padding-left: 12px;-}--.body .vanilla .body div .vanilla .decl {- padding-left: 12px;-}--TABLE.declbar {- background-color: #f0f0f0;- border-spacing: 0px;- border-bottom:1px solid #d7d7df;- border-right:1px solid #d7d7df;- border-top:1px solid #f4f4f9;- border-left:1px solid #f4f4f9;- padding: 4px;- }--TD.declname {- width: 100%;- padding-right: 4px;- }--TD.declbut {- padding-left: 8px;- padding-right: 5px;- border-left-width: 1px;- border-left-color: #000099;- border-left-style: solid;- white-space: nowrap;- font-size: x-small;- }--/* - arg is just like decl, except that wrapping is not allowed. It is- used for function and constructor arguments which have a text box- to the right, where if wrapping is allowed the text box squashes up- the declaration by wrapping it.-*/-TD.arg { - padding: 2px 12px;- background-color: #f0f0f0; - font-size: 80%;- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;-- vertical-align: top;- white-space: nowrap;- }--TD.recfield { padding-left: 20px }--TD.doc { - padding-left: 38px;- font-size: 95%;- line-height: 1.66;- }--TD.ndoc { - font-size: 95%;- line-height: 1.66;- padding: 2px 4px 2px 8px;- }--TD.rdoc { - padding: 2px;- padding-left: 30px;- width: 100%;- font-size: 80%;- font-style: italic;- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- }--TD.body { - padding: 0 30px;- }--TD.pkg {- width: 100%;- padding-left: 30px-}--TABLE.indexsearch TR.indexrow {- display: none;-}-TABLE.indexsearch TR.indexshow {- display: table-row;-}--TD.indexentry {- vertical-align: top;- padding: 0 30px- }--TD.indexannot {- vertical-align: top;- padding-left: 20px;- white-space: nowrap- }--TD.indexlinks {- width: 100%- }--/* ------- Section Headings ------- */--TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;-}--TD.section1 {- padding-top: 14px;- font-weight: bold;- letter-spacing: -0.02em;- font-size: 140%- }--TD.section2 {- padding-top: 4px;- font-weight: bold;- letter-spacing: -0.02em;- font-size: 120%- }--TD.section3 {- padding-top: 5px;- font-weight: bold;- letter-spacing: -0.02em;- font-size: 105%- }--TD.section4 {- font-weight: bold;- padding-top: 12px;- padding-bottom: 4px;- letter-spacing: -0.02em;- font-size: 90%- }--/* -------------- The title bar at the top of the page */--TD.infohead {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- color: #ffffff;- font-weight: bold;- padding: 0 30px;- text-align: left;-}--TD.infoval {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- color: #ffffff;- padding: 0 30px;- text-align: left;-}--TD.topbar {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- background-color: #3465a4;- padding: 5px;- -moz-border-radius-topleft:5px;- -moz-border-radius-topright:5px;- -webkit-border-radius-topleft:5px;- -webkit-border-radius-topright:5px;-}--TD.title {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- color: #ffffff;- padding-left: 30px;- letter-spacing: -0.02em;- font-weight: bold;- width: 100%- }--TD.topbut {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- padding-left: 5px;- padding-right: 5px;- border-left-width: 1px;- border-left-color: #ffffff;- border-left-style: solid;- letter-spacing: -0.02em;- font-weight: bold;- white-space: nowrap;- }--TD.topbut A:link {- color: #ffffff- }--TD.topbut A:visited {- color: #ffff00- }--TD.topbut A:hover {- background-color: #C9D3DE;- }--TD.topbut:hover {- background-color: #C9D3DE;- }--TD.modulebar { - font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- color: #141B24;- background-color: #C9D3DE;- padding: 5px;- border-top-width: 1px;- border-top-color: #ffffff;- border-top-style: solid;- -moz-border-radius-bottomleft:5px;- -moz-border-radius-bottomright:5px;- -webkit-border-radius-bottomleft:5px;- -webkit-border-radius-bottomright:5px;-- }--/* --------- The page footer --------- */--TD.botbar {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- -moz-border-radius:5px;- -webkit-border-radius:5px;- background-color: #3465a4;- color: #ffffff;- padding: 5px- }-TD.botbar A:link {- color: #ffffff;- text-decoration: underline- }-TD.botbar A:visited {- color: #ffff00- }-TD.botbar A:hover {- background-color: #6060ff- }--/* --------- Mini Synopsis for Frame View --------- */--.outer {- margin: 0 0;- padding: 0 0;-}--.mini-synopsis {- padding: 0.25em 0.25em;-}--.mini-synopsis H1 { font-size: 120%; }-.mini-synopsis H2 { font-size: 107%; }-.mini-synopsis H3 { font-size: 100%; }-.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {- font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;- margin-top: 0.5em;- margin-bottom: 0.25em;- padding: 0 0;- font-weight: bold; letter-spacing: -0.02em;-}--.mini-synopsis H1 { border-bottom: 1px solid #ccc; }--.mini-topbar {- font-size: 120%;- background: #0077dd;- padding: 0.25em;-}--
− extra/hscolour.css
@@ -1,15 +0,0 @@-body { font-size: 90%; }--pre, code, body {- font-family: Monaco,- "DejaVu Sans Mono",- "Bitstream Vera Sans Mono",- "Lucida Console",- monospace;-}--.hs-keyglyph, .hs-layout {color: #5200A3;}-.hs-keyword {color: #3465a4; font-weight: bold;}-.hs-comment, .hs-comment a {color: #579; }-.hs-str, .hs-chr {color: #141B24;}-.hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {}
− extra/logo.gif
binary file changed (607 → absent bytes)
− haddock.sh
@@ -1,10 +0,0 @@-#!/bin/sh--set -x--HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css'--cabal haddock $HADDOCK_OPTS --hyperlink-source $@--cp extra/logo.gif dist/doc/html/snap-server/haskell_icon.gif-cp extra/hscolour.css dist/doc/html/snap-server/src/
+ pong/Main.hs view
@@ -0,0 +1,80 @@+{-# 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.cabal view
@@ -1,172 +1,558 @@ name: snap-server-version: 0.4.3-synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework+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 <http://snapframework.com/>. .- The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web- server library written in Haskell. Together with the @snap-core@ library upon- which it depends, it provides a clean and efficient Haskell programming- interface to the HTTP protocol.- .- Higher-level facilities for building web applications (like user/session- management, component interfaces, data modeling, etc.) are planned but not- yet implemented, so this release will mostly be of interest for those who:- .- * need a fast and minimal HTTP API at roughly the same level of abstraction- as Java servlets, or- .- * are interested in contributing to the Snap Framework project.+ 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: James Sanders, Gregory Collins, Doug Beardsley+author: Snap Framework Authors (see CONTRIBUTORS) maintainer: snap@snapframework.com build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.10 homepage: http://snapframework.com/-category: Web+bug-reports: https://github.com/snapframework/snap-server/issues+category: Web, Snap, IO-Streams extra-source-files: CONTRIBUTORS,- extra/haddock.css,- extra/hscolour.css,- extra/logo.gif,- haddock.sh, LICENSE, README.md, README.SNAP.md,- test/benchmark/Benchmark.hs,- test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs,- test/benchmark/Snap/Internal/Http/Parser/Data.hs,- test/common/Paths_snap_server.hs,- test/common/Snap/Test/Common.hs,- test/common/Test/Common/TestHandler.hs,- test/common/Test/Common/Rot13.hs,- test/data/fileServe/foo.bin,- test/data/fileServe/foo.bin.bin.bin,- test/data/fileServe/foo.html,- test/data/fileServe/foo.txt,- test/pongserver/Main.hs,- test/runTestsAndCoverage.sh,- test/snap-server-testsuite.cabal,- test/suite/Snap/Internal/Http/Parser/Tests.hs,- test/suite/Snap/Internal/Http/Server/Tests.hs,- test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs,- test/suite/Test/Blackbox.hs,- test/suite/TestSuite.hs,- test/testserver/Main.hs,- test/testserver/static/hello.txt-+ test/bad_key.pem,+ test/cert.pem,+ test/dummy.txt,+ test/key.pem,+ testserver/static/hello.txt -Flag libev- Description: Use libev?- Default: False+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 gnutls- Description: Enable https support using the libgnutls library.+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+ 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,- Data.Concurrent.HashMap,- Data.Concurrent.HashMap.Internal,- Snap.Internal.Http.Parser,- Snap.Internal.Http.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.Backend,- Snap.Internal.Http.Server.ListenHelpers,- Snap.Internal.Http.Server.GnuTLS,- Snap.Internal.Http.Server.HttpPort,+ 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.SimpleBackend,- Snap.Internal.Http.Server.LibevBackend+ Snap.Internal.Http.Server.TLS build-depends:- array >= 0.2 && <0.4,- attoparsec >= 0.8.1 && < 0.9,- attoparsec-enumerator >= 0.2.0.1 && < 0.3,- base >= 4 && < 5,- binary >=0.5 && <0.6,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,+ 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,- bytestring-nums,+ case-insensitive,+ clock, containers,- directory-tree,- enumerator >= 0.4.7 && <0.5,+ directory >= 1.1 && < 1.4, filepath,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- mtl == 2.0.*,- murmur-hash >= 0.1 && < 0.2,- network >= 2.3 && <2.4,+ io-streams,+ io-streams-haproxy,+ lifted-base,+ monad-control >= 1.0 && < 1.1,+ mtl,+ network, old-locale,- snap-core >= 0.4.3 && <0.5,- template-haskell,+ random >= 1.0 && < 1.3,+ snap-core,+ text,+ threads >= 0.5 && < 0.6, time, transformers,- utf8-string,- unix-compat == 0.2.*,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,- PSQueue >= 1.1 && <1.2+ 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 - if flag(libev)- build-depends: hlibev >= 0.2.8 && < 0.3- cpp-options: -DLIBEV+ -- always label threads in testsuite+ cpp-options: -DLABEL_THREADS - if flag(gnutls)- extra-libraries: gnutls gcrypt- cpp-options: -DGNUTLS- c-sources: src/Snap/Internal/Http/Server/gnutls_helpers.c+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL,+ openssl-streams if os(linux) && !flag(portable)- cpp-options: -DLINUX -DHAS_SENDFILE+ cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile,- System.SendFile.Linux+ System.SendFile.Linux,+ System.SendFile.Tests+ c-sources: test/cbits/errno_util.c if os(darwin) && !flag(portable)- cpp-options: -DOSX -DHAS_SENDFILE+ 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.Darwin+ 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+ cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS other-modules: System.SendFile, System.SendFile.FreeBSD - ghc-prof-options: -prof -auto-all+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL,+ openssl-streams - if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind+ 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- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ 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: http://git.snapframework.com/snap-server.git+ location: git://github.com/snapframework/snap-server.git
+ src/Control/Concurrent/Extended.hs view
@@ -0,0 +1,106 @@+{-# 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
− src/Data/Concurrent/HashMap.hs
@@ -1,237 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Concurrent.HashMap- ( HashMap- , new- , new'- , null- , insert- , delete- , lookup- , update- , fromList- , toList- , hashString- , hashBS- , hashInt- , nextHighestPowerOf2 ) where----------------------------------------------------------------------------------import Control.Concurrent.MVar-import Control.Monad-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.Digest.Murmur32 as Murmur-import qualified Data.Digest.Murmur64 as Murmur-import Data.IntMap (IntMap)-import qualified Data.IntMap as IM-import Data.Maybe-import qualified Data.Vector as V-import Data.Vector (Vector)-import GHC.Conc (numCapabilities)-import Prelude hiding (lookup, null)-import qualified Prelude--#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts ( Word(..), Int(..), shiftRL# )-#else-import Data.Word-#endif--import Data.Concurrent.HashMap.Internal---hashString :: String -> Word-hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]- [| Murmur.asWord64 . Murmur.hash64 |])-{-# INLINE hashString #-}---hashInt :: Int -> Word-hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]- [| Murmur.asWord64 . Murmur.hash64 |])-{-# INLINE hashInt #-}---hashBS :: B.ByteString -> Word-hashBS =- $(let h32 = [| \s -> s `seq`- Murmur.asWord32 $- B.foldl' (\h c -> h `seq` c `seq`- Murmur.hash32AddInt (fromEnum c) h)- (Murmur.hash32 ([] :: [Int]))- s- |]- h64 = [| \s -> s `seq`- Murmur.asWord64 $- B.foldl' (\h c -> h `seq` c `seq`- Murmur.hash64AddInt (fromEnum c) h)- (Murmur.hash64 ([] :: [Int]))- s- |]- in whichHash h32 h64)-{-# INLINE hashBS #-}---data HashMap k v = HM {- _hash :: !(k -> Word)- , _hashToBucket :: !(Word -> Word)- , _maps :: !(Vector (MVar (Submap k v)))-}----null :: HashMap k v -> IO Bool-null ht = liftM V.and $ V.mapM f $ _maps ht-- where- f mv = withMVar mv (return . IM.null)---new' :: Eq k =>- Int -- ^ number of locks to use- -> (k -> Word) -- ^ hash function- -> IO (HashMap k v)-new' numLocks hashFunc = do- vector <- V.replicateM (fromEnum n) (newMVar IM.empty)- return $! HM hf bh vector-- where- hf !x = hashFunc x- bh !x = x .&. (n-1)- !n = nextHighestPowerOf2 $ toEnum numLocks---new :: Eq k =>- (k -> Word) -- ^ hash function- -> IO (HashMap k v)-new = new' defaultNumberOfLocks---insert :: k -> v -> HashMap k v -> IO ()-insert key value ht =- modifyMVar_ submap $ \m ->- return $! insSubmap hashcode key value m-- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---delete :: (Eq k) => k -> HashMap k v -> IO ()-delete key ht =- modifyMVar_ submap $ \m ->- return $! delSubmap hashcode key m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---lookup :: (Eq k) => k -> HashMap k v -> IO (Maybe v)-lookup key ht =- withMVar submap $ \m ->- return $! lookupSubmap hashcode key m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---update :: (Eq k) => k -> v -> HashMap k v -> IO Bool-update key value ht =- modifyMVar submap $ \m ->- return $! updateSubmap hashcode key value m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---toList :: HashMap k v -> IO [(k,v)]-toList ht = liftM (concat . V.toList) $ V.mapM f $ _maps ht- where- f m = withMVar m $ \sm -> return $ concat $ IM.elems sm---fromList :: (Eq k) => (k -> Word) -> [(k,v)] -> IO (HashMap k v)-fromList hf xs = do- ht <- new hf- mapM_ (\(k,v) -> insert k v ht) xs- return $! ht------------------------------------------------------------------------------------ helper functions----------------------------------------------------------------------------------- nicked this technique from Data.IntMap--shiftRL :: Word -> Int -> Word-#if __GLASGOW_HASKELL__-{--------------------------------------------------------------------- GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-shiftRL (W# x) (I# i)- = W# (shiftRL# x i)-#else-shiftRL x i = shiftR x i-#endif---type Submap k v = IntMap [(k,v)]---nextHighestPowerOf2 :: Word -> Word-nextHighestPowerOf2 w = highestBitMask (w-1) + 1---highestBitMask :: Word -> Word-highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of- x1 -> case (x1 .|. shiftRL x1 2) of- x2 -> case (x2 .|. shiftRL x2 4) of- x3 -> case (x3 .|. shiftRL x3 8) of- x4 -> case (x4 .|. shiftRL x4 16) of- x5 -> x5 .|. shiftRL x5 32----insSubmap :: Word -> k -> v -> Submap k v -> Submap k v-insSubmap hashcode key value m = let !x = f m in x- where- f = IM.insertWith (++) (fromIntegral hashcode) [(key,value)]---delSubmap :: (Eq k) => Word -> k -> Submap k v -> Submap k v-delSubmap hashcode key m =- let !z = IM.update f (fromIntegral hashcode) m in z-- where- f l = let l' = del l in if Prelude.null l' then Nothing else Just l'-- del = filter ((/= key) . fst)---lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v-lookupSubmap hashcode key m = maybe Nothing (Prelude.lookup key) mbBucket- where- mbBucket = IM.lookup (fromIntegral hashcode) m---updateSubmap :: (Eq k) => Word -> k -> v -> Submap k v -> (Submap k v, Bool)-updateSubmap hashcode key value m = (m'', b)- where- oldV = lookupSubmap hashcode key m- m' = maybe m (const $ delSubmap hashcode key m) oldV- m'' = insSubmap hashcode key value m'- b = isJust oldV---defaultNumberOfLocks :: Int-defaultNumberOfLocks = 8 * numCapabilities
− src/Data/Concurrent/HashMap/Internal.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Concurrent.HashMap.Internal where--import Data.Bits-import Data.Word-import Language.Haskell.TH---whichHash :: ExpQ -> ExpQ -> Q Exp-whichHash as32 as64 = if bitSize (undefined :: Word) == 32- then [| \x -> fromIntegral $ $as32 x |]- else [| \x -> fromIntegral $ $as64 x |]
src/Snap/Http/Server.hs view
@@ -1,117 +1,312 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--{-|--The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web-server library written in Haskell. Together with the @snap-core@ library upon-which it depends, it provides a clean and efficient Haskell programming-interface to the HTTP protocol.---}+{-# 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.Monad-import Control.Monad.CatchIO-import Data.ByteString (ByteString)-import Data.Char-import Data.List-import Data.Maybe-import Prelude hiding (catch)-import Snap.Http.Server.Config-import qualified Snap.Internal.Http.Server as Int-import Snap.Types-import Snap.Util.GZip+------------------------------------------------------------------------------+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 System.IO+------------------------------------------------------------------------------+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 = Int.snapServerVersion+snapServerVersion = S.pack $! showVersion V.version --------------------------------------------------------------------------------- | Starts serving HTTP requests using the given handler. Uses only the basic--- settings from the given config; error handling and compression are ignored.--- This function never returns; to shut down the HTTP server, kill the--- controlling thread.+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- setUnicodeLocale $ fromJust $ getLocale conf- Int.httpServe tout- (map listenToInt $ getListen conf)- (fmap backendToInt $ getBackend conf)- (fromJust $ getHostname conf)- (fromJust $ getAccessLog conf)- (fromJust $ getErrorLog conf)- (runSnap handler)+ 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- tout = fromMaybe 60 $ getDefaultTimeout config- conf = completeConfig config- listenToInt (ListenHttp b p) = Int.HttpPort b p- listenToInt (ListenHttps b p c k) = Int.HttpsPort b p c k- backendToInt ConfigSimpleBackend = Int.EventLoopSimple- backendToInt ConfigLibEvBackend = Int.EventLoopLibEv+ 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 () -> Snap () -> IO ()-httpServe config handler = do- mapM_ (output . ("Listening on "++) . show) $ getListen conf- serve handler `finally` output "\nShutting down..."+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- conf = completeConfig config- output = when (fromJust $ getVerbose conf) . hPutStrLn stderr- serve = simpleHttpServe config . compress . catch500- catch500 = flip catch $ fromJust $ getErrorHandler conf- compress = if fromJust $ getCompression conf then withCompression else id+ 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 m = commandLineConfig emptyConfig >>= \c -> httpServe c m+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 ()-setUnicodeLocale lang = #ifndef PORTABLE- 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" ]+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- return ()+setUnicodeLocale = const $ return () #endif++------------------------------------------------------------------------------+bshow :: (Show a) => a -> ByteString+bshow = S.pack . show
src/Snap/Http/Server/Config.hs view
@@ -1,563 +1,93 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--{-|--This module exports the 'Config' datatype which represents partially-specified-configurations of \"serve\" functions which run 'Snap' actions in 'IO'.---}-+------------------------------------------------------------------------------+-- | This module exports the 'Config' datatype, which you can use to configure+-- the Snap HTTP server.+-- module Snap.Http.Server.Config ( Config- , ConfigListen(..)- , ConfigBackend(..)+ , ConfigLog(..)+ , ProxyType+ , emptyConfig , defaultConfig- , completeConfig , commandLineConfig+ , extendedCommandLineConfig+ , completeConfig - , getHostname- , getListen+ , optDescrs+ , fmapOpt+ , getAccessLog- , getErrorLog- , getLocale- , getBackend+ , getBind , getCompression- , getVerbose- , getErrorHandler , getDefaultTimeout+ , getErrorHandler+ , getErrorLog+ , getHostname+ , getLocale , getOther+ , getPort+ , getProxyType+ , getSSLBind+ , getSSLCert+ , getSSLKey+ , getSSLChainCert+ , getSSLPort+ , getVerbose+ , getStartupHook+ , getUnixSocket+ , getUnixSocketAccessMode - , setHostname- , addListen- , setListen , setAccessLog- , setErrorLog- , setLocale- , setBackend+ , setBind , setCompression- , setVerbose- , setErrorHandler , setDefaultTimeout+ , setErrorHandler+ , setErrorLog+ , setHostname+ , setLocale , setOther- ) where--import Blaze.ByteString.Builder-import Control.Exception (SomeException)-import Control.Monad-import qualified Data.ByteString.UTF8 as U-import qualified Data.ByteString.Char8 as B-import Data.ByteString (ByteString)-import Data.Char-import Data.List-import Data.Monoid-import Prelude hiding (catch)-import Snap.Types-import Snap.Iteratee ((>==>), enumBuilder)-import Snap.Internal.Debug (debug)-import System.Console.GetOpt-import System.Environment hiding (getEnv)-#ifndef PORTABLE-import System.Posix.Env-#endif-import System.Exit-import System.IO----------------------------------------------------------------------------------- | A data type to store the bind address and port to listen on.------ For SSL support, it also stores the path to the certificate in PEM format--- and the path to the private key in PEM format-data ConfigListen = ListenHttp ByteString Int- | ListenHttps ByteString Int FilePath FilePath---instance Show ConfigListen where- show (ListenHttp b p) = "http://" ++ U.toString b ++ ":" ++ show p- show (ListenHttps b p c k) =- "https://" ++ U.toString b ++ ":" ++ show p ++- " (cert = " ++ show c ++ ", key = " ++ show k ++ ")"------------------------------------------------------------------------------------ | A data type to record which backend event loop should be used when--- serving data.-data ConfigBackend = ConfigSimpleBackend- | ConfigLibEvBackend- deriving (Eq,Show)------------------------------------------------------------------------------------ | 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:------ > addListen (ListenHttp "0.0.0.0" 9000) 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 MonadSnap m => Config m a = Config- { hostname :: Maybe ByteString- -- ^ The name of the server- , listen :: [ConfigListen]- -- ^ The local interfaces to listen on- , accessLog :: Maybe (Maybe FilePath)- -- ^ The path to the access log- , errorLog :: Maybe (Maybe FilePath)- -- ^ The path to the error log- , locale :: Maybe String- -- ^ The locale to use- , backend :: Maybe ConfigBackend- -- ^ The backend to use- , compression :: Maybe Bool- -- ^ Whether to use compression- , verbose :: Maybe Bool- -- ^ Whether to write server status updates to stderr- , errorHandler :: Maybe (SomeException -> m ())- -- ^ A MonadSnap action to handle 500 errors- , defaultTimeout :: Maybe Int- , other :: Maybe a- -- ^ This is for any other state needed to initialize a custom server- }----------------------------------------------------------------------------------instance MonadSnap m => Show (Config m a) where- show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c)- [ showM "hostname" . hostname- , showL "listen" . listen- , showM "accessLog" . accessLog- , showM "errorLog" . errorLog- , showM "locale" . locale- , showM "backend" . backend- , showM "compression" . compression- , showM "verbose" . verbose- , showM "errorHandler" . fmap (const ()) . errorHandler- , showM "defaultTimeout" . fmap (const ()) . defaultTimeout- ]) ++ "}"- where- showM s = maybe "" ((++) (s ++ " = ") . show)- showL s l = s ++ " = " ++ show l------------------------------------------------------------------------------------ | Returns a completely empty 'Config'. Equivalent to 'mempty' from--- 'Config''s 'Monoid' instance.-emptyConfig :: MonadSnap m => Config m a-emptyConfig = mempty----------------------------------------------------------------------------------instance MonadSnap m => Monoid (Config m a) where- mempty = Config- { hostname = Nothing- , listen = []- , accessLog = Nothing- , errorLog = Nothing- , locale = Nothing- , backend = Nothing- , compression = Nothing- , verbose = Nothing- , errorHandler = Nothing- , defaultTimeout = Nothing- , other = Nothing- }-- a `mappend` b = Config- { hostname = (hostname b) `mplus` (hostname a)- , listen = (listen b) ++ (listen a)- , accessLog = (accessLog b) `mplus` (accessLog a)- , errorLog = (errorLog b) `mplus` (errorLog a)- , locale = (locale b) `mplus` (locale a)- , backend = (backend b) `mplus` (backend a)- , compression = (compression b) `mplus` (compression a)- , verbose = (verbose b) `mplus` (verbose a)- , errorHandler = (errorHandler b) `mplus` (errorHandler a)- , defaultTimeout = (defaultTimeout b) `mplus` (defaultTimeout a)- , other = (other b) `mplus` (other a)- }------------------------------------------------------------------------------------ | These are the default values for all the fields in 'Config'.------ > hostname = "localhost"--- > listen = []--- > accessLog = "log/access.log"--- > errorLog = "log/error.log"--- > locale = "en_US"--- > backend = Nothing (the backend is selected based on compile options)--- > compression = True--- > verbose = True--- > errorHandler = prints the error message----defaultConfig :: MonadSnap m => Config m a-defaultConfig = Config- { hostname = Just "localhost"- , listen = []- , accessLog = Just $ Just "log/access.log"- , errorLog = Just $ Just "log/error.log"- , locale = Just "en_US"- , backend = Nothing- , compression = Just True- , verbose = Just True- , errorHandler = Just defaultErrorHandler- , defaultTimeout = Just 60- , other = Nothing- }----------------------------------------------------------------------------------defaultErrorHandler :: MonadSnap m => SomeException -> m ()-defaultErrorHandler e = do- debug "Snap.Http.Server.Config errorHandler: got exception:"- debug $ show e- logError msg- finishWith $ setContentType "text/plain; charset=utf-8"- . setContentLength (fromIntegral $ B.length msg)- . setResponseStatus 500 "Internal Server Error"- . modifyResponseBody- (>==> enumBuilder (fromByteString msg))- $ emptyResponse- where - err = U.fromString $ show e- msg = mappend "A web handler threw an exception. Details:\n" err----------------------------------------------------------------------------------- | Completes a partial 'Config' by filling in the unspecified values with--- the default values from 'defaultConfig'. Also, if no listeners are--- specified, adds a http listener on 0.0.0.0:8000-completeConfig :: MonadSnap m => Config m a -> Config m a-completeConfig c = case listen c' of- [] -> addListen (ListenHttp "0.0.0.0" 8000) c'- _ -> c'- where c' = mappend defaultConfig c------------------------------------------------------------------------------------ | A data structure used during command-line option parsing------ The Config data type allows a list of listen ports, but the command line--- options only allow one http and one https listener. This data structure--- is used during option parsing-data MonadSnap m => OptionData m a = OptionData- { config :: Config m a- , bind :: Maybe ByteString- , port :: Maybe Int- , sslbind :: Maybe ByteString- , sslport :: Maybe Int- , sslcert :: Maybe FilePath- , sslkey :: Maybe FilePath- , tout :: Maybe Int- }----------------------------------------------------------------------------------instance MonadSnap m => Monoid (OptionData m a) where- mempty = OptionData- { config = mempty- , bind = Nothing- , port = Nothing- , sslbind = Nothing- , sslport = Nothing- , sslcert = Nothing- , sslkey = Nothing- , tout = Nothing- }-- a `mappend` b = OptionData- { config = (config b) `mappend` (config a)- , bind = (bind b) `mplus` (bind a)- , port = (port b) `mplus` (port a)- , sslbind = (sslbind b) `mplus` (sslbind a)- , sslport = (sslport b) `mplus` (sslport a)- , sslcert = (sslcert b) `mplus` (sslcert a)- , sslkey = (sslkey b) `mplus` (sslkey a)- , tout = (tout b) `mplus` (tout a)- }------------------------------------------------------------------------------------ | These are the default values for the options-defaultOptions :: MonadSnap m => OptionData m a-defaultOptions = OptionData- { config = defaultConfig- , bind = Just "0.0.0.0"- , port = Just 8000- , sslbind = Just "0.0.0.0"- , sslport = Nothing- , sslcert = Just "cert.pem"- , sslkey = Just "key.pem"- , tout = Just 60- }------------------------------------------------------------------------------------ | Convert options to config-optionsToConfig :: MonadSnap m => OptionData m a -> Config m a-optionsToConfig o = mconcat $ [config o] ++ http ++ https ++ [tmOut]- where lhttp = maybe2 [] ListenHttp (bind o) (port o)- lhttps = maybe4 [] ListenHttps (sslbind o)- (sslport o)- (sslcert o)- (sslkey o)- http = map (flip addListen mempty) lhttp- https = map (flip addListen mempty) lhttps-- maybe2 _ f (Just a) (Just b) = [f a b]- maybe2 d _ _ _ = d- maybe4 _ f (Just a) (Just b) (Just c) (Just d) = [f a b c d]- maybe4 d _ _ _ _ _ = d-- tmOut = maybe mempty- (\t -> mempty { defaultTimeout = Just t })- (tout o)----------------------------------------------------------------------------------- | Convert config to options-configToOptions :: MonadSnap m => Config m a -> OptionData m a-configToOptions c = OptionData- { config = c- , bind = Nothing- , port = Nothing- , sslbind = Nothing- , sslport = Nothing- , sslcert = Nothing- , sslkey = Nothing- , tout = (defaultTimeout c)- }------------------------------------------------------------------------------------ | A description of the command-line options accepted by--- 'commandLineConfig'.------ The 'OptionData' parameter is just for specifying any default values which--- are to override those in 'defaultOptions'. This is so the usage message can--- accurately inform the user what the default values for the options are. In--- most cases, you will probably just end up passing 'mempty' for this--- parameter.------ The return type is a list of options describing @'Maybe' ('OptionData' m)@--- as opposed to @'OptionData' m@, because if the @--help@ option is given,--- the set of command-line options no longer describe a config, but an action--- (printing out the usage message).-options :: MonadSnap m- => OptionData m a- -> [OptDescr (Maybe (OptionData m a))]-options defaults =- [ Option [] ["hostname"]- (ReqArg (Just . setConfig setHostname . U.fromString) "NAME")- $ "local hostname" ++ defaultC getHostname- , Option ['b'] ["address"]- (ReqArg (\s -> Just $ mempty { bind = Just $ U.fromString 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 $ U.fromString 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-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 . Just) "PATH")- $ "access log" ++ (defaultC $ join . getAccessLog)- , Option [] ["error-log"]- (ReqArg (Just . setConfig setErrorLog . Just) "PATH")- $ "error log" ++ (defaultC $ join . getErrorLog)- , Option [] ["no-access-log"]- (NoArg $ Just $ setConfig setErrorLog Nothing)- $ "don't have an access log"- , Option [] ["no-error-log"]- (NoArg $ Just $ setConfig setAccessLog Nothing)- $ "don't have an error log"- , Option ['c'] ["compression"]- (NoArg $ Just $ setConfig setCompression True)- $ "use gzip compression on responses"- , Option ['t'] ["timeout"]- (ReqArg (\t -> Just $ mempty { tout = Just $ read t}) "SECS")- $ "set default timeout in seconds"- , Option [] ["no-compression"]- (NoArg $ Just $ setConfig setCompression False)- $ "serve responses uncompressed"- , Option ['v'] ["verbose"]- (NoArg $ Just $ setConfig setVerbose True)- $ "print server status updates to stderr"- , Option ['q'] ["quiet"]- (NoArg $ Just $ setConfig setVerbose False)- $ "do not print anything to stderr"- , Option ['h'] ["help"]- (NoArg Nothing)- $ "display this help and exit"- ]- where- setConfig f c = configToOptions $ f c mempty- conf = completeConfig $ config defaults- opts = mappend defaultOptions defaults- defaultC f = maybe "" ((", default " ++) . show) $ f conf- defaultO f = maybe ", default off" ((", default " ++) . show) $ f opts------------------------------------------------------------------------------------ | This returns a 'Config' gotten from parsing the options specified on the--- command-line.------ The 'Config' parameter is just for specifying any default values which are--- to override those in 'defaultConfig'. This is so the usage message can--- accurately inform the user what the default values for the options are. In--- most cases, you will probably just end up passing 'mempty' for this--- parameter.------ On Unix systems, the locale is read from the @LANG@ environment variable.-commandLineConfig :: MonadSnap m => Config m a -> IO (Config m a)-commandLineConfig defaults = do- args <- getArgs- prog <- getProgName-- result <- either (usage prog) return $ case getOpt Permute opts args of- (f, _, [] ) -> maybe (Left []) Right $ fmap mconcat $ sequence f- (_, _, errs) -> Left errs-- let result' = optionsToConfig $ mappend defaultOptions result--#ifndef PORTABLE- lang <- getEnv "LANG"- return $ mconcat [defaults, result', mempty {locale = fmap upToUtf8 lang}]-#else- return $ mconcat [defaults, result']-#endif-- where- opts = options $ configToOptions defaults- usage prog errs = do- let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:"- let msg = concat errs ++ usageInfo hdr opts- hPutStrLn stderr msg- exitFailure- upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c----------------------------------------------------------------------------------getHostname :: MonadSnap m => Config m a -> Maybe ByteString-getHostname = hostname----------------------------------------------------------------------------------getListen :: MonadSnap m => Config m a -> [ConfigListen]-getListen = listen----------------------------------------------------------------------------------getAccessLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)-getAccessLog = accessLog----------------------------------------------------------------------------------getErrorLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)-getErrorLog = errorLog----------------------------------------------------------------------------------getLocale :: MonadSnap m => Config m a -> Maybe String-getLocale = locale----------------------------------------------------------------------------------getBackend :: MonadSnap m => Config m a -> Maybe ConfigBackend-getBackend = backend---------------------------------------------------------------------------------getCompression :: MonadSnap m => Config m a -> Maybe Bool-getCompression = compression----------------------------------------------------------------------------------getVerbose :: MonadSnap m => Config m a -> Maybe Bool-getVerbose = verbose----------------------------------------------------------------------------------getErrorHandler :: MonadSnap m => Config m a -> Maybe (SomeException -> m ())-getErrorHandler = errorHandler----------------------------------------------------------------------------------getOther :: MonadSnap m => Config m a -> Maybe a-getOther = other----------------------------------------------------------------------------------getDefaultTimeout :: MonadSnap m => Config m a -> Maybe Int-getDefaultTimeout = defaultTimeout----------------------------------------------------------------------------------setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a-setHostname a m = m {hostname = Just a}----------------------------------------------------------------------------------addListen :: MonadSnap m => ConfigListen -> Config m a -> Config m a-addListen a m = m {listen = a : listen m}----------------------------------------------------------------------------------setListen :: MonadSnap m => [ConfigListen] -> Config m a -> Config m a-setListen a m = m {listen = a}----------------------------------------------------------------------------------setAccessLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a-setAccessLog a m = m {accessLog = Just a}----------------------------------------------------------------------------------setErrorLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a-setErrorLog a m = m {errorLog = Just a}----------------------------------------------------------------------------------setLocale :: MonadSnap m => String -> Config m a -> Config m a-setLocale a m = m {locale = Just a}----------------------------------------------------------------------------------setBackend :: MonadSnap m => ConfigBackend -> Config m a -> Config m a-setBackend a m = m { backend = Just a}-+ , setPort+ , setProxyType+ , setSSLBind+ , setSSLCert+ , setSSLKey+ , setSSLChainCert+ , setSSLPort+ , setVerbose+ , setUnixSocket+ , setUnixSocketAccessMode --------------------------------------------------------------------------------setCompression :: MonadSnap m => Bool -> Config m a -> Config m a-setCompression a m = m {compression = Just a}+ , setStartupHook+ , StartupInfo+ , getStartupSockets+ , getStartupConfig + -- ** Proxy protocol selection+ , noProxy+ , xForwardedFor+ , haProxy+ ) where -------------------------------------------------------------------------------setVerbose :: MonadSnap m => Bool -> Config m a -> Config m a-setVerbose a m = m {verbose = Just a}+import Snap.Internal.Http.Server.Config -------------------------------------------------------------------------------setErrorHandler :: MonadSnap m => (SomeException -> m ()) -> Config m a- -> Config m a-setErrorHandler a m = m {errorHandler = Just a}+-- | Configure Snap in direct / non-proxying mode.+noProxy :: ProxyType+noProxy = NoProxy -------------------------------------------------------------------------------setOther :: MonadSnap m => a -> Config m a -> Config m a-setOther a m = m {other = Just a}-+-- | 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 -------------------------------------------------------------------------------setDefaultTimeout :: MonadSnap m => Int -> Config m a -> Config m a-setDefaultTimeout t m = m {defaultTimeout = Just t}+-- | Assert that Snap is running behind a proxy running the HaProxy protocol+-- (see <http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt>).+-- In this mode connections that don't obey the proxy protocol are rejected.+haProxy :: ProxyType+haProxy = HaProxy
+ src/Snap/Http/Server/Types.hs view
@@ -0,0 +1,319 @@+{-# 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@ (<https://github.com/etsy/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
− src/Snap/Internal/Http/Parser.hs
@@ -1,278 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}--module Snap.Internal.Http.Parser- ( IRequest(..)- , HttpParseException- , parseRequest- , readChunkedTransferEncoding- , iterParser- , parseCookie- , parseUrlEncoded- , strictize- ) where----------------------------------------------------------------------------------import Control.Arrow (second)-import Control.Exception-import Control.Monad (liftM)-import Control.Monad.Trans-import Data.Attoparsec hiding (many, Result(..))-import Data.Attoparsec.Enumerator-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Unsafe as S-import Data.ByteString.Internal (w2c)-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Nums.Careless.Hex as Cvt-import Data.Char-import Data.List (foldl')-import Data.Int-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes)-import Data.Typeable-import Prelude hiding (head, take, takeWhile)------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Debug-import Snap.Internal.Iteratee.Debug-import Snap.Internal.Parsing hiding (pHeaders)-import Snap.Iteratee hiding (map, take)------------------------------------------------------------------------------------ | an internal version of the headers part of an HTTP request-data IRequest = IRequest- { iMethod :: Method- , iRequestUri :: ByteString- , iHttpVersion :: (Int,Int)- , iRequestHeaders :: [(ByteString, ByteString)]- }----------------------------------------------------------------------------------instance Show IRequest where- show (IRequest m u v r) =- concat [ show m- , " "- , show u- , " "- , show v- , " "- , show r ]----------------------------------------------------------------------------------data HttpParseException = HttpParseException String deriving (Typeable, Show)-instance Exception HttpParseException---------------------------------------------------------------------------------parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)-parseRequest = do- eof <- isEOF- if eof- then return Nothing- else do- line <- pLine- if S.null line- then parseRequest- else do- let (!mStr,!s) = bSp line- let (!uri,!vStr) = bSp s-- !method <- methodFromString mStr-- let ver@(!_,!_) = pVer vStr-- hdrs <- pHeaders- return $ Just $ IRequest method uri ver hdrs-- where- pVer s = if S.isPrefixOf "HTTP/" s- then let (a,b) = bDot $ S.drop 5 s- in (read $ S.unpack a, read $ S.unpack b)- else (1,0)-- isSp = (== ' ')- bSp = splitWith isSp- isDot = (== '.')- bDot = splitWith isDot----------------------------------------------------------------------------------pLine :: (Monad m) => Iteratee ByteString m ByteString-pLine = continue $ k S.empty- where- k _ EOF = throwError $- HttpParseException "parse error: expected line ending in crlf"- k !pre (Chunks xs) =- if S.null b- then continue $ k a- else yield a (Chunks [S.drop 2 b])- where- (!a,!b) = S.breakSubstring "\r\n" s- !s = S.append pre s'- !s' = S.concat xs----------------------------------------------------------------------------------splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString)-splitWith !f !s = let (!a,!b) = S.break f s- !b' = S.dropWhile f b- in (a, b')----------------------------------------------------------------------------------pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)]-pHeaders = do- f <- go id- return $! f []- where- go !dlistSoFar = {-# SCC "pHeaders/go" #-} do- line <- pLine- if S.null line- then return dlistSoFar- else do- let (!k,!v) = pOne line- vf <- pCont id- let vs = vf []- let !v' = S.concat (v:vs)- go (dlistSoFar . ((k,v'):))-- where- pOne s = let (k,v) = splitWith (== ':') s- in (trim k, trim v)-- isCont c = c == ' ' || c == '\t'-- pCont !dlist = do- mbS <- peek- maybe (return dlist)- (\s -> if S.null s- then head >> pCont dlist- else if isCont $ w2c $ S.unsafeHead s- then procCont dlist- else return dlist)- mbS-- procCont !dlist = do- line <- pLine- let !t = trim line- pCont (dlist . (" ":) . (t:))----------------------------------------------------------------------------------methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method-methodFromString "GET" = return GET-methodFromString "POST" = return POST-methodFromString "HEAD" = return HEAD-methodFromString "PUT" = return PUT-methodFromString "DELETE" = return DELETE-methodFromString "TRACE" = return TRACE-methodFromString "OPTIONS" = return OPTIONS-methodFromString "CONNECT" = return CONNECT-methodFromString s = - throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'"----------------------------------------------------------------------------------readChunkedTransferEncoding :: (MonadIO m) =>- Enumeratee ByteString ByteString m a-readChunkedTransferEncoding =- chunkParserToEnumeratee $- iterateeDebugWrapper "pGetTransferChunk" $- iterParser pGetTransferChunk----------------------------------------------------------------------------------chunkParserToEnumeratee :: (MonadIO m) =>- Iteratee ByteString m (Maybe ByteString)- -> Enumeratee ByteString ByteString m a-chunkParserToEnumeratee getChunk client = do- mbB <- getChunk- maybe finishIt sendBS mbB-- where- sendBS s = do- step <- lift $ runIteratee $ enumBS s client- chunkParserToEnumeratee getChunk step-- finishIt = lift $ runIteratee $ enumEOF client------------------------------------------------------------------------------------ parse functions----------------------------------------------------------------------------------------------------------------------------------------------------------------pGetTransferChunk :: Parser (Maybe ByteString)-pGetTransferChunk = do- !hex <- liftM fromHex $ (takeWhile (isHexDigit . w2c))- takeTill ((== '\r') . w2c)- crlf- if hex <= 0- then return Nothing- else do- x <- take hex- crlf- return $ Just x- where- fromHex :: ByteString -> Int- fromHex s = Cvt.hex (L.fromChunks [s])------------------------------------------------------------------------------------ COOKIE PARSING----------------------------------------------------------------------------------- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109--- (cookie spec): please point out any errors!---------------------------------------------------------------------------------pCookies :: Parser [Cookie]-pCookies = do- -- grab kvps and turn to strict bytestrings- kvps <- pAvPairs-- return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps-- where- toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing----------------------------------------------------------------------------------parseCookie :: ByteString -> Maybe [Cookie]-parseCookie = parseToCompletion pCookies------------------------------------------------------------------------------------ application/x-www-form-urlencoded----------------------------------------------------------------------------------------------------------------------------------------------------------------parseUrlEncoded :: ByteString -> Map ByteString [ByteString]-parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith' (++) k [v] m)- Map.empty- decoded- where- breakApart = (second (S.drop 1)) . S.break (== '=')-- parts :: [(ByteString,ByteString)]- parts = map breakApart $ S.split '&' s-- urldecode = parseToCompletion pUrlEscaped-- decodeOne (a,b) = do- a' <- urldecode a- b' <- urldecode b- return (a',b')-- decoded = catMaybes $ map decodeOne parts--
− src/Snap/Internal/Http/Server.hs
@@ -1,935 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Server where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-import Blaze.ByteString.Builder.Enumerator-import Blaze.ByteString.Builder.HTTP-import Control.Arrow (first, second)-import Control.Monad.State.Strict-import Control.Exception-import Data.Char-import Data.CIByteString-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as SC-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Nums.Careless.Int as Cvt-import Data.Int-import Data.IORef-import Data.List (foldl')-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromJust, fromMaybe)-import Data.Monoid-import Data.Time-import Data.Typeable-import Data.Version-import GHC.Conc-import System.PosixCompat.Files hiding (setFileSize)-import System.Posix.Types (FileOffset)-import System.Locale--------------------------------------------------------------------------------import System.FastLogger-import Snap.Internal.Http.Types-import Snap.Internal.Debug-import Snap.Internal.Http.Parser-import Snap.Internal.Http.Server.Date--import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Server.HttpPort-import qualified Snap.Internal.Http.Server.GnuTLS as TLS-import Snap.Internal.Http.Server.SimpleBackend-import Snap.Internal.Http.Server.LibevBackend--import Snap.Internal.Iteratee.Debug-import Snap.Iteratee hiding (head, take, map)-import qualified Snap.Iteratee as I--import qualified Paths_snap_server as V------------------------------------------------------------------------------------ | The handler has to return the request object because we have to clear the--- HTTP request body before we send the response. If the handler consumes the--- request body, it is responsible for setting @rqBody=return@ in the returned--- request (otherwise we will mess up reading the input stream).------ Note that we won't be bothering end users with this -- the details will be--- hidden inside the Snap monad-type ServerHandler = (ByteString -> IO ())- -> (Int -> IO ())- -> Request- -> Iteratee ByteString IO (Request,Response)----------------------------------------------------------------------------------type ServerMonad = StateT ServerState (Iteratee ByteString IO)----------------------------------------------------------------------------------data ListenPort =- -- (bind address, port)- HttpPort ByteString Int |- -- (bind address, port, path to certificate, path to key)- HttpsPort ByteString Int FilePath FilePath----------------------------------------------------------------------------------data EventLoopType = EventLoopSimple- | EventLoopLibEv- deriving (Show)------------------------------------------------------------------------------------ This exception will be thrown if we decided to terminate the request before--- running the user handler.-data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException- deriving (Show, Typeable)-instance Exception TerminatedBeforeHandlerException----------------------------------------------------------------------------------defaultEvType :: EventLoopType-#ifdef LIBEV-defaultEvType = EventLoopLibEv-#else-defaultEvType = EventLoopSimple-#endif----------------------------------------------------------------------------------data ServerState = ServerState- { _forceConnectionClose :: Bool- , _localHostname :: ByteString- , _sessionPort :: SessionInfo- , _logAccess :: Request -> Response -> IO ()- , _logError :: ByteString -> IO ()- }----------------------------------------------------------------------------------runServerMonad :: ByteString -- ^ local host name- -> SessionInfo -- ^ session port information- -> (Request -> Response -> IO ()) -- ^ access log function- -> (ByteString -> IO ()) -- ^ error log function- -> ServerMonad a -- ^ monadic action to run- -> Iteratee ByteString IO a-runServerMonad lh s la le m = evalStateT m st- where- st = ServerState False lh s la le------------------------------------------------------------------------------------ input/output----------------------------------------------------------------------------------httpServe :: Int -- ^ default timeout- -> [ListenPort] -- ^ ports to listen on- -> Maybe EventLoopType -- ^ Specify a given event loop,- -- otherwise a default is picked- -> ByteString -- ^ local hostname (server name)- -> Maybe FilePath -- ^ path to the access log- -> Maybe FilePath -- ^ path to the error log- -> ServerHandler -- ^ handler procedure- -> IO ()-httpServe defaultTimeout ports mevType localHostname alogPath elogPath- handler =- withLoggers alogPath elogPath- (\(alog, elog) -> spawnAll alog elog)-- where- --------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do-- let evType = maybe defaultEvType id mevType-- logE elog $ S.concat [ "Server.httpServe: START ("- , toBS $ show evType, ")"]-- let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;}- let initHttps = foldr (\p b -> b || isHttps p) False ports-- if initHttps- then TLS.initTLS- else return ()-- nports <- mapM bindPort ports-- (runEventLoop evType defaultTimeout nports numCapabilities (logE elog)- $ runHTTP defaultTimeout alog elog handler localHostname)- `finally` do- logE elog "Server.httpServe: SHUTDOWN"-- if initHttps- then TLS.stopTLS- else return ()-- logE elog "Server.httpServe: BACKEND STOPPED"-- --------------------------------------------------------------------------- bindPort (HttpPort baddr port) = bindHttp baddr port- bindPort (HttpsPort baddr port cert key) =- TLS.bindHttps baddr port cert key--- --------------------------------------------------------------------------- runEventLoop EventLoopSimple = simpleEventLoop- runEventLoop EventLoopLibEv = libEvEventLoop--- --------------------------------------------------------------------------- maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger--- --------------------------------------------------------------------------- withLoggers afp efp =- bracket (do alog <- maybeSpawnLogger afp- elog <- maybeSpawnLogger efp- return (alog, elog))- (\(alog, elog) -> do- maybe (return ()) stopLogger alog- maybe (return ()) stopLogger elog)----------------------------------------------------------------------------------debugE :: (MonadIO m) => ByteString -> m ()-debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)----------------------------------------------------------------------------------logE :: Maybe Logger -> ByteString -> IO ()-logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog----------------------------------------------------------------------------------logE' :: Logger -> ByteString -> IO ()-logE' logger s = (timestampedLogEntry s) >>= logMsg logger----------------------------------------------------------------------------------bshow :: (Show a) => a -> ByteString-bshow = toBS . show----------------------------------------------------------------------------------logA ::Maybe Logger -> Request -> Response -> IO ()-logA alog = maybe (\_ _ -> return ()) logA' alog----------------------------------------------------------------------------------logA' :: Logger -> Request -> Response -> IO ()-logA' logger req rsp = do- let hdrs = rqHeaders req- let host = rqRemoteAddr req- let user = Nothing -- TODO we don't do authentication yet- let (v, v') = rqVersion req- let ver = S.concat [ "HTTP/", bshow v, ".", bshow v' ]- let method = toBS $ show (rqMethod req)- let reql = S.intercalate " " [ method, rqURI req, ver ]- let status = rspStatus rsp- let cl = rspContentLength rsp- let referer = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs- let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs-- msg <- combinedLogEntry host user reql status cl referer userAgent- logMsg logger msg----------------------------------------------------------------------------------runHTTP :: Int -- ^ default timeout- -> Maybe Logger -- ^ access logger- -> Maybe Logger -- ^ error logger- -> ServerHandler -- ^ handler procedure- -> ByteString -- ^ local host name- -> SessionInfo -- ^ session port information- -> Enumerator ByteString IO () -- ^ read end of socket- -> Iteratee ByteString IO () -- ^ write end of socket- -> (FilePath -> Int64 -> Int64 -> IO ())- -- ^ sendfile end- -> (Int -> IO ()) -- ^ timeout tickler- -> IO ()-runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile- tickle =- go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do- return ()- , Handler $ \(e :: HttpParseException) -> do- return ()- , Handler $ \(e :: AsyncException) -> do- throwIO e- , Handler $ \(e :: SomeException) ->- logE elog $ S.concat [ logPrefix , bshow e ] ]-- where- logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ]-- go = do- buf <- allocBuffer 16384- let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $- httpSession defaultTimeout writeEnd buf- onSendFile tickle handler- let iter = iterateeDebugWrapper "httpSession iteratee" iter1-- debug "runHTTP/go: prepping iteratee for start"-- step <- liftIO $ runIteratee iter-- debug "runHTTP/go: running..."- run_ $ readEnd step- debug "runHTTP/go: finished"----------------------------------------------------------------------------------sERVER_HEADER :: [ByteString]-sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]]----------------------------------------------------------------------------------snapServerVersion :: ByteString-snapServerVersion = SC.pack $ showVersion $ V.version----------------------------------------------------------------------------------logAccess :: Request -> Response -> ServerMonad ()-logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)----------------------------------------------------------------------------------logError :: ByteString -> ServerMonad ()-logError s = gets _logError >>= (\l -> liftIO $ l s)------------------------------------------------------------------------------------ | Runs an HTTP session.-httpSession :: Int- -> Iteratee ByteString IO () -- ^ write end of socket- -> Buffer -- ^ builder buffer- -> (FilePath -> Int64 -> Int64 -> IO ())- -- ^ sendfile continuation- -> (Int -> IO ()) -- ^ timeout tickler- -> ServerHandler -- ^ handler procedure- -> ServerMonad ()-httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do-- let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd'-- liftIO $ debug "Server.httpSession: entered"- mreq <- receiveRequest writeEnd- liftIO $ debug "Server.httpSession: receiveRequest finished"-- -- successfully got a request, so restart timer- liftIO $ tickle defaultTimeout-- case mreq of- (Just req) -> do- liftIO $ debug $ "Server.httpSession: got request: " ++- show (rqMethod req) ++- " " ++ SC.unpack (rqURI req) ++- " " ++ show (rqVersion req)-- -- check for Expect: 100-continue- checkExpect100Continue req writeEnd-- logerr <- gets _logError-- (req',rspOrig) <- lift $ handler logerr tickle req-- liftIO $ debug $ "Server.httpSession: finished running user handler"-- let rspTmp = rspOrig { rspHttpVersion = rqVersion req }- checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp)-- cc <- gets _forceConnectionClose- let rsp = if cc- then (setHeader "Connection" "close" rspTmp)- else rspTmp-- liftIO $ debug "Server.httpSession: handled, skipping request body"-- if rspTransformingRqBody rsp- then liftIO $ debug $- "Server.httpSession: not skipping " ++- "request body, transforming."- else do- srqEnum <- liftIO $ readIORef $ rqBody req'- let (SomeEnumerator rqEnum) = srqEnum-- skipStep <- liftIO $ runIteratee $ iterateeDebugWrapper- "httpSession/skipToEof" skipToEof- lift $ rqEnum skipStep-- liftIO $ debug $ "Server.httpSession: request body skipped, " ++- "sending response"-- date <- liftIO getDateString- let ins = Map.insert "Date" [date] .- Map.insert "Server" sERVER_HEADER- let rsp' = updateHeaders ins rsp- (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile-- liftIO . debug $ "Server.httpSession: sent " ++- (show bytesSent) ++ " bytes"-- maybe (logAccess req rsp')- (\_ -> logAccess req $ setContentLength bytesSent rsp')- (rspContentLength rsp')-- if cc- then do- debug $ "httpSession: Connection: Close, harikari"- liftIO $ myThreadId >>= killThread- else httpSession defaultTimeout writeEnd' buffer onSendFile- tickle handler-- Nothing -> do- liftIO $ debug $ "Server.httpSession: parser did not produce a " ++- "request, ending session"- return ()----------------------------------------------------------------------------------checkExpect100Continue :: Request- -> Iteratee ByteString IO ()- -> ServerMonad ()-checkExpect100Continue req writeEnd = do- let mbEx = getHeaders "Expect" req-- maybe (return ())- (\l -> if elem "100-continue" l then go else return ())- mbEx-- where- go = do- let (major,minor) = rqVersion req- let hl = mconcat [ fromByteString "HTTP/"- , fromShow major- , fromWord8 $ c2w '.'- , fromShow minor- , fromByteString " 100 Continue\r\n\r\n" ]- liftIO $ runIteratee- ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)- return ()----------------------------------------------------------------------------------return411 :: Request- -> Iteratee ByteString IO ()- -> ServerMonad a-return411 req writeEnd = do- go- liftIO $ throwIO $ TerminatedBeforeHandlerException-- where- go = do- let (major,minor) = rqVersion req- let hl = mconcat [ fromByteString "HTTP/"- , fromShow major- , fromWord8 $ c2w '.'- , fromShow minor- , fromByteString " 411 Length Required\r\n\r\n"- , fromByteString "411 Length Required\r\n" ]- liftIO $ runIteratee- ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)- return ()----------------------------------------------------------------------------------receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request)-receiveRequest writeEnd = do- debug "receiveRequest: entered"- mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $- iterateeDebugWrapper "parseRequest" parseRequest- debug "receiveRequest: parseRequest returned"-- case mreq of- (Just ireq) -> do- req' <- toRequest ireq- setEnumerator req'- req <- parseForm req'- checkConnectionClose (rqVersion req) (rqHeaders req)- return $ Just req-- Nothing -> return Nothing--- where- --------------------------------------------------------------------------- -- check: did the client specify "transfer-encoding: chunked"? then we- -- have to honor that.- --- -- otherwise: check content-length header. if set: only take N bytes from- -- the read end of the socket- --- -- if no content-length and no chunked encoding, enumerate the entire- -- socket and close afterwards- setEnumerator :: Request -> ServerMonad ()- setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do- if isChunked- then do- liftIO $ debug $ "receiveRequest/setEnumerator: " ++- "input in chunked encoding"- let e = joinI . readChunkedTransferEncoding- liftIO $ writeIORef (rqBody req)- (SomeEnumerator e)- else maybe (noContentLength req) hasContentLength mbCL-- where- isChunked = maybe False- ((== ["chunked"]) . map toCI)- (Map.lookup "transfer-encoding" hdrs)-- hasContentLength :: Int64 -> ServerMonad ()- hasContentLength len = do- liftIO $ debug $ "receiveRequest/setEnumerator: " ++- "request had content-length " ++ show len- liftIO $ writeIORef (rqBody req) (SomeEnumerator e)- liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"- where- e :: Enumerator ByteString IO a- e st = do- st' <- lift $- runIteratee $- iterateeDebugWrapper "rqBody iterator" $- returnI st-- joinI $ takeExactly len st'-- noContentLength :: Request -> ServerMonad ()- noContentLength rq = do- debug ("receiveRequest/setEnumerator: " ++- "request did NOT have content-length")-- when (rqMethod rq == POST || rqMethod rq == PUT) $- return411 req writeEnd-- let enum = SomeEnumerator $- iterateeDebugWrapper "noContentLength" .- joinI . I.take 0- liftIO $ writeIORef (rqBody rq) enum- debug "receiveRequest/setEnumerator: body enumerator set"--- hdrs = rqHeaders req- mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head--- --------------------------------------------------------------------------- parseForm :: Request -> ServerMonad Request- parseForm req = {-# SCC "receiveRequest/parseForm" #-}- if doIt then getIt else return req- where- mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req)- trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';')- . SC.dropWhile isSpace- mbCT' = liftM trimIt mbCT- doIt = mbCT' == Just "application/x-www-form-urlencoded"-- maximumPOSTBodySize :: Int64- maximumPOSTBodySize = 10*1024*1024-- getIt :: ServerMonad Request- getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do- liftIO $ debug "parseForm: got application/x-www-form-urlencoded"- liftIO $ debug "parseForm: reading POST body"- senum <- liftIO $ readIORef $ rqBody req- let (SomeEnumerator enum) = senum- consumeStep <- liftIO $ runIteratee consume- step <- liftIO $- runIteratee $- joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep- body <- liftM S.concat $ lift $ enum step- let newParams = parseUrlEncoded body-- liftIO $ debug "parseForm: stuffing 'enumBS body' into request"-- let e = enumBS body >==> I.joinI . I.take 0-- let e' = \st -> do- let ii = iterateeDebugWrapper "regurgitate body" (returnI st)- st' <- lift $ runIteratee ii- e st'-- liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'- return $ req { rqParams = rqParams req `mappend` newParams }--- --------------------------------------------------------------------------- toRequest (IRequest method uri version kvps) =- {-# SCC "receiveRequest/toRequest" #-} do- localAddr <- gets $ localAddress . _sessionPort- lport <- gets $ localPort . _sessionPort- remoteAddr <- gets $ remoteAddress . _sessionPort- rport <- gets $ remotePort . _sessionPort- localHostname <- gets $ _localHostname- secure <- gets $ isSecure . _sessionPort-- let (serverName, serverPort) = fromMaybe- (localHostname, lport)- (liftM (parseHost . head)- (Map.lookup "host" hdrs))-- -- will override in "setEnumerator"- enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")-- return $ Request serverName- serverPort- remoteAddr- rport- localAddr- lport- localHostname- secure- hdrs- enum- mbContentLength- method- version- cookies- snapletPath- pathInfo- contextPath- uri- queryString- params-- where- snapletPath = "" -- TODO: snaplets in v0.2-- dropLeadingSlash s = maybe s f mbS- where- f (a,s') = if a == c2w '/' then s' else s- mbS = S.uncons s-- hdrs = toHeaders kvps-- mbContentLength = liftM (Cvt.int . head) $- Map.lookup "content-length" hdrs-- cookies = concat $- maybe []- (catMaybes . map parseCookie)- (Map.lookup "cookie" hdrs)-- contextPath = "/"-- parseHost h = (a, Cvt.int (S.drop 1 b))- where- (a,b) = S.break (== (c2w ':')) h-- params = parseUrlEncoded queryString-- (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $- S.break (== (c2w '?')) uri------------------------------------------------------------------------------------ Response must be well-formed here-sendResponse :: forall a . Request- -> Response- -> Buffer- -> Iteratee ByteString IO a -- ^ iteratee write end- -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on- -- sendfile- -> ServerMonad (Int64, a)-sendResponse req rsp' buffer writeEnd' onSendFile = do- let rsp'' = renderCookies rsp'- rsp <- fixupResponse rsp''- let (!headerString,!hlen) = mkHeaderBuilder rsp- let writeEnd = fixCLIteratee hlen rsp writeEnd'-- (!x,!bs) <-- case (rspBody rsp) of- (Enum e) -> lift $ whenEnum writeEnd headerString hlen- rsp e- (SendFile f Nothing) -> lift $- whenSendFile writeEnd headerString rsp f 0- (SendFile f (Just (st,_))) ->- lift $ whenSendFile writeEnd headerString rsp f st-- debug "sendResponse: response sent"-- return $! (bs,x)-- where- --------------------------------------------------------------------------- whenEnum :: Iteratee ByteString IO a- -> Builder- -> Int- -> Response- -> (forall x . Enumerator Builder IO x)- -> Iteratee ByteString IO (a,Int64)- whenEnum writeEnd hs hlen rsp e = do- -- "enum" here has to be run in the context of the READ iteratee, even- -- though it's writing to the output, because we may be transforming- -- the input. That's why we check if we're transforming the request- -- body here, and if not, send EOF to the write end; so that it- -- doesn't join up with the read iteratee and try to get more data- -- from the socket.- let eBuilder = enumBuilder hs >==> e- let enum = if rspTransformingRqBody rsp- then eBuilder- else eBuilder >==>- mapEnum toByteString fromByteString- (joinI . I.take 0)-- debug $ "sendResponse: whenEnum: enumerating bytes"-- outstep <- lift $ runIteratee $- iterateeDebugWrapper "countBytes writeEnd" $- countBytes writeEnd- (x,bs) <- mapIter fromByteString toByteString- (enum $$ joinI $ unsafeBuilderToByteString- (return buffer) outstep)- debug $ "sendResponse: whenEnum: " ++ show bs ++- " bytes enumerated"-- return (x, bs - fromIntegral hlen)--- --------------------------------------------------------------------------- whenSendFile :: Iteratee ByteString IO a -- ^ write end- -> Builder -- ^ headers- -> Response- -> FilePath -- ^ file to send- -> Int64 -- ^ start byte offset- -> Iteratee ByteString IO (a,Int64)- whenSendFile writeEnd hs r f start = do- -- Guaranteed to have a content length here. Sending EOF through to- -- the write end guarantees that we flush the buffer before we send- -- the file with sendfile().- lift $ runIteratee ((enumBuilder hs >==> enumEOF) $$- unsafeBuilderToByteString (return buffer)- $$ writeEnd)-- let !cl = fromJust $ rspContentLength r- x <- liftIO $ onSendFile f start cl- return (x, cl)--- --------------------------------------------------------------------------- (major,minor) = rspHttpVersion rsp'--- --------------------------------------------------------------------------- buildHdrs :: Map CIByteString [ByteString]- -> (Builder,Int)- buildHdrs hdrs =- {-# SCC "buildHdrs" #-}- Map.foldlWithKey f (mempty,0) hdrs- where- f (b,len) k ys =- let (!b',len') = h k ys- in (b `mappend` b', len+len')-- crlf = fromByteString "\r\n"-- doOne pre plen (b,len) y = ( mconcat [ b- , pre- , fromByteString y- , crlf ]- , len + plen + 2 + S.length y )-- h k ys = foldl' (doOne kb klen) (mempty,0) ys- where- k' = unCI k- kb = fromByteString k' `mappend` fromByteString ": "- klen = S.length k' + 2--- --------------------------------------------------------------------------- noCL :: Response- -> ServerMonad Response- noCL r = {-# SCC "noCL" #-} do- -- are we in HTTP/1.1?- let sendChunked = (rspHttpVersion r) == (1,1)- if sendChunked- then do- let r' = setHeader "Transfer-Encoding" "chunked" r- let origE = rspBodyToEnum $ rspBody r-- let e = \i -> joinI $ origE $$ chunkIt i-- return $! r' { rspBody = Enum e }-- else do- -- HTTP/1.0 and no content-length? We'll have to close the- -- socket.- modify $! \s -> s { _forceConnectionClose = True }- return $! setHeader "Connection" "close" r-- --------------------------------------------------------------------------- chunkIt :: forall x . Enumeratee Builder Builder IO x- chunkIt = checkDone $ continue . step- where- step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return- step k (Chunks []) = continue $ step k- step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])- >>== chunkIt-- --------------------------------------------------------------------------- fixCLIteratee :: Int -- ^ header length- -> Response -- ^ response- -> Iteratee ByteString IO a -- ^ write end- -> Iteratee ByteString IO a- fixCLIteratee hlen resp we = maybe we f mbCL- where- f cl = case rspBody resp of- (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen)- $$ we- (SendFile _ _) -> we-- mbCL = rspContentLength resp-- --------------------------------------------------------------------------- hasCL :: Int64- -> Response- -> ServerMonad Response- hasCL cl r = {-# SCC "hasCL" #-}- -- set the content-length header- return $! setHeader "Content-Length" (toByteString $ fromShow cl) r--- --------------------------------------------------------------------------- setFileSize :: FilePath -> Response -> ServerMonad Response- setFileSize fp r =- {-# SCC "setFileSize" #-}- do- fs <- liftM fromIntegral $ liftIO $ getFileSize fp- return $ r { rspContentLength = Just fs }--- --------------------------------------------------------------------------- handle304 :: Response -> Response- handle304 r = setResponseBody (enumBuilder mempty) $- updateHeaders (Map.delete "Transfer-Encoding") $- setContentLength 0 r--- --------------------------------------------------------------------------- renderCookies :: Response -> Response- renderCookies r = updateHeaders f r- where- f h = if null cookies- then h- else Map.insertWith (flip (++)) "Set-Cookie" cookies h- cookies = fmap cookieToBS . Map.elems $ rspCookies r--- --------------------------------------------------------------------------- fixupResponse :: Response- -> ServerMonad Response- fixupResponse r = {-# SCC "fixupResponse" #-} do- let r' = deleteHeader "Content-Length" r- let code = rspStatus r'- let r'' = if code == 204 || code == 304- then handle304 r'- else r'-- r''' <- do- z <- case rspBody r'' of- (Enum _) -> return r''- (SendFile f Nothing) -> setFileSize f r''- (SendFile _ (Just (s,e))) -> return $- setContentLength (e-s) r''-- case rspContentLength z of- Nothing -> noCL z- (Just sz) -> hasCL sz z-- -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4- if rqMethod req == HEAD- then return $! deleteHeader "Transfer-Encoding" $- r''' { rspBody = Enum $ enumBuilder mempty }- else return $! r'''--- --------------------------------------------------------------------------- mkHeaderBuilder :: Response -> (Builder,Int)- mkHeaderBuilder r = {-# SCC "mkHeaderBuilder" #-}- ( mconcat [ fromByteString "HTTP/"- , fromString majstr- , fromWord8 $ c2w '.'- , fromString minstr- , space- , fromString $ statstr- , space- , fromByteString reason- , crlf- , hdrs- , crlf- ]- , 12 + majlen + minlen + statlen + S.length reason + hlen )-- where- (hdrs,hlen) = buildHdrs $ headers r- majstr = show major- minstr = show minor- majlen = length majstr- minlen = length minstr- statstr = show $ rspStatus r- statlen = length statstr- crlf = fromByteString "\r\n"- space = fromWord8 $ c2w ' '- reason = rspStatusReason r----------------------------------------------------------------------------------checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()-checkConnectionClose ver hdrs =- -- For HTTP/1.1:- -- if there is an explicit Connection: close, close the socket.- -- For HTTP/1.0:- -- if there is no explicit Connection: Keep-Alive, close the socket.- if (ver == (1,1) && l == Just ["close"]) ||- (ver == (1,0) && l /= Just ["keep-alive"])- then modify $ \s -> s { _forceConnectionClose = True }- else return ()- where- l = liftM (map tl) $ Map.lookup "Connection" hdrs- tl = S.map (c2w . toLower . w2c)------------------------------------------------------------------------------------ FIXME: whitespace-trim the values here.-toHeaders :: [(ByteString,ByteString)] -> Headers-toHeaders kvps = foldl' f Map.empty kvps'- where- kvps' = map (first toCI . second (:[])) kvps- f m (k,v) = Map.insertWith' (flip (++)) k v m------------------------------------------------------------------------------------ | Convert 'Cookie' into 'ByteString' for output.-cookieToBS :: Cookie -> ByteString-cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie- where- cookie = S.concat [k, "=", v, path, exptime, domain]- path = maybe "" (S.append "; path=") mbPath- domain = maybe "" (S.append "; domain=") mbDomain- exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime- fmt = fromStr . formatTime defaultTimeLocale- "%a, %d-%b-%Y %H:%M:%S GMT"----------------------------------------------------------------------------------getFileSize :: FilePath -> IO FileOffset-getFileSize fp = liftM fileSize $ getFileStatus fp----------------------------------------------------------------------------------l2s :: L.ByteString -> S.ByteString-l2s = S.concat . L.toChunks----------------------------------------------------------------------------------toBS :: String -> ByteString-toBS = S.pack . map c2w
+ src/Snap/Internal/Http/Server/Address.hs view
@@ -0,0 +1,111 @@+{-# 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+ }
− src/Snap/Internal/Http/Server/Backend.hs
@@ -1,96 +0,0 @@-module Snap.Internal.Http.Server.Backend where--{---The server backend is made up of two APIs.--+ The ListenSocket class abstracts the reading and writing from the network.- We have seperate implementations of ListenSocket for http and https.--+ The EventLoop function is the interface to accept on the socket.- The EventLoop function will listen on the ports, and for each accepted- connection it wil call the SessionHandler.---}--import Data.ByteString (ByteString)-import Foreign-import Foreign.C-import Network.Socket (Socket)-import Snap.Iteratee (Iteratee, Enumerator)----------------------------------------------------------------------------------data SessionInfo = SessionInfo- { localAddress :: ByteString- , localPort :: Int- , remoteAddress :: ByteString- , remotePort :: Int- , isSecure :: Bool- }----------------------------------------------------------------------------------type SessionHandler =- SessionInfo -- ^ session port information- -> Enumerator ByteString IO () -- ^ read end of socket- -> Iteratee ByteString IO () -- ^ write end of socket- -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end- -> (Int -> IO ()) -- ^ timeout tickler- -> IO ()----------------------------------------------------------------------------------type EventLoop = Int -- ^ default timeout- -> [ListenSocket] -- ^ list of ports- -> Int -- ^ number of capabilities- -> (ByteString -> IO ()) -- ^ error log- -> SessionHandler -- ^ session handler- -> IO ()---{- For performance reasons, we do not implement this as a class-class ListenSocket a where- data ListenSocketSession a :: *-- listenSocket :: a -> Socket- isSecure :: a -> Bool-- closePort :: a -> IO ()-- createSession :: a- -> Int -- ^ recv buffer size- -> CInt -- ^ network socket- -> IO () -- ^ action to block waiting for handshake- -> IO (ListenSocketSession a)-- endSession :: a -> ListenSocketSession a -> IO ()-- recv :: a- -> IO () -- ^ action to block waiting for data- -> ListenSocketSession a -- ^ session- -> IO (Maybe ByteString)-- send :: a- -> IO () -- ^ action to tickle the timeout- -> IO () -- ^ action to block waiting for data- -> ListenSocketSession a -- ^ session- -> ByteString -- ^ data to send- -> IO ()--}----------------------------------------------------------------------------------data ListenSocket = ListenHttp Socket- | ListenHttps Socket (Ptr Word) (Ptr Word)--instance Show ListenSocket where- show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")"- show (ListenHttps s _ _) = "ListenHttps (" ++ show s ++ ")"---------------------------------------------------------------------------------data NetworkSession = NetworkSession- { _socket :: CInt- , _session :: Ptr Word- , _recvLen :: Int- }
+ src/Snap/Internal/Http/Server/Clock.hs view
@@ -0,0 +1,44 @@+{-# 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
+ src/Snap/Internal/Http/Server/Common.hs view
@@ -0,0 +1,40 @@+{-# 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 $! ()
+ src/Snap/Internal/Http/Server/Config.hs view
@@ -0,0 +1,856 @@+{-# 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
src/Snap/Internal/Http/Server/Date.hs view
@@ -1,131 +1,81 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Date-( getDateString-, getLogDateString-, getCurrentDateTime) where--import Control.Concurrent-import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import Data.IORef-import Data.Maybe-import Foreign.C.Types-import System.IO.Unsafe-import System.PosixCompat.Time+ ( 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) --- Here comes a dirty hack. We don't want to be wasting context switches--- building date strings, so we're only going to compute one every two--- seconds. (Approximate timestamps to within a couple of seconds are OK here,--- and we'll reduce overhead.)------ Note that we also don't want to wake up a potentially sleeping CPU by just--- running the computation on a timer. We'll allow client traffic to trigger--- the process. ------------------------------------------------------------------------------ data DateState = DateState { _cachedDateString :: !(IORef ByteString) , _cachedLogString :: !(IORef ByteString)- , _cachedDate :: !(IORef CTime)- , _valueIsOld :: !(IORef Bool)- , _morePlease :: !(MVar ())- , _dateThread :: !(MVar ThreadId)+ , _lastFetchTime :: !(IORef CTime) } ------------------------------------------------------------------------------ dateState :: DateState dateState = unsafePerformIO $ do- (s1,s2,date) <- fetchTime- bs1 <- newIORef s1- bs2 <- newIORef s2- dt <- newIORef date- ov <- newIORef False- th <- newEmptyMVar- mp <- newMVar ()-- let d = DateState bs1 bs2 dt ov mp th-- t <- forkIO $ dateThread d- putMVar th t+ (s1, s2, date) <- fetchTime+ bs1 <- newIORef $! s1+ bs2 <- newIORef $! s2+ dt <- newIORef $! date - return d+ return $! DateState bs1 bs2 dt+{-# NOINLINE dateState #-} ------------------------------------------------------------------------------ fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do- now <- epochTime- t1 <- formatHttpTime now- t2 <- formatLogTime now- return (t1, t2, now)+ !now <- epochTime+ !t1 <- formatHttpTime now+ !t2 <- formatLogTime now+ let !out = (t1, t2, now)+ return out ------------------------------------------------------------------------------ updateState :: DateState -> IO ()-updateState (DateState dateString logString time valueIsOld _ _) = do- (s1,s2,now) <- fetchTime- atomicModifyIORef dateString $ const (s1,())- atomicModifyIORef logString $ const (s2,())- atomicModifyIORef time $ const (now,())- writeIORef valueIsOld False-- -- force values in the iorefs to prevent thunk buildup- !_ <- readIORef dateString- !_ <- readIORef logString- !_ <- readIORef time-- return ()----------------------------------------------------------------------------------dateThread :: DateState -> IO ()-dateThread ds@(DateState _ _ _ valueIsOld morePlease _) = loop- where- loop = do- b <- tryTakeMVar morePlease- when (isNothing b) $ do- writeIORef valueIsOld True- takeMVar morePlease+updateState (DateState dateString logString time) = do+ (s1, s2, now) <- fetchTime+ writeIORef dateString $! s1+ writeIORef logString $! s2+ writeIORef time $! now - updateState ds- threadDelay 2000000- loop+ return $! () ------------------------------------------------------------------------------ ensureFreshDate :: IO ()-ensureFreshDate = block $ do- old <- readIORef $ _valueIsOld dateState- _ <- tryPutMVar (_morePlease dateState) ()-- -- if the value is not fresh we will tickle the date thread but also fetch- -- the new value immediately; we used to block but we'll do a little extra- -- work to avoid a delay- when old $ updateState dateState+ensureFreshDate = mask_ $ do+ now <- epochTime+ old <- readIORef $ _lastFetchTime dateState+ when (now > old) $! updateState dateState ------------------------------------------------------------------------------ getDateString :: IO ByteString-getDateString = block $ do+getDateString = mask_ $ do ensureFreshDate readIORef $ _cachedDateString dateState ------------------------------------------------------------------------------ getLogDateString :: IO ByteString-getLogDateString = block $ do+getLogDateString = mask_ $ do ensureFreshDate readIORef $ _cachedLogString dateState----------------------------------------------------------------------------------getCurrentDateTime :: IO CTime-getCurrentDateTime = block $ do- ensureFreshDate- readIORef $ _cachedDate dateState
− src/Snap/Internal/Http/Server/GnuTLS.hs
@@ -1,392 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Snap.Internal.Http.Server.GnuTLS- ( GnuTLSException(..)- , initTLS- , stopTLS- , bindHttps- , freePort- , createSession- , endSession- , recv- , send- ) where----------------------------------------------------------------------------------import Control.Exception-import Data.ByteString (ByteString)-import Data.Dynamic-import Foreign.C--import Snap.Internal.Debug-import Snap.Internal.Http.Server.Backend--#ifdef GNUTLS-import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c)-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BI-import Foreign-import qualified Network.Socket as Socket-#endif----------------------------------------------------------------------------------data GnuTLSException = GnuTLSException String- deriving (Show, Typeable)-instance Exception GnuTLSException--#ifndef GNUTLS--initTLS :: IO ()-initTLS = throwIO $ GnuTLSException "TLS is not supported"--stopTLS :: IO ()-stopTLS = return ()--bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket-bindHttps _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported"--freePort :: ListenSocket -> IO ()-freePort _ = return ()--createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported"--endSession :: NetworkSession -> IO ()-endSession _ = return ()--send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send _ _ _ _ = return ()--recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv _ _ = throwIO $ GnuTLSException "TLS is not supported"--#else------------------------------------------------------------------------------------ | Init-initTLS :: IO ()-initTLS = gnutls_set_threading_helper >>- throwErrorIf "TLS init" gnutls_global_init----------------------------------------------------------------------------------stopTLS :: IO ()-stopTLS = gnutls_global_deinit------------------------------------------------------------------------------------ | Binds ssl port-bindHttps :: ByteString- -> Int- -> FilePath- -> FilePath- -> IO ListenSocket-bindHttps bindAddress bindPort cert key = do- sock <- Socket.socket Socket.AF_INET Socket.Stream 0- addr <- getHostAddr bindPort bindAddress- Socket.setSocketOption sock Socket.ReuseAddr 1- Socket.bindSocket sock addr- Socket.listen sock 150-- creds <- loadCredentials cert key- dh <- regenerateDHParam creds-- return $ ListenHttps sock (castPtr creds) (castPtr dh)----------------------------------------------------------------------------------loadCredentials :: FilePath --- ^ Path to certificate- -> FilePath --- ^ Path to key- -> IO (Ptr GnuTLSCredentials)-loadCredentials cert key = alloca $ \cPtr -> do- throwErrorIf "TLS allocate" $ gnutls_certificate_allocate_credentials cPtr- creds <- peek cPtr-- withCString cert $ \certstr -> withCString key $ \keystr ->- throwErrorIf "TLS set Certificate" $- gnutls_certificate_set_x509_key_file- creds certstr keystr gnutls_x509_fmt_pem-- return creds----------------------------------------------------------------------------------regenerateDHParam :: Ptr GnuTLSCredentials -> IO (Ptr GnuTLSDHParam)-regenerateDHParam creds = alloca $ \dhptr -> do- throwErrorIf "TLS allocate" $ gnutls_dh_params_init dhptr- dh <- peek dhptr- throwErrorIf "TLS DHParm" $ gnutls_dh_params_generate2 dh 1024- gnutls_certificate_set_dh_params creds dh- return dh----------------------------------------------------------------------------------freePort :: ListenSocket -> IO ()-freePort (ListenHttps _ creds dh) = do- gnutls_certificate_free_credentials $ castPtr creds- gnutls_dh_params_deinit $ castPtr dh-freePort _ = return ()----------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttps _ creds _) recvSize socket on_block =- alloca $ \sPtr -> do- throwErrorIf "TLS alloacte" $ gnutls_init sPtr 1- session <- peek sPtr- throwErrorIf "TLS session" $- gnutls_credentials_set session 1 $ castPtr creds- throwErrorIf "TLS session" $ gnutls_set_default_priority session- gnutls_certificate_send_x509_rdn_sequence session 1- gnutls_session_enable_compatibility_mode session-- let s = NetworkSession socket (castPtr session) $- fromIntegral recvSize-- gnutls_transport_set_ptr session $ intPtrToPtr $ fromIntegral $ socket-- handshake s on_block-- return s-createSession _ _ _ _ = error "Invalid socket"----------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession (NetworkSession _ session _) = do- throwErrorIf "TLS bye" $ gnutls_bye (castPtr session) 1 `finally` do- gnutls_deinit $ castPtr session----------------------------------------------------------------------------------handshake :: NetworkSession -> IO () -> IO ()-handshake s@(NetworkSession { _session = session}) on_block = do- rc <- gnutls_handshake $ castPtr session- case rc of- x | x >= 0 -> return ()- | isIntrCode x -> handshake s on_block- | isAgainCode x -> on_block >> handshake s on_block- | otherwise -> throwError "TLS handshake" rc----------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send tickleTimeout onBlock (NetworkSession { _session = session}) bs =- BI.unsafeUseAsCStringLen bs $ uncurry loop- where- loop ptr len = do- sent <- gnutls_record_send (castPtr session) ptr $ fromIntegral len- let sent' = fromIntegral sent- case sent' of- x | x == 0 || x == len -> return ()- | x > 0 && x < len -> tickleTimeout >>- loop (plusPtr ptr sent') (len - sent')- | isIntrCode x -> loop ptr len- | isAgainCode x -> onBlock >> loop ptr len- | otherwise -> throwError "TLS send" $- fromIntegral sent'----------------------------------------------------------------------------------recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv onBlock (NetworkSession _ session recvLen) = do- fp <- BI.mallocByteString recvLen- sz <- withForeignPtr fp loop- if (sz :: Int) <= 0- then return Nothing- else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz-- where- loop recvBuf = do- debug $ "TLS: calling record_recv with recvLen=" ++ show recvLen- size <- gnutls_record_recv (castPtr session) recvBuf $ toEnum recvLen- debug $ "TLS: record_recv returned with size=" ++ show size- let size' = fromIntegral size- case size' of- x | x >= 0 -> return x- | isIntrCode x -> loop recvBuf- | isAgainCode x -> onBlock >> loop recvBuf- | otherwise -> (throwError "TLS recv" $ fromIntegral size')----------------------------------------------------------------------------------throwError :: String -> ReturnCode -> IO a-throwError prefix rc = gnutls_strerror rc >>=- peekCString >>=- throwIO . GnuTLSException . (prefix'++)- where- prefix' = prefix ++ "<" ++ show rc ++ ">: "----------------------------------------------------------------------------------throwErrorIf :: String -> IO ReturnCode -> IO ()-throwErrorIf prefix action = do- rc <- action- if (rc < 0)- then throwError prefix rc- else return ()----------------------------------------------------------------------------------isAgainCode :: (Integral a) => a -> Bool-isAgainCode x = (fromIntegral x) == (-28 :: Int)----------------------------------------------------------------------------------isIntrCode :: (Integral a) => a -> Bool-isIntrCode x = (fromIntegral x) == (-52 :: Int)----------------------------------------------------------------------------------getHostAddr :: Int- -> ByteString- -> IO Socket.SockAddr-getHostAddr p s = do- h <- if s == "*"- then return Socket.iNADDR_ANY- else Socket.inet_addr (map w2c . B.unpack $ s)-- return $ Socket.SockAddrInet (fromIntegral p) h---- Types--newtype ReturnCode = ReturnCode CInt- deriving (Show, Eq, Ord, Num, Real, Enum, Integral)--data GnuTLSCredentials-data GnuTLSSession-data GnuTLSDHParam----------------------------------------------------------------------------------- Global init/errors--foreign import ccall safe- "gnutls_set_threading_helper"- gnutls_set_threading_helper :: IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_global_init"- gnutls_global_init :: IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_global_deinit"- gnutls_global_deinit :: IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_strerror"- gnutls_strerror :: ReturnCode -> IO CString----------------------------------------------------------------------------------- Sessions. All functions here except handshake and bye just--- allocate memory or update members of structures, so they are ok with--- unsafe ccall.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_init"- gnutls_init :: Ptr (Ptr GnuTLSSession) -> CInt -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_deinit"- gnutls_deinit :: Ptr GnuTLSSession -> IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_handshake"- gnutls_handshake :: Ptr GnuTLSSession -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_bye"- gnutls_bye :: Ptr GnuTLSSession -> CInt -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_set_default_priority"- gnutls_set_default_priority :: Ptr GnuTLSSession -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_session_enable_compatibility_mode"- gnutls_session_enable_compatibility_mode :: Ptr GnuTLSSession -> IO ()--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_certificate_send_x509_rdn_sequence"- gnutls_certificate_send_x509_rdn_sequence- :: Ptr GnuTLSSession -> CInt -> IO ()----------------------------------------------------------------------------------- Certificates. Perhaps these could be unsafe but they are not performance--- critical, since they are called only once during server startup.--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_allocate_credentials"- gnutls_certificate_allocate_credentials- :: Ptr (Ptr GnuTLSCredentials) -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_free_credentials"- gnutls_certificate_free_credentials- :: Ptr GnuTLSCredentials -> IO ()--gnutls_x509_fmt_pem :: CInt-gnutls_x509_fmt_pem = 1--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_set_x509_key_file"- gnutls_certificate_set_x509_key_file- :: Ptr GnuTLSCredentials -> CString -> CString -> CInt -> IO ReturnCode------------------------------------------------------------------------------------ Credentials. This is ok as unsafe because it just sets members in the--- session structure.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_credentials_set"- gnutls_credentials_set- :: Ptr GnuTLSSession -> CInt -> Ptr a -> IO ReturnCode----------------------------------------------------------------------------------- Records. These are marked unsafe because they are very performance--- critical. Since we are using non-blocking sockets send and recv will not--- block.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_transport_set_ptr"- gnutls_transport_set_ptr :: Ptr GnuTLSSession -> Ptr a -> IO ()--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_record_recv"- gnutls_record_recv :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_record_send"- gnutls_record_send :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize----------------------------------------------------------------------------------- DHParam. Perhaps these could be unsafe but they are not performance--- critical.--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_init"- gnutls_dh_params_init :: Ptr (Ptr GnuTLSDHParam) -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_deinit"- gnutls_dh_params_deinit :: Ptr GnuTLSDHParam -> IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_generate2"- gnutls_dh_params_generate2 :: Ptr GnuTLSDHParam -> CUInt -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_set_dh_params"- gnutls_certificate_set_dh_params- :: Ptr GnuTLSCredentials -> Ptr GnuTLSDHParam -> IO ()--#endif
− src/Snap/Internal/Http/Server/HttpPort.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Snap.Internal.Http.Server.HttpPort- ( bindHttp- , createSession- , endSession- , recv- , send- ) where----------------------------------------------------------------------------------import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c)-import Foreign-import Foreign.C-import Network.Socket hiding (recv, send)--#ifdef PORTABLE-import qualified Network.Socket.ByteString as SB-#else-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BI-#endif--import Snap.Internal.Debug-import Snap.Internal.Http.Server.Backend---------------------------------------------------------------------------------bindHttp :: ByteString -> Int -> IO ListenSocket-bindHttp bindAddr bindPort = do- sock <- socket AF_INET Stream 0- addr <- getHostAddr bindPort bindAddr- debug $ "bindHttp: binding port " ++ show addr- setSocketOption sock ReuseAddr 1- bindSocket sock addr- listen sock 150- debug $ "bindHttp: bound socket " ++ show sock- return $ ListenHttp sock----------------------------------------------------------------------------------getHostAddr :: Int- -> ByteString- -> IO SockAddr-getHostAddr p s = do- h <- if s == "*"- then return iNADDR_ANY- else inet_addr (map w2c . B.unpack $ s)-- return $ SockAddrInet (fromIntegral p) h----------------------------------------------------------------------------------createSession :: Int -> CInt -> IO () -> IO NetworkSession-createSession buffSize s _ =- return $ NetworkSession s nullPtr $ fromIntegral buffSize----------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession _ = return ()--#ifdef PORTABLE---------------------------------------------------------------------------------recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv sock _ (NetworkSession { _recvLen = s }) = do- bs <- SB.recv sock (fromIntegral s)- if B.null bs- then return Nothing- else return $ Just bs----------------------------------------------------------------------------------send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send sock tickle _ _ bs = SB.sendAll sock bs >> tickle--#else---------------------------------------------------------------------------------recv :: IO () -> NetworkSession -> IO (Maybe ByteString)-recv onBlock (NetworkSession s _ buffSize) = do- fp <- BI.mallocByteString $ fromEnum buffSize- sz <- withForeignPtr fp $ \p ->- throwErrnoIfMinus1RetryMayBlock- "recv"- (c_read s p $ toEnum buffSize)- onBlock-- if sz == 0- then return Nothing- else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz----------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send tickleTimeout onBlock (NetworkSession s _ _) bs =- BI.unsafeUseAsCStringLen bs $ uncurry loop- where loop ptr len = do- sent <- throwErrnoIfMinus1RetryMayBlock- "send"- (c_write s ptr $ toEnum len)- onBlock-- let sent' = fromIntegral sent- if sent' < len- then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')- else return ()----------------------------------------------------------------------------------foreign import ccall unsafe "unistd.h read" c_read- :: CInt -> Ptr a -> CSize -> IO (CSize)-foreign import ccall unsafe "unistd.h write" c_write- :: CInt -> Ptr a -> CSize -> IO (CSize)--#endif
− src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -1,736 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module Snap.Internal.Http.Server.LibevBackend- ( libEvEventLoop- ) where--#ifndef LIBEV--import Control.Exception-import Data.Typeable-import Snap.Internal.Http.Server.Backend--data LibevException = LibevException String- deriving (Show, Typeable)-instance Exception LibevException--libEvEventLoop :: EventLoop-libEvEventLoop _ _ _ _ _ = throwIO $- LibevException "libev event loop is not supported"--#else-------------------------------- TODO: document module ---------------------------------------------------------------------------------------------------------------import Control.Concurrent hiding (yield)-import Control.Exception-import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import Data.ByteString.Internal (c2w)-import qualified Data.ByteString as S-import Data.Maybe-import Data.IORef-import Data.Typeable-import Foreign hiding (new)-import Foreign.C.Types-import GHC.Conc (forkOnIO)-import Network.Libev-import Network.Socket-import Prelude hiding (catch)----------------------------------------------------------------------------------- FIXME: should be HashSet, make that later.-import qualified Data.Concurrent.HashMap as H-import Data.Concurrent.HashMap (HashMap)-import Snap.Iteratee hiding (map)-import Snap.Internal.Debug-import Snap.Internal.Http.Server.Date-import Snap.Internal.Http.Server.Backend-import qualified Snap.Internal.Http.Server.ListenHelpers as Listen--#if defined(HAS_SENDFILE)-import qualified System.SendFile as SF-import System.Posix.IO-import System.Posix.Types (Fd(..))-#endif----------------------------------------------------------------------------------data Backend = Backend- { _acceptSockets :: [ListenSocket]- , _evLoop :: !EvLoopPtr- , _acceptIOCallbacks :: ![MVar (FunPtr IoCallback)]- , _acceptIOObjs :: ![EvIoPtr]- , _mutexCallbacks :: !(FunPtr MutexCallback, FunPtr MutexCallback)- , _loopLock :: !(MVar ())- , _asyncCb :: !(FunPtr AsyncCallback)- , _asyncObj :: !EvAsyncPtr- , _killCb :: !(FunPtr AsyncCallback)- , _killObj :: !EvAsyncPtr- , _connectionThreads :: !(HashMap ThreadId Connection)- , _backendCPU :: !Int- , _loopExit :: !(MVar ())- }----------------------------------------------------------------------------------data Connection = Connection- { _backend :: !Backend- , _listenSocket :: !ListenSocket- , _rawSocket :: !CInt- , _sessionInfo :: !SessionInfo- , _readAvailable :: !(MVar ())- , _writeAvailable :: !(MVar ())- , _timerObj :: !EvTimerPtr- , _timerCallback :: !(FunPtr TimerCallback)- , _timerTimeoutTime :: !(IORef CTime)- , _readActive :: !(IORef Bool)- , _writeActive :: !(IORef Bool)- , _connReadIOObj :: !EvIoPtr- , _connReadIOCallback :: !(FunPtr IoCallback)- , _connWriteIOObj :: !EvIoPtr- , _connWriteIOCallback :: !(FunPtr IoCallback)- , _connThread :: !(ThreadId)- }----------------------------------------------------------------------------------libEvEventLoop :: EventLoop-libEvEventLoop defaultTimeout sockets cap elog handler = do- backends <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)- [0..(cap-1)]-- debug "libevEventLoop: waiting for loop exit"- ignoreException (Prelude.mapM_ (takeMVar . _loopExit) backends)- debug "libevEventLoop: stopping all backends"- ignoreException $ mapM stop backends- ignoreException $ mapM Listen.closeSocket sockets----------------------------------------------------------------------------------newLoop :: Int -- ^ default timeout- -> [ListenSocket] -- ^ value you got from bindIt- -> SessionHandler -- ^ handler- -> (ByteString -> IO ()) -- ^ error logger- -> Int -- ^ cpu- -> IO Backend-newLoop defaultTimeout sockets handler elog cpu = do- -- We'll try kqueue on OSX even though the libev docs complain that it's- -- "broken", in the hope that it works as expected for sockets- f <- evRecommendedBackends- lp <- evLoopNew $ toEnum . fromEnum $ f .|. evbackend_kqueue--- -- we'll be working multithreaded so we need to set up locking for the C- -- event loop struct- (mc1,mc2,looplock) <- setupLockingForLoop lp-- -- setup async callbacks -- these allow us to wake up the main loop- -- (normally blocked in c-land) from other threads- asyncObj <- mkEvAsync- asyncCB <- mkAsyncCallback $ \_ _ _ -> do- debug "async wakeup"- return ()-- killObj <- mkEvAsync- killCB <- mkAsyncCallback $ \_ _ _ -> do- debug "async kill wakeup"- evUnloop lp evunloop_all- return ()-- evAsyncInit asyncObj asyncCB- evAsyncStart lp asyncObj- evAsyncInit killObj killCB- evAsyncStart lp killObj-- -- create the ios for the accept callbacks- accMVars <- forM sockets $ \_ -> newEmptyMVar- accIOs <- forM sockets $ \_ -> mkEvIo-- -- thread set stuff- connSet <- H.new (H.hashString . show)-- -- freed gets stuffed with () when all resources are released.- freed <- newEmptyMVar-- let b = Backend sockets- lp- accMVars- accIOs- (mc1,mc2)- looplock- asyncCB- asyncObj- killCB- killObj- connSet- cpu- freed-- -- setup the accept callback; this watches for read readiness on the- -- listen port- forM_ (zip3 sockets accIOs accMVars) $ \(sock, accIO, x) -> do- accCB <- mkIoCallback $ acceptCallback defaultTimeout b handler elog- cpu sock- evIoInit accIO accCB (fdSocket $ Listen.listenSocket sock) ev_read- evIoStart lp accIO- putMVar x accCB-- forkOnIO cpu $ loopThread b-- debug $ "LibEv.newLoop: loop spawned"- return b------------------------------------------------------------------------------------ | Run evLoop in a thread-loopThread :: Backend -> IO ()-loopThread backend = do- debug $ "starting loop"- (ignoreException go) `finally` cleanup- debug $ "loop finished"- where- cleanup = block $ do- debug $ "loopThread: cleaning up"- ignoreException $ freeBackend backend- putMVar (_loopExit backend) ()-- lock = _loopLock backend- loop = _evLoop backend- go = takeMVar lock >> block (evLoop loop 0)----------------------------------------------------------------------------------acceptCallback :: Int- -> Backend- -> SessionHandler- -> (ByteString -> IO ())- -> Int- -> ListenSocket- -> IoCallback-acceptCallback defaultTimeout back handler- elog cpu sock _loopPtr _ioPtr _ = do- debug "inside acceptCallback"- r <- c_accept $ fdSocket $ Listen.listenSocket sock-- case r of- -- this (EWOULDBLOCK) shouldn't happen (we just got told it was ready!),- -- if it does (maybe the request got picked up by another thread) we'll- -- just bail out- -2 -> return ()- -1 -> debugErrno "Libev.acceptCallback:c_accept()"- fd -> do- debug $ "acceptCallback: accept()ed fd, writing to chan " ++ show fd- forkOnIO cpu $ (go r `catches` cleanup)- return ()- where- go = runSession defaultTimeout back handler sock- cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()- , Handler $ \(e :: SomeException) ->- elog $ S.concat [ "libev.acceptCallback: "- , S.pack . map c2w $ show e ]- ]----------------------------------------------------------------------------------ioReadCallback :: CInt -> IORef Bool -> MVar () -> IoCallback-ioReadCallback fd active ra _loopPtr _ioPtr _ = do- -- send notifications to the worker thread- debug $ "ioReadCallback: notification (" ++ show fd ++ ")"- tryPutMVar ra ()- debug $ "stopping ioReadCallback (" ++ show fd ++ ")"- evIoStop _loopPtr _ioPtr- writeIORef active False----------------------------------------------------------------------------------ioWriteCallback :: CInt -> IORef Bool -> MVar () -> IoCallback-ioWriteCallback fd active wa _loopPtr _ioPtr _ = do- -- send notifications to the worker thread- debug $ "ioWriteCallback: notification (" ++ show fd ++ ")"- tryPutMVar wa ()- debug $ "stopping ioWriteCallback (" ++ show fd ++ ")"- evIoStop _loopPtr _ioPtr- writeIORef active False----------------------------------------------------------------------------------stop :: Backend -> IO ()-stop b = ignoreException $ do- debug $ "Libev.stop"-- -- 1. take the loop lock- -- 2. shut down the accept() callback- -- 3. call evUnloop and wake up the loop using evAsyncSend- -- 4. release the loop lock, the main loop thread should then free/clean- -- everything up (threads, connections, io objects, callbacks, etc)-- withMVar lock $ \_ -> do- forM acceptObjs $ evIoStop loop- evUnloop loop evunloop_all- evAsyncSend loop killObj-- where- loop = _evLoop b- acceptObjs = _acceptIOObjs b- killObj = _killObj b- lock = _loopLock b----------------------------------------------------------------------------------getAddr :: SockAddr -> IO (ByteString, Int)-getAddr addr =- case addr of- SockAddrInet p ha -> do- s <- liftM (S.pack . map c2w) (inet_ntoa ha)- return (s, fromIntegral p)-- a -> throwIO $ AddressNotSupportedException (show a)------------------------------------------------------------------------------------ | Throws a timeout exception to the handling thread. The thread will clean--- up everything.-timerCallback :: EvLoopPtr -- ^ loop obj- -> EvTimerPtr -- ^ timer obj- -> IORef CTime -- ^ when to timeout?- -> ThreadId -- ^ thread to kill- -> TimerCallback-timerCallback loop tmr ioref tid _ _ _ = do- debug "Libev.timerCallback: entered"-- now <- getCurrentDateTime- whenToDie <- readIORef ioref-- if whenToDie <= now- then do- debug "Libev.timerCallback: killing thread"- throwTo tid TimeoutException-- else do- debug $ "Libev.timerCallback: now=" ++ show now- ++ ", whenToDie=" ++ show whenToDie- evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now)- evTimerAgain loop tmr------------------------------------------------------------------------------------ | If you already hold the loop lock, you are entitled to destroy a--- connection-destroyConnection :: Connection -> IO ()-destroyConnection conn = do- debug "Libev.destroyConnection: closing socket and killing connection"- c_close fd-- -- stop and free timer object- evTimerStop loop timerObj- freeEvTimer timerObj- freeTimerCallback timerCb-- -- stop and free i/o objects- evIoStop loop ioWrObj- freeEvIo ioWrObj- freeIoCallback ioWrCb-- evIoStop loop ioRdObj- freeEvIo ioRdObj- freeIoCallback ioRdCb-- where- backend = _backend conn- loop = _evLoop backend-- fd = _rawSocket conn- ioWrObj = _connWriteIOObj conn- ioWrCb = _connWriteIOCallback conn- ioRdObj = _connReadIOObj conn- ioRdCb = _connReadIOCallback conn- timerObj = _timerObj conn- timerCb = _timerCallback conn----------------------------------------------------------------------------------freeConnection :: Connection -> IO ()-freeConnection conn = ignoreException $ do- withMVar loopLock $ \_ -> block $ do- debug $ "freeConnection (" ++ show (_rawSocket conn) ++ ")"- destroyConnection conn- let tid = _connThread conn-- -- remove the thread id from the backend set- H.delete tid $ _connectionThreads backend-- -- wake up the event loop so it can be apprised of the changes- evAsyncSend loop asyncObj-- where- backend = _backend conn- loop = _evLoop backend- loopLock = _loopLock backend- asyncObj = _asyncObj backend----------------------------------------------------------------------------------freeBackend :: Backend -> IO ()-freeBackend backend = ignoreException $ block $ do- -- note: we only get here after an unloop, so we have the loop lock- -- here. (?)-- -- kill everything in thread table- tset <- H.toList $ _connectionThreads backend-- let nthreads = Prelude.length tset-- debug $ "Libev.freeBackend: killing active connection threads"-- Prelude.mapM_ (destroyConnection . snd) tset-- -- kill the threads twice, they're probably getting stuck in the- -- freeConnection 'finally' handler- Prelude.mapM_ (killThread . fst) tset- Prelude.mapM_ (killThread . fst) tset-- debug $ "Libev.freeBackend: " ++ show nthreads ++ " thread(s) killed"- debug $ "Libev.freeBackend: destroying libev resources"-- mapM freeEvIo acceptObjs- forM acceptCbs $ \x -> do- acceptCb <- readMVar x- freeIoCallback acceptCb-- evAsyncStop loop asyncObj- freeEvAsync asyncObj- freeAsyncCallback asyncCb-- evAsyncStop loop killObj- freeEvAsync killObj- freeAsyncCallback killCb-- freeMutexCallback mcb1- freeMutexCallback mcb2-- evLoopDestroy loop- debug $ "Libev.freeBackend: resources destroyed"-- where- acceptObjs = _acceptIOObjs backend- acceptCbs = _acceptIOCallbacks backend- asyncObj = _asyncObj backend- asyncCb = _asyncCb backend- killObj = _killObj backend- killCb = _killCb backend- (mcb1,mcb2) = _mutexCallbacks backend- loop = _evLoop backend------------------------------------------------------------------------------------ | Note: proc gets run in the background-runSession :: Int- -> Backend- -> SessionHandler- -> ListenSocket- -> CInt- -> IO ()-runSession defaultTimeout backend handler lsock fd = do- sock <- mkSocket fd AF_INET Stream 0 Connected- peerName <- getPeerName sock- sockName <- getSocketName sock- tid <- myThreadId-- -- set_linger fd- c_setnonblocking fd-- (raddr, rport) <- getAddr peerName- (laddr, lport) <- getAddr sockName-- let lp = _evLoop backend-- -- makes sense to assume the socket is read/write available when- -- opened; worst-case is we get EWOULDBLOCK- ra <- newMVar ()- wa <- newMVar ()--- ------------------ -- setup timer --- ------------------ tmr <- mkEvTimer- now <- getCurrentDateTime- timeoutTime <- newIORef $ now + 20- tcb <- mkTimerCallback $ timerCallback lp- tmr- timeoutTime- tid- -- 20 second timeout- evTimerInit tmr tcb 0 20.0--- readActive <- newIORef True- writeActive <- newIORef True-- evioRead <- mkEvIo- ioReadCb <- mkIoCallback $ ioReadCallback fd readActive ra-- evioWrite <- mkEvIo- ioWriteCb <- mkIoCallback $ ioWriteCallback fd writeActive wa-- evIoInit evioRead ioReadCb fd ev_read- evIoInit evioWrite ioWriteCb fd ev_write-- -- take ev_loop lock, start timer and io watchers- withMVar (_loopLock backend) $ \_ -> do- evTimerAgain lp tmr- evIoStart lp evioRead- evIoStart lp evioWrite-- -- wakeup the loop thread so that these new watchers get- -- registered next time through the loop- evAsyncSend lp $ _asyncObj backend-- let sinfo = SessionInfo laddr lport raddr rport $- Listen.isSecure lsock- let conn = Connection backend- lsock- fd- sinfo- ra- wa- tmr- tcb- timeoutTime- readActive- writeActive- evioRead- ioReadCb- evioWrite- ioWriteCb- tid-- bracket (Listen.createSession lsock bLOCKSIZE fd $- waitForLock True conn)- (\session -> block $ do- debug "runSession: thread killed, closing socket"-- ignoreException $ Listen.endSession lsock session- ignoreException $ freeConnection conn- )- (\session -> do H.update tid conn (_connectionThreads backend)- handler sinfo- (enumerate conn session)- (writeOut defaultTimeout conn session)- (sendFile defaultTimeout conn session)- (tickleTimeout conn)- )----------------------------------------------------------------------------------ignoreException :: IO a -> IO ()-ignoreException act =- (act >> return ()) `catch` \(_::SomeException) -> return ()----------------------------------------------------------------------------------data AddressNotSupportedException = AddressNotSupportedException String- deriving (Typeable)--instance Show AddressNotSupportedException where- show (AddressNotSupportedException x) = "Address not supported: " ++ x--instance Exception AddressNotSupportedException-----------------------------------------------------------------------------------bLOCKSIZE :: Int-bLOCKSIZE = 8192------- About timeouts------ It's not good enough to restart the timer from io(Read|Write)Callback,--- because those seem to be edge-triggered. I've definitely had where after 20--- seconds they still weren't being re-awakened.-------------------------------------------------------------------------------------data TimeoutException = TimeoutException- deriving (Typeable)--instance Show TimeoutException where- show _ = "timeout"--instance Exception TimeoutException----------------------------------------------------------------------------------tickleTimeout :: Connection -> Int -> IO ()-tickleTimeout conn tm = do- debug "Libev.tickleTimeout"- now <- getCurrentDateTime- writeIORef (_timerTimeoutTime conn) (now + toEnum tm)----------------------------------------------------------------------------------waitForLock :: Bool -- ^ True = wait for read, False = wait for write- -> Connection- -> IO ()-waitForLock readLock conn = do- dbg "start waitForLock"-- withMVar looplock $ \_ -> do- act <- readIORef active- if act- then dbg "read watcher already active, skipping"- else do- dbg "starting watcher, sending async"- tryTakeMVar lock- evIoStart lp io- writeIORef active True- evAsyncSend lp async-- dbg "waitForLock: waiting for mvar"- takeMVar lock- dbg "waitForLock: took mvar"-- where- dbg s = debug $ "Libev.recvData(" ++ show (_rawSocket conn) ++ "): "- ++ s- io = if readLock- then (_connReadIOObj conn)- else (_connWriteIOObj conn)- bk = _backend conn- active = if readLock- then (_readActive conn)- else (_writeActive conn)- lp = _evLoop bk- looplock = _loopLock bk- async = _asyncObj bk- lock = if readLock- then (_readAvailable conn)- else (_writeAvailable conn)----------------------------------------------------------------------------------sendFile :: Int- -> Connection- -> NetworkSession- -> FilePath- -> Int64- -> Int64- -> IO ()-sendFile defaultTimeout c s fp start sz = do- withMVar lock $ \_ -> do- act <- readIORef $ _writeActive c- when act $ evIoStop loop io- writeIORef (_writeActive c) False- evAsyncSend loop asy--#if defined(HAS_SENDFILE)- case (_listenSocket c) of- ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)- (closeFd)- (go start sz)- _ -> do- step <- runIteratee $ writeOut defaultTimeout c s- run_ $ enumFilePartial fp (start,start+sz) step-#else- step <- runIteratee $ writeOut defaultTimeout c s-- run_ $ enumFilePartial fp (start,start+sz) step- return ()-#endif-- withMVar lock $ \_ -> do- tryTakeMVar $ _readAvailable c- tryTakeMVar $ _writeAvailable c- evAsyncSend loop asy-- where-#if defined(HAS_SENDFILE)- go off bytes fd- | bytes == 0 = return ()- | otherwise = do- sent <- SF.sendFile (waitForLock False c) sfd fd off bytes- if sent < bytes- then tickleTimeout c defaultTimeout >>- go (off+sent) (bytes-sent) fd- else return ()-- sfd = Fd $ _rawSocket c-#endif- io = _connWriteIOObj c- b = _backend c- loop = _evLoop b- lock = _loopLock b- asy = _asyncObj b----------------------------------------------------------------------------------enumerate :: (MonadIO m)- => Connection- -> NetworkSession- -> Enumerator ByteString m a-enumerate conn session = loop- where- dbg s = debug $ "Libev.enumerate(" ++ show (_socket session)- ++ "): " ++ s-- loop (Continue k) = do- m <- liftIO $ recvData- let s = fromMaybe "" m- sendOne k s- loop x = returnI x-- sendOne k s | S.null s = do- dbg "sending EOF to continuation"- enumEOF $ Continue k-- | otherwise = do- dbg $ "sending " ++ show s ++ " to continuation"- step <- lift $ runIteratee $ k $ Chunks [s]- case step of- (Yield x st) -> do- dbg $ "got yield, remainder is " ++ show st- yield x st- r@(Continue _) -> do- dbg $ "got continue"- loop r- (Error e) -> throwError e-- recvData = Listen.recv (_listenSocket conn)- (waitForLock True conn) session----------------------------------------------------------------------------------writeOut :: (MonadIO m)- => Int- -> Connection- -> NetworkSession- -> Iteratee ByteString m ()-writeOut defaultTimeout conn session = loop- where- loop = continue k-- k EOF = yield () EOF- k (Chunks xs) = do- liftIO $ sendData $ S.concat xs- loop-- sendData = Listen.send (_listenSocket conn)- (tickleTimeout conn defaultTimeout)- (waitForLock False conn)- session--#endif
− src/Snap/Internal/Http/Server/ListenHelpers.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}--module Snap.Internal.Http.Server.ListenHelpers where----------------------------------------------------------------------------------import Data.ByteString (ByteString)-import Foreign.C-import Network.Socket (Socket, sClose)-import Snap.Internal.Http.Server.Backend-import qualified Snap.Internal.Http.Server.HttpPort as Http-import qualified Snap.Internal.Http.Server.GnuTLS as TLS----------------------------------------------------------------------------------listenSocket :: ListenSocket -> Socket-listenSocket (ListenHttp s) = s-listenSocket (ListenHttps s _ _) = s----------------------------------------------------------------------------------isSecure :: ListenSocket -> Bool-isSecure (ListenHttp _) = False-isSecure (ListenHttps _ _ _) = True----------------------------------------------------------------------------------closeSocket :: ListenSocket -> IO ()-closeSocket (ListenHttp s) = sClose s-closeSocket p@(ListenHttps s _ _) = do TLS.freePort p- sClose s----------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttp _) = Http.createSession-createSession p@(ListenHttps _ _ _) = TLS.createSession p----------------------------------------------------------------------------------endSession :: ListenSocket -> NetworkSession -> IO ()-endSession (ListenHttp _) = Http.endSession-endSession (ListenHttps _ _ _) = TLS.endSession---#ifdef PORTABLE----- For portable builds, we can't call read/write directly so we need the--- original haskell socket to use with network-bytestring package.--- Only the simple backend creates sockets in haskell so the following--- functions only work with the simple backend.----------------------------------------------------------------------------------recv :: ListenSocket -> Socket -> IO () -> NetworkSession- -> IO (Maybe ByteString)-recv (ListenHttp _) s = Http.recv s-recv (ListenHttps _ _ _) _ = TLS.recv----------------------------------------------------------------------------------send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession- -> ByteString -> IO ()-send (ListenHttp _) s = Http.send s-send (ListenHttps _ _ _) _ = TLS.send---#else----------------------------------------------------------------------------------recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv (ListenHttp _) = Http.recv-recv (ListenHttps _ _ _) = TLS.recv----------------------------------------------------------------------------------send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString- -> IO ()-send (ListenHttp _) = Http.send-send (ListenHttps _ _ _) = TLS.send--#endif
+ src/Snap/Internal/Http/Server/Parser.hs view
@@ -0,0 +1,460 @@+{-# 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 #-}
+ src/Snap/Internal/Http/Server/Session.hs view
@@ -0,0 +1,832 @@+{-# 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
− src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -1,327 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Server.SimpleBackend- ( simpleEventLoop- ) where----------------------------------------------------------------------------------import Control.Monad.Trans--import Control.Concurrent hiding (yield)-import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.ByteString.Internal (c2w)-import Data.Maybe-import Data.Typeable-import Foreign hiding (new)-import Foreign.C-import GHC.Conc (labelThread, forkOnIO)-import Network.Socket-import Prelude hiding (catch)--------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Internal.Http.Server.Date-import qualified Snap.Internal.Http.Server.TimeoutManager as TM-import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager)-import Snap.Internal.Http.Server.Backend-import qualified Snap.Internal.Http.Server.ListenHelpers as Listen-import Snap.Iteratee hiding (map)--#if defined(HAS_SENDFILE)-import qualified System.SendFile as SF-import System.Posix.IO-import System.Posix.Types (Fd(..))-#endif------------------------------------------------------------------------------------ | For each cpu, we store:--- * A list of accept threads, one per port.--- * A TimeoutManager--- * An mvar to signal when the timeout thread is shutdown-data EventLoopCpu = EventLoopCpu- { _boundCpu :: Int- , _acceptThreads :: [ThreadId]- , _timeoutManager :: TimeoutManager- , _exitMVar :: !(MVar ())- }----------------------------------------------------------------------------------simpleEventLoop :: EventLoop-simpleEventLoop defaultTimeout sockets cap elog handler = do- loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)- [0..(cap-1)]-- debug "simpleEventLoop: waiting for mvars"-- --wait for all threads to exit- Prelude.mapM_ (takeMVar . _exitMVar) loops `finally` do- debug "simpleEventLoop: killing all threads"- _ <- mapM_ stopLoop loops- mapM_ Listen.closeSocket sockets----------------------------------------------------------------------------------newLoop :: Int- -> [ListenSocket]- -> SessionHandler- -> (S.ByteString -> IO ())- -> Int- -> IO EventLoopCpu-newLoop defaultTimeout sockets handler elog cpu = do- tmgr <- TM.initialize defaultTimeout getCurrentDateTime- exit <- newEmptyMVar- accThreads <- forM sockets $ \p -> forkOnIO cpu $- acceptThread defaultTimeout handler tmgr elog cpu p exit-- return $ EventLoopCpu cpu accThreads tmgr exit----------------------------------------------------------------------------------stopLoop :: EventLoopCpu -> IO ()-stopLoop loop = block $ do- TM.stop $ _timeoutManager loop- Prelude.mapM_ killThread $ _acceptThreads loop----------------------------------------------------------------------------------acceptThread :: Int- -> SessionHandler- -> TimeoutManager- -> (S.ByteString -> IO ())- -> Int- -> ListenSocket- -> MVar ()- -> IO ()-acceptThread defaultTimeout handler tmgr elog cpu sock exitMVar =- loop `finally` (tryPutMVar exitMVar () >> return ())- where- loop = do- debug $ "acceptThread: calling accept() on socket " ++ show sock- (s,addr) <- accept $ Listen.listenSocket sock- debug $ "acceptThread: accepted connection from remote: " ++ show addr- _ <- forkOnIO cpu (go s addr `catches` cleanup)- loop-- go = runSession defaultTimeout handler tmgr sock-- cleanup =- [- Handler $ \(_ :: AsyncException) -> return ()- , Handler $ \(e :: SomeException) -> elog- $ S.concat [ "SimpleBackend.acceptThread: "- , S.pack . map c2w $ show e]- ]----------------------------------------------------------------------------------data AddressNotSupportedException = AddressNotSupportedException String- deriving (Typeable)--instance Show AddressNotSupportedException where- show (AddressNotSupportedException x) = "Address not supported: " ++ x--instance Exception AddressNotSupportedException----------------------------------------------------------------------------------runSession :: Int- -> SessionHandler- -> TimeoutManager- -> ListenSocket- -> Socket- -> SockAddr -> IO ()-runSession defaultTimeout handler tmgr lsock sock addr = do- let fd = fdSocket sock- curId <- myThreadId-- debug $ "Backend.withConnection: running session: " ++ show addr- labelThread curId $ "connHndl " ++ show fd-- (rport,rhost) <-- case addr of- SockAddrInet p h -> do- h' <- inet_ntoa h- return (fromIntegral p, S.pack $ map c2w h')- x -> throwIO $ AddressNotSupportedException $ show x-- laddr <- getSocketName sock-- (lport,lhost) <-- case laddr of- SockAddrInet p h -> do- h' <- inet_ntoa h- return (fromIntegral p, S.pack $ map c2w h')- x -> throwIO $ AddressNotSupportedException $ show x-- let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock-- timeoutHandle <- TM.register (killThread curId) tmgr- let timeout = TM.tickle timeoutHandle-- bracket (Listen.createSession lsock 8192 fd- (threadWaitRead $ fromIntegral fd))- (\session -> block $ do- debug "thread killed, closing socket"-- -- cancel thread timeout- TM.cancel timeoutHandle-- eatException $ Listen.endSession lsock session- eatException $ shutdown sock ShutdownBoth- eatException $ sClose sock- )- (\s -> let writeEnd = writeOut lsock s sock- (timeout defaultTimeout)- in handler sinfo- (enumerate lsock s sock)- writeEnd- (sendFile lsock (timeout defaultTimeout) fd- writeEnd)- timeout- )----------------------------------------------------------------------------------eatException :: IO a -> IO ()-eatException act = (act >> return ()) `catch` \(_::SomeException) -> return ()----------------------------------------------------------------------------------sendFile :: ListenSocket- -> IO ()- -> CInt- -> Iteratee ByteString IO ()- -> FilePath- -> Int64- -> Int64- -> IO ()-#if defined(HAS_SENDFILE)-sendFile lsock tickle sock writeEnd fp start sz =- case lsock of- ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)- (closeFd)- (go start sz)- _ -> do- step <- runIteratee writeEnd- run_ $ enumFilePartial fp (start,start+sz) step- where- go off bytes fd- | bytes == 0 = return ()- | otherwise = do- sent <- SF.sendFile (threadWaitWrite $ fromIntegral sock)- sfd fd off bytes- if sent < bytes- then tickle >> go (off+sent) (bytes-sent) fd- else return ()-- sfd = Fd sock-#else-sendFile _ _ _ writeEnd fp start sz = do- -- no need to count bytes- step <- runIteratee writeEnd- run_ $ enumFilePartial fp (start,start+sz) step- return ()-#endif----------------------------------------------------------------------------------enumerate :: (MonadIO m)- => ListenSocket- -> NetworkSession- -> Socket- -> Enumerator ByteString m a-enumerate port session sock = loop- where- dbg s = debug $ "SimpleBackend.enumerate(" ++ show (_socket session)- ++ "): " ++ s-- loop (Continue k) = do- dbg "reading from socket"- s <- liftIO $ timeoutRecv- case s of- Nothing -> do- dbg "got EOF from socket"- sendOne k ""- Just s' -> do- dbg $ "got " ++ Prelude.show (S.length s')- ++ " bytes from read end"- sendOne k s'-- loop x = returnI x--- sendOne k s | S.null s = do- dbg "sending EOF to continuation"- enumEOF $ Continue k-- | otherwise = do- dbg $ "sending " ++ show s ++ " to continuation"- step <- lift $ runIteratee $ k $ Chunks [s]- case step of- (Yield x st) -> do- dbg $ "got yield, remainder is " ++ show st- yield x st- r@(Continue _) -> do- dbg $ "got continue"- loop r- (Error e) -> throwError e-- fd = fdSocket sock-#ifdef PORTABLE- timeoutRecv = Listen.recv port sock (threadWaitRead $- fromIntegral fd) session-#else- timeoutRecv = Listen.recv port (threadWaitRead $- fromIntegral fd) session-#endif----------------------------------------------------------------------------------writeOut :: (MonadIO m)- => ListenSocket- -> NetworkSession- -> Socket- -> (IO ())- -> Iteratee ByteString m ()-writeOut port session sock tickle = loop- where- dbg s = debug $ "SimpleBackend.writeOut(" ++ show (_socket session)- ++ "): " ++ s-- loop = continue k-- k EOF = yield () EOF- k (Chunks xs) = do- let s = S.concat xs- let n = S.length s- dbg $ "got chunk with " ++ show n ++ " bytes"- ee <- liftIO $ try $ timeoutSend s- case ee of- (Left (e::SomeException)) -> do- dbg $ "timeoutSend got error " ++ show e- throwError e- (Right _) -> do- let last10 = S.drop (n-10) s- dbg $ "wrote " ++ show n ++ " bytes, last 10=" ++ show last10- loop-- fd = fdSocket sock-#ifdef PORTABLE- timeoutSend = Listen.send port sock tickle- (threadWaitWrite $ fromIntegral fd) session-#else- timeoutSend = Listen.send port tickle- (threadWaitWrite $ fromIntegral fd) session-#endif
+ src/Snap/Internal/Http/Server/Socket.hs view
@@ -0,0 +1,208 @@+{-# 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
+ src/Snap/Internal/Http/Server/TLS.hs view
@@ -0,0 +1,165 @@+{-# 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
+ src/Snap/Internal/Http/Server/Thread.hs view
@@ -0,0 +1,107 @@+{-# 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 $! ())
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -1,60 +1,101 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.TimeoutManager ( TimeoutManager- , TimeoutHandle+ , TimeoutThread , initialize , stop , register , tickle+ , set+ , modify , cancel ) where -------------------------------------------------------------------------------import Control.Concurrent-import Control.Exception-import Control.Monad-import Data.IORef-import Foreign.C.Types+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 + -------------------------------------------------------------------------------data State = Deadline !CTime- | Canceled+type State = ClockTime +canceled :: State+canceled = 0 +isCanceled :: State -> Bool+isCanceled = (== 0)++ -------------------------------------------------------------------------------data TimeoutHandle = TimeoutHandle {- _killAction :: !(IO ())+data TimeoutThread = TimeoutThread {+ _thread :: !T.SnapThread , _state :: !(IORef State)- , _hGetTime :: !(IO CTime)+ , _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 :: !Int- , _getTime :: !(IO CTime)- , _connections :: !(IORef [TimeoutHandle])- , _inactivity :: !(IORef Bool)+ _defaultTimeout :: !ClockTime+ , _pollInterval :: !ClockTime+ , _getTime :: !(IO ClockTime)+ , _threads :: !(IORef [TimeoutThread]) , _morePlease :: !(MVar ())- , _managerThread :: !(MVar ThreadId)+ , _managerThread :: !(MVar T.SnapThread) } ------------------------------------------------------------------------------ -- | Create a new TimeoutManager.-initialize :: Int -- ^ default timeout- -> IO CTime -- ^ function to get current time+initialize :: Double -- ^ default timeout+ -> Double -- ^ poll interval+ -> IO ClockTime -- ^ function to get current time -> IO TimeoutManager-initialize defaultTimeout getTime = do+initialize defaultTimeout interval getTime = E.uninterruptibleMask_ $ do conns <- newIORef []- inact <- newIORef False mp <- newEmptyMVar mthr <- newEmptyMVar - let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr+ let tm = TimeoutManager (Clock.fromSecs defaultTimeout)+ (Clock.fromSecs interval)+ getTime+ conns+ mp+ mthr - thr <- forkIO $ managerThread tm+ thr <- T.fork "snap-server: timeout manager" $ managerThread tm putMVar mthr thr return tm @@ -62,109 +103,127 @@ ------------------------------------------------------------------------------ -- | Stop a TimeoutManager. stop :: TimeoutManager -> IO ()-stop tm = readMVar (_managerThread tm) >>= killThread+stop tm = readMVar (_managerThread tm) >>= T.cancelAndWait --------------------------------------------------------------------------------- | Register a new connection with the TimeoutManager.-register :: IO () -- ^ action to run when the timeout deadline is- -- exceeded.- -> TimeoutManager -- ^ manager to register with.- -> IO TimeoutHandle-register killAction tm = do- now <- getTime- let !state = Deadline $ now + toEnum defaultTimeout- stateRef <- newIORef state+wakeup :: TimeoutManager -> IO ()+wakeup tm = void $ tryPutMVar (_morePlease tm) $! () - let !h = TimeoutHandle killAction stateRef getTime- atomicModifyIORef connections $ \x -> (h:x, ()) - inact <- readIORef inactivity- when inact $ do- -- wake up manager thread- writeIORef inactivity False- _ <- tryPutMVar morePlease ()- return ()- return h+------------------------------------------------------------------------------+-- | 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- inactivity = _inactivity tm- morePlease = _morePlease tm- connections = _connections tm+ threads = _threads tm defaultTimeout = _defaultTimeout tm --------------------------------------------------------------------------------- | Tickle the timeout on a connection to be N seconds into the future.-tickle :: TimeoutHandle -> Int -> IO ()-tickle th n = do- now <- getTime+-- | 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 #-} - let state = Deadline $ now + toEnum n- writeIORef stateRef state +------------------------------------------------------------------------------+-- | 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 :: TimeoutHandle -> IO ()-cancel h = writeIORef (_state h) Canceled+cancel :: TimeoutThread -> IO ()+cancel h = E.uninterruptibleMask_ $ do+ writeIORef (_state h) canceled+ T.cancel $ _thread h+{-# INLINE cancel #-} -------------------------------------------------------------------------------managerThread :: TimeoutManager -> IO ()-managerThread tm = loop `finally` (readIORef connections >>= destroyAll)+managerThread :: TimeoutManager -> (forall a. IO a -> IO a) -> IO ()+managerThread tm restore = restore loop `finally` cleanup where+ cleanup = E.uninterruptibleMask_ $+ eatException (readIORef threads >>= destroyAll)+ --------------------------------------------------------------------------- connections = _connections tm- getTime = _getTime tm- inactivity = _inactivity tm- morePlease = _morePlease tm- waitABit = threadDelay 5000000+ getTime = _getTime tm+ morePlease = _morePlease tm+ pollInterval = _pollInterval tm+ threads = _threads tm -------------------------------------------------------------------------- loop = do- waitABit- handles <- atomicModifyIORef connections (\x -> ([],x))-- if null handles- then do- -- we're inactive, go to sleep until we get new threads- writeIORef inactivity True- takeMVar morePlease- else do- now <- getTime- dlist <- processHandles now handles id- atomicModifyIORef connections (\x -> (dlist x, ()))-+ 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 initDlist = go handles initDlist+ processHandles now handles = go handles [] where- go [] !dlist = return dlist-- go (x:xs) !dlist = do- state <- readIORef $ _state x- !dlist' <- case state of- Canceled -> return dlist- Deadline t -> if t <= now- then do- _killAction x- return dlist- else return (dlist . (x:))- go xs dlist'+ go [] !kept = return $! kept - --------------------------------------------------------------------------- destroyAll = mapM_ diediedie+ 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' --------------------------------------------------------------------------- diediedie x = do- state <- readIORef $ _state x- case state of- Canceled -> return ()- _ -> _killAction x+ destroyAll xs = do+ mapM_ (T.cancel . _thread) xs+ mapM_ (T.wait . _thread) xs
+ src/Snap/Internal/Http/Server/Types.hs view
@@ -0,0 +1,185 @@+{-# 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
− src/Snap/Internal/Http/Server/gnutls_helpers.c
@@ -1,17 +0,0 @@-#include <gnutls/gnutls.h>-#include <gcrypt.h>-#include <errno.h>-#include <pthread.h>-GCRY_THREAD_OPTION_PTHREAD_IMPL;--/* See http://www.gnu.org/software/gnutls/manual/html_node/Multi_002dthreaded-applications.html */--static int threading_init = 0;- -void gnutls_set_threading_helper()-{- if (!threading_init) {- gcry_control (GCRYCTL_SET_THREAD_CBS, &gcry_threads_pthread);- threading_init = 1;- }-}
src/System/FastLogger.hs view
@@ -1,31 +1,41 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger-( Logger-, timestampedLogEntry-, combinedLogEntry-, newLogger-, logMsg-, stopLogger-) where-+ ( Logger+ , timestampedLogEntry+ , combinedLogEntry+ , newLogger+ , newLoggerWithCustomErrorFunction+ , withLogger+ , withLoggerWithCustomErrorFunction+ , stopLogger+ , logMsg+ ) where -------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char.Utf8-import Control.Concurrent-import Control.Exception-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.ByteString.Internal (c2w)-import Data.Int-import Data.IORef-import Data.Monoid-import System.IO--import Snap.Internal.Http.Server.Date+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) ------------------------------------------------------------------------------@@ -34,7 +44,9 @@ { _queuedMessages :: !(IORef Builder) , _dataWaiting :: !(MVar ()) , _loggerPath :: !(FilePath)- , _loggingThread :: !(MVar ThreadId) }+ , _loggingThread :: !(MVar ThreadId)+ , _errAction :: ByteString -> IO ()+ } ------------------------------------------------------------------------------@@ -42,79 +54,121 @@ -- \"-\", 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 -> IO Logger-newLogger fp = do+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+ let lg = Logger q dw fp th errAction - tid <- forkIO $ loggingThread lg- putMVar th tid+ 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 $! toByteString- $! mconcat [ fromWord8 $ c2w '['- , fromByteString timeStr- , fromByteString "] "- , fromByteString msg ]+ 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- -> Maybe Int64 -- ^ num bytes sent+ -> 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 !mbNumBytes !mbReferer !ua = do+combinedLogEntry !host !mbUser !req !status !numBytes !mbReferer !ua = do timeStr <- getLogDateString - let !l = [ fromByteString host- , fromByteString " - "+ let !l = [ byteString host+ , byteString " - " , user- , fromByteString " ["- , fromByteString timeStr- , fromByteString "] \""- , fromByteString req- , fromByteString "\" "+ , byteString " ["+ , byteString timeStr+ , byteString "] \""+ , byteString req+ , byteString "\" " , fromShow status , space- , numBytes+ , fromShow numBytes , space , referer- , fromByteString " \""- , fromByteString ua+ , byteString " \""+ , byteString ua , quote ] - let !output = toByteString $ mconcat l-- return $! output+ return $! S.concat . L.toChunks $ toLazyByteString $ mconcat l where- dash = fromWord8 $ c2w '-'- quote = fromWord8 $ c2w '\"'- space = fromWord8 $ c2w ' '- user = maybe dash fromByteString mbUser- numBytes = maybe dash fromShow mbNumBytes+ dash = char8 '-'+ quote = char8 '\"'+ space = char8 ' '+ user = maybe dash byteString mbUser referer = maybe dash (\s -> mconcat [ quote- , fromByteString s+ , byteString s , quote ]) mbReferer @@ -125,72 +179,88 @@ -- (or use 'combinedLogEntry'). logMsg :: Logger -> ByteString -> IO () logMsg !lg !s = do- let !s' = fromByteString s `mappend` (fromWord8 $ c2w '\n')- atomicModifyIORef (_queuedMessages lg) $ \d -> (d `mappend` s',())- tryPutMVar (_dataWaiting lg) () >> return ()+ let !s' = byteString s `mappend` char8 '\n'+ atomicModifyIORef' (_queuedMessages lg) $ \d -> (d `mappend` s',())+ void $ tryPutMVar (_dataWaiting lg) () -------------------------------------------------------------------------------loggingThread :: Logger -> IO ()-loggingThread (Logger queue notifier filePath _) = do+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+ 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 = if filePath == "-" || filePath == "stderr"- then return ()- else hClose h+ closeIt h = unless (h == stdout || h == stderr) $+ hClose h - go (href, lastOpened) =- (loop (href, lastOpened))- `catches`+ logInternalError = errAct . T.encodeUtf8 . T.pack++ --------------------------------------------------------------------------+ go (href, lastOpened) = unmask loop `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do- hPutStrLn stderr $ "logger got exception: " ++ Prelude.show e+ 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 <- getCurrentDateTime+ 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)+ dl <- atomicModifyIORef' queue $ \x -> (mempty,x) let !msgs = toLazyByteString dl h <- readIORef href- L.hPut h msgs- hFlush h+ (do L.hPut h msgs+ hFlush h) `catch` \(e::IOException) -> do+ logInternalError $ "got exception writing to log " +++ filePath ++ ": " ++ show e ++ "\n"+ logInternalError "writing log entries to stderr.\n"+ mapM_ errAct $ L.toChunks msgs -- close the file every 15 minutes (for log rotation)- t <- getCurrentDateTime+ t <- epochTime old <- readIORef lastOpened - if t-old > 900- then do- closeIt h- openIt >>= writeIORef href- writeIORef lastOpened t- else return ()+ when (t-old > 900) $ do+ closeIt h+ mask_ $ openIt >>= writeIORef href+ writeIORef lastOpened t - loop !d = do+ waitFlushDelay !d = do -- wait on the notification mvar _ <- takeMVar notifier @@ -199,7 +269,6 @@ -- at least five seconds between log dumps threadDelay 5000000- loop d ------------------------------------------------------------------------------@@ -207,3 +276,8 @@ -- flushed out to disk stopLogger :: Logger -> IO () stopLogger lg = withMVar (_loggingThread lg) killThread+++------------------------------------------------------------------------------+fromShow :: Show a => a -> Builder+fromShow = stringUtf8 . show
− src/System/SendFile.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}---- | Snap's unified interface to sendfile.--- Modified from sendfile 0.6.1--module System.SendFile- ( sendFile- , sendFileMode- ) where--#if defined(LINUX)-import System.SendFile.Linux (sendFile)--sendFileMode :: String-sendFileMode = "LINUX_SENDFILE"-#elif defined(FREEBSD)-import System.SendFile.FreeBSD (sendFile)--sendFileMode :: String-sendFileMode = "FREEBSD_SENDFILE"-#elif defined(OSX)-import System.SendFile.Darwin (sendFile)--sendFileMode :: String-sendFileMode = "DARWIN_SENDFILE"-#endif
+ src/System/SendFile.hsc view
@@ -0,0 +1,105 @@+{-# 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 <sys/socket.h>++------------------------------------------------------------------------------+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
− src/System/SendFile/Darwin.hsc
@@ -1,45 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--- | Darwin system-dependent code for 'sendfile'.-module System.SendFile.Darwin (sendFile) where--import Data.Int-import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)-import Foreign.C.Types (CInt)-import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (peek, poke)-import System.Posix.Types (Fd, COff)--sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64-sendFile onBlock out_fd in_fd off count- | count == 0 = return 0- | otherwise = alloca $ \pbytes -> do- poke pbytes $ min maxBytes (fromIntegral count)- sbytes <- sendfile onBlock out_fd in_fd (fromIntegral off) pbytes- return $ fromIntegral sbytes--sendfile :: IO () -> Fd -> Fd -> COff -> Ptr COff -> IO COff-sendfile onBlock out_fd in_fd off pbytes = do- status <- c_sendfile out_fd in_fd off pbytes- nsent <- peek pbytes- if status == 0- then return nsent- else do errno <- getErrno- if (errno == eAGAIN) || (errno == eINTR)- then do- if nsent == 0- then onBlock >> sendfile onBlock out_fd in_fd off pbytes- else return nsent- else throwErrno "System.SendFile.Darwin"---- max num of bytes in one send-maxBytes :: COff-maxBytes = maxBound :: COff---- in Darwin sendfile gives LFS support (no sendfile64 routine)-foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_darwin- :: Fd -> Fd -> COff -> Ptr COff -> Ptr () -> CInt -> IO CInt--c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO CInt-c_sendfile out_fd in_fd off pbytes =- c_sendfile_darwin in_fd out_fd off pbytes nullPtr 0
src/System/SendFile/FreeBSD.hsc view
@@ -1,45 +1,79 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | FreeBSD system-dependent code for 'sendfile'.-module System.SendFile.FreeBSD (sendFile) where+module System.SendFile.FreeBSD+ ( sendFile+ , sendFileImpl+ , sendFileMode+ ) where -import Control.Concurrent (threadWaitWrite)-import Data.Int-import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)-import Foreign.C.Types (CInt, CSize)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (peek)-import System.Posix.Types (COff, Fd)+------------------------------------------------------------------------------+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 :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64-sendFile onBlock out_fd in_fd off count++------------------------------------------------------------------------------+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 onBlock out_fd in_fd+ sbytes <- sendfile rawSendFile wait out_fd in_fd (fromIntegral off) (fromIntegral count) pbytes return $ fromIntegral sbytes -sendfile :: IO () -> Fd -> Fd -> COff -> CSize -> Ptr COff -> IO COff-sendfile onBlock out_fd in_fd off count pbytes = do- res <- c_sendfile_freebsd in_fd out_fd off count nullPtr pbytes 0- nsent <- peek pbytes- if (res == 0)- then return nsent- else do- errno <- getErrno- if (errno == eAGAIN) || (errno == eINTR)- then if nsent == 0- then do- onBlock- sendfile onBlock out_fd in_fd off count pbytes- else return nsent- else throwErrno "System.SendFile.FreeBSD.sendfile" +------------------------------------------------------------------------------+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"
src/System/SendFile/Linux.hsc view
@@ -1,42 +1,77 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}++------------------------------------------------------------------------------ -- | Linux system-dependent code for 'sendfile'.-module System.SendFile.Linux (sendFile) where+module System.SendFile.Linux+ ( sendFile+ , sendFileImpl+ , sendFileMode+ ) where -import Data.Int-import Foreign.C.Error (eAGAIN, getErrno, throwErrno)-import Foreign.C.Types (CSize)-import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (poke)-import System.Posix.Types (Fd, COff, CSsize)+------------------------------------------------------------------------------+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 :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64-sendFile onBlock out_fd in_fd off count- | count == 0 = return 0- | off == 0 = do- sbytes <- sendfile onBlock out_fd in_fd nullPtr bytes- return $ fromIntegral sbytes++------------------------------------------------------------------------------+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)- sbytes <- sendfile onBlock out_fd in_fd poff bytes- return $ fromIntegral sbytes+ nsent <- sendfile raw_sendfile wait out_fd in_fd poff bytes+ return $! fromIntegral nsent where- bytes = min (fromIntegral count) maxBytes+ bytes = fromIntegral count+{-# INLINE sendFileImpl #-} -sendfile :: IO () -> Fd -> Fd -> Ptr COff -> CSize -> IO CSsize-sendfile onBlock out_fd in_fd poff bytes = do- nsent <- c_sendfile out_fd in_fd poff bytes- if nsent <= -1- then do errno <- getErrno- if errno == eAGAIN- then onBlock >> sendfile onBlock out_fd in_fd poff bytes- else throwErrno "System.SendFile.Linux"- else return nsent --- max num of bytes in one send-maxBytes :: CSize-maxBytes = maxBound :: CSize+------------------------------------------------------------------------------+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"
+ test/Snap/Internal/Http/Server/Address/Tests.hs view
@@ -0,0 +1,73 @@+{-# 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")
+ test/Snap/Internal/Http/Server/Parser/Tests.hs view
@@ -0,0 +1,249 @@+{-# 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)
+ test/Snap/Internal/Http/Server/Session/Tests.hs view
@@ -0,0 +1,1018 @@+{-# 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
+ test/Snap/Internal/Http/Server/Socket/Tests.hs view
@@ -0,0 +1,171 @@+{-# 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
+ test/Snap/Internal/Http/Server/TimeoutManager/Tests.hs view
@@ -0,0 +1,136 @@+{-# 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
+ test/Snap/Test/Common.hs view
@@ -0,0 +1,174 @@+{-# 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 == "<<timeout>>"+ 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
+ test/System/SendFile/Tests.hs view
@@ -0,0 +1,262 @@+{-# 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) ]
+ test/Test/Blackbox.hs view
@@ -0,0 +1,697 @@+{-# 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
+ test/Test/Common/Rot13.hs view
@@ -0,0 +1,24 @@+module 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
+ test/Test/Common/TestHandler.hs view
@@ -0,0 +1,193 @@+{-# 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 [ "<html><head><title>Upload a file</title></head><body>\n"+ , "<p>Upload some <code>text/plain</code> files:</p>\n"+ , "<form method='post' "+ , "enctype='multipart/form-data' "+ , "action='/upload/handle'>\n"+ , "<input type='file' "+ , "accept='text/plain' "+ , "multiple='true' "+ , "name='file'></input>\n"+ , "<input type='submit' name='Submit'></input>\n"+ , "</form></body></html>" ]+++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 )+ ]
+ test/TestSuite.hs view
@@ -0,0 +1,83 @@+{-# 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
+ test/bad_key.pem view
@@ -0,0 +1,15 @@+-----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-----
− test/benchmark/Benchmark.hs
@@ -1,7 +0,0 @@-module Main where--import Criterion.Main-import qualified Snap.Internal.Http.Parser.Benchmark as PB--main :: IO ()-main = defaultMain [ PB.benchmarks ]
− test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module Snap.Internal.Http.Parser.Benchmark- ( benchmarks )- where--import qualified Control.Exception as E-import Control.Monad.Identity-import Criterion.Main hiding (run)-import Data.Attoparsec hiding (Result(..))-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy.Char8 as L-import Snap.Internal.Http.Parser-import Snap.Internal.Http.Parser.Data-import qualified Snap.Iteratee as SI-import Snap.Iteratee hiding (take)--parseGet :: S.ByteString -> Identity ()-parseGet s = do- !_ <- run_ $ enumBS s $$ parseRequest- return ()---benchmarks = bgroup "parser"- [ bench "firefoxget" $ whnf (runIdentity . parseGet) parseGetData- ]
− test/benchmark/Snap/Internal/Http/Parser/Data.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Snap.Internal.Http.Parser.Data - ( parseGetData- , parseChunkedData- )- where--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-parseGetData = S.concat - [ "GET /favicon.ico HTTP/1.1\r\n"- , "Host: 0.0.0.0=5000\r\n"- , "User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9) Gecko/2008061015 Firefox/3.0\r\n"- , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\n"- , "Accept-Language: en-us,en;q=0.5\r\n"- , "Accept-Encoding: gzip,deflate\r\n"- , "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n"- , "Keep-Alive: 300\r\n"- , "Connection: keep-alive\r\n"- , "\r\n" ]--parseChunkedData = L.fromChunks ["In the beginning, everything was void, and J.H.W.H. Conway began to create numbers.", "Conway said, \"Let there be two rules which bring forth all numbers larege and small.", "This shall be the first rule: Every number corresponds to two sets of previously created numbers, such that no member of the left set is greater than or equal to any member of the right set.", "And the second rule shall be this: One number is less than or equal to another number if and only if no member of the first number \'s left set is greater than or equal to the second number, and no member of the second number\'s right set is less than or equal to the first number.\" And Conway examined these two rules he had made, and behold! They were very good.", "And the first number was created from the void left set and the void right set. Conway called this number \"zero,\" and said that it shall be a sign to separate positive numbers from negative numbers.", "Conway proved that zero was less than or equal to zero, end he saw that it was good.", "And the evening and the morning were the day of zero.", "On the next day, two more numbers were created, one with zero as its left set and one with zero as its right set. And Conway called the former number \"one,\" and the latter he called \"minus one.\" And he proved that minus one is less than but not equal to zero and zero is less than but not equal to one.", "And the evening day.", "And Conway said, \"Let the numbers be added to each other in this wise: The left set of the sum of two numbers shall be the sums of all left parts of each number with the other; and in like manner the right set shall be from the right parts, each according to its kind.\" Conway proved that every number plus zero is unchanged, and he saw that addition was good.", "And the evening and the morning were the third day."]
+ test/cbits/errno_util.c view
@@ -0,0 +1,5 @@+#include <errno.h>++void set_errno(int e) {+ errno = e;+}
+ test/cert.pem view
@@ -0,0 +1,14 @@+-----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-----
− test/common/Paths_snap_server.hs
@@ -1,9 +0,0 @@-module Paths_snap_server (- version- ) where--import Data.Version (Version(..))--version :: Version-version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]}-
− test/common/Snap/Test/Common.hs
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---module Snap.Test.Common where--import Blaze.ByteString.Builder-import Control.Exception (SomeException)-import Control.Monad-import Control.Monad.CatchIO-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w)-import Data.Monoid-import Network.Socket-import qualified Network.Socket.ByteString as N-import Prelude hiding (catch)-import Test.QuickCheck-import System.Timeout--import Snap.Internal.Iteratee.Debug ()---instance Arbitrary S.ByteString where- arbitrary = liftM (S.pack . map c2w) arbitrary--instance Arbitrary L.ByteString where- arbitrary = do- n <- choose(0,5)- chunks <- replicateM n arbitrary- return $ L.fromChunks chunks----expectExceptionBeforeTimeout :: IO a -- ^ action to run- -> Int -- ^ number of seconds to expect- -- exception by- -> IO Bool-expectExceptionBeforeTimeout act nsecs = do- x <- timeout (nsecs * (10::Int)^(6::Int)) f- case x of- Nothing -> return False- (Just y) -> return y-- where- f = (act >> return False) `catch` \(e::SomeException) -> do- if show e == "<<timeout>>"- then return False- else return True- --withSock :: Int -> (Socket -> IO a) -> IO a-withSock port go = do- addr <- liftM (addrAddress . Prelude.head) $- getAddrInfo (Just myHints)- (Just "127.0.0.1")- (Just $ show port)-- sock <- socket AF_INET Stream defaultProtocol- connect sock addr-- go sock `finally` sClose sock-- where- myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] }---recvAll :: Socket -> IO ByteString-recvAll sock = do- b <- f mempty sock- return $ toByteString b-- where- f b sk = do- s <- N.recv sk 100000- if S.null s- then return b- else f (b `mappend` fromByteString s) sk---ditchHeaders :: [ByteString] -> [ByteString]-ditchHeaders ("":xs) = xs-ditchHeaders ("\r":xs) = xs-ditchHeaders (_:xs) = ditchHeaders xs-ditchHeaders [] = []-
− test/common/Test/Common/Rot13.hs
@@ -1,19 +0,0 @@-module Test.Common.Rot13 (rot13) where--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.Char--rotone :: Char -> Char-rotone x | acc x = f- | otherwise = x- where- aA = ord 'A'- aa = ord 'a'- xx = ord x- f = g $ if isAsciiUpper x then aA else aa- g st = chr $ st + (xx - st + 13) `mod` 26- acc c = isAlpha c && (isAsciiUpper c || isAsciiLower c)--rot13 :: ByteString -> ByteString-rot13 = S.map rotone
− test/common/Test/Common/TestHandler.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Common.TestHandler (testHandler) where--import Blaze.ByteString.Builder-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Snap.Iteratee hiding (Enumerator)-import qualified Snap.Iteratee as I-import Snap.Types-import Snap.Util.FileServe-import Snap.Util.FileUploads-import Snap.Util.GZip-import System.Directory-import Test.Common.Rot13 (rot13)---pongHandler :: Snap ()-pongHandler = modifyResponse $- setResponseBody (enumBuilder $ fromByteString "PONG") .- setContentType "text/plain" .- setContentLength 4--echoUriHandler :: Snap ()-echoUriHandler = do- req <- getRequest- writeBS $ rqURI req---echoHandler :: Snap ()-echoHandler = transformRequestBody returnI---rot13Handler :: Snap ()-rot13Handler = transformRequestBody f- where- f origStep = do- mbX <- I.head- maybe (enumEOF origStep)- (feedStep origStep)- mbX-- feedStep origStep b = do- let x = toByteString b- let e = enumBuilder $ fromByteString $ rot13 x- step <- lift $ runIteratee $ e origStep- f step---bigResponseHandler :: Snap ()-bigResponseHandler = do- let sz = 4000000- let s = L.take sz $ L.cycle $ L.fromChunks [S.replicate 400000 '.']- modifyResponse $ setContentLength sz- writeLBS s---responseHandler :: Snap ()-responseHandler = do- !code <- liftM (read . S.unpack . fromMaybe "503") $ getParam "code"- modifyResponse $ setResponseCode code- writeBS $ S.pack $ show code---uploadForm :: Snap ()-uploadForm = do- modifyResponse $ setContentType "text/html"- writeBS form-- where- form = S.concat [ "<html><head><title>Upload a file</title></head><body>\n"- , "<p>Upload some <code>text/plain</code> files:</p>\n"- , "<form method='post' "- , "enctype='multipart/form-data' "- , "action='/upload/handle'>\n"- , "<input type='file' "- , "accept='text/plain' "- , "multiple='true' "- , "name='file'></input>\n"- , "<input type='submit' name='Submit'></input>\n"- , "</form></body></html>" ]---uploadHandler :: Snap ()-uploadHandler = do- liftIO $ createDirectoryIfMissing True tmpdir- handleFileUploads tmpdir defaultUploadPolicy partPolicy hndl-- where- isRight (Left _) = False- isRight (Right _) = True-- f (_, Left _) = error "impossible"- f (p, Right x) = (fromMaybe "-" $ partFileName p, x)-- hndl xs' = do- let xs = [ f x | x <- xs', isRight (snd x) ]-- files <- mapM (\(x,fp) -> do- c <- liftIO $ S.readFile fp- return (x,c)) xs-- let m = sort files-- params <- liftM (Prelude.map (\(a,b) -> (a,S.concat b)) .- Map.toAscList .- rqParams) getRequest-- modifyResponse $ setContentType "text/plain"- writeBuilder $ buildRqParams params `mappend` buildFiles m- -- builder _ [] = mempty- builder ty ((k,v):xs) =- mconcat [ fromByteString ty- , fromByteString ":\n"- , fromByteString k- , fromByteString "\nValue:\n"- , fromByteString v- , fromByteString "\n\n"- , builder ty xs ]--- buildRqParams = builder "Param"- buildFiles = builder "File"-- tmpdir = "dist/filetmp"- partPolicy partInfo = if partContentType partInfo == "text/plain"- then allowWithMaximumSize 200000- else disallow---testHandler :: Snap ()-testHandler = withCompression $- route [ ("pong" , pongHandler )- , ("echo" , echoHandler )- , ("rot13" , rot13Handler )- , ("echoUri" , echoUriHandler )- , ("fileserve" , fileServe "testserver/static")- , ("bigresponse" , bigResponseHandler )- , ("respcode/:code" , responseHandler )- , ("upload/form" , uploadForm )- , ("upload/handle" , uploadHandler )- ]
− test/data/fileServe/foo.bin
@@ -1,1 +0,0 @@-FOO
− test/data/fileServe/foo.bin.bin.bin
@@ -1,1 +0,0 @@-FOO
− test/data/fileServe/foo.html
@@ -1,1 +0,0 @@-FOO
− test/data/fileServe/foo.txt
@@ -1,1 +0,0 @@-FOO
+ test/dummy.txt view
@@ -0,0 +1,1 @@+TESTING 1-2-3
+ test/key.pem view
@@ -0,0 +1,15 @@+-----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-----
− test/pongserver/Main.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Blaze.ByteString.Builder-import Control.Concurrent-import Control.Exception (finally)--import Snap.Iteratee-import Snap.Types-import Snap.Http.Server---- FIXME: need better primitives for output-pongServer :: Snap ()-pongServer = modifyResponse $ setResponseBody enum .- setContentType "text/plain" .- setContentLength 4- where- enum = enumBuilder $ fromByteString "PONG"--main :: IO ()-main = do- m <- newEmptyMVar-- forkIO $ go m- takeMVar m-- return ()-- where- go m = httpServe config pongServer `finally` putMVar m ()- config = addListen (ListenHttp "*" 8000) $- setErrorLog Nothing $- setAccessLog Nothing $- setCompression False $ emptyConfig
− test/runTestsAndCoverage.sh
@@ -1,58 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then- export DEBUG=testsuite-fi--SUITE=./dist/build/testsuite/testsuite--rm -f *.tix--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -j4 -a1000 $*--DIR=dist/hpc--rm -Rf $DIR-mkdir -p $DIR--EXCLUDES='Main-Data.CIByteString-Data.Concurrent.HashMap.Internal-Data.Concurrent.HashMap.Tests-Paths_snap_server-Snap.Internal.Http.Parser.Tests-Snap.Internal.Http.Server.Tests-Snap.Internal.Http.Types.Tests-Snap.Internal.Iteratee.Tests-Text.Snap.Templates.Tests-Snap.Test.Common-Test.Blackbox-Test.Common.Rot13-Test.Common.TestHandler'--EXCL=""--for m in $EXCLUDES; do- EXCL="$EXCL --exclude=$m"-done--hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1--rm -f testsuite.tix--cat <<EOF--Test coverage report written to $DIR.-EOF
− test/snap-server-testsuite.cabal
@@ -1,234 +0,0 @@-name: snap-server-testsuite-version: 0.1.1-build-type: Simple-cabal-version: >= 1.6--Flag libev- Description: Use libev?- Default: False--Flag portable- Description: Compile in cross-platform mode. No platform-specific code or- optimizations such as C routines will be used.- Default: False--Flag gnutls- Description: Enable https support using the libgnutls library.- Default: False--Executable testsuite- hs-source-dirs: suite common ../src- main-is: TestSuite.hs-- build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.8.1 && < 0.9,- attoparsec-enumerator >= 0.2.0.1 && < 0.3,- base >= 4 && < 5,- base16-bytestring == 0.1.*,- binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- bytestring-nums >= 0.3.1 && < 0.4,- containers,- directory,- directory-tree,- enumerator >= 0.4.7 && <0.5,- filepath,- haskell98,- http-enumerator >= 0.3.1 && <0.4,- HUnit >= 1.2 && < 2,- monads-fd >= 0.1.0.4 && <0.2,- murmur-hash >= 0.1 && < 0.2,- network == 2.3.*,- old-locale,- parallel > 2,- process,- snap-core >= 0.4.3 && <0.5,- template-haskell,- test-framework >= 0.3.1 && <0.4,- test-framework-hunit >= 0.2.5 && < 0.3,- test-framework-quickcheck2 >= 0.2.6 && < 0.3,- time,- transformers,- utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,- PSQueue >= 1.1 && <1.2-- if !os(windows)- build-depends: unix-- if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.3- cpp-options: -DLIBEV-- if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- ghc-prof-options: -prof -auto-all- ghc-options: -O2 -Wall -fhpc -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind---Executable pongserver- hs-source-dirs: pongserver common ../src- main-is: Main.hs-- build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.8.1 && < 0.9,- attoparsec-enumerator >= 0.2.0.1 && < 0.3,- base >= 4 && < 5,- base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- bytestring-nums >= 0.3.1 && < 0.4,- cereal >= 0.3 && < 0.4,- containers,- directory-tree,- enumerator >= 0.4.7 && <0.5,- filepath,- haskell98,- HUnit >= 1.2 && < 2,- monads-fd >= 0.1.0.4 && <0.2,- murmur-hash >= 0.1 && < 0.2,- old-locale,- parallel > 2,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- network == 2.3.*,- snap-core >= 0.4.1 && <0.5,- template-haskell,- time,- transformers,- unix-compat == 0.2.*,- utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,- PSQueue >= 1.1 && <1.2-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE- else- build-depends: unix-- if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.3- cpp-options: -DLIBEV-- if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c-- if os(linux) && !flag(portable)- cpp-options: -DLINUX -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.Linux-- if os(darwin) && !flag(portable)- cpp-options: -DOSX -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.Darwin-- if os(freebsd) && !flag(portable)- cpp-options: -DFREEBSD -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.FreeBSD-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind- ghc-prof-options: -prof -auto-all---Executable testserver- hs-source-dirs: testserver common ../src- main-is: Main.hs-- build-depends:- QuickCheck >= 2,- array >= 0.3 && <0.4,- attoparsec >= 0.8.1 && < 0.9,- attoparsec-enumerator >= 0.2.0.1 && < 0.3,- base >= 4 && < 5,- binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- bytestring-nums >= 0.3.1 && < 0.4,- containers,- directory-tree,- enumerator >= 0.4.7 && <0.5,- filepath,- haskell98,- HUnit >= 1.2 && < 2,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- monads-fd >= 0.1.0.4 && <0.2,- murmur-hash >= 0.1 && < 0.2,- network == 2.3.*,- old-locale,- parallel > 2,- snap-core >= 0.4.1 && <0.5,- template-haskell,- test-framework >= 0.3.1 && <0.4,- test-framework-hunit >= 0.2.5 && < 0.3,- test-framework-quickcheck2 >= 0.2.6 && < 0.3,- time,- transformers,- utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,- PSQueue >= 1.1 && <1.2-- if !os(windows)- build-depends: unix-- if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.3- cpp-options: -DLIBEV-- if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- ghc-options: -O2 -Wall -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind- ghc-prof-options: -prof -auto-all---Executable benchmark- hs-source-dirs: benchmark common ../src- main-is: Benchmark.hs-- ghc-options: -O2 -Wall -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind-- ghc-prof-options: -prof -auto-all-- build-depends:- base >= 4 && < 5,- network == 2.3.*,- http-enumerator >= 0.3.1 && <0.4,- criterion >= 0.5 && <0.6
− test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Parser.Tests- ( tests ) where--import qualified Control.Exception as E-import Control.Exception hiding (try, assert)-import Control.Monad-import Control.Parallel.Strategies-import Data.Attoparsec hiding (Result(..))-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w)-import Data.List-import qualified Data.Map as Map-import Data.Maybe (isNothing)-import Data.Monoid-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run, assert)-import Test.HUnit hiding (Test, path)-import Text.Printf--import Snap.Internal.Http.Parser-import Snap.Internal.Http.Types-import Snap.Internal.Debug-import Snap.Iteratee hiding (map, sequence)-import qualified Snap.Iteratee as I-import Snap.Test.Common()---tests :: [Test]-tests = [ testShow- , testCookie- , testChunked- , testP2I- , testNull- , testPartial- , testParseError- , testFormEncoded ]---emptyParser :: Parser ByteString-emptyParser = option "foo" $ string "bar"--testShow :: Test-testShow = testCase "parser/show" $ do- let i = IRequest GET "/" (1,1) []- let !b = show i `using` rdeepseq- return $ b `seq` ()---testP2I :: Test-testP2I = testCase "parser/iterParser" $ do- i <- liftM (enumBS "z") $ runIteratee (iterParser emptyParser)- l <- run_ i-- assertEqual "should be foo" "foo" l---forceErr :: SomeException -> IO ()-forceErr e = f `seq` (return ())- where- !f = show e---testNull :: Test-testNull = testCase "parser/shortParse" $ do- f <- run_ (parseRequest)- assertBool "should be Nothing" $ isNothing f---testPartial :: Test-testPartial = testCase "parser/partial" $ do- i <- liftM (enumBS "GET / ") $ runIteratee parseRequest- f <- E.try $ run_ i-- case f of (Left e) -> forceErr e- (Right x) -> assertFailure $ "expected exception, got " ++ show x---testParseError :: Test-testParseError = testCase "parser/error" $ do- step <- runIteratee parseRequest- let i = enumBS "ZZZZZZZZZZ" step- f <- E.try $ run_ i-- case f of (Left e) -> forceErr e- (Right x) -> assertFailure $ "expected exception, got " ++ show x----- | convert a bytestring to chunked transfer encoding-transferEncodingChunked :: L.ByteString -> L.ByteString-transferEncodingChunked = f . L.toChunks- where- toChunk s = L.concat [ len, "\r\n", L.fromChunks [s], "\r\n" ]- where- len = L.pack $ map c2w $ printf "%x" $ S.length s-- f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"])----- | ensure that running the 'readChunkedTransferEncoding' iteratee against--- 'transferEncodingChunked' returns the original string-testChunked :: Test-testChunked = testProperty "parser/chunkedTransferEncoding" $- monadicIO $ forAllM arbitrary prop_chunked- where- prop_chunked s = do- QC.run $ debug "=============================="- QC.run $ debug $ "input is " ++ show s- QC.run $ debug $ "chunked is " ++ show chunked- QC.run $ debug "------------------------------"- sstep <- QC.run $ runIteratee $ stream2stream- step <- QC.run $ runIteratee $- joinI $ readChunkedTransferEncoding sstep-- out <- QC.run $ run_ $ enum step-- QC.assert $ s == out- QC.run $ debug "==============================\n"-- where- chunked = (transferEncodingChunked s)- enum = enumLBS chunked---testCookie :: Test-testCookie =- testCase "parser/parseCookie" $ do- assertEqual "cookie parsing" (Just [cv]) cv2-- where- cv = Cookie nm v Nothing Nothing Nothing- cv2 = parseCookie ct-- nm = "foo"- v = "bar"-- ct = S.concat [ nm- , "="- , v ]---testFormEncoded :: Test-testFormEncoded = testCase "parser/formEncoded" $ do- let bs = "foo1=bar1&foo2=bar2+baz2&foo3=foo%20bar"- let mp = parseUrlEncoded bs-- assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp- assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp- assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp---copyingStream2Stream :: (Monad m) => Iteratee ByteString m ByteString-copyingStream2Stream = go []- where- go l = do- mbx <- I.head- maybe (return $ S.concat $ reverse l)- (\x -> let !z = S.copy x in go (z:l))- mbx--stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString-stream2stream = liftM L.fromChunks consume
− test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -1,960 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Snap.Internal.Http.Server.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Enumerator-import Control.Concurrent-import Control.Exception ( catch- , try- , throwIO- , bracket- , finally- , SomeException- , Exception )-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.ByteString (ByteString)-import Data.ByteString.Internal (c2w)-import Data.Char-import Data.Int-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe (fromJust)-import Data.Time.Calendar-import Data.Time.Clock-import Data.Typeable-import qualified Network.HTTP.Enumerator as HTTP-import qualified Network.Socket.ByteString as N-import Prelude hiding (catch, take)-import qualified Prelude-import System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import qualified Snap.Http.Server as Svr--import Snap.Internal.Debug-import Snap.Internal.Http.Types-import Snap.Internal.Http.Server-import qualified Snap.Iteratee as I-import Snap.Iteratee hiding (map)-import Snap.Internal.Http.Server.Backend-import Snap.Test.Common-import Snap.Types--data TestException = TestException- deriving (Show, Typeable)-instance Exception TestException---tests :: [Test]-tests = [ testHttpRequest1- , testMultiRequest- , testHttpRequest2- , testHttpRequest3- , testHttpRequest3'- , testHttpResponse1- , testHttpResponse2- , testHttpResponse3- , testHttpResponse4- , testHttpResponseCookies- , testHttp1- , testHttp2- , testHttp100- , test411- , testExpectGarbage- , testPartialParse- , testMethodParsing- , testServerStartupShutdown- , testServerShutdownWithOpenConns- , testChunkOn1_0- , testSendFile- , testTrivials]---testTrivials :: Test-testTrivials = testCase "server/trivials" $ do- let !v = Svr.snapServerVersion- return $! v `seq` ()----------------------------------------------------------------------------------- HTTP request tests---- note leading crlf -- test tolerance of this, some old browsers send an extra--- crlf after a post body-sampleRequest :: ByteString-sampleRequest =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequestExpectContinue :: ByteString-sampleRequestExpectContinue =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Expect: 100-continue\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequest411 :: ByteString-sampleRequest411 =- S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n" ]--sampleRequestExpectGarbage :: ByteString-sampleRequestExpectGarbage =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Expect: wuzzawuzzawuzza\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequest1_0 :: ByteString-sampleRequest1_0 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.0\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--testMethodParsing :: Test-testMethodParsing =- testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms- where- ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]---dummyIter :: Iteratee ByteString IO ()-dummyIter = consume >> return ()---mkRequest :: ByteString -> IO Request-mkRequest s = do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumBS s step- run_ iter---testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString)-testReceiveRequest = do- r <- liftM fromJust $ rsm $ receiveRequest dummyIter- se <- liftIO $ readIORef (rqBody r)- let (SomeEnumerator e) = se- it <- liftM e $ lift $ runIteratee copyingStream2Stream- b <- it- return (r,b)---testReceiveRequestIter :: ByteString- -> IO (Iteratee ByteString IO (Request,L.ByteString))-testReceiveRequestIter req =- liftM (enumBS req) $ runIteratee testReceiveRequest---testHttpRequest1 :: Test-testHttpRequest1 =- testCase "server/HttpRequest1" $ do- iter <- testReceiveRequestIter sampleRequest-- (req,body) <- run_ iter-- assertEqual "not secure" False $ rqIsSecure req-- assertEqual "content length" (Just 10) $ rqContentLength req-- assertEqual "parse body" "0123456789" body-- assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing] $- rqCookies req-- assertEqual "continued headers" (Just ["foo bar"]) $- Map.lookup "x-random-other-header" $ rqHeaders req-- assertEqual "parse URI"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req-- assertEqual "server port" 7777 $ rqServerPort req- assertEqual "context path" "/" $ rqContextPath req- assertEqual "pathinfo" "foo/bar.html" $ rqPathInfo req- assertEqual "query string" "param1=abc¶m2=def%20+¶m1=abc" $- rqQueryString req- assertEqual "server name" "www.zabble.com" $ rqServerName req- assertEqual "version" (1,1) $ rqVersion req- assertEqual "param1" (Just ["abc","abc"]) $- rqParam "param1" req- assertEqual "param2" (Just ["def "]) $- rqParam "param2" req----testMultiRequest :: Test-testMultiRequest =- testCase "server/MultiRequest" $ do- let clientIter = do- (r1,b1) <- testReceiveRequest- (r2,b2) <- testReceiveRequest-- return (r1,b1,r2,b2)-- iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $- runIteratee clientIter-- (req1,body1,req2,body2) <- run_ iter-- assertEqual "parse body 1" "0123456789" body1- assertEqual "parse body 2" "0123456789" body2-- assertEqual "parse URI 1"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req1-- assertEqual "parse URI 2"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req2----testOneMethod :: Method -> IO ()-testOneMethod m = do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumLBS txt step- req <- run_ iter-- assertEqual "method" m $ rqMethod req-- where- txt = methodTestText m---sampleShortRequest :: ByteString-sampleShortRequest = "GET /fo"--expectException :: IO a -> IO ()-expectException m = do- e <- try m- case e of- Left (_::SomeException) -> return ()- Right _ -> assertFailure "expected exception, didn't get it"---testPartialParse :: Test-testPartialParse = testCase "server/short" $ do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumBS sampleShortRequest step-- expectException $ run_ iter---methodTestText :: Method -> L.ByteString-methodTestText m = L.concat [ (L.pack $ map c2w $ show m)- , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ]---sampleRequest2 :: ByteString-sampleRequest2 =- S.concat [ "GET /foo/bar.html?param1=abc¶m2=def¶m1=abc HTTP/1.1\r\n"- , "Host: www.foo.com:8080\r\n"- , "Transfer-Encoding: chunked\r\n"- , "\r\n"- , "a\r\n"- , "0123456789\r\n"- , "4\r\n"- , "0123\r\n"- , "0\r\n\r\n" ]--testHttpRequest2 :: Test-testHttpRequest2 =- testCase "server/HttpRequest2" $ do- iter <- testReceiveRequestIter sampleRequest2- (_,body) <- run_ iter-- assertEqual "parse body" "01234567890123" body---testHttpRequest3 :: Test-testHttpRequest3 =- testCase "server/HttpRequest3" $ do- iter <- testReceiveRequestIter sampleRequest3- (req,body) <- run_ iter-- assertEqual "no cookies" [] $ rqCookies req-- assertEqual "multiheader" (Just ["1","2"]) $- Map.lookup "Multiheader" (rqHeaders req)-- assertEqual "host" ("localhost", 80) $- (rqServerName req, rqServerPort req)-- assertEqual "post param 1"- (rqParam "postparam1" req)- (Just ["1"])-- assertEqual "post param 2"- (rqParam "postparam2" req)- (Just ["2"])-- -- make sure the post body is still emitted- assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body---testHttpRequest3' :: Test-testHttpRequest3' =- testCase "server/HttpRequest3'" $ do- iter <- testReceiveRequestIter sampleRequest3'- (req,body) <- run_ iter-- assertEqual "post param 1"- (rqParam "postparam1" req)- (Just ["1"])-- assertEqual "post param 2"- (rqParam "postparam2" req)- (Just ["2"])-- -- make sure the post body is still emitted- assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body---samplePostBody3 :: ByteString-samplePostBody3 = "postparam1=1&postparam2=2"---sampleRequest3 :: ByteString-sampleRequest3 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Content-Type: application/x-www-form-urlencoded\r\n"- , "Content-Length: 25\r\n"- , "Multiheader: 1\r\n"- , "Multiheader: 2\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "\r\n"- , samplePostBody3 ]---sampleRequest3' :: ByteString-sampleRequest3' =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Content-Type: application/x-www-form-urlencoded; charset=UTF-8\r\n"- , "Content-Length: 25\r\n"- , "Multiheader: 1\r\n"- , "Multiheader: 2\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "\r\n"- , samplePostBody3 ]-----rsm :: ServerMonad a -> Iteratee ByteString IO a-rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog- where- alog = const . const . return $ ()- elog = const $ return ()---testHttpResponse1 :: Test-testHttpResponse1 = testCase "server/HttpResponse1" $ do- req <- mkRequest sampleRequest- buf <- allocBuffer 16384-- b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response" (L.concat [- "HTTP/1.0 600 Test\r\n"- , "Content-Length: 10\r\n"- , "Foo: Bar\r\n\r\n"- , "0123456789"- ]) b-- where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $- setContentLength 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }----testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString-testOnSendFile f st sz = do- sstep <- runIteratee copyingStream2Stream- run_ $ enumFilePartial f (st,st+sz) sstep--testHttpResponse2 :: Test-testHttpResponse2 = testCase "server/HttpResponse2" $ do- req <- mkRequest sampleRequest- buf <- allocBuffer 16384- b2 <- run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response" (L.concat [- "HTTP/1.0 600 Test\r\n"- , "Connection: close\r\n"- , "Foo: Bar\r\n\r\n"- , "0123456789"- ]) b2- where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $- setContentLength 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = rsp1 { rspContentLength = Nothing }---testHttpResponse3 :: Test-testHttpResponse3 = testCase "server/HttpResponse3" $ do- req <- mkRequest sampleRequest- buf <- allocBuffer 16384-- b3 <- run_ $ rsm $- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response" (L.concat [- "HTTP/1.1 600 Test\r\n"- , "Content-Type: text/plain\r\n"- , "Foo: Bar\r\n"- , "Transfer-Encoding: chunked\r\n\r\n"- , "000A\r\n"- , "0123456789\r\n"- , "0\r\n\r\n"- ]) b3--- where- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $- setContentLength 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = rsp1 { rspContentLength = Nothing }- rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) })---testHttpResponse4 :: Test-testHttpResponse4 = testCase "server/HttpResponse4" $ do- buf <- allocBuffer 16384-- req <- mkRequest sampleRequest-- b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n\r\n"- ]) b-- where- rsp1 = setResponseStatus 304 "Test" $- emptyResponse { rspHttpVersion = (1,0) }---testHttpResponseCookies :: Test-testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do- buf <- allocBuffer 16384- req <- mkRequest sampleRequest- b <- run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=- return . snd- b2 <- run_ $ rsm $- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response cookie" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n"- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"- ]) b--- assertEqual "http response multi-cookies" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n"- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n"- , "Set-Cookie: zoo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"- ]) b2-- where- rsp1 = setResponseStatus 304 "Test" $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = addResponseCookie cook rsp1- rsp3 = addResponseCookie cook2 rsp2-- utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")- cook3 = Cookie "boo" "baz" Nothing Nothing Nothing----echoServer :: (ByteString -> IO ())- -> (Int -> IO ())- -> Request- -> Iteratee ByteString IO (Request,Response)-echoServer _ _ req = do- se <- liftIO $ readIORef (rqBody req)- let (SomeEnumerator enum) = se- i <- liftM enum $ lift $ runIteratee copyingStream2Stream- b <- i- let cl = L.length b- liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0)- return (req, rsp b cl)- where- rsp s cl = emptyResponse { rspBody = Enum $- enumBuilder (fromLazyByteString s)- , rspContentLength = Just $ fromIntegral cl }---echoServer2 :: ServerHandler-echoServer2 _ _ req = do- (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req- return (rq, addResponseCookie cook rsp)- where- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- utc = UTCTime (ModifiedJulianDay 55226) 0---testHttp1 :: Test-testHttp1 = testCase "server/httpSession" $ do- let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60 Nothing Nothing echoServer "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody iter onSendFile (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1- , "\r"- , "0123456789HTTP/1.1 200 OK\r"- , "Content-Length: 14\r"- , d2- , s2- , "\r"- , "01234567890123" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Date" `L.isPrefixOf` d2) &&- ("Server" `L.isPrefixOf` s1) &&- ("Server" `L.isPrefixOf` s2))-- _ -> False-- when (not ok) $ do- putStrLn "server/httpSession fail!!!! got:"- LC.putStrLn s-- assertBool "pipelined responses" ok---mkIter :: IORef L.ByteString- -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ())-mkIter ref = (iter, \f st sz -> onF f st sz iter)- where- iter = do- x <- copyingStream2Stream- liftIO $ modifyIORef ref $ \s -> L.append s x-- onF f st sz i = do- step <- runIteratee i- let it = enumFilePartial f (st,st+sz) step- run_ it---testChunkOn1_0 :: Test-testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do- let enumBody = enumBS sampleRequest1_0-- ref <- newIORef ""- let (iter,onSendFile) = mkIter ref-- done <- newEmptyMVar- forkIO (runHTTP 60 Nothing Nothing f "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody iter onSendFile (const $ return ())- `finally` putMVar done ())-- takeMVar done-- -- this is a pretty lame way of checking whether the output was chunked,- -- but "whatever"- output <- liftM lower $ readIORef ref-- assertBool "chunked output" $ not $ S.isInfixOf "chunked" output- assertBool "connection close" $ S.isInfixOf "connection: close" output-- where- lower = S.map toLower . S.concat . L.toChunks-- f :: ServerHandler- f _ _ req = do- let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd"- let out = enumBuilder $ fromLazyByteString s- return (req, emptyResponse { rspBody = Enum out })---sampleRequest4 :: ByteString-sampleRequest4 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Connection: close\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]---testHttp2 :: Test-testHttp2 = testCase "server/connection: close" $ do- let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- done <- newEmptyMVar-- forkIO (runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ()) `finally` putMVar done ())-- takeMVar done-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , "Connection: close\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))-- _ -> False-- assertBool "connection: close" ok----testHttp100 :: Test-testHttp100 = testCase "server/expect100" $ do- let enumBody = enumBS sampleRequestExpectContinue-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 100 Continue\r"- , "\r"- , "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))-- _ -> False-- when (not ok) $ do- putStrLn "expect100 fail! got:"- LC.putStrLn s-- assertBool "100 Continue" ok---test411 :: Test-test411 = testCase "server/expect411" $ do- let enumBody = enumBS sampleRequest411-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ("HTTP/1.1 411 Length Required\r":_) -> True- _ -> False-- when (not ok) $ do- putStrLn "expect411 fail! got:"- LC.putStrLn s-- assertBool "411 Length Required" ok----testExpectGarbage :: Test-testExpectGarbage = testCase "server/Expect: garbage" $ do- let enumBody = enumBS sampleRequestExpectGarbage-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , "Content-Length: 10\r"- , d1- , s1- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- , "\r"- , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&- ("Server" `L.isPrefixOf` s1))-- _ -> False-- assertBool "random expect: header" ok-----pongServer :: Snap ()-pongServer = modifyResponse $ setResponseBody enum .- setContentType "text/plain" .- setContentLength 4- where- enum = enumBuilder $ fromByteString "PONG"--sendFileFoo :: Snap ()-sendFileFoo = sendFile "data/fileServe/foo.html"---testSendFile :: Test-testSendFile = testCase "server/sendFile" $ do- bracket (forkIO serve)- (killThread)- (\tid -> do- m <- timeout (120 * seconds) $ go tid- maybe (assertFailure "timeout")- (const $ return ())- m)-- where- serve = (httpServe 60 [HttpPort "*" port] Nothing "localhost"- Nothing Nothing- $ runSnap sendFileFoo)- `catch` \(_::SomeException) -> return ()-- go tid = do- waitabit-- doc <- HTTP.simpleHttp "http://127.0.0.1:8123/"-- killThread tid- waitabit-- assertEqual "sendFile" "FOO\n" doc--- waitabit = threadDelay $ ((10::Int)^(6::Int))-- port = 8123---testServerStartupShutdown :: Test-testServerStartupShutdown = testCase "server/startup/shutdown" $ do- bracket (forkIO $- httpServe 20- [HttpPort "*" port]- Nothing- "localhost"- (Just "test-access.log")- (Just "test-error.log")- (runSnap pongServer))- (killThread)- (\tid -> do- m <- timeout (120 * seconds) $ go tid- maybe (assertFailure "timeout")- (const $ return ())- m)--- where- go tid = do- debug $ "testServerStartupShutdown: waiting a bit"- waitabit- debug $ "testServerStartupShutdown: sending http request"- doc <- HTTP.simpleHttp "http://127.0.0.1:8145/"- assertEqual "server" "PONG" doc-- debug $ "testServerStartupShutdown: killing thread"- killThread tid- debug $ "testServerStartupShutdown: kill signal sent to thread"- waitabit-- expectException $ HTTP.simpleHttp "http://127.0.0.1:8145/"- return ()-- waitabit = threadDelay $ 2*((10::Int)^(6::Int))-- port = 8145---testServerShutdownWithOpenConns :: Test-testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do- tid <- forkIO $- httpServe 20- [HttpPort "127.0.0.1" port]- Nothing- "localhost"- Nothing- Nothing- (runSnap pongServer)-- waitabit-- result <- newEmptyMVar-- forkIO $ do- e <- try $ withSock port $ \sock -> do- N.sendAll sock "GET /"- waitabit- killThread tid- waitabit- N.sendAll sock "pong HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- resp <- recvAll sock- when (S.null resp) $ throwIO TestException-- let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp- debug $ "got HTTP response " ++ s ++ ", we shouldn't be here...."-- putMVar result e-- e <- timeout (75*seconds) $ takeMVar result-- case e of- Nothing -> killThread tid >> assertFailure "timeout"- (Just r) ->- case r of- (Left (_::SomeException)) -> return ()- (Right _) -> assertFailure "socket didn't get killed"--- where- waitabit = threadDelay $ 2*((10::Int)^(6::Int))- port = 8146----seconds :: Int-seconds = (10::Int) ^ (6::Int)---copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString-copyingStream2Stream = go []- where- go l = do- mbx <- I.head- maybe (return $ L.fromChunks $ reverse l)- (\x -> let !z = S.copy x in go (z:l))- mbx
− test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
@@ -1,76 +0,0 @@-module Snap.Internal.Http.Server.TimeoutManager.Tests- ( tests ) where--import Control.Concurrent-import Data.IORef-import Data.Maybe-import System.PosixCompat.Time-import System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import qualified Snap.Internal.Http.Server.TimeoutManager as TM--tests :: [Test]-tests = [ testOneTimeout- , testOneTimeoutAfterInactivity- , testCancel- , testTickle ]---testOneTimeout :: Test-testOneTimeout = testCase "timeout/oneTimeout" $ do- mgr <- TM.initialize 3 epochTime- oneTimeout mgr---testOneTimeoutAfterInactivity :: Test-testOneTimeoutAfterInactivity =- testCase "timeout/oneTimeoutAfterInactivity" $ do- mgr <- TM.initialize 3 epochTime- threadDelay $ 7 * seconds- oneTimeout mgr--oneTimeout :: TM.TimeoutManager -> IO ()-oneTimeout mgr = do- mv <- newEmptyMVar- _ <- TM.register (putMVar mv ()) mgr- m <- timeout (6*seconds) $ takeMVar mv- assertBool "timeout fired" $ isJust m- TM.stop mgr---testTickle :: Test-testTickle = testCase "timeout/tickle" $ do- mgr <- TM.initialize 8 epochTime- ref <- newIORef (0 :: Int)- h <- TM.register (writeIORef ref 1) mgr- threadDelay $ 5 * seconds- b0 <- readIORef ref- assertEqual "b0" 0 b0- TM.tickle h 8- threadDelay $ 5 * seconds- b1 <- readIORef ref- assertEqual "b1" 0 b1- threadDelay $ 8 * seconds- b2 <- readIORef ref- assertEqual "b2" 1 b2- TM.stop mgr---testCancel :: Test-testCancel = testCase "timeout/cancel" $ do- mgr <- TM.initialize 3 epochTime- ref <- newIORef (0 :: Int)- h <- TM.register (writeIORef ref 1) mgr- threadDelay $ 1 * seconds- TM.cancel h- threadDelay $ 5 * seconds- b0 <- readIORef ref- assertEqual "b0" 0 b0- TM.stop mgr---seconds :: Int-seconds = (10::Int) ^ (6::Int)
− test/suite/Test/Blackbox.hs
@@ -1,381 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module Test.Blackbox- ( tests- , ssltests- , startTestServer ) where-----------------------------------------------------------------------------------import Control.Concurrent-import Control.Exception (SomeException, catch, throwIO)-import Control.Monad-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Int-import Data.List-import Data.Monoid-import qualified Network.HTTP.Enumerator as HTTP-import qualified Network.Socket.ByteString as N-import Prelude hiding (catch, take)-import System.Timeout-import Test.Framework-import Test.Framework.Options-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, path)-import Test.QuickCheck-import qualified Test.QuickCheck.Property as QC-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run, assert)--------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Http.Server-import Snap.Test.Common-import Test.Common.Rot13-import Test.Common.TestHandler---------------------------------------------------------------------------------testFunctions :: [Bool -> Int -> String -> Test]-testFunctions = [ testPong--- FIXME: waiting on http-enumerator patch for HEAD behaviour--- , testHeadPong- , testEcho- , testRot13- , testSlowLoris- , testBlockingRead- , testBigResponse- , testPartial- , testFileUpload- ]----------------------------------------------------------------------------------tests :: Int -> String -> [Test]-tests port name = map (\f -> f False port name) testFunctions----------------------------------------------------------------------------------slowTestOptions ssl =- if ssl- then mempty { topt_maximum_generated_tests = Just 75 }- else mempty { topt_maximum_generated_tests = Just 300 }----------------------------------------------------------------------------------ssltests :: String -> Maybe Int -> [Test]-ssltests name = maybe [] httpsTests- where httpsTests port = map (\f -> f True port sslname) testFunctions- sslname = "ssl/" ++ name---------------------------------------------------------------------------------startTestServer :: Int- -> Maybe Int- -> ConfigBackend- -> IO (ThreadId, MVar ())-startTestServer port sslport backend = do- let cfg = setAccessLog (Just $ "ts-access." ++ show backend ++ ".log") .- setErrorLog (Just $ "ts-error." ++ show backend ++ ".log") .- addListen (ListenHttp "*" port) .- setBackend backend .- setDefaultTimeout 10 .- setVerbose False $- defaultConfig-- let cfg' = case sslport of- Nothing -> cfg- Just p -> addListen- (ListenHttps "*" p "cert.pem" "key.pem")- cfg-- mvar <- newEmptyMVar- tid <- forkIO $ do- (httpServe cfg' testHandler)- `catch` \(_::SomeException) -> return ()- putMVar mvar ()- threadDelay $ 4*seconds-- return (tid,mvar)----------------------------------------------------------------------------------doPong :: Bool -> Int -> IO ByteString-doPong ssl port = do- debug "getting URI"- let !uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/pong"- debug $ "URI is: '" ++ uri ++ "', calling simpleHttp"-- rsp <- HTTP.simpleHttp uri `catch` (\(e::SomeException) -> do- debug $ "simpleHttp threw exception: " ++ show e- throwIO e)- debug $ "response was " ++ show rsp- return $ S.concat $ L.toChunks rsp------------------------------------------------------------------------------------ FIXME: waiting on http-enumerator patch for HEAD behaviour--- headPong :: Bool -> Int -> IO ByteString--- headPong ssl port = do--- let uri = (if ssl then "https" else "http")--- ++ "://127.0.0.1:" ++ show port ++ "/echo"---- req0 <- HTTP.parseUrl uri---- let req = req0 { HTTP.method = "HEAD" }--- rsp <- HTTP.httpLbs req--- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp---------------------------------------------------------------------------------testPong :: Bool -> Int -> String -> Test-testPong ssl port name = testCase (name ++ "/blackbox/pong") $ do- doc <- doPong ssl port- assertEqual "pong response" "PONG" doc------------------------------------------------------------------------------------ FIXME: waiting on http-enumerator patch for HEAD behaviour--- testHeadPong :: Bool -> Int -> String -> Test--- testHeadPong ssl port name = testCase (name ++ "/blackbox/pong/HEAD") $ do--- doc <- headPong ssl port--- assertEqual "pong HEAD response" "" doc----------------------------------------------------------------------------------testEcho :: Bool -> Int -> String -> Test-testEcho ssl port name =- plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/echo") $- QC.mapSize (if ssl then min 100 else min 300) $- monadicIO $ forAllM arbitrary prop- where- prop txt = do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/echo"-- req0 <- QC.run $ HTTP.parseUrl uri- let req = req0 { HTTP.requestBody = txt- , HTTP.method = "POST" }-- rsp <- QC.run $ HTTP.httpLbs req- let doc = HTTP.responseBody rsp-- QC.assert $ txt == doc----------------------------------------------------------------------------------testFileUpload :: Bool -> Int -> String -> Test-testFileUpload ssl port name = - plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/upload") $- QC.mapSize (if ssl then min 100 else min 300) $- monadicIO $- forAllM arbitrary prop- where- boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"-- prefix = [ "--"- , boundary- , "\r\n"- , "content-disposition: form-data; name=\"submit\"\r\n"- , "\r\nSubmit\r\n" ]-- body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix- where- part (k,v) = [ "--"- , boundary- , "\r\ncontent-disposition: attachment; filename=\""- , k- , "\"\r\nContent-Type: text/plain\r\n\r\n"- , v- , "\r\n" ]-- suffix = [ "--", boundary, "--\r\n" ]-- hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ]- ++ L.toChunks boundary) ]-- b16 (k,v) = (ne $ e k, e v)- where- ne s = if L.null s then "file" else s- e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ]-- response kvps = L.concat $ [ "Param:\n"- , "submit\n"- , "Value:\n"- , "Submit\n\n" ] ++ concatMap responseKVP kvps-- responseKVP (k,v) = [ "File:\n"- , k- , "\nValue:\n"- , v- , "\n\n" ]-- prop kvps' = do- let kvps = sort $ map b16 kvps'-- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/upload/handle"-- req0 <- QC.run $ HTTP.parseUrl uri- let req = req0 { HTTP.requestBody = body kvps- , HTTP.method = "POST"- , HTTP.requestHeaders = hdrs }-- let txt = response kvps- rsp <- QC.run $ HTTP.httpLbs req- let doc = HTTP.responseBody rsp-- when (txt /= doc) $ QC.run $ do- L.putStrLn "expected:"- L.putStrLn "----------------------------------------"- L.putStrLn txt- L.putStrLn "----------------------------------------"- L.putStrLn "\ngot:"- L.putStrLn "----------------------------------------"- L.putStrLn doc- L.putStrLn "----------------------------------------"-- QC.assert $ txt == doc----------------------------------------------------------------------------------testRot13 :: Bool -> Int -> String -> Test-testRot13 ssl port name =- plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/rot13") $- monadicIO $ forAllM arbitrary prop- where- prop txt = do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/rot13"-- req0 <- QC.run $ HTTP.parseUrl uri- let req = req0 { HTTP.requestBody = L.fromChunks [txt]- , HTTP.method = "POST" }-- rsp <- QC.run $ HTTP.httpLbs req- let doc = S.concat $ L.toChunks $ HTTP.responseBody rsp-- QC.assert $ txt == rot13 doc------------------------------------------------------------------------------------ TODO: this one doesn't work w/ SSL-testSlowLoris :: Bool -> Int -> String -> Test-testSlowLoris ssl port name = testCase (name ++ "/blackbox/slowloris") $- if ssl then return () else withSock port go-- where- go sock = do- m <- timeout (120*seconds) $ go' sock- maybe (assertFailure "slowloris: timeout")- (const $ return ())- m-- go' sock = do- N.sendAll sock "POST /echo HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 2500000\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- b <- expectExceptionBeforeTimeout (loris sock) 60-- assertBool "didn't catch slow loris attack" b-- loris sock = do- N.sendAll sock "."- waitabit- loris sock------------------------------------------------------------------------------------ TODO: doesn't work w/ ssl-testBlockingRead :: Bool -> Int -> String -> Test-testBlockingRead ssl port name =- testCase (name ++ "/blackbox/testBlockingRead") $- if ssl then return () else runIt-- where- runIt = withSock port $ \sock -> do- m <- timeout (60*seconds) $ go sock- maybe (assertFailure "timeout")- (const $ return ())- m-- go sock = do- N.sendAll sock "GET /"- waitabit- N.sendAll sock "pong HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- resp <- recvAll sock-- let s = head $ ditchHeaders $ S.lines resp-- assertEqual "pong response" "PONG" s------------------------------------------------------------------------------------ TODO: no ssl here--- test server's ability to trap/recover from IO errors-testPartial :: Bool -> Int -> String -> Test-testPartial ssl port name =- testCase (name ++ "/blackbox/testPartial") $- if ssl then return () else runIt-- where- runIt = do- m <- timeout (60*seconds) go- maybe (assertFailure "timeout")- (const $ return ())- m-- go = do- withSock port $ \sock ->- N.sendAll sock "GET /pong HTTP/1.1\r\n"-- doc <- doPong ssl port- assertEqual "pong response" "PONG" doc------------------------------------------------------------------------------------ TODO: no ssl-testBigResponse :: Bool -> Int -> String -> Test-testBigResponse ssl port name =- testCase (name ++ "/blackbox/testBigResponse") $- if ssl then return () else runIt- where- runIt = withSock port $ \sock -> do- m <- timeout (120*seconds) $ go sock- maybe (assertFailure "timeout")- (const $ return ())- m-- go sock = do- N.sendAll sock "GET /bigresponse HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- let body = S.replicate 4000000 '.'- resp <- recvAll sock-- let s = head $ ditchHeaders $ S.lines resp-- assertBool "big response" $ body == s----------------------------------------------------------------------------------waitabit :: IO ()-waitabit = threadDelay $ 2*seconds----------------------------------------------------------------------------------seconds :: Int-seconds = (10::Int) ^ (6::Int)
− test/suite/TestSuite.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main where--import Control.Exception-import Control.Concurrent (killThread)-import Control.Concurrent.MVar-import Control.Monad-import Prelude hiding (catch)-import qualified Network.HTTP.Enumerator as HTTP-import Test.Framework (defaultMain, testGroup)-import System.Environment-import Snap.Http.Server.Config--import qualified Data.Concurrent.HashMap.Tests-import qualified Snap.Internal.Http.Parser.Tests-import qualified Snap.Internal.Http.Server.Tests-import qualified Snap.Internal.Http.Server.TimeoutManager.Tests-import qualified Test.Blackbox--ports :: Int -> [Int]-ports sp = [sp..]--#ifdef GNUTLS-sslports :: Int -> [Maybe Int]-sslports sp = map Just [(sp + 100)..]-#else-sslports :: Int -> [Maybe Int]-sslports _ = repeat Nothing-#endif--#ifdef LIBEV-backends :: Int -> [(Int,Maybe Int,ConfigBackend)]-backends sp = zip3 (ports sp)- (sslports sp)- [ConfigSimpleBackend, ConfigLibEvBackend]-#else-backends :: Int -> [(Int,Maybe Int,ConfigBackend)]-backends sp = zip3 (ports sp)- (sslports sp)- [ConfigSimpleBackend]-#endif--getStartPort :: IO Int-getStartPort = (liftM read (getEnv "STARTPORT") >>= evaluate)- `catch` \(_::SomeException) -> return 8111---main :: IO ()-main = HTTP.withHttpEnumerator $ do- sp <- getStartPort- let bends = backends sp- tinfos <- forM bends $ \(port,sslport,b) ->- Test.Blackbox.startTestServer port sslport b-- defaultMain (tests ++ concatMap blackbox bends) `finally` do- mapM_ killThread $ map fst tinfos- mapM_ takeMVar $ map snd tinfos-- where tests =- [ testGroup "Data.Concurrent.HashMap.Tests"- Data.Concurrent.HashMap.Tests.tests- , testGroup "Snap.Internal.Http.Parser.Tests"- Snap.Internal.Http.Parser.Tests.tests- , testGroup "Snap.Internal.Http.Server.Tests"- Snap.Internal.Http.Server.Tests.tests- , testGroup "Snap.Internal.Http.Server.TimeoutManager.Tests"- Snap.Internal.Http.Server.TimeoutManager.Tests.tests- ]- blackbox (port, sslport, b) =- [ testGroup ("Test.Blackbox " ++ backendName)- $ Test.Blackbox.tests port backendName- , testGroup ("Test.Blackbox SSL " ++ backendName)- $ Test.Blackbox.ssltests backendName sslport- ]- where- backendName = show b
− test/testserver/Main.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--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 ()-
− test/testserver/static/hello.txt
@@ -1,1 +0,0 @@-hello world
+ testserver/Main.hs view
@@ -0,0 +1,36 @@+{-# 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 ()+
+ testserver/static/hello.txt view
@@ -0,0 +1,1 @@+hello world