snap-server 0.9.5.1 → 1.1.2.1
raw patch · 80 files changed
Files
- LICENSE +2/−2
- README.SNAP.md +6/−6
- README.md +7/−16
- 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 +466/−72
- src/Control/Concurrent/Extended.hs +38/−70
- src/Snap/Http/Server.hs +193/−78
- src/Snap/Http/Server/Config.hs +38/−8
- src/Snap/Http/Server/Types.hs +319/−0
- src/Snap/Internal/Http/Parser.hs +0/−217
- src/Snap/Internal/Http/Server.hs +0/−969
- src/Snap/Internal/Http/Server/Address.hs +81/−38
- src/Snap/Internal/Http/Server/Backend.hs +0/−107
- 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 +334/−120
- src/Snap/Internal/Http/Server/Date.hs +33/−39
- src/Snap/Internal/Http/Server/HttpPort.hs +0/−112
- src/Snap/Internal/Http/Server/ListenHelpers.hs +0/−78
- 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/−352
- src/Snap/Internal/Http/Server/Socket.hs +208/−0
- src/Snap/Internal/Http/Server/TLS.hs +95/−125
- src/Snap/Internal/Http/Server/Thread.hs +107/−0
- src/Snap/Internal/Http/Server/TimeoutManager.hs +117/−142
- src/Snap/Internal/Http/Server/Types.hs +185/−0
- src/System/FastLogger.hs +100/−68
- src/System/SendFile.hs +0/−26
- src/System/SendFile.hsc +105/−0
- src/System/SendFile/Darwin.hsc +0/−53
- src/System/SendFile/FreeBSD.hsc +54/−29
- src/System/SendFile/Linux.hsc +56/−31
- 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/−98
- test/common/Test/Common/Rot13.hs +0/−19
- test/common/Test/Common/TestHandler.hs +0/−211
- 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/−36
- test/runTestsAndCoverage.sh +0/−57
- test/snap-server-testsuite.cabal +0/−214
- test/suite/Snap/Internal/Http/Parser/Tests.hs +0/−169
- test/suite/Snap/Internal/Http/Server/Tests.hs +0/−1062
- test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs +0/−76
- test/suite/Test/Blackbox.hs +0/−487
- test/suite/TestSuite.hs +0/−65
- test/testserver/Main.hs +0/−36
- test/testserver/static/hello.txt +0/−1
- testserver/Main.hs +36/−0
- testserver/static/hello.txt +1/−0
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,18 +11,18 @@ The Snap core system consists of: - * a high-speed HTTP server- * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML that allows you to bind- Haskell functionality to XML tags without getting PHP-style tag soup all- over your pants+ * a 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 --------------------@@ -71,6 +62,6 @@ 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'--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,56 +1,47 @@ name: snap-server-version: 0.9.5.1-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.+ 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, Snap+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 +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@@ -60,55 +51,206 @@ 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,- 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.Parser,+ Snap.Internal.Http.Server.Session,+ Snap.Internal.Http.Server.Socket,+ Snap.Internal.Http.Server.Thread,+ Snap.Internal.Http.Server.TimeoutManager,+ Snap.Internal.Http.Server.TLS++ build-depends:+ attoparsec >= 0.12 && < 0.15,+ base >= 4.6 && < 5,+ blaze-builder >= 0.4 && < 0.5,+ bytestring >= 0.9.1 && < 0.12,+ case-insensitive >= 1.1 && < 1.3,+ clock >= 0.7.1 && < 0.9,+ containers >= 0.3 && < 0.7,+ filepath >= 1.1 && < 2.0,+ io-streams >= 1.3 && < 1.6,+ io-streams-haproxy >= 1.0 && < 1.1,+ lifted-base >= 0.1 && < 0.3,+ mtl >= 2.0 && < 2.4,+ network >= 2.3 && < 3.2,+ old-locale >= 1.0 && < 1.1,+ snap-core >= 1.0 && < 1.1,+ text >= 0.11 && < 2.1,+ time >= 1.0 && < 1.13,+ transformers >= 0.3 && < 0.7,+ unix-compat >= 0.2 && < 0.7,+ vector >= 0.7 && < 0.14++ other-extensions:+ BangPatterns,+ CPP,+ MagicHash,+ Rank2Types,+ OverloadedStrings,+ ScopedTypeVariables,+ DeriveDataTypeable,+ PackageImports,+ ViewPatterns,+ ForeignFunctionInterface,+ EmptyDataDecls,+ GeneralizedNewtypeDeriving++ if !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.16 && < 0.19++ if !impl(ghc >= 7.8)+ build-depends: bytestring-builder >= 0.10.4 && < 0.11++ if flag(portable) || os(windows)+ cpp-options: -DPORTABLE+ else+ build-depends: unix < 2.9++ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL >= 0.10.4 && < 0.12,+ openssl-streams >= 1.1 && < 1.3++ if os(linux) && !flag(portable)+ cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS+ other-modules:+ System.SendFile,+ System.SendFile.Linux++-- Disabling sendfile() on OSX for now. See+--+-- https://github.com/snapframework/snap-core/issues/274 and+-- https://github.com/snapframework/snap-core/issues/91+--+ if os(darwin) && !flag(portable)+ cpp-options: -DHAS_UNIX_SOCKETS+ -- if os(darwin) && !flag(portable)+ -- cpp-options: -DOSX -DHAS_UNIX_SOCKETS++ if os(freebsd) && !flag(portable)+ cpp-options: -DFREEBSD -DHAS_SENDFILE -DHAS_UNIX_SOCKETS+ other-modules:+ System.SendFile,+ System.SendFile.FreeBSD++ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++ if flag(debug)+ cpp-options: -DLABEL_THREADS++Test-suite testsuite+ hs-source-dirs: src test+ Type: exitcode-stdio-1.0+ Main-is: TestSuite.hs+ Default-language: Haskell2010++ other-modules:+ Control.Concurrent.Extended,+ Paths_snap_server,+ Snap.Http.Server,+ Snap.Http.Server.Config,+ Snap.Http.Server.Types,+ Snap.Internal.Http.Server.Address,+ Snap.Internal.Http.Server.Clock,+ Snap.Internal.Http.Server.Common, Snap.Internal.Http.Server.Config,- Snap.Internal.Http.Server.ListenHelpers,- Snap.Internal.Http.Server.HttpPort,- Snap.Internal.Http.Server.SimpleBackend,+ 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,- Control.Concurrent.Extended+ 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 >= 0.10 && < 0.13,- attoparsec-enumerator >= 0.3 && < 0.4,- base >= 4.4 && < 5,- blaze-builder >= 0.2.1.4 && < 0.5,- blaze-builder-enumerator >= 0.2.0 && < 0.3,- bytestring >= 0.9.1 && < 0.11,- case-insensitive >= 0.3 && < 1.3,- containers >= 0.3 && < 0.6,- enumerator >= 0.4.15 && < 0.5,- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- mtl >= 2 && < 3,- network >= 2.3 && < 2.7,+ attoparsec,+ base,+ base16-bytestring >= 0.1 && < 1.1,+ blaze-builder,+ bytestring,+ case-insensitive,+ clock,+ containers,+ directory >= 1.1 && < 1.4,+ filepath,+ io-streams,+ io-streams-haproxy,+ lifted-base,+ monad-control >= 1.0 && < 1.1,+ mtl,+ network, old-locale,- snap-core >= 0.9.3 && < 0.10,- text >= 0.11 && < 1.3,- time >= 1.0 && < 1.6,- unix-compat >= 0.2 && < 0.5+ random >= 1.0 && < 1.3,+ snap-core,+ text,+ threads >= 0.5 && < 0.6,+ time,+ transformers,+ unix-compat,+ vector, - extensions:+ 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,@@ -122,42 +264,294 @@ EmptyDataDecls, GeneralizedNewtypeDeriving + if !impl(ghc >= 8.0)+ build-depends: semigroups++ if !impl(ghc >= 7.8)+ build-depends: bytestring-builder+ if flag(portable) || os(windows) cpp-options: -DPORTABLE else build-depends: unix + -- always label threads in testsuite+ cpp-options: -DLABEL_THREADS+ if flag(openssl) cpp-options: -DOPENSSL- build-depends: HsOpenSSL >= 0.10 && <0.12+ 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 flag(debug)- cpp-options: -DLABEL_THREADS+ 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
src/Control/Concurrent/Extended.hs view
@@ -1,79 +1,49 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} --- | Handy functions that should really be merged into--- Control.Concurrent itself.+-- | Handy functions that should really be merged into Control.Concurrent+-- itself. module Control.Concurrent.Extended- ( forkIOLabeledBs- , forkIOLabeledWithUnmaskBs- , forkOnLabeledBs+ ( forkIOLabeledWithUnmaskBs , forkOnLabeledWithUnmaskBs ) where -------------------------------------------------------------------------------import Control.Concurrent (forkIO, forkOn, forkIOWithUnmask, forkOnWithUnmask)-import Control.Exception (mask, mask_)+import Control.Exception (mask_) import qualified Data.ByteString as B import GHC.Conc.Sync (ThreadId (..)) #ifdef LABEL_THREADS-import qualified Data.ByteString.Unsafe as BU+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 'forkIO' to run the given IO--- computation, but first labels the thread with the given label--- (using 'labelThreadBs').------ The implementation makes sure that asynchronous exceptions are--- masked until the given computation is executed. This ensures the--- thread will always be labeled which guarantees you can always--- easily find it in the GHC event log.------ Note that the given computation is executed in the masked state of--- the calling thread.------ Returns the 'ThreadId' of the newly created thread.-forkIOLabeledBs :: B.ByteString -- ^ Latin-1 encoded label- -> IO ()- -> IO ThreadId-forkIOLabeledBs label m =- mask $ \restore -> forkIO $ do- labelMe label- restore m - --------------------------------------------------------------------------------- | Like 'forkIOLabeledBs', but lets you specify on which capability--- (think CPU) the thread should run.-forkOnLabeledBs :: B.ByteString -- ^ Latin-1 encoded label- -> Int -- ^ Capability- -> IO ()- -> IO ThreadId-forkOnLabeledBs label cap m =- mask $ \restore -> forkOn cap $ do- labelMe label- restore m------------------------------------------------------------------------------------ | Sparks off a new thread using 'forkIOWithUnmask' to run the given--- IO computation, but first labels the thread with the given label--- (using 'labelThreadBs').+-- | 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.+-- 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.+-- 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@@ -81,20 +51,20 @@ -> IO ThreadId forkIOLabeledWithUnmaskBs label m = mask_ $ forkIOWithUnmask $ \unmask -> do- labelMe label+ !_ <- labelMe label m unmask --------------------------------------------------------------------------------- | Like 'forkIOLabeledWithUnmaskBs', but lets you specify on which--- capability (think CPU) the thread should run.+-- | 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+ !_ <- labelMe label m unmask @@ -109,19 +79,16 @@ --------------------------------------------------------------------------------- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString'--- instead of a 'String'.------ Note that if you terminate the ByteString with a '\0' this function--- will use a more efficient implementation which avoids copying the--- ByteString.+-- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' instead of a+-- 'String'. labelThreadBs :: ThreadId -> B.ByteString -> IO ()-labelThreadBs tid bs- | n == 0 = return ()- | B.index bs (n - 1) == 0 = BU.unsafeUseAsCString bs $ labelThreadCString tid- | otherwise = B.useAsCString bs $ labelThreadCString tid- where- n = B.length bs+#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 ------------------------------------------------------------------------------@@ -130,9 +97,10 @@ 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/Snap/Http/Server.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------------------------------- | 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.+-- | 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@@ -14,43 +15,81 @@ , quickHttpServe , snapServerVersion , setUnicodeLocale+ , rawHttpServe , module Snap.Http.Server.Config ) where -------------------------------------------------------------------------------import Control.Applicative-import Control.Concurrent (newMVar, withMVar)-import Control.Monad-import Control.Monad.CatchIO-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.List-import Data.Maybe-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Snap.Http.Server.Config-import qualified Snap.Internal.Http.Server as Int-import Snap.Internal.Http.Server.Config (emptyStartupInfo,- setStartupSockets,- setStartupConfig)-import Snap.Core-import Snap.Util.GZip-import Snap.Util.Proxy+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 System.FastLogger+------------------------------------------------------------------------------+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 ------------------------------------------------------------------------------+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. --@@ -60,29 +99,78 @@ simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO () simpleHttpServe config handler = do conf <- completeConfig config- let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr- mapM_ (output . ("Listening on "++) . show) $ listeners conf+ let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr+ (descrs, sockets, afuncs) <- unzip3 <$> listeners conf+ mapM_ (output . ("Listening on " ++) . S.unpack) descrs - go conf `finally` output "\nShutting down..."+ go conf sockets afuncs `finally` (mask_ $ do+ output "\nShutting down.."+ mapM_ (eatException . close) sockets) where+ eatException :: IO a -> IO ()+ eatException act =+ let r0 = return $! ()+ in (act >> r0) `catch` \(_::SomeException) -> r0+ --------------------------------------------------------------------------- go conf = do+ -- 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) ->- Int.httpServe tout- (listeners conf)- (fromJust $ getHostname conf)- alog- elog- (\sockets -> let dat = mkStartupInfo sockets conf- in maybe (return ())- ($ dat)- (getStartupHook conf))- (runSnap handler)+ (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 =@@ -102,7 +190,7 @@ withLoggers afp efp act = bracket (do mvar <- newMVar () let f s = withMVar mvar- (const $ BS.hPutStr stderr s >> hFlush stderr)+ (const $ S.hPutStr stderr s >> hFlush stderr) alog <- maybeSpawnLogger f afp elog <- maybeSpawnLogger f efp return (alog, elog))@@ -115,21 +203,42 @@ -------------------------------------------------------------------------------listeners :: Config m a -> [Int.ListenPort]-listeners conf = catMaybes [ httpListener, httpsListener ]+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+ b <- getSSLBind conf+ p <- getSSLPort conf+ cert <- getSSLCert conf chainCert <- getSSLChainCert conf- key <- getSSLKey conf- return $! Int.HttpsPort b p cert chainCert key-+ 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 $! Int.HttpPort b p+ 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)) ------------------------------------------------------------------------------@@ -140,26 +249,27 @@ httpServe config handler0 = do conf <- completeConfig config let !handler = chooseProxy conf- let serve = compress conf . catch500 conf $ handler+ let serve = compress conf . catch500 conf $ handler simpleHttpServe conf serve where chooseProxy conf = maybe handler0- (\ptype -> behindProxy ptype handler0)+ (\ptype -> pickProxy ptype handler0) (getProxyType conf)-{-# INLINE httpServe #-} + 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 catch $ fromJust $ getErrorHandler conf-{-# INLINE catch500 #-}+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-{-# INLINE compress #-} ------------------------------------------------------------------------------@@ -168,30 +278,35 @@ -- '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 = #ifndef PORTABLE- \lang -> mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True)- [ "LANG"- , "LC_CTYPE"- , "LC_NUMERIC"- , "LC_TIME"- , "LC_COLLATE"- , "LC_MONETARY"- , "LC_MESSAGES"- , "LC_PAPER"- , "LC_NAME"- , "LC_ADDRESS"- , "LC_TELEPHONE"- , "LC_MEASUREMENT"- , "LC_IDENTIFICATION"- , "LC_ALL" ]+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- const $ return ()+setUnicodeLocale = const $ return () #endif++------------------------------------------------------------------------------+bshow :: (Show a) => a -> ByteString+bshow = S.pack . show
src/Snap/Http/Server/Config.hs view
@@ -1,13 +1,11 @@-{-|--This module exports the 'Config' datatype, which you can use to configure the-Snap HTTP server.---}-+------------------------------------------------------------------------------+-- | This module exports the 'Config' datatype, which you can use to configure+-- the Snap HTTP server.+-- module Snap.Http.Server.Config ( Config , ConfigLog(..)+ , ProxyType , emptyConfig , defaultConfig@@ -36,6 +34,8 @@ , getSSLPort , getVerbose , getStartupHook+ , getUnixSocket+ , getUnixSocketAccessMode , setAccessLog , setBind@@ -54,10 +54,40 @@ , setSSLChainCert , setSSLPort , setVerbose+ , setUnixSocket+ , setUnixSocketAccessMode+ , setStartupHook , StartupInfo , getStartupSockets , getStartupConfig++ -- ** Proxy protocol selection+ , noProxy+ , xForwardedFor+ , haProxy ) where -import Snap.Internal.Http.Server.Config+------------------------------------------------------------------------------+import Snap.Internal.Http.Server.Config+++------------------------------------------------------------------------------+-- | Configure Snap in direct / non-proxying mode.+noProxy :: ProxyType+noProxy = NoProxy+++------------------------------------------------------------------------------+-- | Assert that Snap is running behind an HTTP proxy, and that the proxied+-- connection information will be stored in the \"X-Forwarded-For\" or+-- \"Forwarded-For\" HTTP headers.+xForwardedFor :: ProxyType+xForwardedFor = X_Forwarded_For++------------------------------------------------------------------------------+-- | Assert that Snap is running behind a proxy running the HaProxy protocol+-- (see <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,217 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ViewPatterns #-}--module Snap.Internal.Http.Parser- ( IRequest(..)- , HttpParseException- , parseRequest- , readChunkedTransferEncoding- , iterParser- , parseCookie- , parseUrlEncoded- , strictize- ) where----------------------------------------------------------------------------------import Control.Exception-import Control.Monad (liftM)-import Control.Monad.Trans-import Data.Attoparsec-import Data.Attoparsec.Enumerator-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Unsafe as S-import Data.ByteString.Internal (w2c)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char-import Data.Int-import Data.Typeable-import Prelude hiding (head, take, takeWhile)------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Iteratee.Debug-import Snap.Internal.Parsing hiding (pHeaders)-import Snap.Iteratee hiding (map, take)------------------------------------------------------------------------------------ | an internal version of the headers part of an HTTP request-data IRequest = IRequest- { iMethod :: Method- , iRequestUri :: ByteString- , iHttpVersion :: (Int,Int)- , iRequestHeaders :: [(ByteString, ByteString)]- }----------------------------------------------------------------------------------instance Show IRequest where- show (IRequest m u v r) =- concat [ show m- , " "- , show u- , " "- , show v- , " "- , show r ]----------------------------------------------------------------------------------data HttpParseException = HttpParseException String deriving (Typeable, Show)-instance Exception HttpParseException---------------------------------------------------------------------------------parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)-parseRequest = do- eof <- isEOF- if eof- then return Nothing- else do- line <- pLine- if S.null line- then parseRequest- else do- let (!mStr,!s) = bSp line- let (!uri,!vStr) = bSp s-- !method <- methodFromString mStr-- let ver@(!_,!_) = pVer vStr-- hdrs <- pHeaders- return $! Just $! IRequest method uri ver hdrs-- where- pVer s = if S.isPrefixOf "HTTP/" s- then let (a,b) = bDot $ S.drop 5 s- in (read $ S.unpack a, read $ S.unpack b)- else (1,0)-- isSp = (== ' ')- bSp = splitWith isSp- isDot = (== '.')- bDot = splitWith isDot----------------------------------------------------------------------------------pLine :: (Monad m) => Iteratee ByteString m ByteString-pLine = continue $ k S.empty- where- k _ EOF = throwError $- HttpParseException "parse error: expected line ending in crlf"- k !pre (Chunks xs) =- if S.null b- then continue $ k a- else yield a (Chunks [S.drop 2 b])- where- (!a,!b) = S.breakSubstring "\r\n" s- !s = S.append pre s'- !s' = S.concat xs----------------------------------------------------------------------------------splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString)-splitWith !f !s = let (!a,!b) = S.break f s- !b' = S.dropWhile f b- in (a, b')----------------------------------------------------------------------------------pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)]-pHeaders = do- f <- go id- return $! f []- where- go !dlistSoFar = {-# SCC "pHeaders/go" #-} do- line <- pLine- if S.null line- then return dlistSoFar- else do- let (!k,!v) = pOne line- vf <- pCont id- let vs = vf []- let !v' = S.concat (v:vs)- go (dlistSoFar . ((k,v'):))-- where- pOne s = let (k,v) = splitWith (== ':') s- in (trim k, trim v)-- isCont c = c == ' ' || c == '\t'-- pCont !dlist = do- mbS <- peek- maybe (return dlist)- (\s -> if S.null s- then head >> pCont dlist- else if isCont $ w2c $ S.unsafeHead s- then procCont dlist- else return dlist)- mbS-- procCont !dlist = do- line <- pLine- let !t = trim line- pCont (dlist . (" ":) . (t:))----------------------------------------------------------------------------------methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method-methodFromString "GET" = return GET-methodFromString "POST" = return POST-methodFromString "HEAD" = return HEAD-methodFromString "PUT" = return PUT-methodFromString "DELETE" = return DELETE-methodFromString "TRACE" = return TRACE-methodFromString "OPTIONS" = return OPTIONS-methodFromString "CONNECT" = return CONNECT-methodFromString "PATCH" = return PATCH-methodFromString s = return $ Method s----------------------------------------------------------------------------------readChunkedTransferEncoding :: (MonadIO m) =>- Enumeratee ByteString ByteString m a-readChunkedTransferEncoding =- chunkParserToEnumeratee $- iterateeDebugWrapper "pGetTransferChunk" $- iterParser pGetTransferChunk----------------------------------------------------------------------------------chunkParserToEnumeratee :: (MonadIO m) =>- Iteratee ByteString m (Maybe ByteString)- -> Enumeratee ByteString ByteString m a-chunkParserToEnumeratee getChunk client = do- mbB <- getChunk- maybe finishIt sendBS mbB-- where- sendBS s = do- step <- lift $ runIteratee $ enumBS s client- chunkParserToEnumeratee getChunk step-- finishIt = lift $ runIteratee $ enumEOF client------------------------------------------------------------------------------------ parse functions----------------------------------------------------------------------------------------------------------------------------------------------------------------pGetTransferChunk :: Parser (Maybe ByteString)-pGetTransferChunk = do- !hex <- liftM unsafeFromHex $ (takeWhile (isHexDigit . w2c))- takeTill ((== '\r') . w2c)- crlf- if hex <= (0 :: Int)- then return Nothing- else do- x <- take hex- crlf- return $! Just x
− src/Snap/Internal/Http/Server.hs
@@ -1,969 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Server where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-import Blaze.ByteString.Builder.Enumerator-import Blaze.ByteString.Builder.HTTP-import Control.Arrow (first, second)-import Control.Exception hiding (catch, throw)-import Control.Monad.CatchIO hiding (Handler,- bracket, catches,- finally)-import qualified Control.Monad.CatchIO as CatchIO-import Control.Monad.State.Strict-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as SC-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L-import qualified Data.CaseInsensitive as CI-import Data.Char-import Data.Enumerator.Internal-import Data.Int-import Data.IORef-import Data.List (foldl')-import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromJust,- fromMaybe, isJust,- isNothing)-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Time-import Data.Typeable-import Data.Version-import GHC.Conc-import Network.Socket (Socket, withSocketsDo)-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import System.IO-#if !MIN_VERSION_time(1,5,0)-import System.Locale-#endif--------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Internal.Exceptions (EscapeHttpException (..))-import Snap.Internal.Http.Parser-import Snap.Internal.Http.Server.Date-import Snap.Internal.Http.Types-import System.FastLogger (combinedLogEntry,- timestampedLogEntry)--import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Server.HttpPort-import Snap.Internal.Http.Server.SimpleBackend-import qualified Snap.Internal.Http.Server.TLS as TLS--import Snap.Internal.Iteratee.Debug-import Snap.Internal.Parsing (unsafeFromInt)-import Snap.Iteratee hiding (head, map,- take)-import qualified Snap.Iteratee as I--import Snap.Types.Headers (Headers)-import qualified Snap.Types.Headers as H--import qualified Paths_snap_server as V------------------------------------------------------------------------------------ | The handler has to return the request object because we have to clear the--- HTTP request body before we send the response. If the handler consumes the--- request body, it is responsible for setting @rqBody=return@ in the returned--- request (otherwise we will mess up reading the input stream).------ Note that we won't be bothering end users with this -- the details will be--- hidden inside the Snap monad-type ServerHandler = (ByteString -> IO ())- -> ((Int -> Int) -> IO ())- -> Request- -> Iteratee ByteString IO (Request,Response)----------------------------------------------------------------------------------type ServerMonad = StateT ServerState (Iteratee ByteString IO)----------------------------------------------------------------------------------data ListenPort =- -- (bind address, port)- HttpPort ByteString Int |- -- (bind address, port, path to certificate, whether certificate is a complete chain, path to key)- HttpsPort ByteString Int FilePath Bool FilePath---------------------------------------------------------------------------------instance Show ListenPort where- show (HttpPort b p ) =- concat [ "http://" , SC.unpack b, ":", show p, "/" ]-- show (HttpsPort b p _ _ _) =- concat [ "https://", SC.unpack b, ":", show p, "/" ]------------------------------------------------------------------------------------ This exception will be thrown if we decided to terminate the request before--- running the user handler.-data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException- deriving (Show, Typeable)-instance Exception TerminatedBeforeHandlerException----- We throw this if we get an exception that escaped from the user handler.-data ExceptionAlreadyCaught = ExceptionAlreadyCaught- deriving (Show, Typeable)-instance Exception ExceptionAlreadyCaught----------------------------------------------------------------------------------data ServerState = ServerState- { _forceConnectionClose :: Bool- , _localHostname :: ByteString- , _sessionPort :: SessionInfo- , _logAccess :: Request -> Response -> IO ()- , _logError :: ByteString -> IO ()- }----------------------------------------------------------------------------------runServerMonad :: ByteString -- ^ local host name- -> SessionInfo -- ^ session port information- -> (Request -> Response -> IO ()) -- ^ access log function- -> (ByteString -> IO ()) -- ^ error log function- -> ServerMonad a -- ^ monadic action to run- -> Iteratee ByteString IO a-runServerMonad lh s la le m = evalStateT m st- where- st = ServerState False lh s la le------------------------------------------------------------------------------------ input/output----------------------------------------------------------------------------------httpServe :: Int -- ^ default timeout- -> [ListenPort] -- ^ ports to listen on- -> ByteString -- ^ local hostname (server name)- -> Maybe (ByteString -> IO ()) -- ^ access log action- -> Maybe (ByteString -> IO ()) -- ^ error log action- -> ([Socket] -> IO ()) -- ^ initialisation- -> ServerHandler -- ^ handler procedure- -> IO ()-httpServe defaultTimeout ports localHostname alog' elog' initial handler =- withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers-- where- --------------------------------------------------------------------------- errorHandlers = [ Handler sslException- , Handler threadWasKilled- , Handler otherException ]-- --------------------------------------------------------------------------- sslException (e@(TLS.TLSException msg)) = do- logE elog' msg- SC.hPutStrLn stderr msg- throw e-- ------------------------------------------------------------------------------- threadWasKilled (_ :: AsyncException) = return ()-- ------------------------------------------------------------------------------- otherException (e :: SomeException) = do- let msg = SC.concat [- "Error on startup: \n"- , T.encodeUtf8 $ T.pack $ show e- ]- logE elog' msg- SC.hPutStrLn stderr msg- throw e-- --------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do-- logE elog $ S.concat [ "Server.httpServe: START, binding to "- , bshow ports ]-- let isHttps p = case p of { (HttpsPort _ _ _ _ _) -> True; _ -> False;}- let initHttps = foldr (\p b -> b || isHttps p) False ports-- if initHttps- then TLS.initTLS- else return ()-- nports <- mapM bindPort ports- let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports-- (simpleEventLoop defaultTimeout nports numCapabilities (logE elog) (initial socks)- $ runHTTP defaultTimeout alog elog handler localHostname)- `finally` do- logE elog "Server.httpServe: SHUTDOWN"-- if initHttps- then TLS.stopTLS- else return ()-- logE elog "Server.httpServe: BACKEND STOPPED"-- --------------------------------------------------------------------------- bindPort (HttpPort baddr port ) = bindHttp baddr port- bindPort (HttpsPort baddr port cert chainCert key) =- TLS.bindHttps baddr port cert chainCert key----------------------------------------------------------------------------------debugE :: (MonadIO m) => ByteString -> m ()-debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)----------------------------------------------------------------------------------logE :: Maybe (ByteString -> IO ()) -> ByteString -> IO ()-logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog----------------------------------------------------------------------------------logE' :: (ByteString -> IO ()) -> ByteString -> IO ()-logE' logger s = (timestampedLogEntry s) >>= logger----------------------------------------------------------------------------------bshow :: (Show a) => a -> ByteString-bshow = toBS . show----------------------------------------------------------------------------------logA :: Maybe (ByteString -> IO ()) -> Request -> Response -> IO ()-logA alog = maybe (\_ _ -> return ()) logA' alog----------------------------------------------------------------------------------logA' :: (ByteString -> IO ()) -> Request -> Response -> IO ()-logA' logger req rsp = do- let hdrs = rqHeaders req- let host = rqRemoteAddr req- let user = Nothing -- TODO we don't do authentication yet- let (v, v') = rqVersion req- let ver = S.concat [ "HTTP/", bshow v, ".", bshow v' ]- let method = toBS $ show (rqMethod req)- let reql = S.intercalate " " [ method, rqURI req, ver ]- let status = rspStatus rsp- let cl = rspContentLength rsp- let referer = maybe Nothing (Just . head) $ H.lookup "referer" hdrs- let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs-- msg <- combinedLogEntry host user reql status cl referer userAgent- logger msg----------------------------------------------------------------------------------runHTTP :: Int -- ^ default timeout- -> Maybe (ByteString -> IO ()) -- ^ access logger- -> Maybe (ByteString -> IO ()) -- ^ error logger- -> ServerHandler -- ^ handler procedure- -> ByteString -- ^ local host name- -> SessionInfo -- ^ session port information- -> Enumerator ByteString IO () -- ^ read end of socket- -> Iteratee ByteString IO () -- ^ write end of socket- -> (FilePath -> Int64 -> Int64 -> IO ())- -- ^ sendfile end- -> ((Int -> Int) -> IO ()) -- ^ timeout tickler- -> IO ()-runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile- tickle =- go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do- return ()- , Handler $ \(_ :: ExceptionAlreadyCaught) -> do- return ()- , Handler $ \(_ :: HttpParseException) -> do- return ()- , Handler $ \(e :: AsyncException) -> do- throwIO e- , Handler $ \(e :: SomeException) ->- logE elog $ toByteString $ lmsg e- ]-- where- lmsg e = mconcat [ fromByteString "["- , fromShow $ remoteAddress sinfo- , fromByteString "]: "- , fromByteString "an exception escaped to toplevel:\n"- , fromShow e- ]-- go = do- buf <- allocBuffer 16384- let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $- httpSession defaultTimeout writeEnd buf- onSendFile tickle handler- let iter = iterateeDebugWrapper "httpSession iteratee" iter1-- debug "runHTTP/go: prepping iteratee for start"-- step <- liftIO $ runIteratee iter-- debug "runHTTP/go: running..."- run_ $ readEnd step- debug "runHTTP/go: finished"----------------------------------------------------------------------------------requestErrorMessage :: Request -> SomeException -> Builder-requestErrorMessage req e =- mconcat [ fromByteString "During processing of request from "- , fromByteString $ rqRemoteAddr req- , fromByteString ":"- , fromShow $ rqRemotePort req- , fromByteString "\nrequest:\n"- , fromShow $ show req- , fromByteString "\n"- , msgB- ]- where- msgB = mconcat [- fromByteString "A web handler threw an exception. Details:\n"- , fromShow e- ]----------------------------------------------------------------------------------sERVER_HEADER :: ByteString-sERVER_HEADER = S.concat ["Snap/", snapServerVersion]----------------------------------------------------------------------------------snapServerVersion :: ByteString-snapServerVersion = SC.pack $ showVersion $ V.version----------------------------------------------------------------------------------logAccess :: Request -> Response -> ServerMonad ()-logAccess req rsp = gets _logAccess >>= (\l -> liftIO $ l req rsp)----------------------------------------------------------------------------------logError :: ByteString -> ServerMonad ()-logError s = gets _logError >>= (\l -> liftIO $ l s)------------------------------------------------------------------------------------ | Runs an HTTP session.-httpSession :: Int- -> Iteratee ByteString IO () -- ^ write end of socket- -> Buffer -- ^ builder buffer- -> (FilePath -> Int64 -> Int64 -> IO ())- -- ^ sendfile continuation- -> ((Int -> Int) -> IO ()) -- ^ timeout modifier- -> ServerHandler -- ^ handler procedure- -> ServerMonad ()-httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do-- let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd'-- debug "Server.httpSession: entered"- mreq <- receiveRequest writeEnd- debug "Server.httpSession: receiveRequest finished"-- -- successfully got a request, so restart timer- liftIO $ tickle (max defaultTimeout)-- case mreq of- (Just req) -> do- debug $ "Server.httpSession: got request: " ++- show (rqMethod req) ++- " " ++ SC.unpack (rqURI req) ++- " " ++ show (rqVersion req)-- -- check for Expect: 100-continue- checkExpect100Continue req writeEnd-- logerr <- gets _logError-- (req',rspOrig) <- (lift $ handler logerr tickle req)- `CatchIO.catches`- [ CatchIO.Handler $ escapeHttpCatch- , CatchIO.Handler $ errCatch "user handler" req- ]-- debug $ "Server.httpSession: finished running user handler"-- let rspTmp = rspOrig { rspHttpVersion = rqVersion req }- checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp)-- cc <- gets _forceConnectionClose- let rsp = if cc- then (setHeader "Connection" "close" rspTmp)- else rspTmp-- debug "Server.httpSession: handled, skipping request body"-- if rspTransformingRqBody rsp- then debug $- "Server.httpSession: not skipping " ++- "request body, transforming."- else do- srqEnum <- liftIO $ readIORef $ rqBody req'- let (SomeEnumerator rqEnum) = srqEnum-- skipStep <- (liftIO $ runIteratee $ iterateeDebugWrapper- "httpSession/skipToEof" skipToEof)- `catch` errCatch "skipping request body" req- (lift $ rqEnum skipStep) `catch`- errCatch "skipping request body" req-- debug $ "Server.httpSession: request body skipped, " ++- "sending response"-- date <- liftIO getDateString- let insHeader = H.set "Server" sERVER_HEADER- let ins = H.set "Date" date .- if isJust (getHeader "Server" rsp)- then id- else insHeader- let rsp' = updateHeaders ins rsp- (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile- `catch` errCatch "sending response" req-- debug $ "Server.httpSession: sent " ++- (show bytesSent) ++ " bytes"-- maybe (logAccess req rsp')- (\_ -> logAccess req $ setContentLength bytesSent rsp')- (rspContentLength rsp')-- if cc- then do- debug $ "httpSession: Connection: Close, harikari"- liftIO $ myThreadId >>= killThread- else httpSession defaultTimeout writeEnd' buffer onSendFile- tickle handler-- Nothing -> do- debug $ "Server.httpSession: parser did not produce a " ++- "request, ending session"- return ()-- where- escapeHttpCatch :: EscapeHttpException -> ServerMonad a- escapeHttpCatch (EscapeHttpException escapeIter) = do- lift $ escapeIter tickle writeEnd'- throw ExceptionAlreadyCaught-- errCatch :: ByteString -> Request -> SomeException -> ServerMonad a- errCatch phase req e = do- logError $ toByteString $- mconcat [ fromByteString "httpSession caught an exception during "- , fromByteString phase- , fromByteString " phase:\n"- , requestErrorMessage req e- ]- throw ExceptionAlreadyCaught----------------------------------------------------------------------------------checkExpect100Continue :: Request- -> Iteratee ByteString IO ()- -> ServerMonad ()-checkExpect100Continue req writeEnd = do- let mbEx = getHeaders "Expect" req-- maybe (return ())- (\l -> if elem "100-continue" l then go else return ())- mbEx-- where- go = do- let (major,minor) = rqVersion req- let hl = mconcat [ fromByteString "HTTP/"- , fromShow major- , fromWord8 $ c2w '.'- , fromShow minor- , fromByteString " 100 Continue\r\n\r\n"- ]- liftIO $ runIteratee- ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)- return ()----------------------------------------------------------------------------------return411 :: Request- -> Iteratee ByteString IO ()- -> ServerMonad a-return411 req writeEnd = do- go- liftIO $ throwIO $ TerminatedBeforeHandlerException-- where- go = do- let (major,minor) = rqVersion req- let hl = mconcat [ fromByteString "HTTP/"- , fromShow major- , fromWord8 $ c2w '.'- , fromShow minor- , fromByteString " 411 Length Required\r\n\r\n"- , fromByteString "411 Length Required\r\n"- ]- liftIO $ runIteratee- ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)- return ()----------------------------------------------------------------------------------receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request)-receiveRequest writeEnd = do- debug "receiveRequest: entered"- mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $- iterateeDebugWrapper "parseRequest" $- joinI' $ takeNoMoreThan maxHeadersSize $$ parseRequest- debug "receiveRequest: parseRequest returned"-- case mreq of- (Just ireq) -> do- req' <- toRequest ireq- setEnumerator req'- req <- parseForm req'- checkConnectionClose (rqVersion req) (rqHeaders req)- return $! Just req-- Nothing -> return Nothing-- where- --------------------------------------------------------------------------- -- TODO(gdc): make this a policy decision (expose in- -- Snap.Http.Server.Config)- maxHeadersSize = 256 * 1024-- --------------------------------------------------------------------------- -- check: did the client specify "transfer-encoding: chunked"? then we- -- have to honor that.- --- -- otherwise: check content-length header. if set: only take N bytes from- -- the read end of the socket- --- -- if no content-length and no chunked encoding, enumerate the entire- -- socket and close afterwards- setEnumerator :: Request -> ServerMonad ()- setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do- if isChunked- then do- debug $ "receiveRequest/setEnumerator: " ++- "input in chunked encoding"- let e = joinI . readChunkedTransferEncoding- liftIO $ writeIORef (rqBody req)- (SomeEnumerator e)- else maybe (noContentLength req) hasContentLength mbCL-- where- isChunked = maybe False- ((== ["chunked"]) . map CI.mk)- (H.lookup "transfer-encoding" hdrs)-- hasContentLength :: Int64 -> ServerMonad ()- hasContentLength len = do- debug $ "receiveRequest/setEnumerator: " ++- "request had content-length " ++ show len- liftIO $ writeIORef (rqBody req) (SomeEnumerator e)- debug "receiveRequest/setEnumerator: body enumerator set"- where- e :: Enumerator ByteString IO a- e st = do- st' <- lift $- runIteratee $- iterateeDebugWrapper "rqBody iterator" $- returnI st-- joinI $ takeExactly len st'-- noContentLength :: Request -> ServerMonad ()- noContentLength rq = do- debug ("receiveRequest/setEnumerator: " ++- "request did NOT have content-length")-- when (rqMethod rq == POST || rqMethod rq == PUT) $- return411 req writeEnd-- let enum = SomeEnumerator $- iterateeDebugWrapper "noContentLength" .- joinI . I.take 0- liftIO $ writeIORef (rqBody rq) enum- debug "receiveRequest/setEnumerator: body enumerator set"--- hdrs = rqHeaders req- mbCL = H.lookup "content-length" hdrs >>= return . unsafeFromInt . head--- --------------------------------------------------------------------------- parseForm :: Request -> ServerMonad Request- parseForm req = {-# SCC "receiveRequest/parseForm" #-}- if doIt then getIt else return req- where- mbCT = liftM head $ H.lookup "content-type" (rqHeaders req)- trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';')- . SC.dropWhile isSpace- mbCT' = liftM trimIt mbCT- doIt = mbCT' == Just "application/x-www-form-urlencoded"-- maximumPOSTBodySize :: Int64- maximumPOSTBodySize = 10*1024*1024-- getIt :: ServerMonad Request- getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do- debug "parseForm: got application/x-www-form-urlencoded"- debug "parseForm: reading POST body"- senum <- liftIO $ readIORef $ rqBody req- let (SomeEnumerator enum) = senum- consumeStep <- liftIO $ runIteratee consume- step <- liftIO $- runIteratee $- joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep- body <- liftM S.concat $ lift $ enum step- let newParams = parseUrlEncoded body-- debug "parseForm: stuffing 'enumBS body' into request"-- let e = enumBS body >==> I.joinI . I.take 0-- let e' = \st -> do- let ii = iterateeDebugWrapper "regurgitate body" (returnI st)- st' <- lift $ runIteratee ii- e st'-- liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'- return $! req { rqParams = Map.unionWith (++) (rqParams req)- newParams- , rqPostParams = newParams- }--- --------------------------------------------------------------------------- toRequest (IRequest method uri version kvps) =- {-# SCC "receiveRequest/toRequest" #-} do- localAddr <- gets $ localAddress . _sessionPort- lport <- gets $ localPort . _sessionPort- remoteAddr <- gets $ remoteAddress . _sessionPort- rport <- gets $ remotePort . _sessionPort- localHostname <- gets $ _localHostname- secure <- gets $ isSecure . _sessionPort-- let (serverName, serverPort) = fromMaybe- (localHostname, lport)- (liftM (parseHost . head)- (H.lookup "host" hdrs))-- -- will override in "setEnumerator"- enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")-- return $! Request serverName- serverPort- remoteAddr- rport- localAddr- lport- localHostname- secure- hdrs- enum- mbContentLength- method- version- cookies- pathInfo- contextPath- uri- queryString- params- params- Map.empty-- where- dropLeadingSlash s = maybe s f mbS- where- f (a,s') = if a == c2w '/' then s' else s- mbS = S.uncons s-- hdrs = toHeaders kvps-- mbContentLength = liftM (unsafeFromInt . head) $- H.lookup "content-length" hdrs-- cookies = concat $- maybe []- (catMaybes . map parseCookie)- (H.lookup "cookie" hdrs)-- contextPath = "/"-- parseHost h = (a, unsafeFromInt (S.drop 1 b))- where- (a,b) = S.break (== (c2w ':')) h-- params = parseUrlEncoded queryString-- (pathInfo, queryString) = first dropLeadingSlash . second (S.drop 1) $- S.break (== (c2w '?')) uri------------------------------------------------------------------------------------ Response must be well-formed here-sendResponse :: forall a .- Request- -> Response- -> Buffer- -> Iteratee ByteString IO a -- ^ iteratee write end- -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on- -- sendfile- -> ServerMonad (Int64, a)-sendResponse req rsp0 buffer writeEnd' onSendFile = do- let rsp1 = renderCookies rsp0-- let (rsp, shouldClose) = if isNothing $ rspContentLength rsp1- then noCL rsp1- else (rsp1, False)-- when shouldClose $ modify $! \s -> s { _forceConnectionClose = True }-- let (!headerString,!hlen) = mkHeaderBuilder rsp- let writeEnd = fixCLIteratee hlen rsp writeEnd'-- (!x,!bs) <-- case (rspBody rsp) of- (Enum e) -> lift $ whenEnum writeEnd headerString hlen- rsp e- (SendFile f Nothing) -> lift $- whenSendFile writeEnd headerString rsp f 0- (SendFile f (Just (st,_))) ->- lift $ whenSendFile writeEnd headerString rsp f st-- debug "sendResponse: response sent"-- return $! (bs,x)-- where- --------------------------------------------------------------------------- noCL :: Response -> (Response, Bool)- noCL r =- if rqMethod req == HEAD- then let r' = r { rspBody = Enum $ enumBuilder mempty }- in (r', False)- else if rspHttpVersion r >= (1,1)- then let r' = setHeader "Transfer-Encoding" "chunked" r- origE = rspBodyToEnum $ rspBody r- e = \i -> joinI $ origE $$ chunkIt i- in (r' { rspBody = Enum e }, False)- else- -- HTTP/1.0 and no content-length? We'll have to close the- -- socket.- (setHeader "Connection" "close" r, True)- {-# INLINE noCL #-}--- --------------------------------------------------------------------------- chunkIt :: forall x . Enumeratee Builder Builder IO x- chunkIt = checkDone $ continue . step- where- step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return- step k (Chunks []) = continue $ step k- step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])- >>== chunkIt--- --------------------------------------------------------------------------- whenEnum :: Iteratee ByteString IO a- -> Builder- -> Int- -> Response- -> (forall x . Enumerator Builder IO x)- -> Iteratee ByteString IO (a,Int64)- whenEnum writeEnd hs hlen rsp e = do- -- "enum" here has to be run in the context of the READ iteratee, even- -- though it's writing to the output, because we may be transforming- -- the input. That's why we check if we're transforming the request- -- body here, and if not, send EOF to the write end; so that it- -- doesn't join up with the read iteratee and try to get more data- -- from the socket.- let eBuilder = enumBuilder hs >==> e- let enum = if rspTransformingRqBody rsp- then eBuilder- else eBuilder >==>- mapEnum toByteString fromByteString- (joinI . I.take 0)-- debug $ "sendResponse: whenEnum: enumerating bytes"-- outstep <- lift $ runIteratee $- iterateeDebugWrapper "countBytes writeEnd" $- countBytes writeEnd-- let bufferFunc = if getBufferingMode rsp- then unsafeBuilderToByteString (return buffer)- else I.map (toByteString . (`mappend` flush))-- (x,bs) <- mapIter fromByteString toByteString- (enum $$ joinI $ bufferFunc outstep)-- debug $ "sendResponse: whenEnum: " ++ show bs ++- " bytes enumerated"-- return (x, bs - fromIntegral hlen)--- --------------------------------------------------------------------------- whenSendFile :: Iteratee ByteString IO a -- ^ write end- -> Builder -- ^ headers- -> Response- -> FilePath -- ^ file to send- -> Int64 -- ^ start byte offset- -> Iteratee ByteString IO (a,Int64)- whenSendFile writeEnd hs r f start = do- -- Guaranteed to have a content length here. Sending EOF through to- -- the write end guarantees that we flush the buffer before we send- -- the file with sendfile().- lift $ runIteratee ((enumBuilder hs >==> enumEOF) $$- unsafeBuilderToByteString (return buffer)- $$ writeEnd)-- let !cl = fromJust $ rspContentLength r- x <- liftIO $ onSendFile f start cl- return (x, cl)--- --------------------------------------------------------------------------- (major,minor) = rspHttpVersion rsp0--- --------------------------------------------------------------------------- buildHdrs :: Headers -> (Builder,Int)- buildHdrs hdrs =- {-# SCC "buildHdrs" #-}- H.fold f (mempty,0) hdrs- where- f (!b,!len) !k !ys =- let (!b',len') = h k ys- in (b `mappend` b', len+len')-- crlf = fromByteString "\r\n"-- doOne pre plen (b,len) y = ( mconcat [ b- , pre- , fromByteString y- , crlf ]- , len + plen + 2 + S.length y )-- h k ys = foldl' (doOne kb klen) (mempty,0) ys- where- k' = CI.original k- kb = fromByteString k' `mappend` fromByteString ": "- klen = S.length k' + 2--- --------------------------------------------------------------------------- fixCLIteratee :: Int -- ^ header length- -> Response -- ^ response- -> Iteratee ByteString IO a -- ^ write end- -> Iteratee ByteString IO a- fixCLIteratee hlen resp we = maybe we f mbCL- where- f cl = case rspBody resp of- (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen)- $$ we- (SendFile _ _) -> we-- mbCL = rspContentLength resp--- --------------------------------------------------------------------------- renderCookies :: Response -> Response- renderCookies r = updateHeaders f r- where- f h = if null cookies- then h- else foldl' (\m v -> H.insert "Set-Cookie" v m) h cookies- cookies = fmap cookieToBS . Map.elems $ rspCookies r--- --------------------------------------------------------------------------- mkHeaderBuilder :: Response -> (Builder,Int)- mkHeaderBuilder r = {-# SCC "mkHeaderBuilder" #-}- ( mconcat [ fromByteString "HTTP/"- , fromString majstr- , fromWord8 $ c2w '.'- , fromString minstr- , space- , fromString $ statstr- , space- , fromByteString reason- , crlf- , hdrs- , crlf- ]- , 12 + majlen + minlen + statlen + S.length reason + hlen )-- where- (hdrs,hlen) = buildHdrs $ headers r- majstr = show major- minstr = show minor- majlen = length majstr- minlen = length minstr- statstr = show $ rspStatus r- statlen = length statstr- crlf = fromByteString "\r\n"- space = fromWord8 $ c2w ' '- reason = rspStatusReason r----------------------------------------------------------------------------------checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad ()-checkConnectionClose ver hdrs =- -- For HTTP/1.1:- -- if there is an explicit Connection: close, close the socket.- -- For HTTP/1.0:- -- if there is no explicit Connection: Keep-Alive, close the socket.- if (ver == (1,1) && l == Just ["close"]) ||- (ver == (1,0) && l /= Just ["keep-alive"])- then modify $ \s -> s { _forceConnectionClose = True }- else return ()- where- l = liftM (map tl) $ H.lookup "Connection" hdrs- tl = S.map (c2w . toLower . w2c)------------------------------------------------------------------------------------ FIXME: whitespace-trim the values here.-toHeaders :: [(ByteString,ByteString)] -> Headers-toHeaders kvps = H.fromList kvps'- where- kvps' = map (first CI.mk) kvps------------------------------------------------------------------------------------ | Convert 'Cookie' into 'ByteString' for output.-cookieToBS :: Cookie -> ByteString-cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie- where- cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly]- path = maybe "" (S.append "; path=") mbPath- domain = maybe "" (S.append "; domain=") mbDomain- exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime- secure = if isSec then "; Secure" else ""- hOnly = if isHOnly then "; HttpOnly" else ""- fmt = fromStr . formatTime defaultTimeLocale- "%a, %d-%b-%Y %H:%M:%S GMT"----------------------------------------------------------------------------------l2s :: L.ByteString -> S.ByteString-l2s = S.concat . L.toChunks----------------------------------------------------------------------------------toBS :: String -> ByteString-toBS = S.pack . map c2w
src/Snap/Internal/Http/Server/Address.hs view
@@ -1,23 +1,33 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Internal.Http.Server.Address ( getHostAddr+ , getHostAddrImpl , getSockAddr+ , getSockAddrImpl , getAddress+ , getAddressImpl+ , AddressNotSupportedException(..) ) where -------------------------------------------------------------------------------import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.ByteString.Char8 ()-import Data.ByteString.Internal (c2w, w2c)-import Data.Maybe-import Data.Typeable-import Network.Socket+#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)@@ -29,40 +39,73 @@ ------------------------------------------------------------------------------ getHostAddr :: SockAddr -> IO String-getHostAddr addr =- (fromMaybe "" . fst) `liftM` getNameInfo [NI_NUMERICHOST] True False addr+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 addr = do- port <- case addr of- SockAddrInet p _ -> return p- SockAddrInet6 p _ _ _ -> return p- x -> throwIO $ AddressNotSupportedException $ show x- host <- getHostAddr addr- return (fromIntegral port, S.pack $ map c2w host)+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 p s | s == "*" =- return $! ( AF_INET- , SockAddrInet (fromIntegral p) iNADDR_ANY- )-getSockAddr p s | s == "::" =- return $! ( AF_INET6- , SockAddrInet6 (fromIntegral p) 0 iN6ADDR_ANY 0- )-getSockAddr p s = do- let hints = defaultHints { addrFlags = [AI_NUMERICSERV]- , addrSocketType = Stream }- ais <- getAddrInfo (Just hints) (Just $ map w2c $ S.unpack s)- (Just $ show p)- if null ais- then throwIO $ AddressNotSupportedException $ show s- else do- let ai = head ais- let fm = addrFamily ai- let sa = addrAddress ai- return (fm, sa)+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,107 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Internal.Http.Server.Backend where--{---The server backend is made up of two APIs.--+ The ListenSocket class abstracts the reading and writing from the network.- We have seperate implementations of ListenSocket for http and https.--+ The EventLoop function is the interface to accept on the socket.- The EventLoop function will listen on the ports, and for each accepted- connection it wil call the SessionHandler.---}--#ifdef OPENSSL-import OpenSSL.Session-#endif--import GHC.Exts (Any)-import Data.ByteString (ByteString)-import Foreign-import Foreign.C-import Network.Socket (Socket)-import Snap.Iteratee (Iteratee, Enumerator)----------------------------------------------------------------------------------data SessionInfo = SessionInfo- { localAddress :: ByteString- , localPort :: Int- , remoteAddress :: ByteString- , remotePort :: Int- , isSecure :: Bool- }----------------------------------------------------------------------------------type SessionHandler =- SessionInfo -- ^ session port information- -> Enumerator ByteString IO () -- ^ read end of socket- -> Iteratee ByteString IO () -- ^ write end of socket- -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end- -> ((Int -> Int) -> IO ()) -- ^ timeout tickler- -> IO ()----------------------------------------------------------------------------------type EventLoop = Int -- ^ default timeout- -> [ListenSocket] -- ^ list of ports- -> Int -- ^ number of capabilities- -> (ByteString -> IO ()) -- ^ error log- -> IO () -- ^ initialisation function- -> SessionHandler -- ^ session handler- -> IO ()---{- For performance reasons, we do not implement this as a class-class ListenSocket a where- data ListenSocketSession a :: *-- listenSocket :: a -> Socket- isSecure :: a -> Bool-- closePort :: a -> IO ()-- createSession :: a- -> Int -- ^ recv buffer size- -> CInt -- ^ network socket- -> IO () -- ^ action to block waiting for handshake- -> IO (ListenSocketSession a)-- endSession :: a -> ListenSocketSession a -> IO ()-- recv :: a- -> IO () -- ^ action to block waiting for data- -> ListenSocketSession a -- ^ session- -> IO (Maybe ByteString)-- send :: a- -> IO () -- ^ action to tickle the timeout- -> IO () -- ^ action to block waiting for data- -> ListenSocketSession a -- ^ session- -> ByteString -- ^ data to send- -> IO ()--}----------------------------------------------------------------------------------data ListenSocket = ListenHttp Socket-#ifdef OPENSSL- | ListenHttps Socket SSLContext-#else- | ListenHttps Socket ()-#endif-instance Show ListenSocket where- show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")"- show (ListenHttps s _) = "ListenHttps (" ++ show s ++ ")"----------------------------------------------------------------------------------data NetworkSession = NetworkSession- { _socket :: CInt- , _session :: Any -- ^ brutal hack.- , _recvLen :: Int- }
+ 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
@@ -1,61 +1,136 @@ {-# 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 -This module exports the 'Config' datatype, which you can use to configure the-Snap HTTP server.+ , commandLineConfig+ , extendedCommandLineConfig+ , completeConfig --}+ , optDescrs+ , fmapOpt -module Snap.Internal.Http.Server.Config where+ , 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 Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-import Control.Exception (SomeException)-import Control.Monad-import qualified Data.ByteString.Char8 as B-import Data.ByteString (ByteString)-import Data.Char-import Data.Function-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable-import Network(Socket)+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)+import Prelude hiding (catch) #endif-import Snap.Core-import Snap.Iteratee ((>==>), enumBuilder)-import Snap.Internal.Debug (debug)-import Snap.Util.Proxy-import System.Console.GetOpt-import System.Environment hiding (getEnv)+import System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute), OptDescr (..), getOpt, usageInfo)+import System.Environment hiding (getEnv) #ifndef PORTABLE-import System.Posix.Env+import Data.Char (isAlpha)+import System.Posix.Env (getEnv) #endif-import System.Exit-import System.IO+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr) -------------------------------------------------------------------------------import Snap.Internal.Http.Server (requestErrorMessage)+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) --------------------------------------------------------------------------------- | This datatype allows you to override which backend (either simple or--- libev) to use. Most users will not want to set this, preferring to rely on--- the compile-type default.+-- | FIXME ----- Note that if you specify the libev backend and have not compiled in support--- for it, your server will fail at runtime.-data ConfigBackend = ConfigSimpleBackend- | ConfigLibEvBackend- deriving (Show, Eq)+-- 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@@ -68,7 +143,55 @@ 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:@@ -89,12 +212,13 @@ , 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- , backend :: Maybe ConfigBackend , proxyType :: Maybe ProxyType , startupHook :: Maybe (StartupInfo m a -> IO ()) }@@ -102,12 +226,11 @@ deriving Typeable #else - ------------------------------------------------------------------------------ -- | The 'Typeable1' instance is here so 'Config' values can be -- dynamically loaded with Hint. configTyCon :: TyCon-configTyCon = mkTyCon "Snap.Http.Server.Config.Config"+configTyCon = mkTyCon3 "snap-server" "Snap.Http.Server.Config" "Config" {-# NOINLINE configTyCon #-} instance (Typeable1 m) => Typeable1 (Config m) where@@ -128,10 +251,11 @@ , "sslcert: " ++ _sslcert , "sslchaincert: " ++ _sslchaincert , "sslkey: " ++ _sslkey+ , "unixsocket: " ++ _unixsocket+ , "unixaccessmode: " ++ _unixaccessmode , "compression: " ++ _compression , "verbose: " ++ _verbose , "defaultTimeout: " ++ _defaultTimeout- , "backend: " ++ _backend , "proxyType: " ++ _proxyType ] @@ -150,8 +274,11 @@ _compression = show $ compression c _verbose = show $ verbose c _defaultTimeout = show $ defaultTimeout c- _backend = show $ backend c _proxyType = show $ proxyType c+ _unixsocket = show $ unixsocket c+ _unixaccessmode = case unixaccessmode c of+ Nothing -> "Nothing"+ Just s -> ("Just 0" ++) . showOct s $ [] ------------------------------------------------------------------------------@@ -162,6 +289,34 @@ ------------------------------------------------------------------------------+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@@ -175,39 +330,20 @@ , sslcert = Nothing , sslchaincert = Nothing , sslkey = Nothing+ , unixsocket = Nothing+ , unixaccessmode = Nothing , compression = Nothing , verbose = Nothing , errorHandler = Nothing , defaultTimeout = Nothing , other = Nothing- , backend = Nothing , proxyType = Nothing , startupHook = Nothing } - a `mappend` b = Config- { hostname = ov hostname- , accessLog = ov accessLog- , errorLog = ov errorLog- , locale = ov locale- , port = ov port- , bind = ov bind- , sslport = ov sslport- , sslbind = ov sslbind- , sslcert = ov sslcert- , sslchaincert = ov sslchaincert- , sslkey = ov sslkey- , compression = ov compression- , verbose = ov verbose- , errorHandler = ov errorHandler- , defaultTimeout = ov defaultTimeout- , other = ov other- , backend = ov backend- , proxyType = ov proxyType- , startupHook = ov startupHook- }- where- ov f = getLast $! (mappend `on` (Last . f)) a b+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif ------------------------------------------------------------------------------@@ -222,10 +358,10 @@ , verbose = Just True , errorHandler = Just defaultErrorHandler , bind = Just "0.0.0.0"- , sslbind = Just "0.0.0.0"- , sslcert = Just "cert.pem"- , sslchaincert = Just False- , sslkey = Just "key.pem"+ , sslbind = Nothing+ , sslcert = Nothing+ , sslkey = Nothing+ , sslchaincert = Nothing , defaultTimeout = Just 60 } @@ -280,6 +416,24 @@ 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@@ -298,9 +452,6 @@ getOther :: Config m a -> Maybe a getOther = other -getBackend :: Config m a -> Maybe ConfigBackend-getBackend = backend- getProxyType :: Config m a -> Maybe ProxyType getProxyType = proxyType @@ -346,6 +497,12 @@ 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 } @@ -361,9 +518,6 @@ setOther :: a -> Config m a -> Config m a setOther x c = c { other = Just x } -setBackend :: ConfigBackend -> Config m a -> Config m a-setBackend x c = c { backend = Just x }- setProxyType :: ProxyType -> Config m a -> Config m a setProxyType x c = c { proxyType = Just x } @@ -375,14 +529,15 @@ -- | Arguments passed to 'setStartupHook'. data StartupInfo m a = StartupInfo- { startupHookConfig :: Config m a+ { startupHookConfig :: Config m a , startupHookSockets :: [Socket] } emptyStartupInfo :: StartupInfo m a emptyStartupInfo = StartupInfo emptyConfig [] --- | The the 'Socket's opened by the server. There will be two 'Socket's for SSL connections, and one otherwise.+-- | 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 @@ -414,7 +569,8 @@ , isJust . getSSLCert ] sslValid = and sslVals- noPort = isNothing (getPort cfg) && not sslValid+ unixValid = isJust $ unixsocket cfg+ noPort = isNothing (getPort cfg) && not sslValid && not unixValid cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing } @@ -432,31 +588,31 @@ ------------------------------------------------------------------------------ -- | Returns a description of the snap command line options suitable for use -- with "System.Console.GetOpt".-optDescrs :: MonadSnap m =>+optDescrs :: forall m a . MonadSnap m => Config m a -- ^ the configuration defaults. -> [OptDescr (Maybe (Config m a))] optDescrs defaults =- [ Option [] ["hostname"]+ [ Option "" ["hostname"] (ReqArg (Just . setConfig setHostname . bsFromString) "NAME") $ "local hostname" ++ defaultC getHostname- , Option ['b'] ["address"]+ , Option "b" ["address"] (ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString s }) "ADDRESS") $ "address to bind to" ++ defaultO bind- , Option ['p'] ["port"]+ , Option "p" ["port"] (ReqArg (\s -> Just $ mempty { port = Just $ read s}) "PORT") $ "port to listen on" ++ defaultO port- , Option [] ["ssl-address"]+ , Option "" ["ssl-address"] (ReqArg (\s -> Just $ mempty { sslbind = Just $ bsFromString s }) "ADDRESS") $ "ssl address to bind to" ++ defaultO sslbind- , Option [] ["ssl-port"]+ , Option "" ["ssl-port"] (ReqArg (\s -> Just $ mempty { sslport = Just $ read s}) "PORT") $ "ssl port to listen on" ++ defaultO sslport- , Option [] ["ssl-cert"]+ , Option "" ["ssl-cert"] (ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH") $ "path to ssl certificate in PEM format" ++ defaultO sslcert- , Option [] ["ssl-chain-cert"]+ , 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"]@@ -465,58 +621,88 @@ , Option [] ["ssl-key"] (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey- , Option [] ["access-log"]+ , Option "" ["access-log"] (ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH")- $ "access log" ++ (defaultC $ getAccessLog)- , Option [] ["error-log"]+ $ "access log" ++ defaultC getAccessLog+ , Option "" ["error-log"] (ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH")- $ "error log" ++ (defaultC $ getErrorLog)- , Option [] ["no-access-log"]+ $ "error log" ++ defaultC getErrorLog+ , Option "" ["no-access-log"] (NoArg $ Just $ setConfig setAccessLog ConfigNoLog)- $ "don't have an access log"- , Option [] ["no-error-log"]+ "don't have an access log"+ , Option "" ["no-error-log"] (NoArg $ Just $ setConfig setErrorLog ConfigNoLog)- $ "don't have an error log"- , Option ['c'] ["compression"]+ "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"]+ , Option "t" ["timeout"] (ReqArg (\t -> Just $ mempty { defaultTimeout = Just $ read t }) "SECS") $ "set default timeout in seconds" ++ defaultC defaultTimeout- , Option [] ["no-compression"]+ , Option "" ["no-compression"] (NoArg $ Just $ setConfig setCompression False) $ "serve responses uncompressed" ++ defaultB compression "compressed" "uncompressed"- , Option ['v'] ["verbose"]+ , Option "v" ["verbose"] (NoArg $ Just $ setConfig setVerbose True) $ "print server status updates to stderr" ++ defaultC getVerbose- , Option ['q'] ["quiet"]+ , Option "q" ["quiet"] (NoArg $ Just $ setConfig setVerbose False) $ "do not print anything to stderr" ++ defaultB getVerbose "verbose" "quiet"- , Option [] ["proxy"]- (ReqArg (\t -> Just $ setConfig setProxyType $ read t)+ , Option "" ["proxy"]+ (ReqArg (Just . setConfig setProxyType . parseProxy . CI.mk) "X_Forwarded_For")- $ concat [ "Set --proxy=X_Forwarded_For if your snap application "- , "is behind an HTTP reverse proxy to ensure that "- , "rqRemoteAddr is set properly."+ $ 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 ['h'] ["help"]+ , 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"+ "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 f y n = maybe "" (\b -> ", default " ++ if b- then y- else n) $ f conf :: String++ 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 @@ -524,29 +710,34 @@ defaultErrorHandler :: MonadSnap m => SomeException -> m () defaultErrorHandler e = do debug "Snap.Http.Server.Config errorHandler:"- req <- getRequest+ req <- getsRequest blindParams let sm = smsg req debug $ toString sm logError sm finishWith $ setContentType "text/plain; charset=utf-8"- . setContentLength (fromIntegral $ B.length msg)+ . setContentLength (fromIntegral $ S.length msg) . setResponseStatus 500 "Internal Server Error"- . modifyResponseBody- (>==> enumBuilder (fromByteString msg))+ . 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 [- fromByteString "A web handler threw an exception. Details:\n"- , fromShow e+ 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.@@ -577,7 +768,9 @@ extendedCommandLineConfig :: MonadSnap m => [OptDescr (Maybe (Config m a))]- -- ^ User options.+ -- ^ 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.@@ -640,3 +833,24 @@ 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,21 +1,23 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Date-( getDateString-, getLogDateString-, getCurrentDateTime) where--import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import Data.IORef-import Foreign.C.Types-import System.IO.Unsafe-import System.PosixCompat.Time+ ( getDateString+ , getLogDateString+ ) where +------------------------------------------------------------------------------+import Control.Exception (mask_)+import Control.Monad (when)+import Data.ByteString (ByteString)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Foreign.C.Types (CTime)+import System.IO.Unsafe (unsafePerformIO)+import System.PosixCompat.Time (epochTime)+------------------------------------------------------------------------------ import Snap.Internal.Http.Types (formatHttpTime, formatLogTime) + ------------------------------------------------------------------------------ data DateState = DateState { _cachedDateString :: !(IORef ByteString)@@ -27,61 +29,53 @@ ------------------------------------------------------------------------------ dateState :: DateState dateState = unsafePerformIO $ do- (s1,s2,date) <- fetchTime- bs1 <- newIORef s1- bs2 <- newIORef s2- dt <- newIORef date+ (s1, s2, date) <- fetchTime+ bs1 <- newIORef $! s1+ bs2 <- newIORef $! s2+ dt <- newIORef $! date return $! DateState bs1 bs2 dt+{-# NOINLINE dateState #-} ------------------------------------------------------------------------------ fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do- now <- epochTime- t1 <- formatHttpTime now- t2 <- formatLogTime now- 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) = do- (s1,s2,now) <- fetchTime- atomicModifyIORef dateString $ const (s1,())- atomicModifyIORef logString $ const (s2,())- atomicModifyIORef time $ const (now,())-- -- force values in the iorefs to prevent thunk buildup- !_ <- readIORef dateString- !_ <- readIORef logString- !_ <- readIORef time+ (s1, s2, now) <- fetchTime+ writeIORef dateString $! s1+ writeIORef logString $! s2+ writeIORef time $! now - return ()+ return $! () ------------------------------------------------------------------------------ ensureFreshDate :: IO ()-ensureFreshDate = mask $ \_ -> do+ensureFreshDate = mask_ $ do now <- epochTime old <- readIORef $ _lastFetchTime dateState- when (now > old) $ updateState dateState+ when (now > old) $! updateState dateState ------------------------------------------------------------------------------ getDateString :: IO ByteString-getDateString = mask $ \_ -> do+getDateString = mask_ $ do ensureFreshDate readIORef $ _cachedDateString dateState ------------------------------------------------------------------------------ getLogDateString :: IO ByteString-getLogDateString = mask $ \_ -> do+getLogDateString = mask_ $ do ensureFreshDate readIORef $ _cachedLogString dateState----------------------------------------------------------------------------------getCurrentDateTime :: IO CTime-getCurrentDateTime = epochTime
− src/Snap/Internal/Http/Server/HttpPort.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}--module Snap.Internal.Http.Server.HttpPort- ( bindHttp- , createSession- , endSession- , recv- , send- ) where---------------------------------------------------------------------------------import Data.ByteString (ByteString)-import Foreign-import Foreign.C-import Network.Socket hiding (recv, send)-import Unsafe.Coerce--------------------------------------------------------------------------------#ifdef PORTABLE-import qualified Data.ByteString as B-import qualified Network.Socket.ByteString as SB-#else-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BI-#endif--------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Server.Address----------------------------------------------------------------------------------bindHttp :: ByteString -> Int -> IO ListenSocket-bindHttp bindAddr bindPort = do- (family, addr) <- getSockAddr bindPort bindAddr- sock <- socket family Stream 0-- debug $ "bindHttp: binding port " ++ show addr- setSocketOption sock ReuseAddr 1- bindSocket sock addr- listen sock 150-- debug $ "bindHttp: bound socket " ++ show sock- return $! ListenHttp sock----------------------------------------------------------------------------------createSession :: Int -> CInt -> IO () -> IO NetworkSession-createSession buffSize s _ =- return $! NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize----------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession _ = return ()---#ifdef PORTABLE--------------------------------------------------------------------------------recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv sock _ (NetworkSession { _recvLen = s }) = do- bs <- SB.recv sock (fromIntegral s)- return $! if B.null bs then Nothing else Just bs----------------------------------------------------------------------------------send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send sock tickle _ _ bs = SB.sendAll sock bs >> tickle---#else--------------------------------------------------------------------------------recv :: IO () -> NetworkSession -> IO (Maybe ByteString)-recv onBlock (NetworkSession s _ buffSize) = do- fp <- BI.mallocByteString $ fromEnum buffSize- sz <- withForeignPtr fp $ \p ->- throwErrnoIfMinus1RetryMayBlock- "recv"- (c_read s p $ toEnum buffSize)- onBlock-- if sz == 0- then return Nothing- else return $! Just $! BI.fromForeignPtr fp 0 $! fromEnum sz----------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send tickleTimeout onBlock (NetworkSession s _ _) bs =- BI.unsafeUseAsCStringLen bs $ uncurry loop-- where- loop ptr len = do- sent <- throwErrnoIfMinus1RetryMayBlock- "send"- (c_write s ptr $ toEnum len)- onBlock-- let sent' = fromIntegral sent- if sent' < len- then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')- else tickleTimeout----------------------------------------------------------------------------------foreign import ccall unsafe "unistd.h read" c_read- :: CInt -> Ptr a -> CSize -> IO (CSize)-foreign import ccall unsafe "unistd.h write" c_write- :: CInt -> Ptr a -> CSize -> IO (CSize)--#endif
− src/Snap/Internal/Http/Server/ListenHelpers.hs
@@ -1,78 +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.TLS as TLS----------------------------------------------------------------------------------listenSocket :: ListenSocket -> Socket-listenSocket (ListenHttp s ) = s-listenSocket (ListenHttps s _) = s----------------------------------------------------------------------------------isSecure :: ListenSocket -> Bool-isSecure (ListenHttp _ ) = False-isSecure (ListenHttps _ _) = True----------------------------------------------------------------------------------closeSocket :: ListenSocket -> IO ()-closeSocket (ListenHttp s) = sClose s-closeSocket p = TLS.freePort p---------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttp _ ) = Http.createSession-createSession p@(ListenHttps _ _) = TLS.createSession p----------------------------------------------------------------------------------endSession :: ListenSocket -> NetworkSession -> IO ()-endSession (ListenHttp _ ) = Http.endSession-endSession (ListenHttps _ _) = TLS.endSession---#ifdef PORTABLE--- For portable builds, we can't call read/write directly so we need the--- original haskell socket to use with network-bytestring package.--- Only the simple backend creates sockets in haskell so the following--- functions only work with the simple backend.---------------------------------------------------------------------------------recv :: ListenSocket -> Socket -> IO () -> NetworkSession- -> IO (Maybe ByteString)-recv (ListenHttp _ ) s = Http.recv s-recv (ListenHttps _ _) _ = TLS.recv----------------------------------------------------------------------------------send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession- -> ByteString -> IO ()-send (ListenHttp _ ) s = Http.send s-send (ListenHttps _ _) _ = TLS.send---#else---------------------------------------------------------------------------------recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString)-recv (ListenHttp _ ) = Http.recv-recv (ListenHttps _ _) = TLS.recv----------------------------------------------------------------------------------send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString- -> IO ()-send (ListenHttp _ ) = Http.send-send (ListenHttps _ _) = TLS.send--#endif
+ 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,352 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Server.SimpleBackend- ( simpleEventLoop- ) where----------------------------------------------------------------------------------import Control.Monad.Trans--import Control.Concurrent hiding (yield)-import Control.Concurrent.Extended (forkOnLabeledWithUnmaskBs)-import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as SC-import Data.ByteString.Internal (c2w)-import Foreign hiding (new)-import Foreign.C-#if MIN_VERSION_base(4,4,0)-import GHC.Conc (forkOn, labelThread)-#else-import GHC.Conc (forkOnIO,- labelThread)-#endif-import Network.Socket-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif--------------------------------------------------------------------------------import Snap.Internal.Debug-import Snap.Internal.Http.Server.Address-import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Server.Date-import qualified Snap.Internal.Http.Server.ListenHelpers as Listen-import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager)-import qualified Snap.Internal.Http.Server.TimeoutManager as TM-import Snap.Iteratee hiding (map)--#if defined(HAS_SENDFILE)-import System.Posix.IO-import System.Posix.Types (Fd (..))-import qualified System.SendFile as SF-#endif----------------------------------------------------------------------------------#if !MIN_VERSION_base(4,4,0)-forkOn :: Int -> IO () -> IO ThreadId-forkOn = forkOnIO-#endif------------------------------------------------------------------------------------ | For each cpu, we store:--- * A list of accept threads, one per port.--- * A TimeoutManager--- * An mvar to signal when the timeout thread is shutdown-data EventLoopCpu = EventLoopCpu- { _boundCpu :: Int- , _acceptThreads :: [ThreadId]- , _timeoutManager :: TimeoutManager- , _exitMVar :: !(MVar ())- }----------------------------------------------------------------------------------simpleEventLoop :: EventLoop-simpleEventLoop defaultTimeout sockets cap elog initial handler = do- loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)- [0..(cap-1)]-- initial- debug "simpleEventLoop: waiting for mvars"-- --wait for all threads to exit- Prelude.mapM_ (takeMVar . _exitMVar) loops `finally` do- debug "simpleEventLoop: killing all threads"- _ <- mapM_ stopLoop loops- mapM_ Listen.closeSocket sockets----------------------------------------------------------------------------------newLoop :: Int- -> [ListenSocket]- -> SessionHandler- -> (S.ByteString -> IO ())- -> Int- -> IO EventLoopCpu-newLoop defaultTimeout sockets handler elog cpu = do- tmgr <- TM.initialize defaultTimeout getCurrentDateTime- exit <- newEmptyMVar- accThreads <- forM sockets $ \p -> do- let label = S.concat- [ "snap-server: ", SC.pack (show p)- , " on capability: ", SC.pack (show cpu)- ]- forkOnLabeledWithUnmaskBs label cpu $ \unmask ->- acceptThread defaultTimeout handler tmgr elog cpu p unmask- `finally` (tryPutMVar exit () >> return ())-- return $! EventLoopCpu cpu accThreads tmgr exit---------------------------------------------------------------------------------stopLoop :: EventLoopCpu -> IO ()-stopLoop loop = mask_ $ do- TM.stop $ _timeoutManager loop- Prelude.mapM_ killThread $ _acceptThreads loop----------------------------------------------------------------------------------acceptThread :: Int- -> SessionHandler- -> TimeoutManager- -> (S.ByteString -> IO ())- -> Int- -> ListenSocket- -> (forall a. IO a -> IO a)- -> IO ()-acceptThread defaultTimeout handler tmgr elog cpu sock unmask = loop- where- loop = do- unmask (forever acceptAndFork) `catches` acceptHandler- loop-- acceptAndFork = do- debug $ "acceptThread: calling accept() on socket " ++ show sock- (s,addr) <- accept $ Listen.listenSocket sock- setSocketOption s NoDelay 1- debug $ "acceptThread: accepted connection from remote: " ++ show addr- let label = S.concat- [ "snap-server: connection from: "- , SC.pack (show addr)- , " on socket: "- , SC.pack (show (fdSocket s))- , "\0"- ]- _ <- forkOnLabeledWithUnmaskBs label cpu $ \unmask' ->- unmask' (runSession defaultTimeout handler tmgr sock s addr)- `catches` cleanup- return ()-- acceptHandler =- [ Handler $ \(e :: AsyncException) -> throwIO e- , Handler $ \(e :: SomeException) -> do- elog $ S.concat [ "SimpleBackend.acceptThread: accept threw: "- , S.pack . map c2w $ show e ]- -- we're out of file descriptors, and it isn't likely to get- -- better immediately; sleep for 10ms to avoid spamming the error- -- log.- threadDelay $ 10000- ]-- cleanup =- [- Handler $ \(e :: AsyncException) ->- case e of- ThreadKilled -> return ()- UserInterrupt -> return ()- _ -> throwIO e -- This ensures all other asynchronous exceptions- -- (StackOverflow and HeapOverflow) are logged to- -- stderr by forkIO.- , Handler $ \(e :: SomeException) -> elog- $ S.concat [ "SimpleBackend.acceptThread: "- , S.pack . map c2w $ show e]- ]----------------------------------------------------------------------------------runSession :: Int- -> SessionHandler- -> TimeoutManager- -> ListenSocket- -> Socket- -> SockAddr -> IO ()-runSession defaultTimeout handler tmgr lsock sock addr = do- let fd = fdSocket sock- curId <- myThreadId-- debug $ "Backend.withConnection: running session: " ++ show addr-- (rport,rhost) <- getAddress addr- (lport,lhost) <- getSocketName sock >>= getAddress-- let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock-- timeoutHandle <- TM.register (killThread curId) tmgr- let modifyTimeout = TM.modify timeoutHandle- let tickleTimeout = modifyTimeout . max-- bracket (Listen.createSession lsock 8192 fd- (threadWaitRead $ fromIntegral fd))- (\session -> mask_ $ do- debug "thread killed, closing socket"-- -- cancel thread timeout- TM.cancel timeoutHandle-- eatException $ Listen.endSession lsock session- eatException $ shutdown sock ShutdownBoth- eatException $ sClose sock- )- (\s -> let writeEnd = writeOut lsock s sock- (tickleTimeout defaultTimeout)- in handler sinfo- (enumerate lsock s sock)- writeEnd- (sendFile lsock (tickleTimeout defaultTimeout)- fd writeEnd)- modifyTimeout- )----------------------------------------------------------------------------------eatException :: IO a -> IO ()-eatException act = (act >> return ()) `catch` \(_::SomeException) -> return ()----------------------------------------------------------------------------------sendFile :: ListenSocket- -> IO ()- -> CInt- -> Iteratee ByteString IO ()- -> FilePath- -> Int64- -> Int64- -> IO ()-#if defined(HAS_SENDFILE)-sendFile lsock tickle sock writeEnd fp start sz =- case lsock of- ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)- (closeFd)- (go start sz)- _ -> do- step <- runIteratee writeEnd- run_ $ enumFilePartial fp (start,start+sz) step- where- go off bytes fd- | bytes == 0 = return ()- | otherwise = do- sent <- SF.sendFile (threadWaitWrite $ fromIntegral sock)- sfd fd off bytes- if sent < bytes- then tickle >> go (off+sent) (bytes-sent) fd- else return ()-- sfd = Fd sock-#else-sendFile _ _ _ writeEnd fp start sz = do- -- no need to count bytes- step <- runIteratee writeEnd- run_ $ enumFilePartial fp (start,start+sz) step- return ()-#endif----------------------------------------------------------------------------------enumerate :: (MonadIO m)- => ListenSocket- -> NetworkSession- -> Socket- -> Enumerator ByteString m a-enumerate port session sock = loop- where- dbg s = debug $ "SimpleBackend.enumerate(" ++ show (_socket session)- ++ "): " ++ s-- loop (Continue k) = do- dbg "reading from socket"- s <- liftIO $ timeoutRecv- case s of- Nothing -> do- dbg "got EOF from socket"- sendOne k ""- Just s' -> do- dbg $ "got " ++ Prelude.show (S.length s')- ++ " bytes from read end"- sendOne k s'-- loop x = returnI x--- sendOne k s | S.null s = do- dbg "sending EOF to continuation"- enumEOF $ Continue k-- | otherwise = do- dbg $ "sending " ++ show s ++ " to continuation"- step <- lift $ runIteratee $ k $ Chunks [s]- case step of- (Yield x st) -> do- dbg $ "got yield, remainder is " ++ show st- yield x st- r@(Continue _) -> do- dbg $ "got continue"- loop r- (Error e) -> throwError e-- fd = fdSocket sock-#ifdef PORTABLE- timeoutRecv = Listen.recv port sock (threadWaitRead $- fromIntegral fd) session-#else- timeoutRecv = Listen.recv port (threadWaitRead $- fromIntegral fd) session-#endif----------------------------------------------------------------------------------writeOut :: (MonadIO m)- => ListenSocket- -> NetworkSession- -> Socket- -> (IO ())- -> Iteratee ByteString m ()-writeOut port session sock tickle = loop- where- dbg s = debug $ "SimpleBackend.writeOut(" ++ show (_socket session)- ++ "): " ++ s-- loop = continue k-- k EOF = yield () EOF- k (Chunks xs) = do- let s = S.concat xs- let n = S.length s- dbg $ "got chunk with " ++ show n ++ " bytes"- ee <- liftIO $ try $ timeoutSend s- case ee of- (Left (e::SomeException)) -> do- dbg $ "timeoutSend got error " ++ show e- throwError e- (Right _) -> do- let last10 = S.drop (n-10) s- dbg $ "wrote " ++ show n ++ " bytes, last 10=" ++ show last10- loop-- fd = fdSocket sock-#ifdef PORTABLE- timeoutSend = Listen.send port sock tickle- (threadWaitWrite $ fromIntegral fd) session-#else- timeoutSend = Listen.send port tickle- (threadWaitWrite $ fromIntegral fd) session-#endif
+ 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
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}@@ -6,52 +5,48 @@ ------------------------------------------------------------------------------ module Snap.Internal.Http.Server.TLS- ( TLSException (..)- , initTLS- , stopTLS+ ( TLSException(..)+ , withTLS , bindHttps- , freePort- , createSession- , endSession- , recv- , send+ , httpsAcceptFunc+ , sendFileFunc ) where -------------------------------------------------------------------------------import Control.Exception-import Data.ByteString.Char8 (ByteString)-import Data.Dynamic-import Foreign.C-import qualified Data.ByteString.Char8 as S-------------------------------------------------------------------------------+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.Typeable (Typeable)+import Network.Socket (Socket) #ifdef OPENSSL-import Control.Monad-import qualified Network.Socket as Socket-import Network.Socket hiding ( accept- , shutdown- , recv- , recvLen- , send- , socket- )-import OpenSSL-import OpenSSL.Session-import qualified OpenSSL.Session as SSL-import Prelude hiding (catch)-import Unsafe.Coerce-import Snap.Internal.Http.Server.Address+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.Backend--+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 [@@ -60,55 +55,37 @@ , "Please compile snap-server with -fopenssl to enable it." ] --------------------------------------------------------------------------------initTLS :: IO ()-initTLS = throwIO sslNotSupportedException - -------------------------------------------------------------------------------stopTLS :: IO ()-stopTLS = return ()----------------------------------------------------------------------------------bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO ListenSocket-bindHttps _ _ _ _ _ = throwIO sslNotSupportedException----------------------------------------------------------------------------------freePort :: ListenSocket -> IO ()-freePort _ = return ()+withTLS :: IO a -> IO a+withTLS = id -------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession _ _ _ _ = throwIO sslNotSupportedException+barf :: IO a+barf = throwIO sslNotSupportedException -------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession _ = return ()+bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath+ -> IO (Socket, SSLContext)+bindHttps _ _ _ _ _ = barf -------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send _ _ _ _ = return ()+httpsAcceptFunc :: Socket -> SSLContext -> AcceptFunc+httpsAcceptFunc _ _ = AcceptFunc $ \restore -> restore barf -------------------------------------------------------------------------------recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv _ _ = throwIO sslNotSupportedException+sendFileFunc :: SSL -> Socket -> SendFileHandler+sendFileFunc _ _ _ _ _ _ _ = barf #else -------------------------------------------------------------------------------initTLS :: IO ()-initTLS = withOpenSSL $ return ()----------------------------------------------------------------------------------stopTLS :: IO ()-stopTLS = return ()+withTLS :: IO a -> IO a+withTLS = withOpenSSL ------------------------------------------------------------------------------@@ -117,79 +94,72 @@ -> FilePath -> Bool -> FilePath- -> IO ListenSocket-bindHttps bindAddress bindPort cert chainCert key = do- (family, addr) <- getSockAddr bindPort bindAddress- sock <- Socket.socket family Socket.Stream 0-- Socket.setSocketOption sock Socket.ReuseAddr 1- Socket.bindSocket sock addr- Socket.listen sock 150-- ctx <- context- contextSetPrivateKeyFile ctx key- if chainCert- then contextSetCertificateChainFile ctx cert- else contextSetCertificateFile ctx cert- contextSetDefaultCiphers ctx-- certOK <- contextCheckPrivateKey ctx- when (not certOK) $ throwIO $ TLSException certificateError- return $! ListenHttps sock ctx-+ -> 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!" -------------------------------------------------------------------------------freePort :: ListenSocket -> IO ()-freePort (ListenHttps sock _) = Socket.sClose sock-freePort _ = return ()+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 --------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttps _ ctx) recvSize socket _ = do- csock <- mkSocket socket AF_INET Stream defaultProtocol Connected- handle (\(e::SomeException) -> Socket.sClose csock >> throwIO e) $ do- ssl <- connection ctx csock- accept ssl- return $! NetworkSession socket (unsafeCoerce ssl) recvSize-createSession _ _ _ _ = error "can't call createSession on a ListenHttp"+ (readEnd, writeEnd) <- SStreams.sslToStreams ssl + let cleanup = (do Streams.write Nothing writeEnd+ SSL.shutdown ssl $! SSL.Unidirectional)+ `finally` Socket.close sock --------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession (NetworkSession _ aSSL _) =- shutdown (unsafeCoerce aSSL) Unidirectional+ return $! ( sendFileFunc ssl+ , localHost+ , localPort+ , remoteHost+ , remotePort+ , readEnd+ , writeEnd+ , cleanup+ ) -------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send tickleTimeout _ (NetworkSession _ aSSL sz) bs = go bs- where- ssl = unsafeCoerce aSSL-- -- I think we have to chop the data into chunks here because HsOpenSSL- -- won't; of course, blaze-builder may already be doing this for us, but I- -- don't want to risk it.- go !s = if S.null s- then return ()- else do- SSL.write ssl a- tickleTimeout- go b- where- (a,b) = S.splitAt sz s-+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 --------------------------------------------------------------------------------recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv _ (NetworkSession _ aSSL recvLen) = do- b <- SSL.read ssl recvLen- return $! if S.null b then Nothing else Just b where- ssl = unsafeCoerce aSSL-+ 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,10 +1,12 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.TimeoutManager ( TimeoutManager- , TimeoutHandle+ , TimeoutThread , initialize , stop , register@@ -15,112 +17,85 @@ ) where -------------------------------------------------------------------------------import Control.Concurrent-import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs)-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, ($), ($!), (+), (++), (-), (.), (<=), (==)) -------------------------------------------------------------------------------data State = Deadline !CTime- | Canceled- deriving (Eq, Show)--+import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar, takeMVar, tryPutMVar) -------------------------------------------------------------------------------instance Ord State where- compare Canceled Canceled = EQ- compare Canceled _ = LT- compare _ Canceled = GT- compare (Deadline a) (Deadline b) = compare a b+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 --------------------------------------------------------------------------------- Probably breaks Num laws, but I can live with it----instance Num State where- --------------------------------------------------------------------------- Canceled + Canceled = Canceled- Canceled + x = x- x + Canceled = x- (Deadline a) + (Deadline b) = Deadline $! a + b-- --------------------------------------------------------------------------- Canceled - Canceled = Canceled- Canceled - x = negate x- x - Canceled = x- (Deadline a) - (Deadline b) = Deadline $! a - b-- --------------------------------------------------------------------------- Canceled * _ = Canceled- _ * Canceled = Canceled- (Deadline a) * (Deadline b) = Deadline $! a * b-- --------------------------------------------------------------------------- negate Canceled = Canceled- negate (Deadline d) = Deadline (negate d)-- --------------------------------------------------------------------------- abs Canceled = Canceled- abs (Deadline d) = Deadline (abs d)+type State = ClockTime - --------------------------------------------------------------------------- signum Canceled = Canceled- signum (Deadline d) = Deadline (signum d)+canceled :: State+canceled = 0 - --------------------------------------------------------------------------- fromInteger = Deadline . fromInteger+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 :: CTime -> (Int -> Int) -> State -> State-smap _ _ Canceled = Canceled--smap now f (Deadline t) = Deadline t'+smap :: ClockTime -> (ClockTime -> ClockTime) -> State -> State+smap now f deadline | isCanceled deadline = deadline+ | otherwise = t' where- !remaining = fromEnum $ max 0 (t - now)- !newremaining = f remaining- !t' = now + toEnum newremaining+ 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 <- forkIOLabeledWithUnmaskBs "snap-server: timeout manager" $- managerThread tm+ thr <- T.fork "snap-server: timeout manager" $ managerThread tm putMVar mthr thr return tm @@ -128,36 +103,36 @@ ------------------------------------------------------------------------------ -- | 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 @@ -165,28 +140,29 @@ -- | Tickle the timeout on a connection to be at least N seconds into the -- future. If the existing timeout is set for M seconds from now, where M > N, -- then the timeout is unaffected.-tickle :: TimeoutHandle -> Int -> IO ()+tickle :: TimeoutThread -> Int -> IO () tickle th = modify th . max {-# INLINE tickle #-} ------------------------------------------------------------------------------ -- | Set the timeout on a connection to be N seconds into the future.-set :: TimeoutHandle -> Int -> IO ()+set :: TimeoutThread -> Int -> IO () set th = modify th . const {-# INLINE set #-} ------------------------------------------------------------------------------ -- | Modify the timeout with the given function.-modify :: TimeoutHandle -> (Int -> Int) -> IO ()+modify :: TimeoutThread -> (Int -> Int) -> IO () modify th f = do now <- getTime state <- readIORef stateRef- let !state' = smap now f state+ 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 #-}@@ -194,61 +170,60 @@ ------------------------------------------------------------------------------ -- | 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 -> (forall a. IO a -> IO a) -> IO ()-managerThread tm unmask = unmask loop `finally` (readIORef connections >>= destroyAll)+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/System/FastLogger.hs view
@@ -5,38 +5,37 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger-( Logger-, timestampedLogEntry-, combinedLogEntry-, newLogger-, newLoggerWithCustomErrorFunction-, 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.Concurrent.Extended (forkIOLabeledWithUnmaskBs)-import Control.Exception-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Internal (c2w)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Int-import Data.IORef-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import System.IO--import Snap.Internal.Http.Server.Date+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) ------------------------------------------------------------------------------@@ -86,64 +85,90 @@ ------------------------------------------------------------------------------+-- | 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 @@ -154,9 +179,9 @@ -- (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) () ------------------------------------------------------------------------------@@ -186,33 +211,35 @@ logInternalError = errAct . T.encodeUtf8 . T.pack - go (href, lastOpened) =- (unmask $ forever $ waitFlushDelay (href, lastOpened))- `catches`+ --------------------------------------------------------------------------+ go (href, lastOpened) = unmask loop `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do logInternalError $ "logger got exception: " ++ Prelude.show e ++ "\n" threadDelay 20000000 go (href, lastOpened) ]-+ where+ loop = waitFlushDelay (href, lastOpened) >> loop + -------------------------------------------------------------------------- initialize = do lh <- openIt href <- newIORef lh- t <- 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@@ -220,11 +247,11 @@ hFlush h) `catch` \(e::IOException) -> do logInternalError $ "got exception writing to log " ++ filePath ++ ": " ++ show e ++ "\n"- logInternalError $ "writing log entries to stderr.\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 when (t-old > 900) $ do@@ -249,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,53 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--- | Darwin system-dependent code for 'sendfile'.-module System.SendFile.Darwin (sendFile) where--import Data.Int-import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)-#if __GLASGOW_HASKELL__ >= 703-import Foreign.C.Types (CInt(CInt))-#else-import Foreign.C.Types (CInt)-#endif-import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (peek, poke)-#if __GLASGOW_HASKELL__ >= 703-import System.Posix.Types (Fd(Fd), COff(COff))-#else-import System.Posix.Types (Fd, COff)-#endif--sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64-sendFile onBlock out_fd in_fd off count- | count == 0 = return 0- | otherwise = alloca $ \pbytes -> do- poke pbytes $ min maxBytes (fromIntegral count)- sbytes <- sendfile onBlock out_fd in_fd (fromIntegral off) pbytes- return $ fromIntegral sbytes--sendfile :: IO () -> Fd -> Fd -> COff -> Ptr COff -> IO COff-sendfile onBlock out_fd in_fd off pbytes = do- status <- c_sendfile out_fd in_fd off pbytes- nsent <- peek pbytes- if status == 0- then return nsent- else do errno <- getErrno- if (errno == eAGAIN) || (errno == eINTR)- then do- if nsent == 0- then onBlock >> sendfile onBlock out_fd in_fd off pbytes- else return nsent- else throwErrno "System.SendFile.Darwin"---- max num of bytes in one send-maxBytes :: COff-maxBytes = maxBound :: COff---- in Darwin sendfile gives LFS support (no sendfile64 routine)-foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_darwin- :: Fd -> Fd -> COff -> Ptr COff -> Ptr () -> CInt -> IO CInt--c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO CInt-c_sendfile out_fd in_fd off pbytes =- c_sendfile_darwin in_fd out_fd off pbytes nullPtr 0
src/System/SendFile/FreeBSD.hsc view
@@ -1,54 +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 Control.Concurrent (threadWaitWrite)+import Data.Int+import Data.Word+import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock_) #if __GLASGOW_HASKELL__ >= 703-import Foreign.C.Types (CSize(..), CInt(..))+import Foreign.C.Types (CInt (..), CSize (..)) #else-import Foreign.C.Types (CInt, CSize)+import Foreign.C.Types (CInt, CSize) #endif-import Foreign.Marshal.Alloc (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (peek)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (peek) #if __GLASGOW_HASKELL__ >= 703-import System.Posix.Types (COff(..), Fd(..))+import System.Posix.Types (COff (..), Fd (..)) #else-import System.Posix.Types (COff, Fd)+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,52 +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 Control.Concurrent (threadWaitWrite)+import Data.Int (Int64)+import Data.Word (Word64)+import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock) #if __GLASGOW_HASKELL__ >= 703-import Foreign.C.Types (CSize(..), CInt(..))+import Foreign.C.Types (CInt (..), CSize (..)) #else-import Foreign.C.Types (CSize)+import Foreign.C.Types (CSize) #endif-import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (poke)+import Foreign.Marshal (alloca)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (poke) #if __GLASGOW_HASKELL__ >= 703-import System.Posix.Types (Fd(..), COff(..), CSsize(..))+import System.Posix.Types (COff (..), CSsize (..), Fd (..)) #else-import System.Posix.Types (Fd, COff, CSsize)+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,98 +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.HUnit (assertFailure)-import Test.QuickCheck-import System.Timeout--import Snap.Internal.Iteratee.Debug ()---instance Arbitrary S.ByteString where- arbitrary = liftM (S.pack . map c2w) arbitrary--instance Arbitrary L.ByteString where- arbitrary = do- n <- choose(0,5)- chunks <- replicateM n arbitrary- return $! L.fromChunks chunks----expectException :: IO a -> IO ()-expectException m = do- e <- try m- case e of- Left (_::SomeException) -> return ()- Right _ -> assertFailure "expected exception, didn't get it"---expectExceptionBeforeTimeout :: IO a -- ^ action to run- -> Int -- ^ number of seconds to expect- -- exception by- -> IO Bool-expectExceptionBeforeTimeout act nsecs = do- x <- timeout (nsecs * (10::Int)^(6::Int)) f- case x of- Nothing -> return False- (Just y) -> return y-- where- f = (act >> return False) `catch` \(e::SomeException) -> do- if show e == "<<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,211 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Common.TestHandler (testHandler) where--import Blaze.ByteString.Builder-import Control.Concurrent (threadDelay)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Snap.Core-import Snap.Internal.Debug-import Snap.Iteratee hiding (Enumerator)-import qualified Snap.Iteratee as I-import Snap.Util.FileServe-import Snap.Util.FileUploads-import Snap.Util.GZip-import System.Directory-import Test.Common.Rot13 (rot13)------------------------------------------------------------------------------------- timeout handling--------------------------------------------------------------------------------timeoutTickleHandler :: Snap ()-timeoutTickleHandler = do- noCompression -- FIXME: remove this when zlib-bindings and- -- zlib-enumerator support gzip stream flushing- modifyResponse $ setResponseBody (trickleOutput 10)- . setContentType "text/plain"- . setBufferingMode False- setTimeout 2---badTimeoutTickleHandler :: Snap ()-badTimeoutTickleHandler = do- noCompression -- FIXME: remove this when zlib-bindings and- -- zlib-enumerator support gzip stream flushing- modifyResponse $ setResponseBody (trickleOutput 10)- . setContentType "text/plain"- setTimeout 2---trickleOutput :: Int -> Enumerator Builder IO a-trickleOutput n = concatEnums $ dots `interleave` delays- where- enumOne i = do- debug "enumOne: .\\n"- enumList 1 [fromByteString ".\n"] i-- delay st = do- debug "delay 1s"- liftIO $ threadDelay 1000000- returnI st-- interleave x0 y0 = (go id x0 y0) []- where- go !dl [] ys = dl . (++ys)- go !dl xs [] = dl . (++xs)- go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys-- dots = replicate n enumOne- delays = replicate n delay----------------------------------------------------------------------------------pongHandler :: Snap ()-pongHandler = modifyResponse $- setResponseBody (enumBuilder $ fromByteString "PONG") .- setContentType "text/plain" .- setContentLength 4--echoUriHandler :: Snap ()-echoUriHandler = do- req <- getRequest- writeBS $ rqURI req---echoHandler :: Snap ()-echoHandler = transformRequestBody returnI---rot13Handler :: Snap ()-rot13Handler = transformRequestBody f- where- f origStep = do- mbX <- I.head- maybe (enumEOF origStep)- (feedStep origStep)- mbX-- feedStep origStep b = do- let x = toByteString b- let e = enumBuilder $ fromByteString $ rot13 x- step <- lift $ runIteratee $ e origStep- f step---bigResponseHandler :: Snap ()-bigResponseHandler = do- let sz = 4000000- let s = L.take sz $ L.cycle $ L.fromChunks [S.replicate 400000 '.']- modifyResponse $ setContentLength sz- writeLBS s---responseHandler :: Snap ()-responseHandler = do- !code <- liftM (read . S.unpack . fromMaybe "503") $ getParam "code"- modifyResponse $ setResponseCode code- writeBS $ S.pack $ show code---uploadForm :: Snap ()-uploadForm = do- modifyResponse $ setContentType "text/html"- writeBS form-- where- form = S.concat [ "<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---serverHeaderHandler :: Snap ()-serverHeaderHandler = modifyResponse $ setHeader "Server" "foo"---chunkedResponse :: Snap ()-chunkedResponse = writeBS "chunked"---testHandler :: Snap ()-testHandler = withCompression $- route [ ("pong" , pongHandler )- , ("echo" , echoHandler )- , ("rot13" , rot13Handler )- , ("echoUri" , echoUriHandler )- , ("fileserve" , serveDirectory "testserver/static")- , ("bigresponse" , bigResponseHandler )- , ("respcode/:code" , responseHandler )- , ("upload/form" , uploadForm )- , ("upload/handle" , uploadHandler )- , ("timeout/tickle" , timeoutTickleHandler )- , ("timeout/badtickle" , badTimeoutTickleHandler )- , ("server-header" , serverHeaderHandler )- , ("chunked" , chunkedResponse )- ]
− 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,36 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Blaze.ByteString.Builder-import Control.Concurrent-import Control.Exception (finally)--import Snap.Iteratee-import Snap.Core-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- config <- commandLineConfig defaults- forkIO $ go m config- takeMVar m- return ()-- where- defaults = setPort 8000 $- setErrorLog ConfigNoLog $- setAccessLog ConfigNoLog $- setCompression False $- setVerbose False $- emptyConfig-- go m config = httpServe config pongServer `finally` putMVar m ()
− test/runTestsAndCoverage.sh
@@ -1,57 +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.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,214 +0,0 @@-name: snap-server-testsuite-version: 0.1.1-build-type: Simple-cabal-version: >= 1.6--Flag portable- Description: Compile in cross-platform mode. No platform-specific code or- optimizations such as C routines will be used.- Default: False--Flag openssl- Description: Enable https support using the HsOpenSSL library.- Default: False--Executable testsuite- hs-source-dirs: suite common ../src- main-is: TestSuite.hs-- build-depends:- QuickCheck >= 2,- attoparsec >= 0.10 && <0.13,- attoparsec-enumerator >= 0.3 && <0.4,- base >= 4 && <5,- base16-bytestring == 0.1.*,- binary >= 0.5 && <0.7,- blaze-builder >= 0.2.1.4 && <0.5,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- conduit >= 0.5 && <0.6,- containers,- cprng-aes <0.4,- cryptocipher >= 0.3.7 && <0.4,- crypto-api <0.13,- directory,- directory-tree,- enumerator >= 0.4.15 && <0.5,- filepath,- http-conduit >= 1.8 && <1.9,- HUnit >= 1.2 && <2,- mtl >= 2 && <3,- network >= 2.3 && <2.6,- old-locale,- parallel >= 2 && <4,- process,- snap-core >= 0.9.3 && <0.10,- template-haskell,- test-framework >= 0.6 && <0.7,- test-framework-hunit >= 0.2.7 && <0.3,- test-framework-quickcheck2 >= 0.2.12.1 && <0.3,- text >= 0.11 && <1.2,- time,- tls >= 1.0 && <1.1,- tls-extra >= 0.5 && <0.6,- transformers-- extensions:- BangPatterns,- CPP,- MagicHash,- Rank2Types,- OverloadedStrings,- ScopedTypeVariables,- DeriveDataTypeable,- PackageImports,- ViewPatterns,- ForeignFunctionInterface,- EmptyDataDecls,- GeneralizedNewtypeDeriving-- if !os(windows)- build-depends: unix-- if flag(openssl)- cpp-options: -DOPENSSL- build-depends: HsOpenSSL >= 0.10 && <0.11-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- cpp-options: -DTESTSUITE- ghc-prof-options: -prof -auto-all- ghc-options: -O2 -Wall -fhpc -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind -rtsopts---Executable pongserver- hs-source-dirs: pongserver common ../src- main-is: Main.hs-- build-depends:- QuickCheck >= 2,- attoparsec >= 0.10 && <0.13,- attoparsec-enumerator >= 0.3 && <0.4,- base >= 4 && <5,- base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.5,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- cereal >= 0.3 && <0.4,- containers,- directory-tree,- enumerator >= 0.4.15 && <0.5,- filepath,- HUnit >= 1.2 && <2,- mtl >= 2 && <3,- old-locale,- parallel >= 3.2 && <4,- MonadCatchIO-transformers >= 0.2.1 && <0.4,- network >= 2.3 && <2.6,- snap-core >= 0.9.3 && <0.10,- template-haskell,- time,- transformers,- unix-compat >= 0.2 && <0.5,- utf8-string >= 0.3.6 && <0.4-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE- else- build-depends: unix-- if flag(openssl)- cpp-options: -DOPENSSL- build-depends: HsOpenSSL >= 0.10 && <0.11-- if os(linux) && !flag(portable)- cpp-options: -DLINUX -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.Linux-- if os(darwin) && !flag(portable)- cpp-options: -DOSX -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.Darwin-- if os(freebsd) && !flag(portable)- cpp-options: -DFREEBSD -DHAS_SENDFILE- other-modules:- System.SendFile,- System.SendFile.FreeBSD-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind -rtsopts- ghc-prof-options: -prof -auto-all---Executable testserver- hs-source-dirs: testserver common ../src- main-is: Main.hs-- build-depends:- QuickCheck >= 2,- attoparsec >= 0.10 && <0.13,- attoparsec-enumerator >= 0.3 && <0.4,- base >= 4 && <5,- binary >= 0.5 && <0.7,- blaze-builder >= 0.2.1.4 && <0.5,- blaze-builder-enumerator >= 0.2.0 && <0.3,- bytestring,- case-insensitive >= 0.3 && <1.3,- containers,- directory-tree,- enumerator >= 0.4.15 && <0.5,- filepath,- HUnit >= 1.2 && <2,- MonadCatchIO-transformers >= 0.2.1 && <0.4,- mtl >= 2 && <3,- network >= 2.3 && <2.6,- old-locale,- parallel >= 3.2 && <4,- snap-core >= 0.9.3 && <0.10,- template-haskell,- test-framework >= 0.6 && <0.7,- test-framework-hunit >= 0.2.7 && <0.3,- test-framework-quickcheck2 >= 0.2.12.1 && <0.3,- text >= 0.11 && <1.2,- time-- if !os(windows)- build-depends: unix-- if flag(openssl)- cpp-options: -DOPENSSL- build-depends: HsOpenSSL >= 0.10 && <0.11-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE-- ghc-options: -O2 -Wall -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind -rtsopts- ghc-prof-options: -prof -auto-all---Executable benchmark- hs-source-dirs: benchmark common ../src- main-is: Benchmark.hs-- ghc-options: -O2 -Wall -fwarn-tabs- -funbox-strict-fields -threaded- -fno-warn-unused-do-bind -rtsopts-- ghc-prof-options: -prof -auto-all-- build-depends:- base >= 4 && < 5,- network >= 2.3 && < 2.6,- criterion >= 0.8 && < 0.9
− test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -1,169 +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 False False- cv2 = parseCookie ct-- nm = "foo"- v = "bar"-- ct = S.concat [ nm , "=" , v ]---testFormEncoded :: Test-testFormEncoded = testCase "parser/formEncoded" $ do- let bs = "foo1=bar1&foo2=bar2+baz2;foo3=foo%20bar"- let mp = parseUrlEncoded bs-- assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp- assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp- assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp---copyingStream2Stream :: (Monad m) => Iteratee ByteString m ByteString-copyingStream2Stream = go []- where- go l = do- mbx <- I.head- maybe (return $ S.concat $ reverse l)- (\x -> let !z = S.copy x in go (z:l))- mbx--stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString-stream2stream = liftM L.fromChunks consume
− test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -1,1062 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Http.Server.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Enumerator-import Control.Concurrent-import Control.Exception (Exception, SomeException,- bracket, catch, finally,- throwIO, try)-import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Internal (c2w)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as LC-import qualified Data.CaseInsensitive as CI-import Data.Char-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import Data.Int-import Data.IORef-import Data.List (foldl', sort)-import Data.Maybe (fromJust, isJust)-import Data.Time.Calendar-import Data.Time.Clock-import Data.Typeable-import qualified Network.HTTP.Conduit as HTTP-import qualified Network.Socket.ByteString as N-import Prelude hiding (catch, take)-import qualified Prelude-import System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import qualified Snap.Http.Server as Svr--import Snap.Core-import Snap.Internal.Debug-import Snap.Internal.Http.Server-import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Types-import Snap.Iteratee hiding (map)-import qualified Snap.Iteratee as I-import qualified Snap.Test as Test-import Snap.Test.Common-import qualified Snap.Types.Headers as H--data TestException = TestException- deriving (Show, Typeable)-instance Exception TestException---tests :: [Test]-tests = [ testHttpRequest1- , testMultiRequest- , testHttpRequest2- , testHttpRequest3- , testHttpRequest3'- , testHttpResponse1- , testHttpResponse2- , testHttpResponse3- , testHttpResponse4- , testHttpResponseCookies- , testHttp1- , testHttp2- , testHttp100- , test411- , testEscapeHttp- , testExpectGarbage- , testPartialParse- , testMethodParsing- , testServerStartupShutdown- , testServerShutdownWithOpenConns- , testChunkOn1_0- , testSendFile- , testTrivials]---testTrivials :: Test-testTrivials = testCase "server/trivials" $ do- let !v = Svr.snapServerVersion- return $! v `seq` ()----------------------------------------------------------------------------------- HTTP request tests---- note leading crlf -- test tolerance of this, some old browsers send an extra--- crlf after a post body-sampleRequest :: ByteString-sampleRequest =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequestExpectContinue :: ByteString-sampleRequestExpectContinue =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Expect: 100-continue\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequest411 :: ByteString-sampleRequest411 =- S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n" ]--sampleRequestExpectGarbage :: ByteString-sampleRequestExpectGarbage =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Expect: wuzzawuzzawuzza\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--sampleRequest1_0 :: ByteString-sampleRequest1_0 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.0\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]--testMethodParsing :: Test-testMethodParsing =- testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms- where- ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH- , Method "COPY", Method "MOVE" ]---dummyIter :: Iteratee ByteString IO ()-dummyIter = consume >> return ()---testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString)-testReceiveRequest = do- r <- liftM fromJust $ rsm $ receiveRequest dummyIter- se <- liftIO $ readIORef (rqBody r)- let (SomeEnumerator e) = se- it <- liftM e $ lift $ runIteratee copyingStream2Stream- b <- it- return (r,b)---testReceiveRequestIter :: ByteString- -> IO (Iteratee ByteString IO (Request,L.ByteString))-testReceiveRequestIter req =- liftM (enumBS req) $ runIteratee testReceiveRequest---testHttpRequest1 :: Test-testHttpRequest1 =- testCase "server/HttpRequest1" $ do- iter <- testReceiveRequestIter sampleRequest-- (req,body) <- run_ iter-- assertEqual "not secure" False $ rqIsSecure req-- assertEqual "content length" (Just 10) $ rqContentLength req-- assertEqual "parse body" "0123456789" body-- assertEqual "cookie"- [Cookie "foo" "bar\"" Nothing Nothing Nothing False False]- (rqCookies req)-- assertEqual "continued headers" (Just ["foo bar"]) $- H.lookup "x-random-other-header" $ rqHeaders req-- assertEqual "parse URI"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req-- assertEqual "server port" 7777 $ rqServerPort req- assertEqual "context path" "/" $ rqContextPath req- assertEqual "pathinfo" "foo/bar.html" $ rqPathInfo req- assertEqual "query string" "param1=abc¶m2=def%20+¶m1=abc" $- rqQueryString req- assertEqual "server name" "www.zabble.com" $ rqServerName req- assertEqual "version" (1,1) $ rqVersion req- assertEqual "param1" (Just ["abc","abc"]) $- rqParam "param1" req- assertEqual "param2" (Just ["def "]) $- rqParam "param2" req----testMultiRequest :: Test-testMultiRequest =- testCase "server/MultiRequest" $ do- let clientIter = do- (r1,b1) <- testReceiveRequest- (r2,b2) <- testReceiveRequest-- return (r1,b1,r2,b2)-- iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $- runIteratee clientIter-- (req1,body1,req2,body2) <- run_ iter-- assertEqual "parse body 1" "0123456789" body1- assertEqual "parse body 2" "0123456789" body2-- assertEqual "parse URI 1"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req1-- assertEqual "parse URI 2"- "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"- $ rqURI req2----testOneMethod :: Method -> IO ()-testOneMethod m = do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumLBS txt step- req <- run_ iter-- assertEqual "method" m $ rqMethod req-- where- txt = methodTestText m---sampleShortRequest :: ByteString-sampleShortRequest = "GET /fo"---testPartialParse :: Test-testPartialParse = testCase "server/short" $ do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumBS sampleShortRequest step-- expectException $ run_ iter---methodTestText :: Method -> L.ByteString-methodTestText m = L.concat [ mbs m- , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ]- where- mbs (Method b) = L.fromChunks [b]- mbs b = L.pack $ map c2w $ show b--sampleRequest2 :: ByteString-sampleRequest2 =- S.concat [ "GET /foo/bar.html?param1=abc¶m2=def¶m1=abc HTTP/1.1\r\n"- , "Host: www.foo.com:8080\r\n"- , "Transfer-Encoding: chunked\r\n"- , "\r\n"- , "a\r\n"- , "0123456789\r\n"- , "4\r\n"- , "0123\r\n"- , "0\r\n\r\n" ]--testHttpRequest2 :: Test-testHttpRequest2 =- testCase "server/HttpRequest2" $ do- iter <- testReceiveRequestIter sampleRequest2- (_,body) <- run_ iter-- assertEqual "parse body" "01234567890123" body---testHttpRequest3 :: Test-testHttpRequest3 =- testCase "server/HttpRequest3" $ do- iter <- testReceiveRequestIter sampleRequest3- (req,body) <- run_ iter-- assertEqual "no cookies" [] $ rqCookies req-- assertEqual "multiheader" (Just ["1","2"]) $- H.lookup "Multiheader" (rqHeaders req)-- assertEqual "host" ("localhost", 80) $- (rqServerName req, rqServerPort req)-- assertEqual "post param 1"- (rqParam "postparam1" req)- (Just ["1"])-- assertEqual "post param 2"- (rqParam "postparam2" req)- (Just ["2"])-- -- make sure the post body is still emitted- assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body---testHttpRequest3' :: Test-testHttpRequest3' =- testCase "server/HttpRequest3'" $ do- iter <- testReceiveRequestIter sampleRequest3'- (req,body) <- run_ iter-- assertEqual "post param 1"- (rqParam "postparam1" req)- (Just ["1"])-- assertEqual "post param 2"- (rqParam "postparam2" req)- (Just ["2"])-- -- make sure the post body is still emitted- assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body---samplePostBody3 :: ByteString-samplePostBody3 = "postparam1=1&postparam2=2"---sampleRequest3 :: ByteString-sampleRequest3 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Content-Type: application/x-www-form-urlencoded\r\n"- , "Content-Length: 25\r\n"- , "Multiheader: 1\r\n"- , "Multiheader: 2\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "\r\n"- , samplePostBody3 ]---sampleRequest3' :: ByteString-sampleRequest3' =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Content-Type: application/x-www-form-urlencoded; charset=UTF-8\r\n"- , "Content-Length: 25\r\n"- , "Multiheader: 1\r\n"- , "Multiheader: 2\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "\r\n"- , samplePostBody3 ]-----rsm :: ServerMonad a -> Iteratee ByteString IO a-rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog- where- alog = const . const . return $ ()- elog = const $ return ()---testHttpResponse1 :: Test-testHttpResponse1 = testCase "server/HttpResponse1" $ do- buf <- allocBuffer 16384- req <- Test.buildRequest $ return ()- b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertBool "http response" (b == text1 || b == text2)-- where- text1 = L.concat [ "HTTP/1.0 600 Test\r\n"- , "Content-Length: 10\r\n"- , "Foo: Bar\r\n\r\n"- , "0123456789"- ]-- text2 = L.concat [ "HTTP/1.0 600 Test\r\n"- , "Foo: Bar\r\n"- , "Content-Length: 10\r\n\r\n"- , "0123456789"- ]-- rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength' 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }---strToHeaders :: L.ByteString -> H.Headers-strToHeaders s = foldl' mkHeader H.empty lns- where- lns = LC.lines s-- mkHeader hdrs x = hdrs'- where- (a0,b0) = LC.break (== ':') x- a = CI.mk $ S.concat $ LC.toChunks a0- b = S.concat $ LC.toChunks $ LC.drop 2 b0- hdrs' = H.insert a b hdrs---testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString-testOnSendFile f st sz = do- sstep <- runIteratee copyingStream2Stream- run_ $ enumFilePartial f (st,st+sz) sstep---testHttpResponse2 :: Test-testHttpResponse2 = testCase "server/HttpResponse2" $ do- buf <- allocBuffer 16384- req <- Test.buildRequest $ return ()- b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertBool "http prefix"- ("HTTP/1.0 600 Test\r\n" `S.isPrefixOf` b2)-- assertBool "connection close"- ("Connection: close\r\n" `S.isInfixOf` b2)-- assertBool "foo: bar"- ("Foo: Bar\r\n" `S.isInfixOf` b2)-- assertBool "body"- ("\r\n\r\n0123456789" `S.isSuffixOf` b2)-- where- rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength' 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = rsp1 { rspContentLength = Nothing }---testHttpResponse3 :: Test-testHttpResponse3 = testCase "server/HttpResponse3" $ do- buf <- allocBuffer 16384- req <- Test.buildRequest $ return ()- b3 <- run_ $ rsm $- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=- return . snd-- let lns = LC.lines b3-- let ok = case lns of- ([ "HTTP/1.1 600 Test\r"- , h1, h2, h3- , "\r"- , "000A\r"- , "0123456789\r"- , "0\r"- , "\r"]) -> check $ LC.unlines [h1,h2,h3]- _ -> False-- when (not ok) $ LC.putStrLn $- LC.concat ["***testHttpResponse3: b3 was:\n", b3]-- assertBool "http response" ok-- where- check s = (H.lookup "Content-Type" hdrs == Just ["text/plain\r"]) &&- (H.lookup "Foo" hdrs == Just ["Bar\r"]) &&- (H.lookup "Transfer-Encoding" hdrs == Just ["chunked\r"])- where- hdrs = strToHeaders s-- rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength' 10 $- setResponseStatus 600 "Test" $- modifyResponseBody (>==> (enumBuilder $- fromByteString "0123456789")) $- setResponseBody returnI $- emptyResponse { rspHttpVersion = (1,0) }- rsp2 = deleteHeader "Content-Length" $ rsp1 { rspContentLength = Nothing }- rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) })---testHttpResponse4 :: Test-testHttpResponse4 = testCase "server/HttpResponse4" $ do- buf <- allocBuffer 16384- req <- Test.buildRequest $ return ()- b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=- return . snd-- assertEqual "http response" (L.concat [- "HTTP/1.0 304 Test\r\n"- , "Content-Length: 0\r\n\r\n"- ]) b-- where- rsp1 = setResponseStatus 304 "Test" $- setContentLength' 0 $- emptyResponse { rspHttpVersion = (1,0) }---testHttpResponseCookies :: Test-testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do- buf <- allocBuffer 16384- req <- Test.buildRequest $ return ()- b <- run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=- return . snd-- let lns = LC.lines b-- let ok = case lns of- ([ "HTTP/1.0 304 Test\r"- , h1, h2, h3, h4- , "\r"]) -> check $ LC.unlines [h1,h2,h3,h4]- _ -> False-- when (not ok) $ LC.putStrLn $- LC.concat ["*** testHttpResponseCookies: b was:\n", b]- assertBool "http response" ok-- where- check s = (H.lookup "Connection" hdrs == Just ["close\r"]) &&- (ch $ H.lookup "Set-Cookie" hdrs)- where- hdrs = strToHeaders s-- ch Nothing = False- ch (Just l) =- sort l == [- "ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r"- , "ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r"- , "ck3=bar\r"- ]---- rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) }- rsp2 = addResponseCookie cook3 . addResponseCookie cook2- . addResponseCookie cook $ rsp1-- utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False- cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True- cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False----echoServer :: (ByteString -> IO ())- -> ((Int -> Int) -> IO ())- -> Request- -> Iteratee ByteString IO (Request,Response)-echoServer _ _ req = do- se <- liftIO $ readIORef (rqBody req)- let (SomeEnumerator enum) = se- i <- liftM enum $ lift $ runIteratee copyingStream2Stream- b <- i- let cl = L.length b- liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0)- return (req, rsp b cl)- where- rsp s cl = setContentLength' cl $- emptyResponse { rspBody = Enum $- enumBuilder (fromLazyByteString s) }---echoServer2 :: ServerHandler-echoServer2 _ _ req = do- (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req- return (rq, addResponseCookie cook rsp)- where- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False- utc = UTCTime (ModifiedJulianDay 55226) 0---testHttp1 :: Test-testHttp1 = testCase "server/httpSession" $ do- let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60 Nothing Nothing echoServer "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody iter onSendFile (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , h1- , h2- , h3- , "\r"- , "0123456789HTTP/1.1 200 OK\r"- , g1- , g2- , g3- , "\r"- , "01234567890123" ]) -> (check1 $ LC.unlines [h1,h2,h3]) &&- (check2 $ LC.unlines [g1,g2,g3])- _ -> False--- when (not ok) $ do- putStrLn "server/httpSession fail!!!! got:"- LC.putStrLn s-- assertBool "pipelined responses" ok-- where- check1 s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&- (isJust $ H.lookup "Server" hdrs) &&- (isJust $ H.lookup "Date" hdrs)- where- hdrs = strToHeaders s-- check2 s = (H.lookup "Content-Length" hdrs == Just ["14\r"]) &&- (isJust $ H.lookup "Server" hdrs) &&- (isJust $ H.lookup "Date" hdrs)- where- hdrs = strToHeaders s---mkIter :: IORef L.ByteString- -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ())-mkIter ref = (iter, \f st sz -> onF f st sz iter)- where- iter = do- x <- copyingStream2Stream- liftIO $ modifyIORef ref $ \s -> L.append s x-- onF f st sz i = do- step <- runIteratee i- let it = enumFilePartial f (st,st+sz) step- run_ it---testChunkOn1_0 :: Test-testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do- let enumBody = enumBS sampleRequest1_0-- ref <- newIORef ""- let (iter,onSendFile) = mkIter ref-- done <- newEmptyMVar- forkIO (runHTTP 60 Nothing Nothing f "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody iter onSendFile (const $ return ())- `finally` putMVar done ())-- takeMVar done-- -- this is a pretty lame way of checking whether the output was chunked,- -- but "whatever"- output <- liftM lower $ readIORef ref-- assertBool "chunked output" $ not $ S.isInfixOf "chunked" output- assertBool "connection close" $ S.isInfixOf "connection: close" output-- where- lower = S.map toLower . S.concat . L.toChunks-- f :: ServerHandler- f _ _ req = do- let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd"- let out = enumBuilder $ fromLazyByteString s- return (req, emptyResponse { rspBody = Enum out })---sampleRequest4 :: ByteString-sampleRequest4 =- S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"- , "Host: www.zabble.com:7777\r\n"- , "Content-Length: 10\r\n"- , "Connection: close\r\n"- , "X-Random-Other-Header: foo\r\n bar\r\n"- , "Cookie: foo=\"bar\\\"\"\r\n"- , "\r\n"- , "0123456789" ]---testHttp2 :: Test-testHttp2 = testCase "server/connectionClose" $ do- let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- done <- newEmptyMVar-- forkIO (runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ()) `finally` putMVar done ())-- takeMVar done-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , h1- , h2- , h3- , h4- , h5- , "\r"- , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4,h5])-- _ -> False-- assertBool "connection: close" ok-- where- check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&- (H.lookup "Connection" hdrs == Just ["close\r"]) &&- (H.lookup "Set-Cookie" hdrs == Just [- "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- ]) &&- (isJust $ H.lookup "Server" hdrs) &&- (isJust $ H.lookup "Date" hdrs)- where- hdrs = strToHeaders s----testHttp100 :: Test-testHttp100 = testCase "server/expect100" $ do- let enumBody = enumBS sampleRequestExpectContinue-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 100 Continue\r"- , "\r"- , "HTTP/1.1 200 OK\r"- , h1- , h2- , h3- , h4- , "\r"- , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4])- _ -> False-- when (not ok) $ do- putStrLn "expect100 fail! got:"- LC.putStrLn s-- assertBool "100 Continue" ok-- where- check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&- (H.lookup "Set-Cookie" hdrs == Just [- "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- ]) &&- (isJust $ H.lookup "Server" hdrs) &&- (isJust $ H.lookup "Date" hdrs)- where- hdrs = strToHeaders s---test411 :: Test-test411 = testCase "server/expect411" $ do- let enumBody = enumBS sampleRequest411-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ("HTTP/1.1 411 Length Required\r":_) -> True- _ -> False-- when (not ok) $ do- putStrLn "expect411 fail! got:"- LC.putStrLn s-- assertBool "411 Length Required" ok---testEscapeHttp :: Test-testEscapeHttp = testCase "server/escapeHttp" $ do- ref <- newIORef ""- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- escapeServer- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- (enumBS sampleRequest)- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- assertEqual "escapeHttp" "0123456789" s- where- -- Escape HTTP traffic. Read one ByteString and send it back.- escapeServer = runSnap $ escapeHttp $ \_ sendIter -> do- Just bs <- EL.head- liftIO $ E.run_ $ E.enumList 1 [bs] $$ sendIter---testExpectGarbage :: Test-testExpectGarbage = testCase "server/expectGarbage" $ do- let enumBody = enumBS sampleRequestExpectGarbage-- ref <- newIORef ""-- let (iter,onSendFile) = mkIter ref-- runHTTP 60- Nothing- Nothing- echoServer2- "localhost"- (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)- enumBody- iter- onSendFile- (const $ return ())-- s <- readIORef ref-- let lns = LC.lines s-- let ok = case lns of- ([ "HTTP/1.1 200 OK\r"- , h1- , h2- , h3- , h4- , "\r"- , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4])- _ -> False-- assertBool "random expect: header" ok-- where- check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) &&- (H.lookup "Set-Cookie" hdrs == Just [- "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"- ]) &&- (isJust $ H.lookup "Server" hdrs) &&- (isJust $ H.lookup "Date" hdrs)- where- hdrs = strToHeaders s---pongServer :: Snap ()-pongServer = modifyResponse $ setResponseBody enum .- setContentType "text/plain" .- setContentLength' 4- where- enum = enumBuilder $ fromByteString "PONG"--sendFileFoo :: Snap ()-sendFileFoo = sendFile "data/fileServe/foo.html"---testSendFile :: Test-testSendFile = testCase "server/sendFile" $ do- bracket (forkIO serve)- (killThread)- (\tid -> do- m <- timeout (120 * seconds) $ go tid- maybe (assertFailure "timeout")- (const $ return ())- m)-- where- serve = (httpServe 60 [HttpPort "*" port] "localhost"- Nothing Nothing (const $ return ())- $ runSnap sendFileFoo)- `catch` \(_::SomeException) -> return ()-- go tid = do- waitabit-- doc <- HTTP.simpleHttp "http://127.0.0.1:8123/"-- killThread tid- waitabit-- assertEqual "sendFile" "FOO\n" doc--- waitabit = threadDelay $ ((10::Int)^(6::Int))-- port = 8123---testServerStartupShutdown :: Test-testServerStartupShutdown = testCase "server/startup/shutdown" $ do- bracket (forkIO $- httpServe 20- [HttpPort "*" port]- "localhost"- (Just $ const (return ())) -- dummy logging- (Just $ const (return ())) -- dummy logging- (const $ return ())- (runSnap pongServer))- (killThread)- (\tid -> do- m <- timeout (120 * seconds) $ go tid- maybe (assertFailure "timeout")- (const $ return ())- m)--- where- go tid = do- debug $ "testServerStartupShutdown: waiting a bit"- waitabit- debug $ "testServerStartupShutdown: sending http request"- doc <- HTTP.simpleHttp "http://127.0.0.1:8145/"- assertEqual "server" "PONG" doc-- debug $ "testServerStartupShutdown: killing thread"- killThread tid- debug $ "testServerStartupShutdown: kill signal sent to thread"- waitabit-- expectException $ HTTP.simpleHttp "http://127.0.0.1:8145/"- return ()-- waitabit = threadDelay $ 2*((10::Int)^(6::Int))-- port = 8145---testServerShutdownWithOpenConns :: Test-testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do- tid <- forkIO $- httpServe 20- [HttpPort "*" port]- "localhost"- Nothing- Nothing- (const $ return ())- (runSnap pongServer)-- waitabit-- result <- newEmptyMVar-- forkIO $ do- e <- try $ withSock port $ \sock -> do- N.sendAll sock "GET /"- waitabit- killThread tid- waitabit- N.sendAll sock "pong HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- resp <- recvAll sock- when (S.null resp) $ throwIO TestException-- let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp- debug $ "got HTTP response " ++ s ++ ", we shouldn't be here...."-- putMVar result e-- e <- timeout (75*seconds) $ takeMVar result-- case e of- Nothing -> killThread tid >> assertFailure "timeout"- (Just r) ->- case r of- (Left (_::SomeException)) -> return ()- (Right _) -> assertFailure "socket didn't get killed"--- where- waitabit = threadDelay $ 2*((10::Int)^(6::Int))- port = 8149----seconds :: Int-seconds = (10::Int) ^ (6::Int)---copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString-copyingStream2Stream = go []- where- go l = do- mbx <- I.head- maybe (return $ L.fromChunks $ reverse l)- (\x -> let !z = S.copy x in go (z:l))- mbx---setContentLength' :: Int64 -> Response -> Response-setContentLength' cl = setHeader "Content-Length" (S.pack $ show cl) .- setContentLength cl
− 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,487 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Test.Blackbox- ( tests- , ssltests- , startTestServer ) where-----------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Concurrent-import Control.Exception (SomeException, catch,- throwIO)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Base16 as B16-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.CaseInsensitive (CI)-import Data.Conduit (ResourceT)-import Data.Int-import Data.List-import Data.Monoid-import qualified Network.HTTP.Conduit as HTTP-import qualified Network.Socket.ByteString as N-import Network.TLS (CertificateUsage (..))-import Prelude hiding (catch, take)-import System.Timeout-import Test.Framework-import Test.Framework.Options-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, path)-import Test.QuickCheck-import Test.QuickCheck.Monadic hiding (assert, run)-import qualified Test.QuickCheck.Monadic as QC-import qualified Test.QuickCheck.Property as QC--------------------------------------------------------------------------------import Snap.Http.Server-import Snap.Internal.Debug-import Snap.Iteratee hiding (head, map)-import qualified Snap.Iteratee as I-import Snap.Test.Common-import Test.Common.Rot13-import Test.Common.TestHandler---------------------------------------------------------------------------------testFunctions :: [Bool -> Int -> String -> Test]-testFunctions = [ testPong--- FIXME: waiting on http-enumerator patch for HEAD behaviour--- , testHeadPong- , testEcho- , testRot13- , testSlowLoris- , testBlockingRead- , testBigResponse- , testPartial- , testFileUpload- , testTimeoutTickle- , testTimeoutBadTickle- , testServerHeader- , testChunkedHead- ]----------------------------------------------------------------------------------tests :: Int -> [Test]-tests port = map (\f -> f False port "") testFunctions----------------------------------------------------------------------------------slowTestOptions :: Bool -> TestOptions' Maybe-slowTestOptions ssl =- if ssl- then mempty { topt_maximum_generated_tests = Just 75 }- else mempty { topt_maximum_generated_tests = Just 300 }----------------------------------------------------------------------------------ssltests :: Maybe Int -> [Test]-ssltests = maybe [] httpsTests- where httpsTests port = map (\f -> f True port sslname) testFunctions- sslname = "ssl/"---------------------------------------------------------------------------------startTestServer :: Int- -> Maybe Int- -> IO (ThreadId, MVar ())-startTestServer port sslport = do- let cfg = setAccessLog (ConfigFileLog "ts-access.log") .- setErrorLog (ConfigFileLog "ts-error.log") .- setBind "*" .- setPort port .- setDefaultTimeout 10 .- setVerbose False $- defaultConfig-- let cfg' = maybe cfg- (\p ->- setSSLPort p .- setSSLBind "*" .- setSSLCert "cert.pem" .- setSSLKey "key.pem" .- setAccessLog (ConfigFileLog "ts-access-ssl.log") .- setErrorLog (ConfigFileLog "ts-error-ssl.log") $- cfg)- sslport-- mvar <- newEmptyMVar- tid <- forkIO $ do- (httpServe cfg' testHandler)- `catch` \(_::SomeException) -> return ()- putMVar mvar ()- threadDelay $ 4*seconds-- return (tid,mvar)----------------------------------------------------------------------------------doPong :: Bool -> Int -> IO ByteString-doPong ssl port = do- debug "getting URI"- let !uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/pong"- debug $ "URI is: '" ++ uri ++ "', calling simpleHttp"-- rsp <- fetch uri-- debug $ "response was " ++ show rsp- return $ S.concat $ L.toChunks rsp------------------------------------------------------------------------------------ FIXME: waiting on http-enumerator patch for HEAD behaviour--- headPong :: Bool -> Int -> IO ByteString--- headPong ssl port = do--- let uri = (if ssl then "https" else "http")--- ++ "://127.0.0.1:" ++ show port ++ "/echo"---- req0 <- HTTP.parseUrl uri---- let req = req0 { HTTP.method = "HEAD" }--- rsp <- HTTP.httpLbs req--- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp---------------------------------------------------------------------------------testPong :: Bool -> Int -> String -> Test-testPong ssl port name = testCase (name ++ "blackbox/pong") $ do- doc <- doPong ssl port- assertEqual "pong response" "PONG" doc------------------------------------------------------------------------------------ FIXME: waiting on http-enumerator patch for HEAD behaviour--- testHeadPong :: Bool -> Int -> String -> Test--- testHeadPong ssl port name = testCase (name ++ "blackbox/pong/HEAD") $ do--- doc <- headPong ssl port--- assertEqual "pong HEAD response" "" doc----------------------------------------------------------------------------------testEcho :: Bool -> Int -> String -> Test-testEcho ssl port name =- plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "blackbox/echo") $- QC.mapSize (if ssl then min 100 else min 300) $- monadicIO $ forAllM arbitrary prop- where- prop txt = do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/echo"-- doc <- QC.run $ post uri txt []- QC.assert $ txt == doc----------------------------------------------------------------------------------testFileUpload :: Bool -> Int -> String -> Test-testFileUpload ssl port name =- plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "blackbox/upload") $- QC.mapSize (if ssl then min 100 else min 300) $- monadicIO $- forAllM arbitrary prop- where- boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"-- prefix = [ "--"- , boundary- , "\r\n"- , "content-disposition: form-data; name=\"submit\"\r\n"- , "\r\nSubmit\r\n" ]-- body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix- where- part (k,v) = [ "--"- , boundary- , "\r\ncontent-disposition: attachment; filename=\""- , k- , "\"\r\nContent-Type: text/plain\r\n\r\n"- , v- , "\r\n" ]-- suffix = [ "--", boundary, "--\r\n" ]-- hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ]- ++ L.toChunks boundary) ]-- b16 (k,v) = (ne $ e k, e v)- where- ne s = if L.null s then "file" else s- e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ]-- response kvps = L.concat $ [ "Param:\n"- , "submit\n"- , "Value:\n"- , "Submit\n\n" ] ++ concatMap responseKVP kvps-- responseKVP (k,v) = [ "File:\n"- , k- , "\nValue:\n"- , v- , "\n\n" ]-- prop kvps' = do- let kvps = sort $ map b16 kvps'-- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/upload/handle"-- let txt = response kvps- doc <- QC.run $ post uri (body kvps) hdrs-- when (txt /= doc) $ QC.run $ do- L.putStrLn "expected:"- L.putStrLn "----------------------------------------"- L.putStrLn txt- L.putStrLn "----------------------------------------"- L.putStrLn "\ngot:"- L.putStrLn "----------------------------------------"- L.putStrLn doc- L.putStrLn "----------------------------------------"-- QC.assert $ txt == doc----------------------------------------------------------------------------------testRot13 :: Bool -> Int -> String -> Test-testRot13 ssl port name =- plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "blackbox/rot13") $- monadicIO $ forAllM arbitrary prop- where- prop txt = do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/rot13"-- doc <- QC.run $ liftM (S.concat . L.toChunks)- $ post uri (L.fromChunks [txt]) []- QC.assert $ txt == rot13 doc------------------------------------------------------------------------------------ TODO: this one doesn't work w/ SSL-testSlowLoris :: Bool -> Int -> String -> Test-testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $- if ssl then return () else withSock port go-- where- go sock = do- m <- timeout (120*seconds) $ go' sock- maybe (assertFailure "slowloris: timeout")- (const $ return ())- m-- go' sock = do- N.sendAll sock "POST /echo HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 2500000\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- b <- expectExceptionBeforeTimeout (loris sock) 60-- assertBool "didn't catch slow loris attack" b-- loris sock = do- N.sendAll sock "."- waitabit- loris sock----------------------------------------------------------------------------------testChunkedHead :: Bool -> Int -> String -> Test-testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $- if ssl then return () else withSock port go- where- go sock = do- N.sendAll sock $ "HEAD /chunked HTTP/1.1\r\n\r\n"- s <- N.recv sock 4096- assertBool "no body" $ isOK s-- split x l | S.null x = reverse l- | otherwise = let (a, b) = S.break (== '\r') x- b' = S.drop 2 b- in split b' (a : l)-- isOK s = let lns = split s []- lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns- in null lns'------------------------------------------------------------------------------------ TODO: doesn't work w/ ssl-testBlockingRead :: Bool -> Int -> String -> Test-testBlockingRead ssl port name =- testCase (name ++ "blackbox/testBlockingRead") $- if ssl then return () else runIt-- where- runIt = withSock port $ \sock -> do- m <- timeout (60*seconds) $ go sock- maybe (assertFailure "timeout")- (const $ return ())- m-- go sock = do- N.sendAll sock "GET /"- waitabit- N.sendAll sock "pong HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- resp <- recvAll sock-- let s = head $ ditchHeaders $ S.lines resp-- assertEqual "pong response" "PONG" s------------------------------------------------------------------------------------ TODO: no ssl here--- test server's ability to trap/recover from IO errors-testPartial :: Bool -> Int -> String -> Test-testPartial ssl port name =- testCase (name ++ "blackbox/testPartial") $- if ssl then return () else runIt-- where- runIt = do- m <- timeout (60*seconds) go- maybe (assertFailure "timeout")- (const $ return ())- m-- go = do- withSock port $ \sock ->- N.sendAll sock "GET /pong HTTP/1.1\r\n"-- doc <- doPong ssl port- assertEqual "pong response" "PONG" doc------------------------------------------------------------------------------------ TODO: no ssl-testBigResponse :: Bool -> Int -> String -> Test-testBigResponse ssl port name =- testCase (name ++ "blackbox/testBigResponse") $- if ssl then return () else runIt- where- runIt = withSock port $ \sock -> do- m <- timeout (120*seconds) $ go sock- maybe (assertFailure "timeout")- (const $ return ())- m-- go sock = do- N.sendAll sock "GET /bigresponse HTTP/1.1\r\n"- N.sendAll sock "Host: 127.0.0.1\r\n"- N.sendAll sock "Content-Length: 0\r\n"- N.sendAll sock "Connection: close\r\n\r\n"-- let body = S.replicate 4000000 '.'- resp <- recvAll sock-- let s = head $ ditchHeaders $ S.lines resp-- assertBool "big response" $ body == s----------------------------------------------------------------------------------waitabit :: IO ()-waitabit = threadDelay $ 2*seconds----------------------------------------------------------------------------------seconds :: Int-seconds = (10::Int) ^ (6::Int)----------------------------------------------------------------------------------fetchReq :: HTTP.Request (ResourceT IO) -> IO (L.ByteString)-fetchReq req = go `catch` (\(e::SomeException) -> do- debug $ "simpleHttp threw exception: " ++ show e- throwIO e)- where- go = do- rsp <- HTTP.withManagerSettings settings $ HTTP.httpLbs req- return $ HTTP.responseBody rsp-- settings = HTTP.def { HTTP.managerCheckCerts = \_ _ _ ->- return CertificateUsageAccept }---------------------------------------------------------------------------------fetchResponse :: String -> IO (HTTP.Response L.ByteString)-fetchResponse url = do- req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do- debug $ "parseUrl threw exception: " ++ show e- throwIO e)- go req `catch` (\(e::SomeException) -> do- debug $ "simpleHttp threw exception: " ++ show e- throwIO e)- where- go req = HTTP.withManagerSettings settings $ HTTP.httpLbs req- settings = HTTP.def { HTTP.managerCheckCerts = \_ _ _ ->- return CertificateUsageAccept }----------------------------------------------------------------------------------fetch :: String -> IO (L.ByteString)-fetch url = do- req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do- debug $ "HTTP.parseUrl threw exception: " ++ show e- throwIO e)- fetchReq req----------------------------------------------------------------------------------post :: String- -> L.ByteString- -> [(CI ByteString, ByteString)]- -> IO (L.ByteString)-post url body hdrs = do- req <- HTTP.parseUrl url `catch` (\(e::SomeException) -> do- debug $ "HTTP.parseUrl threw exception: " ++ show e- throwIO e)- fetchReq $ req { HTTP.requestBody = HTTP.RequestBodyLBS body- , HTTP.method = "POST"- , HTTP.requestHeaders = hdrs }------------------------------------------------------------------------------------ This test checks two things:------ 1. that the timeout tickling logic works--- 2. that "flush" is passed along through a gzip operation.-testTimeoutTickle :: Bool -> Int -> String -> Test-testTimeoutTickle ssl port name =- testCase (name ++ "blackbox/timeout/tickle") $ do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle"- doc <- liftM (S.concat . L.toChunks) $ fetch uri- let expected = S.concat $ replicate 10 ".\n"- assertEqual "response equal" expected doc----------------------------------------------------------------------------------testTimeoutBadTickle :: Bool -> Int -> String -> Test-testTimeoutBadTickle ssl port name =- testCase (name ++ "blackbox/timeout/badtickle") $ do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/timeout/badtickle"- expectException $ fetch uri----------------------------------------------------------------------------------testServerHeader :: Bool -> Int -> String -> Test-testServerHeader ssl port name =- testCase (name ++ "/blackbox/server-header") $ do- let uri = (if ssl then "https" else "http")- ++ "://127.0.0.1:" ++ show port ++ "/server-header"- rsp <- fetchResponse uri- let serverHeader = lookup "server" $ HTTP.responseHeaders rsp- assertEqual "server header" (Just "foo") serverHeader
− test/suite/TestSuite.hs
@@ -1,65 +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 Network (withSocketsDo)-import Test.Framework (defaultMain, testGroup)-import System.Environment-import Snap.Http.Server.Config--import qualified Snap.Internal.Http.Parser.Tests-import qualified Snap.Internal.Http.Server.Tests-import qualified Snap.Internal.Http.Server.TimeoutManager.Tests-import qualified Test.Blackbox--ports :: Int -> [Int]-ports sp = [sp]--#ifdef OPENSSL-sslports :: Int -> [Maybe Int]-sslports sp = map Just [(sp + 100)]-#else-sslports :: Int -> [Maybe Int]-sslports _ = repeat Nothing-#endif--backends :: Int -> [(Int,Maybe Int)]-backends sp = zip (ports sp)- (sslports sp)--getStartPort :: IO Int-getStartPort = (liftM read (getEnv "STARTPORT") >>= evaluate)- `catch` \(_::SomeException) -> return 8111---main :: IO ()-main = withSocketsDo $ do- sp <- getStartPort- let bends = backends sp- tinfos <- forM bends $ \(port,sslport) ->- Test.Blackbox.startTestServer port sslport-- defaultMain (tests ++ concatMap blackbox bends) `finally` do- mapM_ killThread $ map fst tinfos- mapM_ takeMVar $ map snd tinfos-- where tests =- [ testGroup "Snap.Internal.Http.Parser.Tests"- Snap.Internal.Http.Parser.Tests.tests- , testGroup "Snap.Internal.Http.Server.Tests"- Snap.Internal.Http.Server.Tests.tests- , testGroup "Snap.Internal.Http.Server.TimeoutManager.Tests"- Snap.Internal.Http.Server.TimeoutManager.Tests.tests- ]- blackbox (port, sslport) =- [ testGroup ("Test.Blackbox")- $ Test.Blackbox.tests port- , testGroup ("Test.Blackbox SSL")- $ Test.Blackbox.ssltests sslport- ]
− test/testserver/Main.hs
@@ -1,36 +0,0 @@-{-# 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 ()-
− 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