snap-core 0.7.0.1 → 1.0.5.1
raw patch · 58 files changed
Files
- CONTRIBUTORS +1/−0
- README.SNAP.md +6/−7
- README.md +13/−17
- cbits/timefuncs.c +6/−1
- changelog.md +59/−0
- runTestsAndCoverage.sh +62/−0
- snap-core.cabal +221/−89
- src/Snap/Core.hs +31/−20
- src/Snap/Internal/Core.hs +2073/−0
- src/Snap/Internal/Debug.hs +63/−44
- src/Snap/Internal/Http/Types.hs +1413/−732
- src/Snap/Internal/Instances.hs +35/−35
- src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +0/−242
- src/Snap/Internal/Iteratee/Debug.hs +0/−113
- src/Snap/Internal/Parsing.hs +361/−191
- src/Snap/Internal/Parsing/FastSet.hs +0/−118
- src/Snap/Internal/Routing.hs +153/−93
- src/Snap/Internal/Test/Assertions.hs +108/−22
- src/Snap/Internal/Test/RequestBuilder.hs +661/−143
- src/Snap/Internal/Types.hs +0/−1044
- src/Snap/Internal/Util/FileServe.hs +809/−0
- src/Snap/Internal/Util/FileUploads.hs +1125/−0
- src/Snap/Iteratee.hs +0/−750
- src/Snap/Test.hs +9/−6
- src/Snap/Types.hs +0/−6
- src/Snap/Types/Headers.hs +261/−32
- src/Snap/Util/CORS.hs +281/−0
- src/Snap/Util/FileServe.hs +40/−705
- src/Snap/Util/FileUploads.hs +71/−883
- src/Snap/Util/GZip.hs +97/−78
- src/Snap/Util/Proxy.hs +90/−0
- src/Snap/Util/Readable.hs +0/−36
- test/Snap/Core/Tests.hs +954/−0
- test/Snap/Internal/Http/Types/Tests.hs +205/−0
- test/Snap/Internal/Parsing/Tests.hs +177/−0
- test/Snap/Internal/Routing/Tests.hs +513/−0
- test/Snap/Test/Common.hs +143/−0
- test/Snap/Test/Tests.hs +449/−0
- test/Snap/Types/Headers/Tests.hs +77/−0
- test/Snap/Util/CORS/Tests.hs +121/−0
- test/Snap/Util/FileServe/Tests.hs +627/−0
- test/Snap/Util/FileUploads/Tests.hs +1199/−0
- test/Snap/Util/GZip/Tests.hs +391/−0
- test/Snap/Util/Proxy/Tests.hs +164/−0
- test/TestSuite.hs +45/−0
- test/data/fileServe/mydir2/dir/foo.txt +1/−0
- test/runTestsAndCoverage.sh +0/−64
- test/snap-core-testsuite.cabal +0/−82
- test/suite/Snap/Core/Tests.hs +0/−602
- test/suite/Snap/Internal/Http/Types/Tests.hs +0/−166
- test/suite/Snap/Internal/Parsing/Tests.hs +0/−32
- test/suite/Snap/Internal/Routing/Tests.hs +0/−325
- test/suite/Snap/Iteratee/Tests.hs +0/−536
- test/suite/Snap/Test/Common.hs +0/−110
- test/suite/Snap/Util/FileServe/Tests.hs +0/−565
- test/suite/Snap/Util/FileUploads/Tests.hs +0/−601
- test/suite/Snap/Util/GZip/Tests.hs +0/−426
- test/suite/TestSuite.hs +0/−37
CONTRIBUTORS view
@@ -9,3 +9,4 @@ Jurriën Stutterheim <j.stutterheim@me.com> Jasper Van der Jeugt <m@jaspervdj.be> Bryan O'Sullivan <bos@serpentine.com>+Koz Ross <koz@mlabs.city>
README.SNAP.md view
@@ -11,19 +11,18 @@ The Snap core system consists of: - * a high-speed HTTP server, with an optional high-concurrency backend using- the [libev](http://software.schmorp.de/pkg/libev.html) library- * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML 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,11 +1,12 @@ Snap Framework Core =================== -Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by-Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more-information about Snap, read the `README.SNAP.md` or visit the Snap project-website at http://www.snapframework.com/.+[](https://github.com/snapframework/snap-core/actions) +Snap is a web framework for Haskell. For more information about Snap, read the+`README.SNAP.md` or visit the Snap project website at+http://www.snapframework.com/.+ ## Library contents This is the `snap-core` library, which contains:@@ -13,11 +14,7 @@ * primitive types and functions for HTTP (requests, responses, cookies, post/query parameters, etc). - * type aliases and helper functions for Iteratee I/O.-- * a "Snap" monad interface, inspired by- [happstack's](http://happstack.com/index.html), for programming web- handlers, which allows:+ * a "Snap" monad interface for programming web handlers, which allows: * stateful access to the HTTP request and response objects. @@ -27,7 +24,8 @@ * early termination of the computation if you know early what you want to return and want to prevent further monadic processing. - * Some useful utilities for web handlers, including gzip/zlib compression.+ * useful utilities for web handlers, like file serving and gzip/zlib+ compression. Building snap-core@@ -53,18 +51,16 @@ ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big-chunk of the code) right now is centred on the test suite. Snap aims for 100%-test coverage, and we're trying hard to stick to that.+Snap aims for 100% test coverage, and we're trying hard to stick to that. -To build the test suite, `cd` into the `test/` directory and run+To build the test suite, configure with --enable-tests: - $ cabal configure+ $ cabal configure --enable-tests $ cabal build From here you can invoke the testsuite by running: - $ ./runTestsAndCoverage.sh + $ ./runTestsAndCoverage.sh -The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.+The testsuite generates an `hpc` test coverage report in `dist/hpc`.
cbits/timefuncs.c view
@@ -1,3 +1,4 @@+#define _DEFAULT_SOURCE #define _XOPEN_SOURCE #define _BSD_SOURCE #include <time.h>@@ -9,9 +10,13 @@ } +// When given invalid input, returns 0. time_t c_parse_http_time(char* s) {+ if (s == NULL) return 0; struct tm dest;- strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest);+ if (strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest) == NULL) {+ return 0;+ } return timegm(&dest); }
+ changelog.md view
@@ -0,0 +1,59 @@+## 1.0.5.0++- Add `head` helper for `Snap.Test`+- Add support for GHC 9+- Expose Snap.Internal.Util.FileServe+- Ensure parseHttpTime returns 0 on invalid input+- Add test helper for HEAD requests+- Misc version bumps++## 1.0.4.0+- Allow `network` 3.0.++## 1.0.3.2+- Allow `unix-compat` 0.5++- Stop using deprecated Data.Map.insertWith'++- Test with GHC 8.4.1++## 1.0.3.1+- Allow `io-streams` 1.5.++## 1.0.3.0+### Added+- Alternative file upload handling into Snap.Util.FileUploads++### Fixes+- Fixed parsing of field values in multipart/form-data headers with encodings+ other than US-ASCII++## 1.0.2.1+### Dependencies+- Allow `io-streams` 1.4.++## 1.0.2.0+### Added+- Merged CORS functionality from snap-cors project into Snap.Util.CORS++### Dependencies+- Bumped `time` dependency.++## 1.0.1.1+### Fixes+- Fixed a bug in token parsing in Snap.Util.Parsing++## 1.0.1.0+### Fixes+- fixed a FileUpload exception test++- Exported `compressibleMimeTypes`++- Added a missing file to the tarball.++## 1.0.0.0+### Added+### Removed++ - Removed support for `iteratees` in favor of+ [io-streams](https://hackage.haskell.org/package/io-streams)
+ runTestsAndCoverage.sh view
@@ -0,0 +1,62 @@+#!/bin/sh++set -e++export LC_ALL=C+export LANG=C++rm -f testsuite.tix++# TODO How do we find the executable without knowing the version number in dist-newstyle?+./dist-newstyle/build/snap-core-1.0.0.0/build/testsuite/testsuite -j4 -a1000 $*++DIR="./dist-newstyle/hpc"++rm -Rf $DIR+mkdir -p $DIR+mkdir -p out++# NOTE+# Snap.Internal.Util.FileUploads shouldn't be in the excludes list. This is a+# temporary workaround so we can release.++EXCLUDES='Main+Snap.Core.Tests+Snap.Internal.Debug+Snap.Internal.Http.Parser.Tests+Snap.Internal.Http.Server.Tests+Snap.Internal.Http.Types.Tests+Snap.Internal.Parsing.Tests+Snap.Internal.Routing.Tests+Snap.Internal.Test.Assertions+Snap.Internal.Test.RequestBuilder+Snap.Internal.Util.FileUploads+Snap.Test+Snap.Test.Common+Snap.Test.Tests+Snap.Types.Tests+Snap.Types.Headers.Tests+Snap.Util.FileServe.Tests+Snap.Util.FileUploads.Tests+Snap.Util.GZip.Tests+Snap.Util.Proxy.Tests+Snap.Util.Readable.Tests+Text.Snap.Templates.Tests'++EXCL=""++for m in $EXCLUDES; do+ EXCL="$EXCL --exclude=$m"+done++hpc markup $EXCL --destdir=$DIR testsuite++rm -f testsuite.tix++#TODO only copy hpc results if this script is called from deploy_hpc.sh+cp -r $DIR out/++cat <<EOF++Test coverage report written to $DIR.+EOF
snap-core.cabal view
@@ -1,6 +1,7 @@+cabal-version: 2.2 name: snap-core-version: 0.7.0.1-synopsis: Snap: A Haskell Web Framework (Core)+version: 1.0.5.1+synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: Snap is a simple and fast web development framework and server written in@@ -13,10 +14,7 @@ 1. Primitive types and functions for HTTP (requests, responses, cookies, post/query parameters, etc) .- 2. Type aliases and helper functions for Iteratee I/O- .- 3. A monad for programming web handlers called \"Snap\", inspired by- happstack's (<http://happstack.com/index.html>), which allows:+ 2. A monad for programming web handlers called \"Snap\", which allows: . * Stateful access to the HTTP request and response objects .@@ -26,31 +24,30 @@ * Early termination of the computation if you know early what you want to return and want to prevent further monadic processing .- /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Core",- some iteratee utilities are in "Snap.Iteratee".- .- Higher-level facilities for building web applications (like user/session- management, component interfaces, data modeling, etc.) are planned but not- yet implemented, so this release will mostly be of interest for those who:- .- * need a fast and minimal HTTP API at roughly the same level of abstraction- as Java servlets, or- .- * are interested in contributing to the Snap Framework project.+ /Quick start/: The 'Snap' monad and HTTP definitions are in "Snap.Core". -license: BSD3+license: BSD-3-Clause license-file: LICENSE-author: James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley+author: Snap Framework Authors (see CONTRIBUTORS) maintainer: snap@snapframework.com build-type: Simple-cabal-version: >= 1.6 homepage: http://snapframework.com/-category: Web, Snap+bug-reports: https://github.com/snapframework/snap-core/issues+category: Web, Snap, IO-Streams +tested-with:+ GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.5+ GHC == 9.4.4+ extra-source-files:- test/suite/TestSuite.hs,+ test/TestSuite.hs, cbits/timefuncs.c, CONTRIBUTORS,+ changelog.md, extra/haddock.css, extra/hscolour.css, extra/logo.gif,@@ -59,25 +56,25 @@ README.md, README.SNAP.md, Setup.hs,+ runTestsAndCoverage.sh, test/data/fileServe/foo.bin, test/data/fileServe/foo.bin.bin.bin, test/data/fileServe/foo.html, test/data/fileServe/foo.txt, test/data/fileServe/mydir1/index.txt,+ test/data/fileServe/mydir2/dir/foo.txt, test/data/fileServe/mydir2/foo.txt, test/data/fileServe/mydir3/altindex.html,- test/runTestsAndCoverage.sh,- test/snap-core-testsuite.cabal,- test/suite/Snap/Core/Tests.hs,- test/suite/Snap/Internal/Http/Types/Tests.hs,- test/suite/Snap/Internal/Parsing/Tests.hs,- test/suite/Snap/Internal/Routing/Tests.hs,- test/suite/Snap/Iteratee/Tests.hs,- test/suite/Snap/Test/Common.hs,- test/suite/Snap/Util/FileServe/Tests.hs,- test/suite/Snap/Util/FileUploads/Tests.hs,- test/suite/Snap/Util/GZip/Tests.hs-+ test/Snap/Core/Tests.hs,+ test/Snap/Internal/Http/Types/Tests.hs,+ test/Snap/Internal/Parsing/Tests.hs,+ test/Snap/Internal/Routing/Tests.hs,+ test/Snap/Test/Common.hs,+ test/Snap/Types/Headers/Tests.hs,+ test/Snap/Util/FileServe/Tests.hs,+ test/Snap/Util/FileUploads/Tests.hs,+ test/Snap/Util/GZip/Tests.hs,+ test/Snap/Util/Proxy/Tests.hs Flag portable Description: Compile in cross-platform mode. No platform-specific code or@@ -95,7 +92,18 @@ Default: False +Flag network-uri+ Description: Get Network.URI from the network-uri package+ Default: True++common universal+ default-language: Haskell2010++ build-depends:+ , base >= 4 && < 5+ Library+ import: universal hs-source-dirs: src if !flag(debug)@@ -103,94 +111,218 @@ if flag(portable) || os(windows) cpp-options: -DPORTABLE+ build-depends: time-locale-compat == 0.1.* else c-sources: cbits/timefuncs.c include-dirs: cbits- build-depends: bytestring-mmap >= 0.2.2 && <0.3,- unix >= 2.4 && <3.0- cpp-options: -DUSE_UNIX+ build-depends: old-locale >= 1 && <2 exposed-modules: Snap.Core,- Snap.Types,- Snap.Iteratee,+ Snap.Internal.Core, Snap.Internal.Debug, Snap.Internal.Http.Types,- Snap.Internal.Iteratee.Debug, Snap.Internal.Parsing,+ Snap.Internal.Util.FileServe, Snap.Test, Snap.Types.Headers,+ Snap.Util.CORS, Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip,- Snap.Util.Readable+ Snap.Util.Proxy other-modules: Snap.Internal.Instances,- Snap.Internal.Iteratee.BoyerMooreHorspool,- Snap.Internal.Parsing.FastSet, Snap.Internal.Routing,- Snap.Internal.Types, Snap.Internal.Test.RequestBuilder,- Snap.Internal.Test.Assertions+ Snap.Internal.Test.Assertions,+ Snap.Internal.Util.FileUploads build-depends:- attoparsec >= 0.10 && < 0.11,- attoparsec-enumerator >= 0.3 && <0.4,- base >= 4 && < 5,- base16-bytestring <= 0.2,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2 && <0.3,+ HUnit >= 1.2 && < 2,+ attoparsec >= 0.12 && < 0.15,+ bytestring >= 0.9 && < 0.12,+ bytestring-builder >= 0.10.4 && < 0.11,+ case-insensitive >= 1.1 && < 1.3,+ containers >= 0.3 && < 1.0,+ directory >= 1 && < 2,+ filepath >= 1.1 && < 2.0,+ lifted-base >= 0.1 && < 0.3,+ io-streams >= 1.3 && < 1.6,+ hashable >= 1.2.0.6 && < 1.5,+ monad-control >= 1.0 && < 1.1,+ mtl >= 2.0 && < 2.4,+ random >= 1 && < 2,+ readable >= 0.1 && < 0.4,+ regex-posix >= 0.95 && < 1,+ text >= 0.11 && < 2.1,+ time >= 1.0 && < 1.14,+ transformers >= 0.3 && < 0.7,+ transformers-base >= 0.4 && < 0.5,+ unix-compat >= 0.3 && < 0.7,+ unordered-containers >= 0.1.4.3 && < 0.3,+ vector >= 0.6 && < 0.14++ other-extensions:+ BangPatterns,+ CPP,+ DeriveDataTypeable,+ EmptyDataDecls,+ ExistentialQuantification,+ FlexibleContexts,+ FlexibleInstances,+ ForeignFunctionInterface,+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ OverloadedStrings,+ OverloadedStrings,+ PackageImports,+ Rank2Types,+ ScopedTypeVariables,+ TypeSynonymInstances++ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs++ -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0++ if impl(ghc < 8.8)+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ else+ build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20++ if flag(network-uri)+ -- Leaving network-uri-2.7.0.0 out for now because it is marked deprecated+ build-depends: network-uri >= 2.6 && < 2.7,+ network >= 2.6 && < 3.2+ else+ build-depends: network-uri >= 2.5 && < 2.6,+ network >= 2.3 && < 2.6++ if !impl(ghc >= 7.6)+ build-depends: unix-compat >= 0.3 && < 0.5.3+++Test-suite testsuite+ import: universal+ hs-source-dirs: src test+ Type: exitcode-stdio-1.0+ Main-is: TestSuite.hs++ if flag(portable) || os(windows)+ cpp-options: -DPORTABLE+ build-depends: time-locale-compat == 0.1.*+ else+ c-sources: cbits/timefuncs.c+ include-dirs: cbits+ build-depends: old-locale >= 1 && <2++ other-modules:+ Snap.Core,+ Snap.Internal.Debug,+ Snap.Internal.Http.Types,+ Snap.Internal.Parsing,+ Snap.Test,+ Snap.Types.Headers,+ Snap.Util.CORS,+ Snap.Util.FileServe,+ Snap.Util.FileUploads,+ Snap.Util.GZip,+ Snap.Util.Proxy,+ Snap.Internal.Core,+ Snap.Internal.Instances,+ Snap.Internal.Routing,+ Snap.Internal.Test.RequestBuilder,+ Snap.Internal.Test.Assertions,+ Snap.Internal.Util.FileServe,+ Snap.Internal.Util.FileUploads,+ --------------------------------------------------------------------------+ Snap.Core.Tests,+ Snap.Internal.Http.Types.Tests,+ Snap.Internal.Parsing.Tests,+ Snap.Internal.Routing.Tests,+ Snap.Test.Common,+ Snap.Test.Tests,+ Snap.Types.Headers.Tests,+ Snap.Util.CORS.Tests,+ Snap.Util.FileServe.Tests,+ Snap.Util.FileUploads.Tests,+ Snap.Util.GZip.Tests,+ Snap.Util.Proxy.Tests++ build-depends:+ HUnit,+ attoparsec, bytestring,- bytestring-nums,- case-insensitive >= 0.3 && < 0.5,+ bytestring-builder,+ case-insensitive, containers,- deepseq >= 1.1 && <1.4, directory,- dlist >= 0.5 && < 0.6,- enumerator >= 0.4.13.1 && < 0.5, filepath,- HUnit >= 1.2 && < 2,- MonadCatchIO-transformers >= 0.2.1 && < 0.3,- mtl == 2.0.*,- mwc-random >= 0.10 && <0.11,- old-locale,- old-time,- regex-posix <= 0.95.2,- text >= 0.11 && <0.12,- time >= 1.0 && < 1.5,- transformers == 0.2.*,- unix-compat >= 0.2 && <0.4,- unordered-containers >= 0.1.4.3 && <0.2,- vector >= 0.6 && <0.10,- zlib-enum >= 0.2.1 && <0.3+ hashable,+ lifted-base,+ io-streams,+ monad-control,+ mtl,+ random,+ readable,+ regex-posix,+ text,+ time,+ transformers,+ transformers-base,+ unix-compat,+ unordered-containers,+ vector,+ --------------------------------------------------------------------------+ QuickCheck >= 2.3.0.2 && <3,+ deepseq >= 1.1 && < 1.5,+ 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,+ zlib >= 0.5 && <0.7 - extensions:+ if flag(network-uri)+ build-depends: network-uri,+ network+ else+ build-depends: network-uri,+ network++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded+ -fno-warn-unused-do-bind++ -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+ if impl(ghc < 8.8)+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ else+ build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20++ other-extensions: BangPatterns, CPP,- PackageImports,- ScopedTypeVariables,+ DeriveDataTypeable, EmptyDataDecls,- ForeignFunctionInterface,- OverloadedStrings,- Rank2Types,- TypeSynonymInstances,- FlexibleInstances, ExistentialQuantification,- OverloadedStrings, FlexibleContexts,+ FlexibleInstances,+ ForeignFunctionInterface, GeneralizedNewtypeDeriving,- DeriveDataTypeable,- MultiParamTypeClasses-- ghc-prof-options: -prof -auto-all-- if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind- else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ MagicHash,+ MultiParamTypeClasses,+ OverloadedStrings,+ Rank2Types,+ ScopedTypeVariables,+ StandaloneDeriving,+ TypeFamilies,+ TypeSynonymInstances source-repository head type: git
src/Snap/Core.hs view
@@ -11,15 +11,18 @@ , runSnap , MonadSnap(..) , NoHandlerException(..)- , EscapeHttpException(..) -- ** Functions for control flow and early termination , bracketSnap , finishWith , catchFinishWith , pass- , terminateConnection++ -- *** Escaping HTTP+ , EscapeHttpHandler+ , EscapeSnap(..) , escapeHttp+ , terminateConnection -- ** Routing , method@@ -49,7 +52,6 @@ -- ** Grabbing/transforming request bodies , runRequestBody- , getRequestBody , readRequestBody , transformRequestBody @@ -69,18 +71,18 @@ , addHeader , setHeader , getHeader- , getHeaders , listHeaders , deleteHeader , ipHeaderFilter , ipHeaderFilter' -- ** Requests- , rqServerName+ , rqHeaders+ , rqHostName+ , rqClientAddr+ , rqClientPort+ , rqServerAddr , rqServerPort- , rqRemoteAddr- , rqRemotePort- , rqLocalAddr , rqLocalHostname , rqIsSecure , rqContentLength@@ -92,12 +94,24 @@ , rqURI , rqQueryString , rqParams+ , rqQueryParams+ , rqPostParams , rqParam+ , rqPostParam+ , rqQueryParam , getParam+ , getPostParam+ , getQueryParam , getParams+ , getPostParams+ , getQueryParams , rqModifyParams , rqSetParam + -- *** Deprecated functions+ , rqRemoteAddr+ , rqRemotePort+ -- ** Responses , emptyResponse , setResponseCode@@ -132,11 +146,9 @@ -- ** Timeouts , setTimeout- , getTimeoutAction-- -- * Iteratee- , Enumerator- , SomeEnumerator(..)+ , extendTimeout+ , modifyTimeout+ , getTimeoutModifier -- * HTTP utilities , formatHttpTime@@ -150,13 +162,12 @@ ) where -------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Instances ()-import Snap.Internal.Parsing-import Snap.Internal.Routing-import Snap.Internal.Types-import Snap.Iteratee (Enumerator)-import Snap.Types.Headers (Headers)+import Snap.Internal.Core (EscapeHttpHandler, EscapeSnap (..), MonadSnap (..), NoHandlerException (..), Snap, addToOutput, bracketSnap, catchFinishWith, dir, escapeHttp, expireCookie, extendTimeout, finishWith, getCookie, getParam, getParams, getPostParam, getPostParams, getQueryParam, getQueryParams, getRequest, getResponse, getTimeoutModifier, getsRequest, getsResponse, ifTop, ipHeaderFilter, ipHeaderFilter', localRequest, logError, method, methods, modifyRequest, modifyResponse, modifyTimeout, pass, path, pathArg, putRequest, putResponse, readCookie, readRequestBody, redirect, redirect', runRequestBody, runSnap, sendFile, sendFilePartial, setTimeout, terminateConnection, transformRequestBody, withRequest, withResponse, writeBS, writeBuilder, writeLBS, writeLazyText, writeText)+import Snap.Internal.Http.Types (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (rqClientAddr, rqClientPort, rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqLocalHostname, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqServerAddr, rqServerPort, rqURI, rqVersion), Response (rspStatus, rspStatusReason), addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqRemoteAddr, rqRemotePort, rqSetParam, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus)+import Snap.Internal.Instances ()+import Snap.Internal.Parsing (buildUrlEncoded, parseUrlEncoded, printUrlEncoded, urlDecode, urlEncode, urlEncodeBuilder)+import Snap.Internal.Routing (route, routeLocal)+import Snap.Types.Headers (Headers) ------------------------------------------------------------------------------ -- $httpDoc
+ src/Snap/Internal/Core.hs view
@@ -0,0 +1,2073 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE StandaloneDeriving #-}+#endif++module Snap.Internal.Core+ ( MonadSnap(..)+ , SnapResult(..)+ , EscapeHttpHandler+ , EscapeSnap(..)+ , Zero(..)+ , Snap(..)+ , SnapState(..)+ , runRequestBody+ , readRequestBody+ , transformRequestBody+ , finishWith+ , catchFinishWith+ , pass+ , method+ , methods+ , updateContextPath+ , pathWith+ , dir+ , path+ , pathArg+ , ifTop+ , sget+ , smodify+ , getRequest+ , getResponse+ , getsRequest+ , getsResponse+ , putRequest+ , putResponse+ , modifyRequest+ , modifyResponse+ , redirect+ , redirect'+ , logError+ , addToOutput+ , writeBuilder+ , writeBS+ , writeLBS+ , writeText+ , writeLazyText+ , sendFile+ , sendFilePartial+ , localRequest+ , withRequest+ , withResponse+ , ipHeaderFilter+ , ipHeaderFilter'+ , bracketSnap+ , NoHandlerException(..)+ , terminateConnection+ , escapeHttp+ , runSnap+ , fixupResponse+ , evalSnap+ , getParamFrom+ , getParam+ , getPostParam+ , getQueryParam+ , getParams+ , getPostParams+ , getQueryParams+ , getCookie+ , readCookie+ , expireCookie+ , setTimeout+ , extendTimeout+ , modifyTimeout+ , getTimeoutModifier+ , module Snap.Internal.Http.Types+ ) where++------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>), empty), Applicative ((<*>), pure), (<$>))+import Control.Exception.Lifted (ErrorCall (..), Exception, Handler (..), SomeException (..), catch, catches, mask, onException, throwIO)+import Control.Monad (Functor (..), Monad (..), MonadPlus (..), ap, liftM, unless, (=<<))+import qualified Control.Monad.Fail as Fail+import Control.Monad.Base (MonadBase (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.State (StateT (..))+import Data.ByteString.Builder (Builder, byteString, lazyByteString)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S (break, concat, drop, dropWhile, intercalate, length, take, takeWhile)+import qualified Data.ByteString.Internal as S (create)+import qualified Data.ByteString.Lazy.Char8 as L (ByteString, fromChunks)+import Data.CaseInsensitive (CI)+import Data.Maybe (Maybe (..), listToMaybe, maybe)+import qualified Data.Text as T (Text)+import qualified Data.Text.Encoding as T (encodeUtf8)+import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8)+import qualified Data.Text.Lazy as LT (Text)+import Data.Time (Day (ModifiedJulianDay), UTCTime (UTCTime))+#if __GLASGOW_HASKELL__ < 708+import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp)+#else+import Data.Typeable (Typeable)+#endif+import Data.Word (Word64, Word8)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (poke)+import Prelude (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Ord (..), Show (..), String, const, divMod, elem, filter, fromIntegral, id, map, max, otherwise, quot, ($), ($!), (++), (.), (||))+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import System.Posix.Types (FileOffset)+import System.PosixCompat.Files (fileSize, getFileStatus)+#if !MIN_VERSION_bytestring(0,10,6)+import qualified Data.ByteString.Internal as S (inlinePerformIO)+#else+import qualified Data.ByteString.Internal as S (accursedUnutterablePerformIO)+#endif+------------------------------------------------------------------------------+import qualified Data.Readable as R+import Snap.Internal.Http.Types (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (..), Response (..), ResponseBody (..), StreamProc, addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, normalizeMethod, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqSetParam, rspBodyMap, rspBodyToEnum, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus, statusReasonMap)+import Snap.Internal.Parsing (urlDecode)+import qualified Snap.Types.Headers as H+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes it+-- easy to wrap 'Snap' inside monad transformers.+class (Monad m, MonadIO m, MonadBaseControl IO m, MonadPlus m, Functor m,+ Applicative m, Alternative m) => MonadSnap m where+ -- | Lift a computation from the 'Snap' monad.+ liftSnap :: Snap a -> m a+++------------------------------------------------------------------------------+data SnapResult a = SnapValue a+ | Zero Zero+++------------------------------------------------------------------------------+-- | Type of external handler passed to 'escapeHttp'.+type EscapeHttpHandler = ((Int -> Int) -> IO ()) -- ^ timeout modifier+ -> InputStream ByteString -- ^ socket read end+ -> OutputStream Builder -- ^ socket write end+ -> IO ()+++------------------------------------------------------------------------------+-- | Used internally to implement 'escapeHttp'.+data EscapeSnap = TerminateConnection SomeException+ | EscapeHttp EscapeHttpHandler+ deriving (Typeable)++instance Exception EscapeSnap++instance Show EscapeSnap where+ show (TerminateConnection e) = "<terminated: " ++ show e ++ ">"+ show (EscapeHttp _) = "<escape http>"+++------------------------------------------------------------------------------+data Zero = PassOnProcessing+ | EarlyTermination Response+ | EscapeSnap EscapeSnap++ --------------------+ -- The Snap Monad --+ --------------------+{-|+'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you:++1. Stateful access to fetch or modify an HTTP 'Request'.++ @+ printRqContextPath :: Snap ()+ printRqContextPath = 'writeBS' . 'rqContextPath' =<< 'getRequest'+ @++2. Stateful access to fetch or modify an HTTP 'Response'.++ @+ printRspStatusReason :: Snap ()+ printRspStatusReason = 'writeBS' . 'rspStatusReason' =<< 'getResponse'+ @++3. Failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can+choose not to handle a given request, using 'empty' or its synonym 'pass', and+you can try alternative handlers with the '<|>' operator:++ @+ a :: Snap String+ a = 'pass'++ b :: Snap String+ b = return \"foo\"++ c :: Snap String+ c = a '<|>' b -- try running a, if it fails then try b+ @++4. Convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText',+'addToOutput') for queueing output to be written to the 'Response', or for+streaming to the response using+<http://hackage.haskell.org/package/io-streams io-streams>:++ @+ example :: ('OutputStream' 'Builder' -> IO ('OutputStream' 'Builder')) -> Snap ()+ example streamProc = do+ 'writeBS' \"I\'m a strict bytestring\"+ 'writeLBS' \"I\'m a lazy bytestring\"+ 'writeText' \"I\'m strict text\"+ 'addToOutput' streamProc+ @++5. Early termination: if you call 'finishWith':++ @+ a :: Snap ()+ a = do+ 'modifyResponse' $ 'setResponseStatus' 500 \"Internal Server Error\"+ 'writeBS' \"500 error\"+ r <- 'getResponse'+ 'finishWith' r+ @++ then any subsequent processing will be skipped and the supplied 'Response'+ value will be returned from 'runSnap' as-is.++6. Access to the 'IO' monad through a 'MonadIO' instance:++ @+ a :: Snap ()+ a = 'liftIO' fireTheMissiles+ @++7. The ability to set or extend a timeout which will kill the handler thread+after @N@ seconds of inactivity (the default is 20 seconds):++ @+ a :: Snap ()+ a = 'setTimeout' 30+ @++8. Throw and catch exceptions using a 'MonadBaseControl' instance:++ @+ import "Control.Exception.Lifted" ('SomeException', 'throwIO', 'catch')++ foo :: Snap ()+ foo = bar \`catch\` \(e::'SomeException') -> baz+ where+ bar = 'throwIO' FooException+ @++9. Log a message to the error log:++ @+ foo :: Snap ()+ foo = 'logError' \"grumble.\"+ @+-}++-- Haddock comment broken in two to work around https://github.com/haskell/haddock/issues/313++-- | You may notice that most of the type signatures in this module contain a+-- @('MonadSnap' m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass+-- which, in essence, says \"you can get back to the 'Snap' monad from+-- here\". Using 'MonadSnap' you can extend the 'Snap' monad with additional+-- functionality and still have access to most of the 'Snap' functions without+-- writing 'Control.Monad.Trans.Class.lift' everywhere. Instances are already+-- provided for most of the common monad transformers+-- ('Control.Monad.Trans.Reader.ReaderT', 'Control.Monad.Trans.Writer.WriterT',+-- 'Control.Monad.Trans.State.StateT', etc.).+newtype Snap a = Snap {+ unSnap :: forall r . (a -> SnapState -> IO r) -- success continuation+ -> (Zero -> SnapState -> IO r) -- mzero continuation+ -> SnapState -- state for the monad+ -> IO r+ }+++------------------------------------------------------------------------------+data SnapState = SnapState+ { _snapRequest :: Request+ , _snapResponse :: Response+ , _snapLogError :: ByteString -> IO ()+ , _snapModifyTimeout :: (Int -> Int) -> IO ()+ }++-- TODO(greg): error log action and timeout modifier are never modified.+-- Splitting them out into their own datatype would save 16 bytes of allocation+-- every time you modify the request or response, but would gobble a register.+-- Benchmark it both ways.++------------------------------------------------------------------------------+instance Monad Snap where+ (>>=) = snapBind+#if !MIN_VERSION_base(4,8,0)+ -- pre-AMP+ return = pure+ {-# INLINE return #-}+#endif+#if !MIN_VERSION_base(4,13,0)+ fail = Fail.fail+#endif++instance Fail.MonadFail Snap where+ fail = snapFail++------------------------------------------------------------------------------+snapBind :: Snap a -> (a -> Snap b) -> Snap b+snapBind m f = Snap $ \sk fk st -> unSnap m (\a st' -> unSnap (f a) sk fk st') fk st+{-# INLINE snapBind #-}++snapFail :: String -> Snap a+snapFail !_ = Snap $ \_ fk st -> fk PassOnProcessing st+{-# INLINE snapFail #-}+++------------------------------------------------------------------------------+instance MonadIO Snap where+ liftIO m = Snap $ \sk _ st -> do x <- m+ sk x st+++------------------------------------------------------------------------------+instance (MonadBase IO) Snap where+ liftBase = liftIO+++------------------------------------------------------------------------------+newtype StSnap a = StSnap {+ unStSnap :: StM (StateT SnapState IO) (SnapResult a)+ }++instance (MonadBaseControl IO) Snap where+ type StM Snap a = StSnap a++ liftBaseWith f = stateTToSnap $ liftM SnapValue $+ liftBaseWith $ \g' -> f $ \m ->+ liftM StSnap $ g' $ snapToStateT m+ {-# INLINE liftBaseWith #-}++ restoreM = stateTToSnap . restoreM . unStSnap+ {-# INLINE restoreM #-}++------------------------------------------------------------------------------+snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)+snapToStateT m = StateT $ \st -> do+ unSnap m (\a st' -> return (SnapValue a, st'))+ (\z st' -> return (Zero z, st')) st+{-# INLINE snapToStateT #-}+++------------------------------------------------------------------------------+{-# INLINE stateTToSnap #-}+stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a+stateTToSnap m = Snap $ \sk fk st -> do+ (a, st') <- runStateT m st+ case a of+ SnapValue x -> sk x st'+ Zero z -> fk z st'+++------------------------------------------------------------------------------+instance MonadPlus Snap where+ mzero = Snap $ \_ fk st -> fk PassOnProcessing st++ a `mplus` b =+ Snap $ \sk fk st ->+ let fk' z st' = case z of+ PassOnProcessing -> unSnap b sk fk st'+ _ -> fk z st'+ in unSnap a sk fk' st+++------------------------------------------------------------------------------+instance Functor Snap where+ fmap f m = Snap $ \sk fk st -> unSnap m (sk . f) fk st++------------------------------------------------------------------------------+instance Applicative Snap where+ pure x = Snap $ \sk _ st -> sk x st+ (<*>) = ap+++------------------------------------------------------------------------------+instance Alternative Snap where+ empty = mzero+ (<|>) = mplus+++------------------------------------------------------------------------------+instance MonadSnap Snap where+ liftSnap = id+++------------------------------------------------------------------------------+-- | The Typeable instance is here so Snap can be dynamically executed with+-- Hint.+#if __GLASGOW_HASKELL__ < 708+snapTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+snapTyCon = mkTyCon3 "snap-core" "Snap.Core" "Snap"+#else+snapTyCon = mkTyCon "Snap.Core.Snap"+#endif+{-# NOINLINE snapTyCon #-}++instance Typeable1 Snap where+ typeOf1 _ = mkTyConApp snapTyCon []+#else+deriving instance Typeable Snap+#endif++------------------------------------------------------------------------------+-- | Pass the request body stream to a consuming procedure, returning the+-- result.+--+-- If the consuming procedure you pass in here throws an exception, Snap will+-- attempt to clear the rest of the unread request body (using+-- 'System.IO.Streams.Combinators.skipToEof') before rethrowing the+-- exception. If you used 'terminateConnection', however, Snap will give up and+-- immediately close the socket.+--+-- To prevent slowloris attacks, the connection will be also terminated if the+-- input socket produces data too slowly (500 bytes per second is the default+-- limit).+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> import qualified "Data.ByteString.Lazy" as L+-- ghci> import "Data.Char" (toUpper)+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"+-- ghci> :{+-- ghci| let f s = do u \<- Streams.map (B8.map toUpper) s+-- ghci| l \<- Streams.toList u+-- ghci| return $ L.fromChunks l+-- ghci| :}+-- ghci> T.runHandler r ('runRequestBody' f >>= 'writeLBS')+-- HTTP/1.1 200 OK+-- server: Snap/test+-- date: Thu, 07 Aug 2014 20:48:40 GMT+--+-- SOME TEXT+-- @+runRequestBody :: MonadSnap m =>+ (InputStream ByteString -> IO a)+ -> m a+runRequestBody proc = do+ bumpTimeout <- liftM ($ max 5) getTimeoutModifier+ req <- getRequest+ body <- liftIO $ Streams.throwIfTooSlow bumpTimeout 500 5 $+ rqBody req+ run body++ where+ skip body = liftIO (Streams.skipToEof body) `catch` tooSlow++ tooSlow (e :: Streams.RateTooSlowException) =+ terminateConnection e++ run body = (liftIO $ do+ x <- proc body+ Streams.skipToEof body+ return x) `catches` handlers+ where+ handlers = [ Handler tooSlow, Handler other ]+ other (e :: SomeException) = skip body >> throwIO e+++------------------------------------------------------------------------------+-- | Returns the request body as a lazy bytestring. /Note that the request is+-- not actually provided lazily!/+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"+-- ghci> T.runHandler r ('readRequestBody' 2048 >>= 'writeLBS')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 20:08:44 GMT+--+-- some text+-- @+--+-- /Since: 0.6/+readRequestBody :: MonadSnap m =>+ Word64 -- ^ size of the largest request body we're willing+ -- to accept. If a request body longer than this is+ -- received, a 'TooManyBytesReadException' is+ -- thrown. See 'takeNoMoreThan'.+ -> m L.ByteString+readRequestBody sz = liftM L.fromChunks $ runRequestBody f+ where+ f str = Streams.throwIfProducesMoreThan (fromIntegral sz) str >>=+ Streams.toList+++------------------------------------------------------------------------------+-- | Normally Snap is careful to ensure that the request body is fully+-- consumed after your web handler runs, but before the 'Response' body+-- is streamed out the socket. If you want to transform the request body into+-- some output in O(1) space, you should use this function.+--+-- Take care: in order for this to work, the HTTP client must be written with+-- input-to-output streaming in mind.+--+-- Note that upon calling this function, response processing finishes early as+-- if you called 'finishWith'. Make sure you set any content types, headers,+-- cookies, etc. before you call this function.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> import "Data.Char" (toUpper)+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"+-- ghci> let f = Streams.map (B8.map toUpper)+-- ghci> T.runHandler r ('transformRequestBody' f >> 'readRequestBody' 2048 >>= 'writeLBS')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 20:30:15 GMT+--+-- SOME TEXT+-- @+transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString))+ -- ^ the 'InputStream' from the 'Request' is passed to+ -- this function, and then the resulting 'InputStream'+ -- is fed to the output.+ -> Snap ()+transformRequestBody trans = do+ req <- getRequest+ is <- liftIO ((trans $ rqBody req) >>=+ Streams.mapM (return . byteString))+ origRsp <- getResponse+ let rsp = setResponseBody (\out -> Streams.connect is out >> return out) $+ origRsp { rspTransformingRqBody = True }+ finishWith rsp+++------------------------------------------------------------------------------+-- | Short-circuits a 'Snap' monad action early, storing the given+-- 'Response' value in its state.+--+-- IMPORTANT: Be vary careful when using this with things like a DB library's+-- `withTransaction` function or any other kind of setup/teardown block, as it+-- can prevent the cleanup from being called and result in resource leaks.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import "Control.Applicative"+-- ghci> let r = T.get \"\/\" M.empty+-- ghci> T.runHandler r (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 16:58:57 GMT+--+-- TOP+-- ghci> let r\' = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r\' (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 17:50:50 GMT+--+--+-- @+finishWith :: MonadSnap m => Response -> m a+finishWith r = liftSnap $ Snap $ \_ fk st -> fk (EarlyTermination r) st+{-# INLINE finishWith #-}+++------------------------------------------------------------------------------+-- | Capture the flow of control in case a handler calls 'finishWith'.+--+-- /WARNING/: in the event of a call to 'transformRequestBody' it is possible+-- to violate HTTP protocol safety when using this function. If you call+-- 'catchFinishWith' it is suggested that you do not modify the body of the+-- 'Response' which was passed to the 'finishWith' call.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import "Control.Applicative"+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> let h = ('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse'+-- ghci> T.runHandler r ('catchFinishWith' h >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 18:35:42 GMT+--+-- Left HTTP\/1.1 200 OK+--+--+-- @+catchFinishWith :: Snap a -> Snap (Either Response a)+catchFinishWith (Snap m) = Snap $ \sk fk st -> do+ let sk' v s = sk (Right v) s+ let fk' z s = case z of+ (EarlyTermination resp) -> sk (Left resp) s+ _ -> fk z s+ m sk' fk' st+{-# INLINE catchFinishWith #-}+++------------------------------------------------------------------------------+-- | Fails out of a 'Snap' monad action. This is used to indicate+-- that you choose not to handle the given request within the given+-- handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r 'pass'+-- HTTP\/1.1 404 Not Found+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 13:35:42 GMT+--+-- \<!DOCTYPE html>+-- \<html>+-- \<head>+-- \<title>Not found\<\/title>+-- \<\/head>+-- \<body>+-- \<code>No handler accepted \"\/foo\/bar\"<\/code>+-- \<\/body>\<\/html>+-- @+pass :: MonadSnap m => m a+pass = empty+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only if the request's HTTP method matches+-- the given method.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('method' 'GET' $ 'writeBS' \"OK\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 13:38:48 GMT+--+-- OK+-- ghci> T.runHandler r ('method' 'POST' $ 'writeBS' \"OK\")+-- HTTP\/1.1 404 Not Found+-- ...+-- @+method :: MonadSnap m => Method -> m a -> m a+method m action = do+ req <- getRequest+ unless (rqMethod req == m) pass+ action+{-# INLINE method #-}+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only if the request's HTTP method matches+-- one of the given methods.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('methods' ['GET', 'POST'] $ 'writeBS' \"OK\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 13:38:48 GMT+--+-- OK+-- ghci> T.runHandler r ('methods' ['POST'] $ 'writeBS' \"OK\")+-- HTTP\/1.1 404 Not Found+-- ...+-- @+methods :: MonadSnap m => [Method] -> m a -> m a+methods ms action = do+ req <- getRequest+ unless (rqMethod req `elem` ms) pass+ action+{-# INLINE methods #-}+++------------------------------------------------------------------------------+-- Appends n bytes of the path info to the context path with a+-- trailing slash.+updateContextPath :: Int -> Request -> Request+updateContextPath n req | n > 0 = req { rqContextPath = ctx+ , rqPathInfo = pinfo }+ | otherwise = req+ where+ ctx' = S.take n (rqPathInfo req)+ ctx = S.concat [rqContextPath req, ctx', "/"]+ pinfo = S.drop (n+1) (rqPathInfo req)+++------------------------------------------------------------------------------+-- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given+-- predicate.+pathWith :: MonadSnap m+ => (ByteString -> ByteString -> Bool)+ -> ByteString+ -> m a+ -> m a+pathWith c p action = do+ req <- getRequest+ unless (c p (rqPathInfo req)) pass+ localRequest (updateContextPath $ S.length p) action+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request+-- starts with the given path. For example,+--+-- > dir "foo" handler+--+-- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will+-- add @\"foo\/\"@ to the handler's local 'rqContextPath'.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('dir' \"foo\" $ 'writeBS' \"OK\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 14:52:24 GMT+--+-- OK+-- ghci> T.runHandler r ('dir' \"baz\" $ 'writeBS' \"OK\")+-- HTTP\/1.1 404 Not Found+-- ...+-- @+dir :: MonadSnap m+ => ByteString -- ^ path component to match+ -> m a -- ^ handler to run+ -> m a+dir = pathWith f+ where+ f dr pinfo = dr == x+ where+ (x,_) = S.break (=='/') pinfo+{-# INLINE dir #-}+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is+-- exactly equal to the given string. If the path matches, locally sets+-- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\",+-- and runs the given handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"foo\" $ 'writeBS' \"bar\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 14:15:42 GMT+--+-- bar+-- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"bar\" $ 'writeBS' \"baz\")+-- HTTP\/1.1 404 Not Found+-- ...+-- @+path :: MonadSnap m+ => ByteString -- ^ path to match against+ -> m a -- ^ handler to run+ -> m a+path = pathWith (==)+{-# INLINE path #-}+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only when the first path component is+-- successfully parsed as the argument to the supplied handler function.+--+-- Note that the path segment is url-decoded prior to being passed to 'fromBS';+-- this is new as of snap-core 0.10.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/11\/foo\/bar\" M.empty+-- ghci> let f = (\\i -> if i == 11 then 'writeBS' \"11\" else 'writeBS' \"???\")+-- ghci> T.runHandler r ('pathArg' f)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 14:27:10 GMT+--+-- 11+-- ghci> let r\' = T.get \"\/foo\/11\/bar\" M.empty+-- ghci> T.runHandler r\' ('pathArg' f)+-- HTTP\/1.1 404 Not Found+-- ...+-- @+pathArg :: (R.Readable a, MonadSnap m)+ => (a -> m b)+ -> m b+pathArg f = do+ req <- getRequest+ let (p,_) = S.break (=='/') (rqPathInfo req)+ p' <- maybe mzero return $ urlDecode p+ a <- R.fromBS p'+ localRequest (updateContextPath $ S.length p) (f a)+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/\" M.empty+-- ghci> T.runHandler r ('ifTop' $ 'writeBS' "OK")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 14:56:39 GMT+--+-- OK+-- ghci> let r\' = T.get \"\/foo\" M.empty+-- ghci> T.runHandler r\' ('ifTop' $ 'writeBS' \"OK\")+-- HTTP\/1.1 404 Not Found+-- ...+-- @+ifTop :: MonadSnap m => m a -> m a+ifTop = path ""+{-# INLINE ifTop #-}+++------------------------------------------------------------------------------+-- | Local Snap version of 'get'.+sget :: Snap SnapState+sget = Snap $ \sk _ st -> sk st st+{-# INLINE sget #-}+++------------------------------------------------------------------------------+-- | Local Snap monad version of 'modify'.+smodify :: (SnapState -> SnapState) -> Snap ()+smodify f = Snap $ \sk _ st -> sk () (f st)+{-# INLINE smodify #-}+++------------------------------------------------------------------------------+-- | Grabs the 'Request' object out of the 'Snap' monad.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBS' . 'rqURI' =\<\< 'getRequest')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Sat, 02 Aug 2014 07:51:54 GMT+--+-- \/foo\/bar+-- @+getRequest :: MonadSnap m => m Request+getRequest = liftSnap $ liftM _snapRequest sget+{-# INLINE getRequest #-}+++------------------------------------------------------------------------------+-- | Grabs something out of the 'Request' object, using the given projection+-- function. See 'gets'.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBS' =\<\< 'getsRequest' 'rqURI')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Sat, 02 Aug 2014 07:51:54 GMT+--+-- \/foo\/bar+-- @+getsRequest :: MonadSnap m => (Request -> a) -> m a+getsRequest f = liftSnap $ liftM (f . _snapRequest) sget+{-# INLINE getsRequest #-}+++------------------------------------------------------------------------------+-- | Grabs the 'Response' object out of the 'Snap' monad.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBS' . 'rspStatusReason' =\<\< 'getResponse')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Sat, 02 Aug 2014 15:06:00 GMT+--+-- OK+-- @+getResponse :: MonadSnap m => m Response+getResponse = liftSnap $ liftM _snapResponse sget+{-# INLINE getResponse #-}+++------------------------------------------------------------------------------+-- | Grabs something out of the 'Response' object, using the given projection+-- function. See 'gets'.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBS' =\<\< 'getsResponse' 'rspStatusReason')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 13:35:45 GMT+--+-- OK+-- @+getsResponse :: MonadSnap m => (Response -> a) -> m a+getsResponse f = liftSnap $ liftM (f . _snapResponse) sget+{-# INLINE getsResponse #-}+++------------------------------------------------------------------------------+-- | Puts a new 'Response' object into the 'Snap' monad.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let rsp = 'setResponseCode' 404 'emptyResponse'+-- ghci> let req = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler req ('putResponse' rsp)+-- HTTP\/1.1 404 Not Found+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 13:59:58 GMT+--+--+-- @+putResponse :: MonadSnap m => Response -> m ()+putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r }+{-# INLINE putResponse #-}+++------------------------------------------------------------------------------+-- | Puts a new 'Request' object into the 'Snap' monad.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> :{+-- ghci| let hndlr = do rq \<- T.buildRequest (T.get \"\/bar\/foo\" M.empty)+-- ghci| 'putRequest' rq+-- ghci| uri\' \<- 'getsRequest' 'rqURI'+-- ghci| 'writeBS' uri\'+-- ghci| :}+-- ghci> T.runHandler (T.get \"\/foo\/bar\" M.empty) hndlr+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:13:46 GMT+--+-- \/bar\/foo+-- @+putRequest :: MonadSnap m => Request -> m ()+putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r }+{-# INLINE putRequest #-}+++------------------------------------------------------------------------------+-- | Modifies the 'Request' object stored in a 'Snap' monad.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty+-- ghci> T.runHandler r ('modifyRequest' (const r\') >> 'getsRequest' 'rqURI' >>= 'writeBS')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:24:25 GMT+--+-- \/bar\/foo+-- @+modifyRequest :: MonadSnap m => (Request -> Request) -> m ()+modifyRequest f = liftSnap $+ smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss }+{-# INLINE modifyRequest #-}+++------------------------------------------------------------------------------+-- | Modifes the 'Response' object stored in a 'Snap' monad.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('modifyResponse' $ 'setResponseCode' 404)+-- HTTP\/1.1 404 Not Found+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:27:11 GMT+--+--+-- @+modifyResponse :: MonadSnap m => (Response -> Response) -> m ()+modifyResponse f = liftSnap $+ smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss }+{-# INLINE modifyResponse #-}+++------------------------------------------------------------------------------+-- | Performs a redirect by setting the @Location@ header to the given target+-- URL/path and the status code to 302 in the 'Response' object stored in a+-- 'Snap' monad. Note that the target URL is not validated in any way.+-- Consider using 'redirect'' instead, which allows you to choose the correct+-- status code.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('redirect' \"http:\/\/snapframework.com\")+-- HTTP\/1.1 302 Found+-- content-length: 0+-- location: http:\/\/snapframework.com+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 08:52:11 GMT+-- Content-Length: 0+--+--+-- @+redirect :: MonadSnap m => ByteString -> m a+redirect target = redirect' target 302+{-# INLINE redirect #-}+++------------------------------------------------------------------------------+-- | Performs a redirect by setting the @Location@ header to the given target+-- URL/path and the status code (should be one of 301, 302, 303 or 307) in the+-- 'Response' object stored in a 'Snap' monad. Note that the target URL is not+-- validated in any way.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('redirect'' \"http:\/\/snapframework.com\" 301)+-- HTTP\/1.1 307 Temporary Redirect+-- content-length: 0+-- location: http:\/\/snapframework.com+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 08:55:51 GMT+-- Content-Length: 0+--+--+-- @+redirect' :: MonadSnap m => ByteString -> Int -> m a+redirect' target status = do+ r <- getResponse++ finishWith+ $ setResponseCode status+ $ setContentLength 0+ $ modifyResponseBody (const $ return . id)+ $ setHeader "Location" target r++{-# INLINE redirect' #-}+++------------------------------------------------------------------------------+-- | Log an error message in the 'Snap' monad.+--+-- Example:+--+-- @+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> 'runSnap' ('logError' \"fatal error!\") ('error' . B8.unpack) undefined undefined+-- *** Exception: fatal error!+-- @+logError :: MonadSnap m => ByteString -> m ()+logError s = liftSnap $ Snap $ \sk _ st -> do+ _snapLogError st s+ sk () st+{-# INLINE logError #-}+++------------------------------------------------------------------------------+-- | Run the given stream procedure, adding its output to the 'Response' stored+-- in the 'Snap' monad state.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Builder" as B+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> :{+-- ghci| let f str = do {+-- ghci| Streams.write (Just $ B.byteString \"Hello, streams world\") str;+-- ghci| return str }+-- ghci| :}+-- ghci> T.runHandler r ('addToOutput' f)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:55:47 GMT+--+-- Hello, streams world+-- @+addToOutput :: MonadSnap m+ => (OutputStream Builder -> IO (OutputStream Builder))+ -- ^ output to add+ -> m ()+addToOutput enum = modifyResponse $ modifyResponseBody (c enum)+ where+ c a b = \out -> b out >>= a++------------------------------------------------------------------------------+-- | Adds the given 'Builder' to the body of the 'Response' stored in the+-- | 'Snap' monad state.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Builder" as B+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBuilder' $ B.byteString \"Hello, world\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:33:33 GMT+--+-- Hello, world+-- @+writeBuilder :: MonadSnap m => Builder -> m ()+writeBuilder b = addToOutput f+ where+ f str = Streams.write (Just b) str >> return str+{-# INLINE writeBuilder #-}+++------------------------------------------------------------------------------+-- | Adds the given strict 'ByteString' to the body of the 'Response' stored+-- in the 'Snap' monad state.+--+-- Warning: This function is intentionally non-strict. If any pure+-- exceptions are raised by the expression creating the 'ByteString',+-- the exception won't actually be raised within the Snap handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeBS' \"Hello, bytestring world\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:34:27 GMT+--+-- Hello, bytestring world+-- @+writeBS :: MonadSnap m => ByteString -> m ()+writeBS = writeBuilder . byteString+{-# INLINE writeBS #-}+++------------------------------------------------------------------------------+-- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored+-- in the 'Snap' monad state.+--+-- Warning: This function is intentionally non-strict. If any pure+-- exceptions are raised by the expression creating the 'ByteString',+-- the exception won't actually be raised within the Snap handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeLBS' \"Hello, lazy bytestring world\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:35:15 GMT+--+-- Hello, lazy bytestring world+-- @+writeLBS :: MonadSnap m => L.ByteString -> m ()+writeLBS = writeBuilder . lazyByteString+{-# INLINE writeLBS #-}+++------------------------------------------------------------------------------+-- | Adds the given strict 'T.Text' to the body of the 'Response' stored in+-- the 'Snap' monad state.+--+-- Warning: This function is intentionally non-strict. If any pure+-- exceptions are raised by the expression creating the 'ByteString',+-- the exception won't actually be raised within the Snap handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeText' \"Hello, text world\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:36:38 GMT+--+-- Hello, text world+-- @+writeText :: MonadSnap m => T.Text -> m ()+writeText = writeBS . T.encodeUtf8+ -- it's inefficient, but we don't have bytestring builder text functions for+ -- 0.9-era bytestring+{-# INLINE writeText #-}+++------------------------------------------------------------------------------+-- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the+-- 'Snap' monad state.+--+-- Warning: This function is intentionally non-strict. If any pure+-- exceptions are raised by the expression creating the 'ByteString',+-- the exception won't actually be raised within the Snap handler.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('writeLazyText' \"Hello, lazy text world\")+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:37:41 GMT+--+-- Hello, lazy text world+-- @+writeLazyText :: MonadSnap m => LT.Text -> m ()+writeLazyText = writeLBS . LT.encodeUtf8+{-# INLINE writeLazyText #-}+++------------------------------------------------------------------------------+-- | Sets the output to be the contents of the specified file.+--+-- Calling 'sendFile' will overwrite any output queued to be sent in the+-- 'Response'. If the response body is not modified after the call to+-- 'sendFile', Snap will use the efficient @sendfile()@ system call on+-- platforms that support it.+--+-- If the response body is modified (using 'modifyResponseBody'), the file+-- will be read using @mmap()@.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFile world\"+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('sendFile' \"\/tmp\/snap-file\")+-- HTTP\/1.1 200 OK+-- content-length: 21+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:45:10 GMT+-- Content-Length: 21+--+-- Hello, sendFile world+-- @+sendFile :: (MonadSnap m) => FilePath -> m ()+sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing }+++------------------------------------------------------------------------------+-- | Sets the output to be the contents of the specified file, within the+-- given (start,end) range.+--+-- Calling 'sendFilePartial' will overwrite any output queued to be sent in+-- the 'Response'. If the response body is not modified after the call to+-- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on+-- platforms that support it.+--+-- If the response body is modified (using 'modifyResponseBody'), the file+-- will be read using @mmap()@.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFilePartial world\"+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('sendFilePartial' \"\/tmp\/snap-file\" (7, 28))+-- HTTP\/1.1 200 OK+-- content-length: 21+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 17:47:20 GMT+-- Content-Length: 21+--+-- sendFilePartial world+-- @+sendFilePartial :: (MonadSnap m) => FilePath -> (Word64, Word64) -> m ()+sendFilePartial f rng = modifyResponse $ \r ->+ r { rspBody = SendFile f (Just rng) }+++------------------------------------------------------------------------------+-- | Runs a 'Snap' action with a locally-modified 'Request' state+-- object. The 'Request' object in the Snap monad state after the call+-- to localRequest will be unchanged.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty+-- ghci> let printRqURI = 'getsRequest' 'rqURI' >>= 'writeBS' >> 'writeBS' \"\\n\"+-- ghci> T.runHandler r (printRqURI >> 'localRequest' (const r\') printRqURI)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:34:12 GMT+--+-- \/foo\/bar+-- \/bar\/foo+--+-- @+localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a+localRequest f m = do+ req <- getRequest++ runAct req <|> (putRequest req >> pass)++ where+ runAct req = do+ modifyRequest f+ result <- m+ putRequest req+ return result+{-# INLINE localRequest #-}+++------------------------------------------------------------------------------+-- | Fetches the 'Request' from state and hands it to the given action.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import "Control.Monad.IO.Class"+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> let h = 'withRequest' (\\rq -> 'liftIO' (T.requestToString rq) >>= 'writeBS')+-- ghci> T.runHandler r h+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:44:24 GMT+--+-- GET \/foo\/bar HTTP\/1.1+-- host: localhost+--+--+-- @+withRequest :: MonadSnap m => (Request -> m a) -> m a+withRequest = (getRequest >>=)+{-# INLINE withRequest #-}+++------------------------------------------------------------------------------+-- | Fetches the 'Response' from state and hands it to the given action.+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r ('withResponse' $ 'writeBS' . 'rspStatusReason')+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Wed, 06 Aug 2014 15:48:45 GMT+--+-- OK+-- @+withResponse :: MonadSnap m => (Response -> m a) -> m a+withResponse = (getResponse >>=)+{-# INLINE withResponse #-}+++------------------------------------------------------------------------------+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'+-- field to the value in the X-Forwarded-For header. If the header is+-- not present, this action has no effect.+--+-- This action should be used only when working behind a reverse http+-- proxy that sets the X-Forwarded-For header. This is the only way to+-- ensure the value in the X-Forwarded-For header can be trusted.+--+-- This is provided as a filter so actions that require the remote+-- address can get it in a uniform manner. It has specifically limited+-- functionality to ensure that its transformation can be trusted,+-- when used correctly.+ipHeaderFilter :: MonadSnap m => m ()+ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"+++------------------------------------------------------------------------------+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'+-- field to the value from the header specified. If the header+-- specified is not present, this action has no effect.+--+-- This action should be used only when working behind a reverse http+-- proxy that sets the header being looked at. This is the only way to+-- ensure the value in the header can be trusted.+--+-- This is provided as a filter so actions that require the remote+-- address can get it in a uniform manner. It has specifically limited+-- functionality to ensure that its transformation can be trusted,+-- when used correctly.+ipHeaderFilter' :: MonadSnap m => CI ByteString -> m ()+ipHeaderFilter' header = do+ headerContents <- getHeader header <$> getRequest++ let whitespace = [ ' ', '\t', '\r', '\n' ]+ ipChrs = '.' : "0123456789"+ trim f s = f (`elem` s)++ clean = trim S.takeWhile ipChrs . trim S.dropWhile whitespace+ setIP ip = modifyRequest $ \rq -> rq { rqClientAddr = clean ip }+ maybe (return $! ()) setIP headerContents+++------------------------------------------------------------------------------+-- | This function brackets a Snap action in resource acquisition and+-- release. This is provided because MonadCatchIO's 'bracket' function+-- doesn't work properly in the case of a short-circuit return from+-- the action being bracketed.+--+-- In order to prevent confusion regarding the effects of the+-- aquisition and release actions on the Snap state, this function+-- doesn't accept Snap actions for the acquire or release actions.+--+-- This function will run the release action in all cases where the+-- acquire action succeeded. This includes the following behaviors+-- from the bracketed Snap action.+--+-- 1. Normal completion+--+-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'+--+-- 3. An exception being thrown.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let br = 'bracketSnap' (putStrLn \"before\") (const $ putStrLn \"after\")+-- ghci> T.runHandler (T.get \"/\" M.empty) (br $ const $ writeBS \"OK\")+-- before+-- after+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Thu, 07 Aug 2014 18:41:50 GMT+--+-- OK+-- @+bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c+bracketSnap before after thing = mask $ \restore ->+ stateTToSnap $ do+ a <- liftIO before+ let after' = liftIO $ after a+ r <- snapToStateT (restore $ thing a) `onException` after'+ _ <- after'+ return r+++------------------------------------------------------------------------------+-- | This exception is thrown if the handler you supply to 'runSnap' fails.+data NoHandlerException = NoHandlerException String+ deriving (Eq, Typeable)+++------------------------------------------------------------------------------+instance Show NoHandlerException where+ show (NoHandlerException e) = "No handler for request: failure was " ++ e+++------------------------------------------------------------------------------+instance Exception NoHandlerException+++------------------------------------------------------------------------------+-- | Terminate the HTTP session with the given exception.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Control.Exception" as E+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> T.runHandler r (terminateConnection $ E.AssertionFailed \"Assertion failed!\")+-- *** Exception: \<terminated: Assertion failed!>+-- @+terminateConnection :: (Exception e, MonadSnap m) => e -> m a+terminateConnection e =+ liftSnap $ Snap $ \_ fk -> fk $ EscapeSnap $ TerminateConnection+ $ SomeException e+++------------------------------------------------------------------------------+-- | Terminate the HTTP session and hand control to some external handler,+-- escaping all further HTTP traffic.+--+-- The external handler takes three arguments: a function to modify the thread's+-- timeout, and a read and a write ends to the socket.+escapeHttp :: MonadSnap m =>+ EscapeHttpHandler+ -> m ()+escapeHttp h = liftSnap $ Snap $ \_ fk st -> fk (EscapeSnap $ EscapeHttp h) st+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action.+--+-- This function is mostly intended for library writers; instead of invoking+-- 'runSnap' directly, use 'Snap.Http.Server.httpServe' or+-- 'Snap.Test.runHandler' (for testing).+runSnap :: Snap a -- ^ Action to run.+ -> (ByteString -> IO ()) -- ^ Error logging action.+ -> ((Int -> Int) -> IO ()) -- ^ Timeout action.+ -> Request -- ^ HTTP request.+ -> IO (Request, Response)+runSnap (Snap m) logerr timeoutAction req =+ m ok diediedie ss+ where+ ok _ st = return (_snapRequest st, _snapResponse st)++ diediedie z !st = do+ resp <- case z of+ PassOnProcessing -> return fourohfour+ (EarlyTermination x) -> return x+ (EscapeSnap e) -> throwIO e+ return (_snapRequest st, resp)++ --------------------------------------------------------------------------+ fourohfour = do+ clearContentLength $+ setResponseStatus 404 "Not Found" $+ setResponseBody enum404 $+ emptyResponse++ --------------------------------------------------------------------------+ enum404 out = do+ is <- Streams.fromList html+ Streams.connect is out+ return out++ --------------------------------------------------------------------------+ html = map byteString [ "<!DOCTYPE html>\n"+ , "<html>\n"+ , "<head>\n"+ , "<title>Not found</title>\n"+ , "</head>\n"+ , "<body>\n"+ , "<code>No handler accepted \""+ , rqURI req+ , "\"</code>\n</body></html>"+ ]++ --------------------------------------------------------------------------+ dresp = emptyResponse++ --------------------------------------------------------------------------+ ss = SnapState req dresp logerr timeoutAction+{-# INLINE runSnap #-}++++--------------------------------------------------------------------------+-- | Post-process a finalized HTTP response:+--+-- * fixup content-length header+-- * properly handle 204/304 responses+-- * if request was HEAD, remove response body+--+-- Note that we do NOT deal with transfer-encoding: chunked or "connection:+-- close" here.+--+{-# INLINE fixupResponse #-}+fixupResponse :: Request -> Response -> IO Response+fixupResponse req rsp = {-# SCC "fixupResponse" #-} do+ rsp' <- case rspBody rsp of+ (Stream _) -> return rsp+ (SendFile f Nothing) -> setFileSize f rsp+ (SendFile _ (Just (s,e))) -> return $! setContentLength (e-s) rsp+ let !cl = if noBody then Nothing else rspContentLength rsp'+ let rsp'' = if noBody+ then rsp' { rspBody = Stream $ return . id+ , rspContentLength = Nothing+ }+ else rsp'+ return $! updateHeaders (H.fromList . addCL cl . fixup . H.toList) rsp''++ where+ --------------------------------------------------------------------------+ addCL Nothing xs = xs+ addCL (Just cl) xs = ("content-length", word64ToByteString cl):xs++ --------------------------------------------------------------------------+ setFileSize :: FilePath -> Response -> IO Response+ setFileSize fp r = {-# SCC "setFileSize" #-} do+ fs <- liftM fromIntegral $ getFileSize fp+ return $! r { rspContentLength = Just fs }++ ------------------------------------------------------------------------------+ getFileSize :: FilePath -> IO FileOffset+ getFileSize fp = liftM fileSize $ getFileStatus fp++ code = rspStatus rsp+ noBody = code == 204 || code == 304 || rqMethod req == HEAD++ ------------------------------------------------------------------------------+ fixup [] = []+ fixup (("date",_):xs) = fixup xs+ fixup (("content-length",_):xs) = fixup xs+ fixup (x@("transfer-encoding",_):xs) = if noBody+ then fixup xs+ else x : fixup xs+ fixup (x:xs) = x : fixup xs+++------------------------------------------------------------------------------+-- This number code stolen and massaged from Bryan's blog post:+-- http://www.serpentine.com/blog/2013/03/20/whats-good-for-c-is-good-for-haskell/++{-# INLINE countDigits #-}+countDigits :: Word64 -> Int+countDigits v0 = go 1 v0+ where go !k v+ | v < 10 = k+ | v < 100 = k + 1+ | v < 1000 = k + 2+ | v < 10000 = k + 3+ | otherwise = go (k+4) (v `quot` 10000)+++------------------------------------------------------------------------------+{-# INLINE word64ToByteString #-}+word64ToByteString :: Word64 -> ByteString+word64ToByteString d =+#if !MIN_VERSION_bytestring(0,10,6)+ S.inlinePerformIO $+#else+ S.accursedUnutterablePerformIO $+#endif+ if d < 10+ then S.create 1 $ \p -> poke p (i2w d)+ else let !n = countDigits d+ in S.create n $ posDecimal n d+++{-# INLINE posDecimal #-}+posDecimal :: Int -> Word64 -> Ptr Word8 -> IO ()+posDecimal !n0 !v0 !op0 = go n0 (plusPtr op0 (n0-1)) v0+ where go !n !op !v+ | n == 1 = poke op $! i2w v+ | otherwise = do+ let (!v', !d) = divMod v 10+ poke op $! i2w d+ go (n-1) (plusPtr op (-1)) v'+++{-# INLINE i2w #-}+i2w :: Word64 -> Word8+i2w v = 48 + fromIntegral v+++------------------------------------------------------------------------------+-- | Evaluates a 'Snap' monad action.+--+-- Unlike 'runSnap', 'evalSnap' evaluates to the value, not the 'Response'.+-- Like 'runSnap', 'evalSnap' is intended for library writers.+-- Note that there is no meaningful way of evaluating a 'Snap' monad action+-- that contains 'pass' without alternative (i.e. failure), 'finishWith'+-- (i.e. early termination), or 'escapeHttp' (i.e. escaping Snap).+-- In all of those three cases 'evalSnap' throws an IO exception.+evalSnap :: Snap a -- ^ Action to run.+ -> (ByteString -> IO ()) -- ^ Error logging action.+ -> ((Int -> Int) -> IO ()) -- ^ Timeout action.+ -> Request -- ^ HTTP request.+ -> IO a+evalSnap (Snap m) logerr timeoutAction req =+ m (\v _ -> return v) diediedie ss+ where+ diediedie z _ = case z of+ PassOnProcessing -> throwIO $ NoHandlerException "pass"+ (EarlyTermination _) -> throwIO $ ErrorCall "no value"+ (EscapeSnap e) -> throwIO e++ dresp = emptyResponse+ ss = SnapState req dresp logerr timeoutAction+{-# INLINE evalSnap #-}+++------------------------------------------------------------------------------+getParamFrom :: MonadSnap m =>+ (ByteString -> Request -> Maybe [ByteString])+ -> ByteString+ -> m (Maybe ByteString)+getParamFrom f k = do+ rq <- getRequest+ return $! liftM (S.intercalate " ") $ f k rq+{-# INLINE getParamFrom #-}+++------------------------------------------------------------------------------+-- | See 'rqParam'. Looks up a value for the given named parameter in the+-- 'Request'. If more than one value was entered for the given parameter name,+-- 'getParam' gloms the values together with @'S.intercalate' \" \"@.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]+-- ghci> T.runHandler r ('getParam' \"foo\" >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Mon, 11 Aug 2014 12:57:20 GMT+--+-- Just \"bar\"+-- @+getParam :: MonadSnap m+ => ByteString -- ^ parameter name to look up+ -> m (Maybe ByteString)+getParam = getParamFrom rqParam+{-# INLINE getParam #-}+++------------------------------------------------------------------------------+-- | See 'rqPostParam'. Looks up a value for the given named parameter in the+-- POST form parameters mapping in 'Request'. If more than one value was+-- entered for the given parameter name, 'getPostParam' gloms the values+-- together with: @'S.intercalate' \" \"@.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]+-- ghci> T.runHandler r ('getPostParam' \"foo\" >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Mon, 11 Aug 2014 13:01:04 GMT+--+-- Just \"bar\"+-- @+getPostParam :: MonadSnap m+ => ByteString -- ^ parameter name to look up+ -> m (Maybe ByteString)+getPostParam = getParamFrom rqPostParam+{-# INLINE getPostParam #-}+++------------------------------------------------------------------------------+-- | See 'rqQueryParam'. Looks up a value for the given named parameter in the+-- query string parameters mapping in 'Request'. If more than one value was+-- entered for the given parameter name, 'getQueryParam' gloms the values+-- together with @'S.intercalate' \" \"@.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\"+-- ghci> T.runHandler r ('getQueryParam' \"foo\" >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Mon, 11 Aug 2014 13:06:50 GMT+--+-- Just \"bar baz\"+-- @+getQueryParam :: MonadSnap m+ => ByteString -- ^ parameter name to look up+ -> m (Maybe ByteString)+getQueryParam = getParamFrom rqQueryParam+{-# INLINE getQueryParam #-}+++------------------------------------------------------------------------------+-- | See 'rqParams'. Convenience function to return 'Params' from the+-- 'Request' inside of a 'MonadSnap' instance.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]+-- ghci> T.runHandler r ('getParams' >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Mon, 11 Aug 2014 13:02:54 GMT+--+-- fromList [(\"foo\",[\"bar\"])]+-- @+getParams :: MonadSnap m => m Params+getParams = getRequest >>= return . rqParams+++------------------------------------------------------------------------------+-- | See 'rqParams'. Convenience function to return 'Params' from the+-- 'Request' inside of a 'MonadSnap' instance.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]+-- ghci> T.runHandler r ('getPostParams' >>= 'writeBS' . B8.pack . show)+-- HTTP/1.1 200 OK+-- server: Snap/test+-- date: Mon, 11 Aug 2014 13:04:34 GMT+--+-- fromList [("foo",["bar"])]+-- @+getPostParams :: MonadSnap m => m Params+getPostParams = getRequest >>= return . rqPostParams+++------------------------------------------------------------------------------+-- | See 'rqParams'. Convenience function to return 'Params' from the+-- 'Request' inside of a 'MonadSnap' instance.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\"+-- ghci> T.runHandler r ('getQueryParams' >>= 'writeBS' . B8.pack . show)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Mon, 11 Aug 2014 13:10:17 GMT+--+-- fromList [(\"foo\",[\"bar\",\"baz\"])]+-- @+getQueryParams :: MonadSnap m => m Params+getQueryParams = getRequest >>= return . rqQueryParams+++------------------------------------------------------------------------------+-- | Gets the HTTP 'Cookie' with the specified name.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False+-- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]+-- ghci> T.runHandler r ('getCookie' \"name\" >>= 'writeBS' . B8.pack . show)+-- HTTP/1.1 200 OK+-- server: Snap/test+-- date: Thu, 07 Aug 2014 12:16:58 GMT+--+-- Just (Cookie {cookieName = "name", cookieValue = "value", ...})+-- @+getCookie :: MonadSnap m+ => ByteString+ -> m (Maybe Cookie)+getCookie name = withRequest $+ return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies+++------------------------------------------------------------------------------+-- | Gets the HTTP 'Cookie' with the specified name and decodes it. If the+-- decoding fails, the handler calls pass.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False+-- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]+-- ghci> T.runHandler r ('readCookie' \"name\" >>= 'writeBS')+-- HTTP/1.1 200 OK+-- server: Snap/test+-- date: Thu, 07 Aug 2014 12:20:09 GMT+--+-- value+-- @+readCookie :: (MonadSnap m, R.Readable a)+ => ByteString+ -> m a+readCookie name = maybe pass (R.fromBS . cookieValue) =<< getCookie name+++------------------------------------------------------------------------------+-- | Expire given 'Cookie' in client's browser.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\/bar\" M.empty+-- ghci> let cookie = Cookie "name" "" Nothing (Just "/subsite") Nothing True False+-- ghci> T.runHandler r ('expireCookie' cookie)+-- HTTP/1.1 200 OK+-- set-cookie: name=; path=/subsite; expires=Sat, 24 Dec 1994 06:28:16 GMT; Secure+-- server: Snap/test+--+-- date: Thu, 07 Aug 2014 12:21:27 GMT+-- ghci> let cookie = Cookie "name" "value" Nothing Nothing Nothing False False+-- ghci> let r2 = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]+-- ghci> T.runHandler r ('getCookie' "name" >>= maybe (return ()) 'expireCookie')+-- HTTP/1.1 200 OK+-- set-cookie: name=; expires=Sat, 24 Dec 1994 06:28:16 GMT+-- server: Snap/test+--+--+-- @+expireCookie :: (MonadSnap m) => Cookie -> m ()+expireCookie cookie = do+ let old = UTCTime (ModifiedJulianDay 0) 0+ modifyResponse $ addResponseCookie+ $ cookie { cookieValue = ""+ , cookieExpires = (Just old) }++------------------------------------------------------------------------------+-- | Causes the handler thread to be killed @n@ seconds from now.+setTimeout :: MonadSnap m => Int -> m ()+setTimeout = modifyTimeout . const+++------------------------------------------------------------------------------+-- | Causes the handler thread to be killed at least @n@ seconds from now.+extendTimeout :: MonadSnap m => Int -> m ()+extendTimeout = modifyTimeout . max+++------------------------------------------------------------------------------+-- | Modifies the amount of time remaining before the request times out.+modifyTimeout :: MonadSnap m => (Int -> Int) -> m ()+modifyTimeout f = do+ m <- getTimeoutModifier+ liftIO $ m f+++------------------------------------------------------------------------------+-- | Returns an 'IO' action which you can use to modify the timeout value.+getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ())+getTimeoutModifier = liftSnap $ liftM _snapModifyTimeout sget
src/Snap/Internal/Debug.hs view
@@ -1,81 +1,100 @@--- | An internal Snap module for (optionally) printing debugging--- messages. Normally 'debug' does nothing, but if you set @DEBUG=1@ in the--- environment you'll get debugging messages. We use 'unsafePerformIO' to make--- sure that the call to 'getEnv' is only made once.+-- | An internal Snap module for (optionally) printing debugging messages. To+-- enable debug output, compile the library with the @debug@ flag (off by+-- default) and set the environment variable @DEBUG@ to @1@. We use+-- 'unsafePerformIO' to make sure that the call to 'getEnv' is only made once. -- -- /N.B./ this is an internal interface, please don't write external code that -- depends on it. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-cse #-} -module Snap.Internal.Debug where+module Snap.Internal.Debug (debug, debugErrno) where -------------------------------------------------------------------------------import Control.Monad.Trans+import Control.Monad.IO.Class (MonadIO (..)) #ifndef NODEBUG-import Control.Concurrent-import Control.DeepSeq-import Control.Exception-import Data.Char-import Data.List-import Data.Maybe-import Foreign.C.Error-import System.Environment-import System.IO-import System.IO.Unsafe-import Text.Printf+import Control.Concurrent (MVar, myThreadId, newMVar, withMVar)+import Control.Exception (SomeException, try)+import Data.Char (toLower)+import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+import Foreign.C.Error (errnoToIOError, getErrno)+import System.Environment (getEnv)+import System.IO (hFlush, hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf (printf) #endif ------------------------------------------------------------------------------ -debug, debugErrno :: MonadIO m => String -> m ()+-- | Print out the provided debug message prefixed by the thread ID.+--+-- Example:+--+-- @+-- ghci> debug "Some debug message"+-- [ 225] Some debug message+-- @+debug :: MonadIO m => String -> m () +-- | Print out the error message corresponding to the 'Foreign.C.Error.Errno'+-- value returned by 'Foreign.C.Error.getErrno' together with any additional+-- information provided by the user (usually the location where the error+-- occurred).+--+-- Example:+--+-- @+-- ghci> debugErrno "path/to/Source.hs:34"+-- [ 323] path/to/Source.hs:34: failed (Success)+-- @+debugErrno :: MonadIO m => String -> m ()++ #ifndef NODEBUG {-# NOINLINE debug #-}-debug = let !x = unsafePerformIO $! do- !e <- try $ getEnv "DEBUG"+debug = let !x = unsafePerformIO $ do+ !e <- try $ getEnv "DEBUG" - !f <- either (\(_::SomeException) -> return debugIgnore)- (\y -> if y == "1" || y == "on"- then return debugOn- else if y == "testsuite"- then return debugSeq- else return debugIgnore)- (fmap (map toLower) e)- return $! f+ !f <- either (\(_::SomeException) -> return debugIgnore)+ (\y0 -> let y = map toLower y0+ in if y == "1" || y == "on"+ then return debugOn+ else if y == "testsuite"+ then return debugSeq+ else return debugIgnore)+ e+ return $! f in x {-# NOINLINE debugErrno #-} debugErrno = let !x = unsafePerformIO $ do- e <- try $ getEnv "DEBUG"-- !f <- either (\(_::SomeException) -> return debugErrnoIgnore)- (\y -> if y == "1" || y == "on"- then return debugErrnoOn- else if y == "testsuite"- then return debugErrnoSeq- else return debugErrnoIgnore)- (fmap (map toLower) e)- return $! f+ e <- try $ getEnv "DEBUG"+ !f <- either (\(_::SomeException) -> return debugErrnoIgnore)+ (\y0 -> let y = map toLower y0+ in if y == "1" || y == "on"+ then return debugErrnoOn+ else if y == "testsuite"+ then return debugSeq+ else return debugErrnoIgnore)+ e+ return $! f in x ------------------------------------------------------------------------------ debugSeq :: (MonadIO m) => String -> m ()-debugSeq !s = let !s' = rnf s in return $! s' `deepseq` ()+debugSeq !s = length s `seq` return $! () {-# NOINLINE debugSeq #-}--debugErrnoSeq :: (MonadIO m) => String -> m ()-debugErrnoSeq !s = let !s' = rnf s in return $! s' `deepseq` ()-{-# NOINLINE debugErrnoSeq #-} ------------------------------------------------------------------------------ _debugMVar :: MVar ()
src/Snap/Internal/Http/Types.hs view
@@ -1,732 +1,1413 @@--- | An internal Snap module containing HTTP types.------ /N.B./ this is an internal interface, please don't write user code that--- depends on it. Most of these declarations (except for the--- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core".--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ExistentialQuantification #-}--module Snap.Internal.Http.Types where----------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Monad (liftM)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Internal (c2w,w2c)-import qualified Data.ByteString as S-import Data.Int-import qualified Data.IntMap as IM-import Data.IORef-import Data.List hiding (take)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Time.Clock-import Foreign.C.Types-import Prelude hiding (take)---#ifdef PORTABLE-import Data.Time.Format-import Data.Time.LocalTime-import Data.Time.Clock.POSIX-import System.Locale (defaultTimeLocale)-#else-import Data.Time.Format ()-import Foreign-import qualified Data.ByteString.Unsafe as S-import Foreign.C.String-#endif---------------------------------------------------------------------------------import Data.CaseInsensitive (CI)-import qualified Data.CaseInsensitive as CI-import Snap.Iteratee (Enumerator)-import qualified Snap.Iteratee as I-import Snap.Types.Headers (Headers)-import qualified Snap.Types.Headers as H--#ifndef PORTABLE----------------------------------------------------------------------------------- foreign imports from cbits--foreign import ccall unsafe "set_c_locale"- set_c_locale :: IO ()--foreign import ccall unsafe "c_parse_http_time"- c_parse_http_time :: CString -> IO CTime--foreign import ccall unsafe "c_format_http_time"- c_format_http_time :: CTime -> CString -> IO ()--foreign import ccall unsafe "c_format_log_time"- c_format_log_time :: CTime -> CString -> IO ()--#endif------------------------------------------------------------------------------------ | A typeclass for datatypes which contain HTTP headers.-class HasHeaders a where-- -- | Modify the datatype's headers.- updateHeaders :: (Headers -> Headers) -> a -> a-- -- | Retrieve the headers from a datatype that has headers.- headers :: a -> Headers------------------------------------------------------------------------------------ | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header--- with the same name already exists, the new value is appended to the headers--- list.-addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a-addHeader k v = updateHeaders $ H.insert k v------------------------------------------------------------------------------------ | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with--- the same name already exists, it is overwritten with the new value.-setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a-setHeader k v = updateHeaders $ H.set k v------------------------------------------------------------------------------------ | Gets all of the values for a given header.-getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]-getHeaders k a = H.lookup k $ headers a------------------------------------------------------------------------------------ | Gets a header value out of a 'HasHeaders' datatype. If many headers came--- in with the same name, they will be catenated together.-getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString-getHeader k a = liftM (S.intercalate " ") (H.lookup k $ headers a)------------------------------------------------------------------------------------ | Lists all the headers out of a 'HasHeaders' datatype. If many--- headers came in with the same name, they will be catenated together.-listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]-listHeaders = H.toList . headers------------------------------------------------------------------------------------ | Clears a header value from a 'HasHeaders' datatype.-deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a-deleteHeader k = updateHeaders $ H.delete k------------------------------------------------------------------------------------ | Enumerates the HTTP method values (see--- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>).-data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT- deriving(Show,Read,Ord,Eq)----------------------------------------------------------------------------------type HttpVersion = (Int,Int)------------------------------------------------------------------------------------ | A datatype representing an HTTP cookie.-data Cookie = Cookie {- -- | The name of the cookie.- cookieName :: !ByteString-- -- | The cookie's string value.- , cookieValue :: !ByteString-- -- | The cookie's expiration value, if it has one.- , cookieExpires :: !(Maybe UTCTime)-- -- | The cookie's \"domain\" value, if it has one.- , cookieDomain :: !(Maybe ByteString)-- -- | The cookie path.- , cookiePath :: !(Maybe ByteString)-- -- | Tag as secure cookie?- , cookieSecure :: !Bool-- -- | HttpOnly?- , cookieHttpOnly :: !Bool-} deriving (Eq, Show)------------------------------------------------------------------------------------ | A type alias for the HTTP parameters mapping. Each parameter--- key maps to a list of ByteString values; if a parameter is specified--- multiple times (e.g.: \"@GET /foo?param=bar1¶m=bar2@\"), looking up--- \"@param@\" in the mapping will give you @[\"bar1\", \"bar2\"]@.-type Params = Map ByteString [ByteString]------------------------------------------------------------------------------------ request type----------------------------------------------------------------------------------- | An existential wrapper for the 'Enumerator ByteString IO a' type-newtype SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a)------------------------------------------------------------------------------------ | Contains all of the information about an incoming HTTP request.-data Request = Request- { -- | The server name of the request, as it came in from the request's- -- @Host:@ header.- rqServerName :: !ByteString-- -- | Returns the port number the HTTP server is listening on.- , rqServerPort :: !Int-- -- | The remote IP address.- , rqRemoteAddr :: !ByteString-- -- | The remote TCP port number.- , rqRemotePort :: !Int-- -- | The local IP address for this request.- , rqLocalAddr :: !ByteString-- -- | Returns the port number the HTTP server is listening on.- , rqLocalPort :: !Int-- -- | Returns the HTTP server's idea of its local hostname.- , rqLocalHostname :: !ByteString-- -- | Returns @True@ if this is an @HTTPS@ session.- , rqIsSecure :: !Bool- , rqHeaders :: Headers- , rqBody :: IORef SomeEnumerator-- -- | Returns the @Content-Length@ of the HTTP request body.- , rqContentLength :: !(Maybe Int)-- -- | Returns the HTTP request method.- , rqMethod :: !Method-- -- | Returns the HTTP version used by the client.- , rqVersion :: !HttpVersion-- -- | Returns a list of the cookies that came in from the HTTP request- -- headers.- , rqCookies :: [Cookie]--- -- | We'll be doing web components (or \"snaplets\") for version 0.2.- -- The \"snaplet path\" refers to the place on the URL where your- -- containing snaplet is hung. The value of 'rqSnapletPath' is either- -- @\"\"@ (at the top-level context) or is a path beginning with a- -- slash, but not ending with one.- --- -- An identity is that:- --- -- > rqURI r == S.concat [ rqSnapletPath r- -- > , rqContextPath r- -- > , rqPathInfo r- -- > , let q = rqQueryString r- -- > in if S.null q- -- > then ""- -- > else S.append "?" q- -- > ]- --- -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will- -- be \"\"- , rqSnapletPath :: !ByteString-- -- | Handlers can (/will be; --ed/) be hung on a @URI@ \"entry point\";- -- this is called the \"context path\". If a handler is hung on the- -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the- -- value of 'rqPathInfo' will be @\"bar\"@.- , rqPathInfo :: !ByteString-- -- | The \"context path\" of the request; catenating 'rqContextPath',- -- and 'rqPathInfo' should get you back to the original 'rqURI'- -- (ignoring query strings). The 'rqContextPath' always begins and ends- -- with a slash (@\"\/\"@) character, and represents the path (relative- -- to your component\/snaplet) you took to get to your handler.- , rqContextPath :: !ByteString-- -- | Returns the @URI@ requested by the client.- , rqURI :: !ByteString-- -- | Returns the HTTP query string for this 'Request'.- , rqQueryString :: !ByteString-- -- | Returns the 'Params' mapping for this 'Request'. \"Parameters\" are- -- automatically decoded from the query string and @POST@ body and- -- entered into this mapping.- , rqParams :: Params- }----------------------------------------------------------------------------------instance Show Request where- show r = concat [ "Request <\n"- , body- , ">" ]- where- body = concat $ map ((" "++) . (++ "\n")) [- sname- , remote- , local- , beginheaders- , hdrs- , endheaders- , contentlength- , method- , version- , cookies- , pathinfo- , contextpath- , snapletpath- , uri- , params- ]-- sname = concat [ "server-name: ", toStr $ rqServerName r ]- remote = concat [ "remote: "- , toStr $ rqRemoteAddr r- , ":"- , show (rqRemotePort r)- ]- local = concat [ "local: "- , toStr $ rqLocalAddr r- , ":"- , show $ rqServerPort r- ]- beginheaders =- "Headers:\n ========================================"- endheaders = " ========================================"- hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ B.unpack b- hdrs = " " ++ (concat $ intersperse "\n " $- map hdrs' (H.toList $ rqHeaders r))- contentlength = concat [ "content-length: "- , show $ rqContentLength r- ]- method = concat [ "method: "- , show $ rqMethod r- ]- version = concat [ "version: "- , show $ rqVersion r- ]- cookies' = " " ++ (concat $ intersperse "\n " $- map show $ rqCookies r)- cookies = concat- [ "cookies:\n"- , " ========================================\n"- , cookies'- , "\n ========================================"- ]- pathinfo = concat [ "pathinfo: ", toStr $ rqPathInfo r ]- contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ]- snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ]- uri = concat [ "URI: ", toStr $ rqURI r ]- params' = " " ++- (concat $ intersperse "\n " $- map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $- Map.toAscList $ rqParams r)- params = concat- [ "params:\n"- , " ========================================\n"- , params'- , "\n ========================================"- ]----------------------------------------------------------------------------------instance HasHeaders Request where- headers = rqHeaders- updateHeaders f r = r { rqHeaders = f (rqHeaders r) }----------------------------------------------------------------------------------instance HasHeaders Headers where- headers = id- updateHeaders = id----------------------------------------------------------------------------------- response type---------------------------------------------------------------------------------data ResponseBody = Enum (forall a . Enumerator Builder IO a)- -- ^ output body is a 'Builder' enumerator-- | SendFile FilePath (Maybe (Int64,Int64))- -- ^ output body is sendfile(), optional second argument- -- is a byte range to send----------------------------------------------------------------------------------rspBodyMap :: (forall a .- Enumerator Builder IO a -> Enumerator Builder IO a)- -> ResponseBody- -> ResponseBody-rspBodyMap f b = Enum $ f $ rspBodyToEnum b-----------------------------------------------------------------------------------rspBodyToEnum :: ResponseBody -> Enumerator Builder IO a-rspBodyToEnum (Enum e) = e-rspBodyToEnum (SendFile fp Nothing) =- I.mapEnum toByteString fromByteString $ I.enumFile fp-rspBodyToEnum (SendFile fp (Just s)) =- I.mapEnum toByteString fromByteString $ I.enumFilePartial fp s------------------------------------------------------------------------------------ | Represents an HTTP response.-data Response = Response- { rspHeaders :: Headers- , rspCookies :: Map ByteString Cookie- , rspHttpVersion :: !HttpVersion-- -- | We will need to inspect the content length no matter what, and- -- looking up \"content-length\" in the headers and parsing the number- -- out of the text will be too expensive.- , rspContentLength :: !(Maybe Int64)- , rspBody :: ResponseBody-- -- | Returns the HTTP status code.- , rspStatus :: !Int-- -- | Returns the HTTP status explanation string.- , rspStatusReason :: !ByteString-- -- | If true, we are transforming the request body with- -- 'transformRequestBody'- , rspTransformingRqBody :: !Bool- }----------------------------------------------------------------------------------instance Show Response where- show r = concat [ statusline- , hdrs- , "\r\n"- ]- where- (v1,v2) = rspHttpVersion r-- statusline = concat [ "HTTP/"- , show v1- , "."- , show v2- , " "- , show $ rspStatus r- , " "- , toStr $ rspStatusReason r- , "\r\n" ]-- hdrs = concatMap showHdr $ H.toList $ rspHeaders r-- showHdr (k,v) = concat [ toStr (CI.original k), ": ", toStr v, "\r\n" ]----------------------------------------------------------------------------------instance HasHeaders Response where- headers = rspHeaders- updateHeaders f r = r { rspHeaders = f (rspHeaders r) }------------------------------------------------------------------------------------ | Looks up the value(s) for the given named parameter. Parameters initially--- come from the request's query string and any decoded POST body (if the--- request's @Content-Type@ is @application\/x-www-form-urlencoded@).--- Parameter values can be modified within handlers using "rqModifyParams".-rqParam :: ByteString -- ^ parameter name to look up- -> Request -- ^ HTTP request- -> Maybe [ByteString]-rqParam k rq = Map.lookup k $ rqParams rq-{-# INLINE rqParam #-}------------------------------------------------------------------------------------ | Modifies the parameters mapping (which is a @Map ByteString ByteString@)--- in a 'Request' using the given function.-rqModifyParams :: (Params -> Params) -> Request -> Request-rqModifyParams f r = r { rqParams = p }- where- p = f $ rqParams r-{-# INLINE rqModifyParams #-}------------------------------------------------------------------------------------ | Writes a key-value pair to the parameters mapping within the given--- request.-rqSetParam :: ByteString -- ^ parameter name- -> [ByteString] -- ^ parameter values- -> Request -- ^ request- -> Request-rqSetParam k v = rqModifyParams $ Map.insert k v-{-# INLINE rqSetParam #-}----------------------------------------------------------------------------------- responses----------------------------------------------------------------------------------- | An empty 'Response'.-emptyResponse :: Response-emptyResponse = Response H.empty Map.empty (1,1) Nothing- (Enum (I.enumBuilder mempty))- 200 "OK" False------------------------------------------------------------------------------------ | Sets an HTTP response body to the given 'Enumerator' value.-setResponseBody :: (forall a . Enumerator Builder IO a)- -- ^ new response body enumerator- -> Response -- ^ response to modify- -> Response-setResponseBody e r = r { rspBody = Enum e }-{-# INLINE setResponseBody #-}------------------------------------------------------------------------------------ | Sets the HTTP response status. Note: normally you would use--- 'setResponseCode' unless you needed a custom response explanation.----setResponseStatus :: Int -- ^ HTTP response integer code- -> ByteString -- ^ HTTP response explanation- -> Response -- ^ Response to be modified- -> Response-setResponseStatus s reason r = r { rspStatus=s, rspStatusReason=reason }-{-# INLINE setResponseStatus #-}------------------------------------------------------------------------------------ | Sets the HTTP response code.-setResponseCode :: Int -- ^ HTTP response integer code- -> Response -- ^ Response to be modified- -> Response-setResponseCode s r = setResponseStatus s reason r- where- reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap)-{-# INLINE setResponseCode #-}------------------------------------------------------------------------------------ | Modifies a response body.-modifyResponseBody :: (forall a . Enumerator Builder IO a- -> Enumerator Builder IO a)- -> Response- -> Response-modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }-{-# INLINE modifyResponseBody #-}------------------------------------------------------------------------------------ | Sets the @Content-Type@ in the 'Response' headers.-setContentType :: ByteString -> Response -> Response-setContentType = setHeader "Content-Type"-{-# INLINE setContentType #-}------------------------------------------------------------------------------------ | Adds an HTTP 'Cookie' to 'Response' headers.-addResponseCookie :: Cookie -- ^ cookie value- -> Response -- ^ response to modify- -> Response-addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' }- where- cks'= Map.insert k ck $ rspCookies r-{-# INLINE addResponseCookie #-}------------------------------------------------------------------------------------ | Gets an HTTP 'Cookie' with the given name from 'Response' headers.-getResponseCookie :: ByteString -- ^ cookie name- -> Response -- ^ response to query- -> Maybe Cookie-getResponseCookie cn r = Map.lookup cn $ rspCookies r-{-# INLINE getResponseCookie #-}----- | Returns a list of 'Cookie's present in 'Response'-getResponseCookies :: Response -- ^ response to query- -> [Cookie]-getResponseCookies = Map.elems . rspCookies-{-# INLINE getResponseCookies #-}------------------------------------------------------------------------------------ | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note--- this does not necessarily erase the cookie from the client browser.-deleteResponseCookie :: ByteString -- ^ cookie name- -> Response -- ^ response to modify- -> Response-deleteResponseCookie cn r = r { rspCookies = cks' }- where- cks'= Map.delete cn $ rspCookies r-{-# INLINE deleteResponseCookie #-}------------------------------------------------------------------------------------ | Modifies an HTTP 'Cookie' with given name in 'Response' headers.--- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.-modifyResponseCookie :: ByteString -- ^ cookie name- -> (Cookie -> Cookie) -- ^ modifier function- -> Response -- ^ response to modify- -> Response-modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r- where- modify ck = addResponseCookie (f ck) r-{-# INLINE modifyResponseCookie #-}------------------------------------------------------------------------------------ | A note here: if you want to set the @Content-Length@ for the response,--- Snap forces you to do it with this function rather than by setting it in--- the headers; the @Content-Length@ in the headers will be ignored.------ The reason for this is that Snap needs to look up the value of--- @Content-Length@ for each request, and looking the string value up in the--- headers and parsing the number out of the text will be too expensive.------ If you don't set a content length in your response, HTTP keep-alive will be--- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For--- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if--- @Content-Length@ is not specified.-setContentLength :: Int64 -> Response -> Response-setContentLength l r = r { rspContentLength = Just l }-{-# INLINE setContentLength #-}------------------------------------------------------------------------------------ | Removes any @Content-Length@ set in the 'Response'.-clearContentLength :: Response -> Response-clearContentLength r = r { rspContentLength = Nothing }-{-# INLINE clearContentLength #-}------------------------------------------------------------------------------------ HTTP dates---- | Converts a 'CTime' into an HTTP timestamp.-formatHttpTime :: CTime -> IO ByteString---- | Converts a 'CTime' into common log entry format.-formatLogTime :: CTime -> IO ByteString---- | Converts an HTTP timestamp into a 'CTime'.-parseHttpTime :: ByteString -> IO CTime--#ifdef PORTABLE--formatHttpTime = return . format . toUTCTime- where- format :: UTCTime -> ByteString- format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"-- toUTCTime :: CTime -> UTCTime- toUTCTime = posixSecondsToUTCTime . realToFrac--formatLogTime ctime = do- t <- utcToLocalZonedTime $ toUTCTime ctime- return $ format t-- where- format :: ZonedTime -> ByteString- format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"-- toUTCTime :: CTime -> UTCTime- toUTCTime = posixSecondsToUTCTime . realToFrac---parseHttpTime = return . toCTime . prs . toStr- where- prs :: String -> Maybe UTCTime- prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"-- toCTime :: Maybe UTCTime -> CTime- toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t- toCTime Nothing = fromInteger 0--#else--formatLogTime t = do- ptr <- mallocBytes 40- c_format_log_time t ptr- S.unsafePackMallocCString ptr--formatHttpTime t = do- ptr <- mallocBytes 40- c_format_http_time t ptr- S.unsafePackMallocCString ptr--parseHttpTime s = S.unsafeUseAsCString s $ \ptr ->- c_parse_http_time ptr--#endif------------------------------------------------------------------------------------ local definitions-fromStr :: String -> ByteString-fromStr = S.pack . map c2w-{-# INLINE fromStr #-}----------------------------------------------------------------------------------- private helper functions-toStr :: ByteString -> String-toStr = map w2c . S.unpack----------------------------------------------------------------------------------statusReasonMap :: IM.IntMap ByteString-statusReasonMap = IM.fromList [- (100, "Continue"),- (101, "Switching Protocols"),- (200, "OK"),- (201, "Created"),- (202, "Accepted"),- (203, "Non-Authoritative Information"),- (204, "No Content"),- (205, "Reset Content"),- (206, "Partial Content"),- (300, "Multiple Choices"),- (301, "Moved Permanently"),- (302, "Found"),- (303, "See Other"),- (304, "Not Modified"),- (305, "Use Proxy"),- (307, "Temporary Redirect"),- (400, "Bad Request"),- (401, "Unauthorized"),- (402, "Payment Required"),- (403, "Forbidden"),- (404, "Not Found"),- (405, "Method Not Allowed"),- (406, "Not Acceptable"),- (407, "Proxy Authentication Required"),- (408, "Request Time-out"),- (409, "Conflict"),- (410, "Gone"),- (411, "Length Required"),- (412, "Precondition Failed"),- (413, "Request Entity Too Large"),- (414, "Request-URI Too Large"),- (415, "Unsupported Media Type"),- (416, "Requested range not satisfiable"),- (417, "Expectation Failed"),- (500, "Internal Server Error"),- (501, "Not Implemented"),- (502, "Bad Gateway"),- (503, "Service Unavailable"),- (504, "Gateway Time-out"),- (505, "HTTP Version not supported")- ]+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeSynonymInstances #-}++------------------------------------------------------------------------------+-- | An internal Snap module containing HTTP types.+--+-- /N.B./ this is an internal interface, please don't write user code that+-- depends on it. Most of these declarations (except for the+-- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core".+--+module Snap.Internal.Http.Types where++------------------------------------------------------------------------------+import Control.Monad (unless)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteString, toLazyByteString)+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 qualified Data.IntMap as IM+import Data.List hiding (take)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (Maybe (..), fromMaybe, maybe)+import Data.Monoid (mconcat)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Word (Word64)+import Foreign.C.Types (CTime (..))+import Prelude (Bool (..), Eq (..), FilePath, IO, Int, Integral (..), Monad (..), Num ((-)), Ord (..), Ordering (..), Read (..), Show (..), String, fmap, fromInteger, fromIntegral, id, not, otherwise, truncate, ($), (.))+#ifdef PORTABLE+import Prelude (realToFrac, ($!))+#endif+import System.IO (IOMode (ReadMode), SeekMode (AbsoluteSeek), hSeek, withBinaryFile)+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import System.IO.Unsafe (unsafePerformIO)++------------------------------------------------------------------------------+#ifdef PORTABLE+import Data.Time.Clock.POSIX+import Data.Time.Clock.POSIX+import Data.Time.Format as Time+import Data.Time.Locale.Compat (defaultTimeLocale)+import Data.Time.LocalTime+#else+import qualified Data.ByteString.Unsafe as S+import Data.Time.Format ()+import Foreign.C.String (CString)+import Foreign.Marshal.Alloc (mallocBytes)+#endif++------------------------------------------------------------------------------+import Snap.Types.Headers (Headers)+import qualified Snap.Types.Headers as H+++#ifndef PORTABLE++------------------------------------------------------------------------------+-- foreign imports from cbits+foreign import ccall unsafe "set_c_locale"+ set_c_locale :: IO ()++foreign import ccall unsafe "c_parse_http_time"+ c_parse_http_time :: CString -> IO CTime++foreign import ccall unsafe "c_format_http_time"+ c_format_http_time :: CTime -> CString -> IO ()++foreign import ccall unsafe "c_format_log_time"+ c_format_log_time :: CTime -> CString -> IO ()++#endif+++------------------------------------------------------------------------------+-- | A typeclass for datatypes which contain HTTP headers.+class HasHeaders a where+ -- | Modify the datatype's headers.+ updateHeaders :: (Headers -> Headers) -> a -> a++ -- | Retrieve the headers from a datatype that has headers.+ headers :: a -> Headers+++------------------------------------------------------------------------------+-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header+-- with the same name already exists, the new value is appended to the headers+-- list.+--+-- Example:+--+-- @+-- ghci> import qualified "Snap.Types.Headers" as H+-- ghci> 'addHeader' \"Host\" "localhost" H.'empty'+-- H {unH = [("host","localhost")]}+-- ghci> 'addHeader' \"Host\" "127.0.0.1" it+-- H {unH = [("host","localhost,127.0.0.1")]}+-- @+addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a+addHeader k v = updateHeaders $ H.insert k v+++------------------------------------------------------------------------------+-- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with+-- the same name already exists, it is overwritten with the new value.+--+-- Example:+--+-- @+-- ghci> import qualified "Snap.Types.Headers" as H+-- ghci> 'setHeader' \"Host\" "localhost" H.'empty'+-- H {unH = [(\"host\",\"localhost\")]}+-- ghci> setHeader \"Host\" "127.0.0.1" it+-- H {unH = [("host","127.0.0.1")]}+-- @+setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a+setHeader k v = updateHeaders $ H.set k v+++------------------------------------------------------------------------------+-- | Gets a header value out of a 'HasHeaders' datatype.+--+-- Example:+--+-- @+-- ghci> import qualified "Snap.Types.Headers" as H+-- ghci> 'getHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty'+-- Just "localhost"+-- @+getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString+getHeader k a = H.lookup k $ headers a+++------------------------------------------------------------------------------+-- | Lists all the headers out of a 'HasHeaders' datatype. If many+-- headers came in with the same name, they will be catenated together.+--+-- Example:+--+-- @+-- ghci> import qualified "Snap.Types.Headers" as H+-- ghci> 'listHeaders' $ 'setHeader' \"Host\" "localhost" H.'empty'+-- [("host","localhost")]+-- @+listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]+listHeaders = H.toList . headers+++------------------------------------------------------------------------------+-- | Clears a header value from a 'HasHeaders' datatype.+--+-- Example:+--+-- @+-- ghci> import qualified "Snap.Types.Headers" as H+-- ghci> 'deleteHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty'+-- H {unH = []}+-- @+deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a+deleteHeader k = updateHeaders $ H.delete k+++------------------------------------------------------------------------------+-- | Enumerates the HTTP method values (see+-- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>).+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT |+ PATCH | Method ByteString+ deriving(Show, Read)++instance Eq Method where+ a == b =+ normalizeMethod a `eq` normalizeMethod b+ where+ GET `eq` GET = True+ HEAD `eq` HEAD = True+ POST `eq` POST = True+ PUT `eq` PUT = True+ DELETE `eq` DELETE = True+ TRACE `eq` TRACE = True+ OPTIONS `eq` OPTIONS = True+ CONNECT `eq` CONNECT = True+ PATCH `eq` PATCH = True+ Method x1 `eq` Method y1 = x1 == y1+ _ `eq` _ = False++instance Ord Method where+ compare a b =+ check (normalizeMethod a) (normalizeMethod b)+ where+ check GET GET = EQ+ check HEAD HEAD = EQ+ check POST POST = EQ+ check PUT PUT = EQ+ check DELETE DELETE = EQ+ check TRACE TRACE = EQ+ check OPTIONS OPTIONS = EQ+ check CONNECT CONNECT = EQ+ check PATCH PATCH = EQ+ check (Method x1) (Method y1) = compare x1 y1+ check x y = compare (tag x) (tag y)++ tag :: Method -> Int+ tag (GET{}) = 0+ tag (HEAD{}) = 1+ tag (POST{}) = 2+ tag (PUT{}) = 3+ tag (DELETE{}) = 4+ tag (TRACE{}) = 5+ tag (OPTIONS{}) = 6+ tag (CONNECT{}) = 7+ tag (PATCH{}) = 8+ tag (Method{}) = 9++-- | Equate the special case constructors with their corresponding+-- @Method name@ variant.+{-# INLINE normalizeMethod #-}+normalizeMethod :: Method -> Method+normalizeMethod m@(Method name) = case name of+ "GET" -> GET+ "HEAD" -> HEAD+ "POST" -> POST+ "PUT" -> PUT+ "DELETE" -> DELETE+ "TRACE" -> TRACE+ "OPTIONS" -> OPTIONS+ "CONNECT" -> CONNECT+ "PATCH" -> PATCH+ _ -> m+normalizeMethod m = m+++------------------------------------------------------------------------------+-- | Represents a (major, minor) version of the HTTP protocol.+type HttpVersion = (Int,Int)+++------------------------------------------------------------------------------+-- | A datatype representing an HTTP cookie.+data Cookie = Cookie {+ -- | The name of the cookie.+ cookieName :: !ByteString++ -- | The cookie's string value.+ , cookieValue :: !ByteString++ -- | The cookie's expiration value, if it has one.+ , cookieExpires :: !(Maybe UTCTime)++ -- | The cookie's \"domain\" value, if it has one.+ , cookieDomain :: !(Maybe ByteString)++ -- | The cookie path.+ , cookiePath :: !(Maybe ByteString)++ -- | Tag as secure cookie?+ , cookieSecure :: !Bool++ -- | HTTP only?+ , cookieHttpOnly :: !Bool+} deriving (Eq, Show)+++------------------------------------------------------------------------------+-- | A type alias for the HTTP parameters mapping. Each parameter+-- key maps to a list of 'ByteString' values; if a parameter is specified+-- multiple times (e.g.: \"@GET /foo?param=bar1¶m=bar2@\"), looking up+-- \"@param@\" in the mapping will give you @[\"bar1\", \"bar2\"]@.+type Params = Map ByteString [ByteString]+++------------------------------------------------------------------------------+-- request type+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Contains all of the information about an incoming HTTP request.+data Request = Request+ { -- | The server name of the request, as it came in from the request's+ -- @Host:@ header.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> :{+ -- ghci| rq <- T.buildRequest $ do+ -- ghci| T.get "\/foo\/bar" M.empty+ -- ghci| T.setHeader "host" "example.com"+ -- ghci| :}+ -- ghci> rqHostName rq+ -- "example.com"+ -- @+ rqHostName :: ByteString++ -- | The remote IP address.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqClientAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "127.0.0.1"+ -- @+ , rqClientAddr :: ByteString++ -- | The remote TCP port number.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqClientPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "60000"+ -- @+ , rqClientPort :: {-# UNPACK #-} !Int++ -- | The local IP address for this request.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqServerAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "127.0.0.1"+ -- @+ , rqServerAddr :: ByteString++ -- | Returns the port number the HTTP server is listening on. This may be+ -- useless from the perspective of external requests, e.g. if the server+ -- is running behind a proxy.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqServerPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- 8080+ -- @+ , rqServerPort :: {-# UNPACK #-} !Int++ -- | Returns the HTTP server's idea of its local hostname, including+ -- port. This is as configured with the @Config@ object at startup.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqLocalHostname \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "localhost"+ -- @+ , rqLocalHostname :: ByteString++ -- | Returns @True@ if this is an HTTPS session.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqIsSecure \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- False+ -- @+ , rqIsSecure :: !Bool++ -- | Contains all HTTP 'Headers' associated with this request.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqHeaders \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- H {unH = [("host","localhost")]}+ -- @+ , rqHeaders :: Headers++ -- | Actual body of the request.+ , rqBody :: InputStream ByteString++ -- | Returns the @Content-Length@ of the HTTP request body.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqContentLength \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- Nothing+ -- @+ , rqContentLength :: !(Maybe Word64)++ -- | Returns the HTTP request method.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqMethod \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- GET+ -- @+ , rqMethod :: !Method++ -- | Returns the HTTP version used by the client.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqVersion \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- (1,1)+ -- @+ , rqVersion :: {-# UNPACK #-} !HttpVersion++ -- | Returns a list of the cookies that came in from the HTTP request+ -- headers.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqCookies \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- []+ -- @+ , rqCookies :: [Cookie]++ -- | Handlers can be hung on a @URI@ \"entry point\"; this is called the+ -- \"context path\". If a handler is hung on the context path+ -- @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value of+ -- 'rqPathInfo' will be @\"bar\"@.+ --+ -- The following identity holds:+ --+ -- > rqURI r == S.concat [ rqContextPath r+ -- > , rqPathInfo r+ -- > , let q = rqQueryString r+ -- > in if S.null q+ -- > then ""+ -- > else S.append "?" q+ -- > ]+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqPathInfo \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "foo/bar"+ -- @+ , rqPathInfo :: ByteString++ -- | The \"context path\" of the request; catenating 'rqContextPath',+ -- and 'rqPathInfo' should get you back to the original 'rqURI'+ -- (ignoring query strings). The 'rqContextPath' always begins and ends+ -- with a slash (@\"\/\"@) character, and represents the path (relative+ -- to your component\/snaplet) you took to get to your handler.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqContextPath \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "/"+ -- @+ , rqContextPath :: ByteString++ -- | Returns the @URI@ requested by the client.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rqURI \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)+ -- "foo/bar"+ -- @+ , rqURI :: ByteString++ -- | Returns the HTTP query string for this 'Request'.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> rq <- T.buildRequest (T.get "\/foo\/bar" (M.fromList [("name", ["value"])]))+ -- ghci> rqQueryString rq+ -- "name=value"+ -- @+ , rqQueryString :: ByteString++ -- | Returns the parameters mapping for this 'Request'. \"Parameters\"+ -- are automatically decoded from the URI's query string and @POST@ body+ -- and entered into this mapping. The 'rqParams' value is thus a union of+ -- 'rqQueryParams' and 'rqPostParams'.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> :{+ -- ghci| rq <- T.buildRequest $ do+ -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+ -- ghci| T.setQueryStringRaw "baz=quux"+ -- ghci| :}+ -- ghci> rqParams rq+ -- fromList [("baz",["qux","quux"])]+ -- @+ , rqParams :: Params++ -- | The parameter mapping decoded from the URI's query string.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> :{+ -- ghci| rq <- T.buildRequest $ do+ -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+ -- ghci| T.setQueryStringRaw "baz=quux"+ -- ghci| :}+ -- ghci> rqQueryParams rq+ -- fromList [("baz",["quux"])]+ -- @+ , rqQueryParams :: Params++ -- | The parameter mapping decoded from the POST body. Note that Snap+ -- only auto-decodes POST request bodies when the request's+ -- @Content-Type@ is @application\/x-www-form-urlencoded@.+ -- For @multipart\/form-data@ use 'Snap.Util.FileUploads.handleFileUploads'+ -- to decode the POST request and fill this mapping.+ --+ -- Example:+ --+ -- @+ -- ghci> :set -XOverloadedStrings+ -- ghci> import qualified "Snap.Test" as T+ -- ghci> import qualified "Data.Map" as M+ -- ghci> :{+ -- ghci| rq <- T.buildRequest $ do+ -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+ -- ghci| T.setQueryStringRaw "baz=quux"+ -- ghci| :}+ -- ghci> rqPostParams rq+ -- fromList [("baz",["qux"])]+ -- @+ , rqPostParams :: Params+ }+++------------------------------------------------------------------------------+instance Show Request where+ show r = concat [ method, " ", uri, " HTTP/", version, "\n"+ , hdrs, "\n\n"+ , "sn=\"", sname, "\" c=", clntAddr, " s=", srvAddr+ , " ctx=", contextpath, " clen=", contentlength, secure+ , params, cookies+ ]+ where+ method = show $ rqMethod r+ uri = S.unpack $ rqURI r+ version = let (mj, mn) = rqVersion r in show mj ++ "." ++ show mn+ hdrs = intercalate "\n" $ map showHdr (H.toList $ rqHeaders r)+ showHdr (a,b) = (S.unpack $ CI.original a) ++ ": " ++ S.unpack b+ sname = S.unpack $ rqLocalHostname r+ clntAddr = concat [S.unpack $ rqClientAddr r, ":", show $ rqClientPort r]+ srvAddr = concat [S.unpack $ rqServerAddr r, ":", show $ rqServerPort r]+ contextpath = S.unpack $ rqContextPath r+ contentlength = maybe "n/a" show (rqContentLength r)+ secure = if rqIsSecure r then " secure" else ""++ params = showFlds "\nparams: " ", " $+ map (\ (a,b) -> S.unpack a ++ ": " ++ show b)+ (Map.toAscList $ rqParams r)+ cookies = showFlds "\ncookies: " "\n " $+ map show (rqCookies r)++ showFlds header delim lst+ = if not . null $ lst then header ++ (intercalate delim lst)+ else "" :: String++------------------------------------------------------------------------------+instance HasHeaders Request where+ headers = rqHeaders+ updateHeaders f r = r { rqHeaders = f (rqHeaders r) }+++------------------------------------------------------------------------------+instance HasHeaders Headers where+ headers = id+ updateHeaders = id++------------------------------------------------------------------------------+-- response type+------------------------------------------------------------------------------++type StreamProc = OutputStream Builder -> IO (OutputStream Builder)+data ResponseBody = Stream (StreamProc)+ -- ^ output body is a function that writes to a 'Builder'+ -- stream++ | SendFile FilePath (Maybe (Word64, Word64))+ -- ^ output body is sendfile(), optional second argument+ -- is a byte range to send+++------------------------------------------------------------------------------+rspBodyMap :: (StreamProc -> StreamProc) -> ResponseBody -> ResponseBody+rspBodyMap f b = Stream $ f $ rspBodyToEnum b+++------------------------------------------------------------------------------+rspBodyToEnum :: ResponseBody -> StreamProc+rspBodyToEnum (Stream e) = e++rspBodyToEnum (SendFile fp Nothing) = \out ->+ Streams.withFileAsInput fp $ \is -> do+ is' <- Streams.mapM (return . byteString) is+ Streams.connect is' out+ return out++rspBodyToEnum (SendFile fp (Just (start, end))) = \out ->+ withBinaryFile fp ReadMode $ \handle -> do+ unless (start == 0) $ hSeek handle AbsoluteSeek $ toInteger start+ is <- Streams.handleToInputStream handle+ is' <- Streams.takeBytes (fromIntegral $ end - start) is >>=+ Streams.mapM (return . byteString)+ Streams.connect is' out+ return out+++------------------------------------------------------------------------------+-- | Represents an HTTP response.+data Response = Response+ { rspHeaders :: Headers+ , rspCookies :: Map ByteString Cookie++ -- | We will need to inspect the content length no matter what, and+ -- looking up \"content-length\" in the headers and parsing the number+ -- out of the text will be too expensive.+ , rspContentLength :: !(Maybe Word64)+ , rspBody :: ResponseBody++ -- | Returns the HTTP status code.+ --+ -- Example:+ --+ -- @+ -- ghci> rspStatus 'emptyResponse'+ -- 200+ -- @+ , rspStatus :: !Int++ -- | Returns the HTTP status explanation string.+ --+ -- Example:+ --+ -- @+ -- ghci> rspStatusReason 'emptyResponse'+ -- "OK"+ -- @+ , rspStatusReason :: !ByteString++ -- | If true, we are transforming the request body with+ -- 'transformRequestBody'+ , rspTransformingRqBody :: !Bool+ }+++------------------------------------------------------------------------------+instance Show Response where+ show r = concat [ statusline+ , hdrs+ , contentLength+ , "\r\n"+ , body+ ]+ where+ statusline = concat [ "HTTP/1.1 "+ , show $ rspStatus r+ , " "+ , S.unpack $ rspStatusReason r+ , "\r\n" ]++ hdrs = concatMap showHdr $ H.toList $ renderCookies r+ $ rspHeaders $ clearContentLength r++ contentLength = maybe "" (\l -> concat ["Content-Length: ", show l, "\r\n"] ) (rspContentLength r)++ showHdr (k,v) = concat [ S.unpack (CI.original k), ": ", S.unpack v, "\r\n" ]++ -- io-streams are impure, so we're forced to use 'unsafePerformIO'.+ body = unsafePerformIO $ do+ (os, grab) <- Streams.listOutputStream+ let f = rspBodyToEnum $ rspBody r+ _ <- f os+ fmap (L.unpack . toLazyByteString . mconcat) grab++++------------------------------------------------------------------------------+instance HasHeaders Response where+ headers = rspHeaders+ updateHeaders f r = r { rspHeaders = f (rspHeaders r) }+++------------------------------------------------------------------------------+-- | Looks up the value(s) for the given named parameter. Parameters initially+-- come from the request's query string and any decoded POST body (if the+-- request's @Content-Type@ is @application\/x-www-form-urlencoded@).+-- Parameter values can be modified within handlers using "rqModifyParams".+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| rq <- T.buildRequest $ do+-- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+-- ghci| T.setQueryStringRaw "baz=quux"+-- ghci| :}+-- ghci> 'rqParam' "baz" rq+-- Just ["qux","quux"]+-- @+rqParam :: ByteString -- ^ parameter name to look up+ -> Request -- ^ HTTP request+ -> Maybe [ByteString]+rqParam k rq = Map.lookup k $ rqParams rq+{-# INLINE rqParam #-}+++------------------------------------------------------------------------------+-- | Looks up the value(s) for the given named parameter in the POST parameters+-- mapping.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| rq <- T.buildRequest $ do+-- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+-- ghci| T.setQueryStringRaw "baz=quux"+-- ghci| :}+-- ghci> 'rqPostParam' "baz" rq+-- Just ["qux"]+-- @+rqPostParam :: ByteString -- ^ parameter name to look up+ -> Request -- ^ HTTP request+ -> Maybe [ByteString]+rqPostParam k rq = Map.lookup k $ rqPostParams rq+{-# INLINE rqPostParam #-}+++------------------------------------------------------------------------------+-- | Looks up the value(s) for the given named parameter in the query+-- parameters mapping.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| rq <- T.buildRequest $ do+-- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+-- ghci| T.setQueryStringRaw "baz=quux"+-- ghci| :}+-- ghci> 'rqQueryParam' "baz" rq+-- Just ["quux"]+-- @+rqQueryParam :: ByteString -- ^ parameter name to look up+ -> Request -- ^ HTTP request+ -> Maybe [ByteString]+rqQueryParam k rq = Map.lookup k $ rqQueryParams rq+{-# INLINE rqQueryParam #-}+++------------------------------------------------------------------------------+-- | Modifies the parameters mapping (which is a @Map ByteString ByteString@)+-- in a 'Request' using the given function.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| rq <- T.buildRequest $ do+-- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+-- ghci| T.setQueryStringRaw "baz=quux"+-- ghci| :}+-- ghci> 'rqParams' rq+-- fromList [("baz",["qux","quux"])]+-- ghci> 'rqParams' $ 'rqModifyParams' (M.delete "baz") rq+-- fromList []+-- @+rqModifyParams :: (Params -> Params) -> Request -> Request+rqModifyParams f r = r { rqParams = p }+ where+ p = f $ rqParams r+{-# INLINE rqModifyParams #-}+++------------------------------------------------------------------------------+-- | Writes a key-value pair to the parameters mapping within the given+-- request.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| rq <- T.buildRequest $ do+-- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]+-- ghci| T.setQueryStringRaw "baz=quux"+-- ghci| :}+-- ghci> 'rqParams' rq+-- fromList [("baz",["qux","quux"])]+-- ghci> 'rqParams' $ 'rqSetParam' "baz" ["corge"] rq+-- fromList [("baz", ["corge"])]+-- @+rqSetParam :: ByteString -- ^ parameter name+ -> [ByteString] -- ^ parameter values+ -> Request -- ^ request+ -> Request+rqSetParam k v = rqModifyParams $ Map.insert k v+{-# INLINE rqSetParam #-}+++ ---------------+ -- responses --+ ---------------++------------------------------------------------------------------------------+-- | An empty 'Response'.+--+-- Example:+--+-- @+-- ghci> 'emptyResponse'+-- HTTP\/1.1 200 OK+--+--+-- @+emptyResponse :: Response+emptyResponse = Response H.empty Map.empty Nothing+ (Stream (return . id))+ 200 "OK" False+++------------------------------------------------------------------------------+-- | Sets an HTTP response body to the given stream procedure.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> import qualified "Data.ByteString.Builder" as Builder+-- ghci> :{+-- ghci| let r = 'setResponseBody'+-- ghci| (\out -> do+-- ghci| Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out+-- ghci| return out)+-- ghci| 'emptyResponse'+-- ghci| :}+-- ghci> r+-- HTTP\/1.1 200 OK+--+-- Hello, world!+-- @+setResponseBody :: (OutputStream Builder -> IO (OutputStream Builder))+ -- ^ new response body+ -> Response -- ^ response to modify+ -> Response+setResponseBody e r = r { rspBody = Stream e }+{-# INLINE setResponseBody #-}+++------------------------------------------------------------------------------+-- | Sets the HTTP response status. Note: normally you would use+-- 'setResponseCode' unless you needed a custom response explanation.+--+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> setResponseStatus 500 \"Internal Server Error\" 'emptyResponse'+-- HTTP\/1.1 500 Internal Server Error+--+--+-- @+setResponseStatus :: Int -- ^ HTTP response integer code+ -> ByteString -- ^ HTTP response explanation+ -> Response -- ^ Response to be modified+ -> Response+setResponseStatus s reason r = r { rspStatus=s, rspStatusReason=reason }+{-# INLINE setResponseStatus #-}+++------------------------------------------------------------------------------+-- | Sets the HTTP response code.+--+-- Example:+--+-- @+-- ghci> setResponseCode 404 'emptyResponse'+-- HTTP\/1.1 404 Not Found+--+--+-- @+setResponseCode :: Int -- ^ HTTP response integer code+ -> Response -- ^ Response to be modified+ -> Response+setResponseCode s r = setResponseStatus s reason r+ where+ reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap)+{-# INLINE setResponseCode #-}+++------------------------------------------------------------------------------+-- | Modifies a response body.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> import qualified "Data.ByteString.Builder" as Builder+-- ghci> :{+-- ghci| let r = 'setResponseBody'+-- ghci| (\out -> do+-- ghci| Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out+-- ghci| return out)+-- ghci| 'emptyResponse'+-- ghci| :}+-- ghci> r+-- HTTP\/1.1 200 OK+--+-- Hello, world!+-- ghci> :{+-- ghci| let r' = 'modifyResponseBody'+-- ghci| (\f out -> do+-- ghci| out' <- f out+-- ghci| Streams.write (Just $ Builder.'byteString' \"\\nBye, world!\") out'+-- ghci| return out') r+-- ghci| :}+-- ghci> r'+-- HTTP\/1.1 200 OK+--+-- Hello, world!+-- Bye, world!+-- @+modifyResponseBody :: ((OutputStream Builder -> IO (OutputStream Builder)) ->+ (OutputStream Builder -> IO (OutputStream Builder)))+ -> Response+ -> Response+modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }+{-# INLINE modifyResponseBody #-}+++------------------------------------------------------------------------------+-- | Sets the @Content-Type@ in the 'Response' headers.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> setContentType \"text\/html\" 'emptyResponse'+-- HTTP\/1.1 200 OK+-- content-type: text\/html+--+--+-- @+setContentType :: ByteString -> Response -> Response+setContentType = setHeader "Content-Type"+{-# INLINE setContentType #-}+++------------------------------------------------------------------------------+-- | Convert 'Cookie' into 'ByteString' for output.+--+-- TODO: Remove duplication. This function is copied from+-- snap-server/Snap.Internal.Http.Server.Session.+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 ""++ -- TODO: 'formatHttpTime' uses "DD MMM YYYY" instead of "DD-MMM-YYYY",+ -- unlike the code in 'Snap.Internal.Http.Server.Session'. Is this form+ -- allowed?+ fmt = unsafePerformIO . formatHttpTime . toCTime++ toCTime :: UTCTime -> CTime+ toCTime = fromInteger . truncate . utcTimeToPOSIXSeconds++------------------------------------------------------------------------------+-- | Render cookies from a given 'Response' to 'Headers'.+--+-- TODO: Remove duplication. This function is copied from+-- snap-server/Snap.Internal.Http.Server.Session.+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++------------------------------------------------------------------------------+-- | Adds an HTTP 'Cookie' to 'Response' headers.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False+-- ghci> 'getResponseCookie' \"name\" $ 'addResponseCookie' cookie 'emptyResponse'+-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})+-- @+addResponseCookie :: Cookie -- ^ cookie value+ -> Response -- ^ response to modify+ -> Response+addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' }+ where+ cks'= Map.insert k ck $ rspCookies r+{-# INLINE addResponseCookie #-}+++------------------------------------------------------------------------------+-- | Gets an HTTP 'Cookie' with the given name from 'Response' headers.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'getResponseCookie' \"cookie-name\" 'emptyResponse'+-- Nothing+-- @+getResponseCookie :: ByteString -- ^ cookie name+ -> Response -- ^ response to query+ -> Maybe Cookie+getResponseCookie cn r = Map.lookup cn $ rspCookies r+{-# INLINE getResponseCookie #-}+++-- | Returns a list of 'Cookie's present in 'Response'+--+-- Example:+--+-- @+-- ghci> 'getResponseCookies' 'emptyResponse'+-- []+-- @+getResponseCookies :: Response -- ^ response to query+ -> [Cookie]+getResponseCookies = Map.elems . rspCookies+{-# INLINE getResponseCookies #-}+++------------------------------------------------------------------------------+-- | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note+-- this does not necessarily erase the cookie from the client browser.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False+-- ghci> let rsp = 'addResponseCookie' cookie 'emptyResponse'+-- ghci> 'getResponseCookie' \"name\" rsp+-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})+-- ghci> 'getResponseCookie' \"name\" $ 'deleteResponseCookie' \"name\" rsp+-- Nothing+-- @+deleteResponseCookie :: ByteString -- ^ cookie name+ -> Response -- ^ response to modify+ -> Response+deleteResponseCookie cn r = r { rspCookies = cks' }+ where+ cks'= Map.delete cn $ rspCookies r+{-# INLINE deleteResponseCookie #-}+++------------------------------------------------------------------------------+-- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.+-- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import "Data.Monoid"+-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False+-- ghci> let rsp = 'addResponseCookie' cookie 'emptyResponse'+-- ghci> 'getResponseCookie' \"name\" rsp+-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})+-- ghci> let f ck@('Cookie' { cookieName = name }) = ck { cookieName = name <> \"\'\"}+-- ghci> let rsp' = 'modifyResponseCookie' \"name\" f rsp+-- ghci> 'getResponseCookie' \"name\'\" rsp\'+-- Just (Cookie {cookieName = \"name\'\", ...})+-- ghci> 'getResponseCookie' \"name\" rsp\'+-- Just (Cookie {cookieName = \"name\", ...})+-- @+modifyResponseCookie :: ByteString -- ^ cookie name+ -> (Cookie -> Cookie) -- ^ modifier function+ -> Response -- ^ response to modify+ -> Response+modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r+ where+ modify ck = addResponseCookie (f ck) r+{-# INLINE modifyResponseCookie #-}+++------------------------------------------------------------------------------+-- | A note here: if you want to set the @Content-Length@ for the response,+-- Snap forces you to do it with this function rather than by setting it in+-- the headers; the @Content-Length@ in the headers will be ignored.+--+-- The reason for this is that Snap needs to look up the value of+-- @Content-Length@ for each request, and looking the string value up in the+-- headers and parsing the number out of the text will be too expensive.+--+-- If you don't set a content length in your response, HTTP keep-alive will be+-- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For+-- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if+-- @Content-Length@ is not specified.+--+-- Example:+--+-- @+-- ghci> setContentLength 400 'emptyResponse'+-- HTTP\/1.1 200 OK+-- Content-Length: 400+--+--+-- @+setContentLength :: Word64 -> Response -> Response+setContentLength !l r = r { rspContentLength = Just l }+{-# INLINE setContentLength #-}+++------------------------------------------------------------------------------+-- | Removes any @Content-Length@ set in the 'Response'.+--+-- Example:+--+-- @+-- ghci> clearContentLength $ 'setContentLength' 400 'emptyResponse'+-- HTTP\/1.1 200 OK+--+--+-- @+clearContentLength :: Response -> Response+clearContentLength r = r { rspContentLength = Nothing }+{-# INLINE clearContentLength #-}+++ ----------------+ -- HTTP dates --+ ----------------++------------------------------------------------------------------------------+-- | Convert a 'CTime' into an HTTP timestamp.+--+-- Example:+--+-- @+-- ghci> 'formatHttpTime' . 'fromIntegral' $ 10+-- \"Thu, 01 Jan 1970 00:00:10 GMT\"+-- @+formatHttpTime :: CTime -> IO ByteString+++------------------------------------------------------------------------------+-- | Convert a 'CTime' into common log entry format.+formatLogTime :: CTime -> IO ByteString+++------------------------------------------------------------------------------+-- | Converts an HTTP timestamp into a 'CTime'.+--+-- If the given time string is unparseable, this function will return 0.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'parseHttpTime' \"Thu, 01 Jan 1970 00:00:10 GMT\"+-- 10+-- @+parseHttpTime :: ByteString -> IO CTime++#ifdef PORTABLE++------------------------------------------------------------------------------+-- local definitions+fromStr :: String -> ByteString+fromStr = S.pack -- only because we know there's no unicode+{-# INLINE fromStr #-}+++------------------------------------------------------------------------------+formatHttpTime = return . format . toUTCTime+ where+ format :: UTCTime -> ByteString+ format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"++ toUTCTime :: CTime -> UTCTime+ toUTCTime = posixSecondsToUTCTime . realToFrac+++------------------------------------------------------------------------------+formatLogTime ctime = do+ t <- utcToLocalZonedTime $ toUTCTime ctime+ return $! format t++ where+ format :: ZonedTime -> ByteString+ format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"++ toUTCTime :: CTime -> UTCTime+ toUTCTime = posixSecondsToUTCTime . realToFrac+++------------------------------------------------------------------------------+parseHttpTime = return . toCTime . prs . S.unpack+ where+ parseTime =+#if MIN_VERSION_time(1,10,0)+ parseTimeM True+#else+ Time.parseTime+#endif++ prs :: String -> Maybe UTCTime+ prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"++ toCTime :: Maybe UTCTime -> CTime+ toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t+ toCTime Nothing = fromInteger 0++#else++------------------------------------------------------------------------------+formatLogTime t = do+ ptr <- mallocBytes 40+ c_format_log_time t ptr+ S.unsafePackMallocCString ptr+++------------------------------------------------------------------------------+formatHttpTime t = do+ ptr <- mallocBytes 40+ c_format_http_time t ptr+ S.unsafePackMallocCString ptr+++------------------------------------------------------------------------------+parseHttpTime s = S.unsafeUseAsCString s $ \ptr ->+ c_parse_http_time ptr++#endif+++------------------------------------------------------------------------------+-- | Adapted from:+--+-- <https://www.iana.org/assignments/http-status-codes/http-status-codes.txt>+statusReasonMap :: IM.IntMap ByteString+statusReasonMap = IM.fromList [+ (100, "Continue"),+ (101, "Switching Protocols"),+ (102, "Processing"),+ (103, "Early Hints"),+ -- 104-199 Unassigned+ (200, "OK"),+ (201, "Created"),+ (202, "Accepted"),+ (203, "Non-Authoritative Information"),+ (204, "No Content"),+ (205, "Reset Content"),+ (206, "Partial Content"),+ (207, "Multi-Status"),+ (208, "Already Reported"),+ -- 209-225 Unassigned+ (226, "IM Used"),+ -- 227-299 Unassigned,+ (300, "Multiple Choices"),+ (301, "Moved Permanently"),+ (302, "Found"),+ (303, "See Other"),+ (304, "Not Modified"),+ (305, "Use Proxy"),+ (306, "(Unused)"),+ (307, "Temporary Redirect"),+ (308, "Permanent Redirect"),+ -- 309-399 Unassigned+ (400, "Bad Request"),+ (401, "Unauthorized"),+ (402, "Payment Required"),+ (403, "Forbidden"),+ (404, "Not Found"),+ (405, "Method Not Allowed"),+ (406, "Not Acceptable"),+ (407, "Proxy Authentication Required"),+ (408, "Request Timeout"),+ (409, "Conflict"),+ (410, "Gone"),+ (411, "Length Required"),+ (412, "Precondition Failed"),+ (413, "Payload Too Large"),+ (414, "URI Too Long"),+ (415, "Unsupported Media Type"),+ (416, "Range Not Satisfiable"),+ (417, "Expectation Failed"),+ -- 418-420 Unassigned+ (421, "Misdirected Request"),+ (422, "Unprocessable Entity"),+ (423, "Locked"),+ (424, "Failed Dependency"),+ (425, "Too Early"),+ (426, "Upgrade Required"),+ -- 427 Unassigned+ (428, "Precondition Required"),+ (429, "Too Many Requests"),+ -- 430 Unassigned+ (431, "Request Header Fields Too Large"),+ -- 432-450 Unassigned+ (451, "Unavailable For Legal Reasons"),+ -- 452-499 Unassigned+ (500, "Internal Server Error"),+ (501, "Not Implemented"),+ (502, "Bad Gateway"),+ (503, "Service Unavailable"),+ (504, "Gateway Timeout"),+ (505, "HTTP Version Not Supported"),+ (506, "Variant Also Negotiates"),+ (507, "Insufficient Storage"),+ (508, "Loop Detected"),+ -- 509 Unassigned+ (510, "Not Extended"),+ (511, "Network Authentication Required")+ -- 512-599 Unassigned+ ]++------------------------------------------------------------------------------+-- Deprecated functions++-- | See 'rqClientAddr'.+rqRemoteAddr :: Request -> ByteString+rqRemoteAddr = rqClientAddr+{-# DEPRECATED rqRemoteAddr "(snap-core >= 1.0.0.0) please use 'rqClientAddr', this will be removed in 1.1.*" #-}++-- | See 'rqClientPort'.+rqRemotePort :: Request -> Int+rqRemotePort = rqClientPort+{-# DEPRECATED rqRemotePort "(snap-core >= 1.0.0.0) please use 'rqClientPort', this will be removed in 1.1.*" #-}
src/Snap/Internal/Instances.hs view
@@ -1,51 +1,51 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE PackageImports #-}--module Snap.Internal.Instances where+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-}+{-# LANGUAGE CPP #-} -import Control.Applicative-import Control.Monad.CatchIO ()-import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.List-import Control.Monad.RWS.Strict hiding (pass)-import qualified Control.Monad.RWS.Lazy as LRWS-import Control.Monad.Reader-import Control.Monad.State.Strict-import qualified Control.Monad.State.Lazy as LState-import Control.Monad.Writer.Strict hiding (pass)-import qualified Control.Monad.Writer.Lazy as LWriter-import Prelude hiding (catch)+-- Note re: "-fno-warn-warnings-deprecations" above: transformers has+-- deprecated Control.Monad.Trans.Error (which we like) but we are going to+-- provide an ErrorT instance for compatibility until the deprecated modules+-- are removed. +module Snap.Internal.Instances () where -------------------------------------------------------------------------------import Snap.Internal.Types--+import Control.Monad.Trans.Class (MonadTrans (lift))+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (Error, ErrorT)+#endif+#if MIN_VERSION_transformers(0,4,0)+import Control.Monad.Trans.Except (ExceptT)+#endif+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.List (ListT)+#endif+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.RWS.Lazy as LRWS (RWST)+import Control.Monad.Trans.RWS.Strict (RWST)+import qualified Control.Monad.Trans.State.Lazy as LState (StateT)+import Control.Monad.Trans.State.Strict (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LWriter (WriterT)+import Control.Monad.Trans.Writer.Strict (WriterT)+import Snap.Internal.Core (MonadSnap (..))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid)+#endif -------------------------------------------------------------------------------instance MonadPlus m => MonadPlus (ContT c m) where- mzero = lift mzero- m `mplus` n = ContT $ \ f -> runContT m f `mplus` runContT n f -------------------------------------------------------------------------------instance MonadPlus m => Alternative (ContT c m) where- empty = mzero- (<|>) = mplus----------------------------------------------------------------------------------instance MonadSnap m => MonadSnap (ContT c m) where- liftSnap = lift . liftSnap---------------------------------------------------------------------------------+#if !MIN_VERSION_transformers(0,6,0) instance (MonadSnap m, Error e) => MonadSnap (ErrorT e m) where liftSnap = lift . liftSnap - ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (ListT m) where liftSnap = lift . liftSnap+#endif++#if MIN_VERSION_transformers(0,4,0)+instance (MonadSnap m, Monoid e) => MonadSnap (ExceptT e m) where+ liftSnap = lift . liftSnap+#endif ------------------------------------------------------------------------------
− src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
@@ -1,242 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}--module Snap.Internal.Iteratee.BoyerMooreHorspool- ( bmhEnumeratee- , MatchInfo(..) )- where--import Control.Monad.State-import qualified Data.ByteString as S-import Data.ByteString (ByteString)-import Data.ByteString.Unsafe as S-import Data.Enumerator hiding (head, filter, last, map)-import qualified Data.Enumerator.List as EL-import Data.Int-import qualified Data.Vector.Unboxed as V-import qualified Data.Vector.Unboxed.Mutable as MV-import Prelude hiding (head, last)-----{-# INLINE debug #-}---debug :: MonadIO m => String -> m ()---debug s = liftIO $ putStrLn s---debug _ = return ()---------------------------------------------------------------------------------data MatchInfo = Match !ByteString- | NoMatch !ByteString- deriving (Show)----- We return strict bytestring because we always expect a chunk to be bigger--- than the needle-lookahead :: (MonadIO m) =>- Int- -> Iteratee ByteString m (Either ByteString ByteString)-lookahead n = go id n- where- go !dlist !k = do- EL.head >>= maybe- (do- let !ls = S.concat $ dlist []- -- debug $ "lookahead " ++ show n- -- ++ " failing, returning " ++ show ls-- return $ Left ls)- (\x -> do- let !l = S.length x- let !r = k - l- let !d' = dlist . (x:)-- if r <= 0- then do- let !ls = S.concat $ d' []- -- debug $ "lookahead " ++ show n- -- ++ " successfully returning "- -- ++ show ls- return $ Right $ ls- else go d' r)-{-# INLINE lookahead #-}--matches :: ByteString -- ^ needle- -> Int -- ^ needle start- -> Int -- ^ needle end (inclusive)- -> ByteString -- ^ haystack- -> Int -- ^ haystack start- -> Int -- ^ haystack end (inclusive)- -> Bool-matches !needle !nstart !nend' !haystack !hstart !hend' =- go nend' hend'- where- go !nend !hend =- if nend < nstart || hend < hstart- then True- else let !nc = S.unsafeIndex needle nend- !hc = S.unsafeIndex haystack hend- in if nc /= hc- then False- else go (nend-1) (hend-1)-{-# INLINE matches #-}---bmhEnumeratee :: (MonadIO m) =>- ByteString- -> Step MatchInfo m a- -> Iteratee ByteString m (Step MatchInfo m a)-bmhEnumeratee needle _step = do- -- debug $ "boyermoore: needle=" ++ show needle- cDone _step iter- where- {-# INLINE cDone #-}- cDone (Continue k) f = f k- cDone step _ = yield step (Chunks [])--- iter !k = {-# SCC "bmh/iter" #-} do- lookahead nlen >>= either (finishAndEOF k . (:[]))- (startSearch k)-- finishAndEOF k xs = {-# SCC "finishAndEOF" #-} do- -- debug $ "finishAndEOF, returning NoMatch for " ++ show xs- step <- lift $ runIteratee $ k $- Chunks (map NoMatch $ filter (not . S.null) xs)- cDone step (\k' -> lift $ runIteratee $ k' EOF)--- startSearch !k !haystack = {-# SCC "startSearch" #-} do- -- debug $ "startsearch: " ++ show haystack- if S.null haystack- then lookahead nlen >>=- either (\s -> finishAndEOF k [s])- (startSearch k)- else go 0- where- !hlen = S.length haystack-- go !hidx- | hend >= hlen = crossBound hidx- | otherwise = {-# SCC "go" #-} do- let match = matches needle 0 last haystack hidx hend- -- debug $ "go " ++ show hidx ++ ", hend=" ++ show hend- -- ++ ", match was " ++ show match- if match- then {-# SCC "go/match" #-} do- let !nomatch = S.take hidx haystack- let !aftermatch = S.drop (hend+1) haystack-- step <- if not $ S.null nomatch- then lift $ runIteratee $ k- $ Chunks [NoMatch nomatch]- else return $ Continue k-- cDone step $ \k' -> do- step' <- lift $ runIteratee $ k' $ Chunks [Match needle]- cDone step' $ \k'' -> startSearch k'' aftermatch- else {-# SCC "go/nomatch" #-} do- -- skip ahead- let c = S.unsafeIndex haystack hend- let !skip = V.unsafeIndex table $ fromEnum c- go (hidx + skip)- where- !hend = hidx + nlen - 1-- mkCoeff hidx = let !ll = hlen - hidx- !nm = nlen - ll- in (ll,nm)-- crossBound !hidx0 = {-# SCC "crossBound" #-} do- let (!leftLen, needMore) = mkCoeff hidx0-- lookahead needMore >>=- either (\s -> finishAndEOF k [haystack, s])- (runNext hidx0 leftLen needMore)- where- runNext !hidx !leftLen !needMore !nextHaystack = do- let match1 = matches needle leftLen last- nextHaystack 0 (needMore-1)- let match2 = matches needle 0 (leftLen-1)- haystack hidx (hlen-1)-- -- debug $ "crossbound match1=" ++ show match1- -- ++ " match2=" ++ show match2-- if match1 && match2- then {-# SCC "crossBound/match" #-} do- let !nomatch = S.take hidx haystack- let !aftermatch = S.drop needMore nextHaystack-- -- FIXME: merge this code w/ above- step <- if not $ S.null nomatch- then lift $ runIteratee $ k $- Chunks [NoMatch nomatch]- else return $ Continue k-- -- debug $ "matching"- cDone step $ \k' -> do- step' <- lift $ runIteratee $ k' $- Chunks [Match needle]- cDone step' $ \k'' ->- startSearch k'' aftermatch-- else {-# SCC "crossBound/nomatch" #-} do- let c = S.unsafeIndex nextHaystack $ needMore-1- let p = V.unsafeIndex table (fromEnum c)-- -- debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen- if p < leftLen- then do- let !hidx' = hidx+p- let (!leftLen', needMore') = mkCoeff hidx'- let !nextlen = S.length nextHaystack- if (nextlen < needMore')- then do- -- this should be impossibly rare- lookahead (needMore' - nextlen) >>=- either (\s -> finishAndEOF k [ haystack- , nextHaystack- , s ])- (\s -> runNext hidx' leftLen' needMore' $- S.append nextHaystack s)- else runNext hidx' leftLen' needMore' nextHaystack- else do- let sidx = p - leftLen- let (!crumb, !rest) = S.splitAt sidx nextHaystack- step <- lift $ runIteratee $ k $- Chunks $ map NoMatch $- filter (not . S.null) [haystack, crumb]-- cDone step $ flip startSearch rest--- !nlen = S.length needle-- !last = nlen - 1-- !table = V.create $ do- t <- MV.replicate 256 nlen- go t-- where- go !t = go' 0- where- go' !i | i >= last = return t- | otherwise = do- let c = fromEnum $ S.unsafeIndex needle i- MV.unsafeWrite t c (last - i)- go' $! i+1--{--testIt :: ByteString -> [ByteString] -> IO [MatchInfo]-testIt needle haystack = do- consumeStep <- runIteratee EL.consume- eteeStep <- runIteratee $ etee consumeStep- -- iter :: Iteratee ByteString m (Step MatchInfo m [MatchInfo])- let iter = enumList 1 haystack eteeStep- finalInnerStep <- run_ iter- run_ $ returnI finalInnerStep-- where- etee = bmhEnumeratee needle--}
− src/Snap/Internal/Iteratee/Debug.hs
@@ -1,113 +0,0 @@--- | An internal Snap module for debugging iteratees.------ /N.B./ this is an internal interface, please don't write user code that--- depends on it.--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}---module Snap.Internal.Iteratee.Debug- ( debugIteratee- , iterateeDebugWrapper- , iterateeDebugWrapperWith- , showBuilder- ) where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Monad.Trans-import Data.ByteString (ByteString)-import System.IO--------------------------------------------------------------------------------#ifndef NODEBUG-import Snap.Internal.Debug-#endif-import Snap.Iteratee hiding (map)-----------------------------------------------------------------------------------------------------------------------------------------------------------------showBuilder :: Builder -> String-showBuilder = show . toByteString----------------------------------------------------------------------------------debugIteratee :: Iteratee ByteString IO ()-debugIteratee = continue f- where- f EOF = do- liftIO $ putStrLn $ "got EOF"- liftIO $ hFlush stdout- yield () EOF-- f (Chunks xs) = do- liftIO $ putStrLn $ "got chunk: " ++ show (xs)- liftIO $ hFlush stdout- continue f---#ifndef NODEBUG--iterateeDebugWrapperWith :: (MonadIO m) =>- (a -> String)- -> String- -> Iteratee a m b- -> Iteratee a m b-iterateeDebugWrapperWith showFunc name iter = do- debug $ name ++ ": BEGIN"- step <- lift $ runIteratee iter- whatWasReturn step- check step-- where- whatWasReturn (Continue _) = debug $ name ++ ": continue"- whatWasReturn (Yield _ z) = debug $ name ++ ": yield, with remainder "- ++ showStream z- whatWasReturn (Error e) = debug $ name ++ ": error, with " ++ show e-- check (Continue k) = continue $ f k- check st = returnI st--- f k EOF = do- debug $ name ++ ": got EOF"- k EOF-- f k ch@(Chunks xs) = do- debug $ name ++ ": got chunk: " ++ showL xs- step <- lift $ runIteratee $ k ch- whatWasReturn step- check step-- showStream = show . fmap showFunc- showL = show . map showFunc---iterateeDebugWrapper :: (Show a, MonadIO m) =>- String- -> Iteratee a m b- -> Iteratee a m b-iterateeDebugWrapper = iterateeDebugWrapperWith show---#else--iterateeDebugWrapperWith :: (MonadIO m) =>- (s -> String)- -> String- -> Iteratee s m a- -> Iteratee s m a-iterateeDebugWrapperWith _ _ = id-{-# INLINE iterateeDebugWrapperWith #-}---iterateeDebugWrapper :: (Show a, MonadIO m) =>- String- -> Iteratee a m b- -> Iteratee a m b-iterateeDebugWrapper _ = id-{-# INLINE iterateeDebugWrapper #-}--#endif
src/Snap/Internal/Parsing.hs view
@@ -1,167 +1,201 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------ module Snap.Internal.Parsing where- -------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Applicative-import Control.Arrow (first, second)-import Control.Monad-import Data.Attoparsec.Types (IResult(..))-import Data.Attoparsec.Char8-import Data.Bits-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.ByteString.Nums.Careless.Int (int)-import qualified Data.ByteString.Nums.Careless.Hex as Cvt-import qualified Data.CaseInsensitive as CI-import Data.CaseInsensitive (CI)-import Data.Char hiding (isDigit, isSpace)-import Data.DList (DList)-import qualified Data.DList as DL-import Data.Int-import Data.List (intersperse)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Word-import Prelude hiding (head, take, takeWhile)-+import Control.Applicative (Alternative ((<|>)), Applicative (pure, (*>), (<*)), liftA2, (<$>))+import Control.Arrow (first, second)+import Control.Monad (Monad (return), MonadPlus (mzero), liftM, when)+import Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile, sepBy')+import qualified Data.Attoparsec.ByteString.Char8 as AP+import Data.Bits (Bits (unsafeShiftL, (.&.), (.|.)))+import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString, word8)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI (mk)+import Data.Char (Char, intToDigit, isAlpha, isAlphaNum, isAscii, isControl, isHexDigit, ord)+import Data.Int (Int64)+import Data.List (concat, intercalate, intersperse)+import Data.Map (Map)+import qualified Data.Map as Map (empty, insertWith, toList)+import Data.Maybe (Maybe (..), maybe)+import Data.Monoid (Monoid (mconcat, mempty), (<>))+import Data.Word (Word8)+import GHC.Exts ( Int (I#)+ , word2Int#+#if MIN_VERSION_base(4,16,0)+ , uncheckedShiftRLWord8#+ , word8ToWord#+#else+ , uncheckedShiftRL#+#endif+ )+import GHC.Word (Word8 (..))+import Prelude (Bool (..), Either (..), Enum (fromEnum, toEnum), Eq (..), Num (..), Ord (..), String, and, any, concatMap, elem, error, filter, flip, foldr, fst, id, map, not, otherwise, show, snd, ($), ($!), (&&), (++), (.), (||))+import Snap.Internal.Http.Types (Cookie (Cookie)) -------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Parsing.FastSet (FastSet)-import qualified Snap.Internal.Parsing.FastSet as FS ------------------------------------------------------------------------------+{-# INLINE fullyParse #-} fullyParse :: ByteString -> Parser a -> Either String a-fullyParse s p =+fullyParse = fullyParse' parse feed++{-# INLINE (<?>) #-}+(<?>) :: Parser a -> String -> Parser a+(<?>) a !b = (AP.<?>) a b+infix 0 <?>++------------------------------------------------------------------------------+{-# INLINE fullyParse' #-}+fullyParse' :: (Parser a -> ByteString -> Result a)+ -> (Result a -> ByteString -> Result a)+ -> ByteString+ -> Parser a+ -> Either String a+fullyParse' parseFunc feedFunc s p = case r' of- (Fail _ _ e) -> Left e- (Partial _) -> Left "parse failed"+ (Fail _ context e) -> Left $ concat [ "Parsing "+ , intercalate "/" context+ , ": "+ , e+ , "."+ ]+ (Partial _) -> Left "parse failed" -- expected to be impossible (Done _ x) -> Right x where- r = parse p s- r' = feed r ""-+ r = parseFunc p s+ r' = feedFunc r "" -------------------------------------------------------------------------------parseNum :: Parser Int64-parseNum = liftM int $ takeWhile1 isDigit-+-- Parsers for different tokens in an HTTP request. --------------------------------------------------------------------------------- | Parsers for different tokens in an HTTP request.-sp, digit, letter :: Parser Char-sp = char ' '-digit = satisfy isDigit-letter = satisfy isAlpha+parseNum :: Parser Int64+parseNum = decimal ------------------------------------------------------------------------------ untilEOL :: Parser ByteString-untilEOL = takeWhile notend+untilEOL = takeWhile notend <?> "untilEOL" where notend c = not $ c == '\r' || c == '\n' ------------------------------------------------------------------------------ crlf :: Parser ByteString-crlf = string "\r\n"----------------------------------------------------------------------------------generateFS :: (Word8 -> Bool) -> FastSet-generateFS f = FS.fromList $ filter f [0..255]+crlf = string "\r\n" <?> "crlf" --------------------------------------------------------------------------------- | Parser for zero or more spaces.-spaces :: Parser [Char]-spaces = many sp+toTableList :: (Char -> Bool) -> [Char]+toTableList f = l+ where+ g c = c /= '-' && f c+ !l1 = filter g $ map w2c [0..255]+ !l0 = if f '-' then ['-'] else []+ !l = l0 ++ l1+{-# INLINE toTableList #-} -------------------------------------------------------------------------------pSpaces :: Parser ByteString-pSpaces = takeWhile isSpace+toTable :: (Char -> Bool) -> (Char -> Bool)+toTable = inClass . toTableList+{-# INLINE toTable #-} -------------------------------------------------------------------------------fieldChars :: Parser ByteString-fieldChars = takeWhile isFieldChar- where- isFieldChar = flip FS.memberChar fieldCharSet+skipFieldChars :: Parser ()+skipFieldChars = skipWhile isFieldChar -------------------------------------------------------------------------------fieldCharSet :: FastSet-fieldCharSet = generateFS f+isFieldChar :: Char -> Bool+isFieldChar = toTable f where- f d = let c = (toEnum $ fromEnum d)- in (isDigit c) || (isAlpha c) || c == '-' || c == '_'+ f c = (isDigit c) || (isAlpha c) || c == '-' || c == '_' ------------------------------------------------------------------------------ -- | Parser for request headers. pHeaders :: Parser [(ByteString, ByteString)]-pHeaders = many header+pHeaders = many' header <?> "headers" where- header = {-# SCC "pHeaders/header" #-}- liftA2 (,)- fieldName- (char ':' *> spaces *> contents)+ --------------------------------------------------------------------------+ slurp p = fst <$> match p - fieldName = {-# SCC "pHeaders/fieldName" #-}- liftA2 S.cons letter fieldChars+ --------------------------------------------------------------------------+ header = {-# SCC "pHeaders/header" #-}+ liftA2 (,)+ fieldName+ (char ':' *> skipSpace *> contents) - contents = {-# SCC "pHeaders/contents" #-}- liftA2 S.append- (untilEOL <* crlf)- (continuation <|> pure S.empty)+ --------------------------------------------------------------------------+ fieldName = {-# SCC "pHeaders/fieldName" #-}+ slurp (letter_ascii *> skipFieldChars) - isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-}- elem w wstab+ --------------------------------------------------------------------------+ contents = {-# SCC "pHeaders/contents" #-}+ liftA2 S.append+ (untilEOL <* crlf)+ (continuation <|> pure S.empty) - wstab = " \t"+ --------------------------------------------------------------------------+ isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-}+ w == ' ' || w == '\t' + -------------------------------------------------------------------------- leadingWhiteSpace = {-# SCC "pHeaders/leadingWhiteSpace" #-}- takeWhile1 isLeadingWS+ skipWhile1 isLeadingWS - continuation = {-# SCC "pHeaders/continuation" #-}- liftA2 S.cons- (leadingWhiteSpace *> pure ' ')- contents+ --------------------------------------------------------------------------+ continuation = {-# SCC "pHeaders/continuation" #-}+ liftA2 S.cons+ (leadingWhiteSpace *> pure ' ')+ contents + --------------------------------------------------------------------------+ skipWhile1 f = satisfy f *> skipWhile f + ------------------------------------------------------------------------------ -- unhelpfully, the spec mentions "old-style" cookies that don't have quotes -- around the value. wonderful. pWord :: Parser ByteString-pWord = pQuotedString <|> (takeWhile (/= ';'))+pWord = pWord' isRFCText ------------------------------------------------------------------------------+pWord' :: (Char -> Bool) -> Parser ByteString+pWord' charPred = pQuotedString' charPred <|> (takeWhile (/= ';'))+++------------------------------------------------------------------------------ pQuotedString :: Parser ByteString-pQuotedString = q *> quotedText <* q+pQuotedString = pQuotedString' isRFCText+++------------------------------------------------------------------------------+pQuotedString' :: (Char -> Bool) -> Parser ByteString+pQuotedString' charPred = q *> quotedText <* q where- quotedText = (S.concat . reverse) <$> f []+ quotedText = (S.concat . L.toChunks . toLazyByteString) <$> f mempty f soFar = do t <- takeWhile qdtext-- let soFar' = t:soFar-+ let soFar' = soFar <> byteString t -- RFC says that backslash only escapes for <">- choice [ string "\\\"" *> f ("\"" : soFar')+ choice [ string "\\\"" *> f (soFar' <> char8 '"') , pure soFar' ] -- q = char '\"'-- qdtext = matchAll [ isRFCText, (/= '\"'), (/= '\\') ]+ q = char '"'+ qdtext = matchAll [ charPred, (/= '"'), (/= '\\') ] ------------------------------------------------------------------------------@@ -180,53 +214,73 @@ pAvPairs :: Parser [(ByteString, ByteString)] pAvPairs = do a <- pAvPair- b <- many (pSpaces *> char ';' *> pSpaces *> pAvPair)-- return $ a:b+ b <- many' (skipSpace *> char ';' *> skipSpace *> pAvPair)+ return $! a:b ------------------------------------------------------------------------------+{-# INLINE pAvPair #-} pAvPair :: Parser (ByteString, ByteString) pAvPair = do- key <- pToken <* pSpaces- val <- liftM trim (option "" $ char '=' *> pSpaces *> pWord)-- return (key, val)+ key <- pToken <* skipSpace+ val <- liftM trim (option "" $ char '=' *> skipSpace *> pWord)+ return $! (key, val) ------------------------------------------------------------------------------ pParameter :: Parser (ByteString, ByteString)-pParameter = do- key <- pToken <* pSpaces- val <- liftM trim (char '=' *> pSpaces *> pWord)- return (trim key, val)+pParameter = pParameter' isRFCText ------------------------------------------------------------------------------+pParameter' :: (Char -> Bool) -> Parser (ByteString, ByteString)+pParameter' valueCharPred = parser <?> "pParameter'"+ where+ parser = do+ key <- pToken <* skipSpace+ val <- liftM trim (char '=' *> skipSpace *> pWord' valueCharPred)+ return $! (trim key, val)+++------------------------------------------------------------------------------+{-# INLINE trim #-} trim :: ByteString -> ByteString trim = snd . S.span isSpace . fst . S.spanEnd isSpace ------------------------------------------------------------------------------ pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])-pValueWithParameters = do- value <- liftM trim (pSpaces *> takeWhile (/= ';'))- params <- many pParam- return (value, map (first CI.mk) params)+pValueWithParameters = pValueWithParameters' isRFCText+++------------------------------------------------------------------------------+pValueWithParameters' :: (Char -> Bool) -> Parser (ByteString, [(CI ByteString, ByteString)])+pValueWithParameters' valueCharPred = parser <?> "pValueWithParameters'" where- pParam = pSpaces *> char ';' *> pSpaces *> pParameter+ parser = do+ value <- liftM trim (skipSpace *> takeWhile (/= ';'))+ params <- many' pParam+ endOfInput+ return (value, map (first CI.mk) params)+ pParam = skipSpace *> char ';' *> skipSpace *> pParameter' valueCharPred + -------------------------------------------------------------------------------pContentTypeWithParameters ::- Parser (ByteString, [(CI ByteString, ByteString)])-pContentTypeWithParameters = do- value <- liftM trim (pSpaces *> takeWhile (not . isSep))- params <- many (pSpaces *> satisfy isSep *> pSpaces *> pParameter)- return (value, map (first CI.mk) params)+pContentTypeWithParameters :: Parser ( ByteString+ , [(CI ByteString, ByteString)] )+pContentTypeWithParameters = parser <?> "pContentTypeWithParameters" where+ parser = do+ value <- liftM trim (skipSpace *> takeWhile (not . isSep))+ params <- many' (skipSpace *> satisfy isSep *> skipSpace *> pParameter)+ endOfInput+ return $! (value, map (first CI.mk) params)+ isSep c = c == ';' || c == ',' + ------------------------------------------------------------------------------+{-# INLINE pToken #-} pToken :: Parser ByteString pToken = takeWhile isToken @@ -234,10 +288,7 @@ ------------------------------------------------------------------------------ {-# INLINE isToken #-} isToken :: Char -> Bool-isToken c = FS.memberChar c tokenTable--tokenTable :: FastSet-tokenTable = generateFS (f . toEnum . fromEnum)+isToken = toTable f where f = matchAll [ isAscii , not . isControl@@ -249,9 +300,19 @@ --------------------------------------------------------------------------------- URL ENCODING-------------------------------------------------------------------------------+{-# INLINE pTokens #-}+-- | Used for "#field-name", and field-name = token, so "#token":+-- comma-separated tokens/field-names, like a header field list.+pTokens :: Parser [ByteString]+pTokens = (skipSpace *> pToken <* skipSpace) `sepBy'` char ',' ++ ------------------+ -- Url encoding --+ ------------------++------------------------------------------------------------------------------+{-# INLINE parseToCompletion #-} parseToCompletion :: Parser a -> ByteString -> Maybe a parseToCompletion p s = toResult $ finish r where@@ -262,161 +323,241 @@ ------------------------------------------------------------------------------+type DList a = [a] -> [a]+ pUrlEscaped :: Parser ByteString pUrlEscaped = do- sq <- nextChunk DL.empty- return $ S.concat $ DL.toList sq+ sq <- nextChunk id+ return $! S.concat $ sq [] where+ -------------------------------------------------------------------------- nextChunk :: DList ByteString -> Parser (DList ByteString)- nextChunk s = (endOfInput *> pure s) <|> do+ nextChunk !s = (endOfInput *> pure s) <|> do c <- anyChar case c of '+' -> plusSpace s '%' -> percentEncoded s _ -> unEncoded c s + -------------------------------------------------------------------------- percentEncoded :: DList ByteString -> Parser (DList ByteString)- percentEncoded l = do+ percentEncoded !l = do hx <- take 2 when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $- fail "bad hex in url"+ mzero - let code = w2c ((Cvt.hex hx) :: Word8)- nextChunk $ DL.snoc l (S.singleton code)+ let code = w2c ((unsafeFromHex hx) :: Word8)+ nextChunk $ l . ((S.singleton code) :) + -------------------------------------------------------------------------- unEncoded :: Char -> DList ByteString -> Parser (DList ByteString)- unEncoded c l' = do- let l = DL.snoc l' (S.singleton c)- bs <- takeTill (flip elem "%+")+ unEncoded !c !l' = do+ let l = l' . ((S.singleton c) :)+ bs <- takeTill (flip elem ['%', '+']) if S.null bs then nextChunk l- else nextChunk $ DL.snoc l bs+ else nextChunk $ l . (bs :) + -------------------------------------------------------------------------- plusSpace :: DList ByteString -> Parser (DList ByteString)- plusSpace l = nextChunk (DL.snoc l (S.singleton ' '))+ plusSpace l = nextChunk (l . ((S.singleton ' ') :)) --------------------------------------------------------------------------------- | Decodes an URL-escaped string (see+-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"+-- [not including the quotes - ed], and reserved characters used for their+-- reserved purposes may be used unencoded within a URL."+++++------------------------------------------------------------------------------+-- | Decode an URL-escaped string (see -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+--+-- Example:+--+-- @+-- ghci> 'urlDecode' "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"+-- Just "1 attoparsec ~= 3 * 10^-2 meters"+-- @ urlDecode :: ByteString -> Maybe ByteString urlDecode = parseToCompletion pUrlEscaped+{-# INLINE urlDecode #-} --------------------------------------------------------------------------------- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"--- [not including the quotes - ed], and reserved characters used for their--- reserved purposes may be used unencoded within a URL."---- | URL-escapes a string (see+-- | URL-escape a string (see -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+--+-- Example:+--+-- @+-- ghci> 'urlEncode' "1 attoparsec ~= 3 * 10^-2 meters"+-- "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"+-- @ urlEncode :: ByteString -> ByteString-urlEncode = toByteString . urlEncodeBuilder+urlEncode = S.concat . L.toChunks . toLazyByteString . urlEncodeBuilder+{-# INLINE urlEncode #-} --------------------------------------------------------------------------------- | URL-escapes a string (see+-- | URL-escape a string (see -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+--+-- Example:+--+-- @+-- ghci> import "Data.ByteString.Builder"+-- ghci> 'toLazyByteString' . 'urlEncodeBuilder' $ "1 attoparsec ~= 3 * 10^-2 meters"+-- "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"+-- @ urlEncodeBuilder :: ByteString -> Builder-urlEncodeBuilder = S.foldl' f mempty+urlEncodeBuilder = go mempty where- f b c =- if c == ' '- then b `mappend` fromWord8 (c2w '+')- else if FS.memberChar c urlEncodeTable- then b `mappend` fromWord8 (c2w c)- else b `mappend` hexd c+ go !b !s = maybe b' esc (S.uncons y)+ where+ (x,y) = S.span urlEncodeClean s+ b' = b <> byteString x+ esc (c,r) = let b'' = if c == ' '+ then b' <> char8 '+'+ else b' <> hexd c+ in go b'' r -------------------------------------------------------------------------------urlEncodeTable :: FastSet-urlEncodeTable = generateFS f+urlEncodeClean :: Char -> Bool+urlEncodeClean = toTable f where- f w = any ($ c) [ isAlphaNum- , flip elem ['$', '-', '.', '!', '*'- , '\'', '(', ')', ',' ]]- where- c = w2c w+ f c = any ($ c) [\c' -> isAscii c' && isAlphaNum c'+ , flip elem [ '$', '_', '-', '.', '!'+ , '*' , '\'', '(', ')', ',' ]] ------------------------------------------------------------------------------ hexd :: Char -> Builder-hexd c0 = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low+hexd c0 = char8 '%' <> word8 hi <> word8 low where- c = c2w c0- d = c2w . intToDigit- low = d $ fromEnum $ c .&. 0xf- hi = d $ fromEnum $ (c .&. 0xf0) `shiftR` 4+ !c = c2w c0+ toDigit = c2w . intToDigit+ !low = toDigit $ fromEnum $ c .&. 0xf+ !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 + shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))+#if MIN_VERSION_base(4,16,0)+ uncheckedShiftRL# a# b# = word8ToWord# (uncheckedShiftRLWord8# a# b#)+#endif + ------------------------------------------------------------------------------ finish :: Result a -> Result a finish (Partial f) = flip feed "" $ f "" finish x = x ----------------------------------------------------------------------------------- application/x-www-form-urlencoded-------------------------------------------------------------------------------+ ---------------------------------------+ -- application/x-www-form-urlencoded --+ --------------------------------------- --------------------------------------------------------------------------------- | Parses a string encoded in @application/x-www-form-urlencoded@ format.+-- | Parse a string encoded in @application/x-www-form-urlencoded@ < http://en.wikipedia.org/wiki/POST_%28HTTP%29#Use_for_submitting_web_forms format>.+--+-- Example:+--+-- @+-- ghci> 'parseUrlEncoded' "Name=John+Doe&Name=Jane+Doe&Age=23&Formula=a+%2B+b+%3D%3D+13%25%21"+-- 'Data.Map.fromList' [("Age",["23"]),("Formula",["a + b == 13%!"]),("Name",["John Doe","Jane Doe"])]+-- @ parseUrlEncoded :: ByteString -> Map ByteString [ByteString]-parseUrlEncoded s = foldr (\(k,v) m -> Map.insertWith' (++) k [v] m)- Map.empty- decoded+parseUrlEncoded s = foldr ins Map.empty decoded+ where- breakApart = (second (S.drop 1)) . S.break (== '=')+ --------------------------------------------------------------------------+ ins (!k,v) !m = Map.insertWith (++) k [v] m + -------------------------------------------------------------------------- parts :: [(ByteString,ByteString)] parts = map breakApart $ S.splitWith (\c -> c == '&' || c == ';') s + --------------------------------------------------------------------------+ breakApart = (second (S.drop 1)) . S.break (== '=')++ -------------------------------------------------------------------------- urldecode = parseToCompletion pUrlEscaped + -------------------------------------------------------------------------- decodeOne (a,b) = do- a' <- urldecode a- b' <- urldecode b- return (a',b')+ !a' <- urldecode a+ !b' <- urldecode b+ return $! (a',b') - decoded = catMaybes $ map decodeOne parts+ --------------------------------------------------------------------------+ decoded = go id parts+ where+ go !dl [] = dl []+ go !dl (x:xs) = maybe (go dl xs)+ (\p -> go (dl . (p:)) xs)+ (decodeOne x) ------------------------------------------------------------------------------+-- | Like 'printUrlEncoded', but produces a 'Builder' instead of a+-- 'ByteString'. Useful for constructing a large string efficiently in+-- a single step.+--+-- Example:+--+-- @+-- ghci> import "Data.Map"+-- ghci> import "Data.Monoid"+-- ghci> import "Data.ByteString.Builder"+-- ghci> let bldr = 'buildUrlEncoded' ('Data.Map.fromList' [("Name", ["John Doe"]), ("Age", ["23"])])+-- ghci> 'toLazyByteString' $ 'byteString' "http://example.com/script?" <> bldr+-- "http://example.com/script?Age=23&Name=John+Doe"+-- @ buildUrlEncoded :: Map ByteString [ByteString] -> Builder buildUrlEncoded m = mconcat builders where- builders = intersperse (fromWord8 $ c2w '&') $- concatMap encodeVS $ Map.toList m+ builders = intersperse (char8 '&') $+ concatMap encodeVS $ Map.toList m encodeVS (k,vs) = map (encodeOne k) vs - encodeOne k v = mconcat [ urlEncodeBuilder k- , fromWord8 $ c2w '='- , urlEncodeBuilder v ]+ encodeOne k v = mconcat [ urlEncodeBuilder k+ , char8 '='+ , urlEncodeBuilder v ] ------------------------------------------------------------------------------+-- | Given a collection of key-value pairs with possibly duplicate+-- keys (represented as a 'Data.Map.Map'), construct a string in+-- @application/x-www-form-urlencoded@ format.+--+-- Example:+--+-- @+-- ghci> 'printUrlEncoded' ('Data.Map.fromList' [("Name", ["John Doe"]), ("Age", ["23"])])+-- "Age=23&Name=John+Doe"+-- @ printUrlEncoded :: Map ByteString [ByteString] -> ByteString-printUrlEncoded = toByteString . buildUrlEncoded+printUrlEncoded = S.concat . L.toChunks . toLazyByteString . buildUrlEncoded ---------------------------------------------------------------------------------- COOKIE PARSING-------------------------------------------------------------------------------+ --------------------+ -- Cookie parsing --+ -------------------- +------------------------------------------------------------------------------ -- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109 -- (cookie spec): please point out any errors!- ------------------------------------------------------------------------------ pCookies :: Parser [Cookie] pCookies = do -- grab kvps and turn to strict bytestrings kvps <- pAvPairs-- return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps+ return $! map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps where toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False@@ -427,11 +568,40 @@ parseCookie = parseToCompletion pCookies ---------------------------------------------------------------------------------- utility functions+ -----------------------+ -- utility functions --+ -----------------------+ ------------------------------------------------------------------------------+unsafeFromHex :: (Enum a, Num a, Bits a) => ByteString -> a+unsafeFromHex = S.foldl' f 0+ where+#if MIN_VERSION_base(4,5,0)+ sl = unsafeShiftL+#else+ sl = shiftL+#endif + f !cnt !i = sl cnt 4 .|. nybble i + nybble c | c >= '0' && c <= '9' = toEnum $! fromEnum c - fromEnum '0'+ | c >= 'a' && c <= 'f' = toEnum $! 10 + fromEnum c - fromEnum 'a'+ | c >= 'A' && c <= 'F' = toEnum $! 10 + fromEnum c - fromEnum 'A'+ | otherwise = error $ "bad hex digit: " ++ show c+{-# INLINE unsafeFromHex #-}++ -------------------------------------------------------------------------------strictize :: L.ByteString -> ByteString-strictize = S.concat . L.toChunks+-- Note: only works for nonnegative naturals+unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a+unsafeFromNat = S.foldl' f 0+ where+ zero = ord '0'+ f !cnt !i = cnt * 10 + toEnum (digitToInt i)++ digitToInt c = if d >= 0 && d <= 9+ then d+ else error $ "bad digit: '" ++ [c] ++ "'"+ where+ !d = ord c - zero+{-# INLINE unsafeFromNat #-}
− src/Snap/Internal/Parsing/FastSet.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash #-}---------------------------------------------------------------------------------- |--- Module : Snap.Internal.Parsing.FastSet--- Copyright : Bryan O'Sullivan 2008--- License : BSD3--- --- Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : unknown------ Fast set membership tests for 'Word8' and 8-bit 'Char' values. The--- set representation is unboxed for efficiency. For small sets, we--- test for membership using a binary search. For larger sets, we use--- a lookup table.------ Note: this module copied here from the attoparsec source because it was made--- private in version 0.10.--- -------------------------------------------------------------------------------module Snap.Internal.Parsing.FastSet- (- -- * Data type- FastSet- -- * Construction- , fromList- , set- -- * Lookup- , memberChar- , memberWord8- -- * Debugging- , fromSet- -- * Handy interface- , charClass- ) where--import Data.Bits ((.&.), (.|.))-import Foreign.Storable (peekByteOff, pokeByteOff)-import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)-import GHC.Word (Word8(W8#))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as U--data FastSet = Sorted { fromSet :: !B.ByteString }- | Table { fromSet :: !B.ByteString }- deriving (Eq, Ord)--instance Show FastSet where- show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s)- show (Table _) = "FastSet Table"---- | The lower bound on the size of a lookup table. We choose this to--- balance table density against performance.-tableCutoff :: Int-tableCutoff = 8---- | Create a set.-set :: B.ByteString -> FastSet-set s | B.length s < tableCutoff = Sorted . B.sort $ s- | otherwise = Table . mkTable $ s--fromList :: [Word8] -> FastSet-fromList = set . B.pack--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8--shiftR :: Int -> Int -> Int-shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--shiftL :: Word8 -> Int -> Word8-shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))--index :: Int -> I-index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))-{-# INLINE index #-}---- | Check the set for membership.-memberWord8 :: Word8 -> FastSet -> Bool-memberWord8 w (Table t) =- let I byte bit = index (fromIntegral w)- in U.unsafeIndex t byte .&. bit /= 0-memberWord8 w (Sorted s) = search 0 (B.length s - 1)- where search lo hi- | hi < lo = False- | otherwise =- let mid = (lo + hi) `div` 2- in case compare w (U.unsafeIndex s mid) of- GT -> search (mid + 1) hi- LT -> search lo (mid - 1)- _ -> True---- | Check the set for membership. Only works with 8-bit characters:--- characters above code point 255 will give wrong answers.-memberChar :: Char -> FastSet -> Bool-memberChar c = memberWord8 (I.c2w c)-{-# INLINE memberChar #-}--mkTable :: B.ByteString -> B.ByteString-mkTable s = I.unsafeCreate 32 $ \t -> do- _ <- I.memset t 0 32- U.unsafeUseAsCStringLen s $ \(p, l) ->- let loop n | n == l = return ()- | otherwise = do- c <- peekByteOff p n :: IO Word8- let I byte bit = index (fromIntegral c)- prev <- peekByteOff t byte :: IO Word8- pokeByteOff t byte (prev .|. bit)- loop (n + 1)- in loop 0--charClass :: String -> FastSet-charClass = set . B8.pack . go- where go (a:'-':b:xs) = [a..b] ++ go xs- go (x:xs) = x : go xs- go _ = ""
src/Snap/Internal/Routing.hs view
@@ -1,61 +1,67 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-}-module Snap.Internal.Routing where--+module Snap.Internal.Routing+ ( Route(..)+ , pRoute+ , route+ , routeEarliestNC+ , routeHeight+ , routeLocal+ , splitPath+ ) where -------------------------------------------------------------------------------import Control.Applicative ((<|>))-import Data.ByteString (ByteString)+import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (head, intercalate, length, null, pack, splitWith, tail) import Data.ByteString.Internal (c2w)-import qualified Data.ByteString as B-import Data.Monoid-import qualified Data.Map as Map+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H (elems, empty, fromList, lookup, unionWith)+import qualified Data.Map as Map (empty, insertWith, unionWith)+import Snap.Internal.Core (MonadSnap, getRequest, getsRequest, localRequest, modifyRequest, pass, updateContextPath)+import Snap.Internal.Http.Types (Params, Request (rqContextPath, rqParams, rqPathInfo))+import Snap.Internal.Parsing (urlDecode)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..))+#endif+import Data.Semigroup (Semigroup (..)) -------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Parsing-import Snap.Internal.Types - -------------------------------------------------------------------------------{-|--The internal data type you use to build a routing tree. Matching is-done unambiguously.--'Capture' and 'Dir' routes can have a "fallback" route:-- - For 'Capture', the fallback is routed when there is nothing to capture- - For 'Dir', the fallback is routed when we can't find a route in its map--Fallback routes are stacked: i.e. for a route like:--> Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz--visiting the URI foo/ will result in the "bar" capture being empty and-triggering its fallback. It's NoRoute, so we go to the nearest parent-fallback and try that, which is the baz action.---}+-- | The internal data type you use to build a routing tree. Matching is+-- done unambiguously.+--+-- 'Capture' and 'Dir' routes can have a "fallback" route:+--+-- - For 'Capture', the fallback is routed when there is nothing to capture+-- - For 'Dir', the fallback is routed when we can't find a route in its map+--+-- Fallback routes are stacked: i.e. for a route like:+--+-- > Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz+--+-- visiting the URI foo/ will result in the "bar" capture being empty and+-- triggering its fallback. It's NoRoute, so we go to the nearest parent+-- fallback and try that, which is the baz action. data Route a m = Action ((MonadSnap m) => m a) -- wraps a 'Snap' action -- captures the dir in a param | Capture ByteString (Route a m) (Route a m) -- match on a dir- | Dir (Map.Map ByteString (Route a m)) (Route a m)+ | Dir (HashMap ByteString (Route a m)) (Route a m) | NoRoute -------------------------------------------------------------------------------instance Monoid (Route a m) where- mempty = NoRoute - mappend NoRoute r = r+instance Semigroup (Route a m) where+ NoRoute <> r = r - mappend l@(Action a) r = case r of+ l@(Action a) <> r = case r of (Action a') -> Action (a <|> a')- (Capture p r' fb) -> Capture p r' (mappend fb l)- (Dir _ _) -> mappend (Dir Map.empty l) r+ (Capture p r' fb) -> Capture p r' (fb <> l)+ (Dir _ _) -> Dir H.empty l <> r NoRoute -> l -- Whenever we're unioning two Captures and their capture variables@@ -63,28 +69,31 @@ -- 1. Prefer whichever route is longer -- 2. Else, prefer whichever has the earliest non-capture -- 3. Else, prefer the right-hand side- mappend l@(Capture p r' fb) r = case r of- (Action _) -> Capture p r' (mappend fb r)+ l@(Capture p r' fb) <> r = case r of+ (Action _) -> Capture p r' (fb <> r) (Capture p' r'' fb')- | p == p' -> Capture p (mappend r' r'') (mappend fb fb')- | rh' > rh'' -> Capture p r' (mappend fb r)- | rh' < rh'' -> Capture p' r'' (mappend fb' l)- | en' < en'' -> Capture p r' (mappend fb r)- | otherwise -> Capture p' r'' (mappend fb' l)+ | p == p' -> Capture p (r' <> r'') (fb <> fb')+ | rh' > rh'' -> Capture p r' (fb <> r)+ | rh' < rh'' -> Capture p' r'' (fb' <> l)+ | en' < en'' -> Capture p r' (fb <> r)+ | otherwise -> Capture p' r'' (fb' <> l) where rh' = routeHeight r' rh'' = routeHeight r'' en' = routeEarliestNC r' 1 en'' = routeEarliestNC r'' 1- (Dir rm fb') -> Dir rm (mappend fb' l)+ (Dir rm fb') -> Dir rm (fb' <> l) NoRoute -> l - mappend l@(Dir rm fb) r = case r of- (Action _) -> Dir rm (mappend fb r)- (Capture _ _ _) -> Dir rm (mappend fb r)- (Dir rm' fb') -> Dir (Map.unionWith mappend rm rm') (mappend fb fb')+ (<>) l@(Dir rm fb) r = case r of+ (Action _) -> Dir rm (fb <> r)+ (Capture _ _ _) -> Dir rm (fb <> r)+ (Dir rm' fb') -> Dir (H.unionWith (<>) rm rm') (fb <> fb') NoRoute -> l +instance Monoid (Route a m) where+ mempty = NoRoute+ mappend = (<>) ------------------------------------------------------------------------------ routeHeight :: Route a m -> Int@@ -92,7 +101,7 @@ NoRoute -> 1 (Action _) -> 1 (Capture _ r' _) -> 1 + routeHeight r'- (Dir rm _) -> 1 + foldl max 1 (map routeHeight $ Map.elems rm)+ (Dir rm _) -> 1 + foldl max 1 (map routeHeight $ H.elems rm) {-# INLINE routeHeight #-} @@ -110,53 +119,47 @@ -- | A web handler which, given a mapping from URL entry points to web -- handlers, efficiently routes requests to the correct handler. ----- The URL entry points are given as relative paths, for example: ----- > route [ ("foo/bar/quux", fooBarQuux) ]------ If the URI of the incoming request is------ > /foo/bar/quux+-- __Usage__ ----- or+-- The URL entry points are given as relative paths, for example: ----- > /foo/bar/quux/...anything...+-- > route [ ("foo/bar/quux", fooBarQuux) ] ----- then the request will be routed to \"@fooBarQuux@\", with 'rqContextPath'--- set to \"@\/foo\/bar\/quux\/@\" and 'rqPathInfo' set to--- \"@...anything...@\".+-- If the URI of the incoming request is @\/foo\/bar\/quux@ or+-- @\/foo\/bar\/quux\/...anything...@ then the request will be routed to+-- @\"fooBarQuux\"@, with 'rqContextPath' set to @\"\/foo\/bar\/quux\/\"@ and+-- 'rqPathInfo' set to @\"...anything...\"@. ----- A path component within an URL entry point beginning with a colon (\"@:@\")+-- A path component within an URL entry point beginning with a colon (@\":\"@) -- is treated as a /variable capture/; the corresponding path component within -- the request URI will be entered into the 'rqParams' parameters mapping with -- the given name. For instance, if the routes were: -- -- > route [ ("foo/:bar/baz", fooBazHandler) ] ----- Then a request for \"@\/foo\/saskatchewan\/baz@\" would be routed to--- @fooBazHandler@ with a mapping for:------ > "bar" => "saskatchewan"------ in its parameters table.+-- Then a request for @\"\/foo\/saskatchewan\/baz\"@ would be routed to+-- @fooBazHandler@ with a mapping for @\"bar\" => \"saskatchewan\"@ in its+-- parameters table. -- -- Longer paths are matched first, and specific routes are matched before -- captures. That is, if given routes: -- -- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ] ----- a request for \"@\/a\/b@\" will go to @h2@, \"@\/a\/s@\" for any /s/ will--- go to @h3@, and \"@\/a@\" will go to @h1@.------ The following example matches \"@\/article@\" to an article index,--- \"@\/login@\" to a login, and \"@\/article\/...@\" to an article renderer.+-- a request for @\"\/a\/b\"@ will go to @h2@, @\"\/a\/s\"@ for any /s/ will go+-- to @h3@, and @\"\/a\"@ will go to @h1@. ----- > route [ ("article", renderIndex)--- > , ("article/:id", renderArticle)--- > , ("login", method POST doLogin) ]+-- The following example matches @\"\/article\"@ to an article index,+-- @\"\/login\"@ to a login, and @\"\/article\/...\"@ to an article renderer. --+-- @+-- 'route' [ (\"article\", renderIndex)+-- , (\"article\/:id\", renderArticle)+-- , (\"login\", 'Snap.Core.method' POST doLogin) ]+-- @ ----- /URL decoding/+-- __Note: URL decoding__ -- -- A short note about URL decoding: path matching and variable capture are done -- on /decoded/ URLs, but the contents of 'rqContextPath' and 'rqPathInfo' will@@ -166,25 +169,82 @@ -- > route [ ("a b c d/", foo ) ] -- -- A request for \"@/a+b+c+d@\" will be sent to @foo@ with 'rqContextPath' set--- to \"/a+b+c+d/\".+-- to @\"/a+b+c+d/\"@. -- -- This behaviour changed as of Snap 0.6.1; previous versions had unspecified -- (and buggy!) semantics here. --+--+-- __Example:__+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as Map+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> import "Snap.Test"+-- ghci> :{+-- ghci| let handler = do r \<- 'getRequest'+-- ghci| 'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"+-- ghci| 'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"+-- ghci| 'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)+-- ghci| :}+-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\", handler)])+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Sat, 02 Aug 2014 05:16:59 GMT+--+-- rqContextPath: \/foo\/+-- rqPathInfo: bar+-- rqParams: fromList []+-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\/:bar\", handler)])+-- [...]+--+-- rqContextPath: \/foo\/bar\/+-- rqPathInfo:+-- rqParams: fromList [(\"bar\",[\"bar\"])]+-- @ route :: MonadSnap m => [(ByteString, m a)] -> m a route rts = do p <- getsRequest rqPathInfo- route' (return ()) [] (splitPath p) Map.empty rts'+ route' (return $! ()) [] (splitPath p) Map.empty rts' where rts' = mconcat (map pRoute rts) {-# INLINE route #-} --------------------------------------------------------------------------------- | The 'routeLocal' function is the same as 'route'', except it doesn't+-- | The 'routeLocal' function is the same as 'route', except it doesn't -- change the request's context path. This is useful if you want to route to a -- particular handler but you want that handler to receive the 'rqPathInfo' as -- it is.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> import "Snap.Test"+-- ghci> :{+-- ghci| let handler = do r \<- 'getRequest'+-- ghci| 'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"+-- ghci| 'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"+-- ghci| 'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)+-- ghci| :}+-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\", handler)])+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Sat, 02 Aug 2014 05:17:28 GMT+--+-- rqContextPath: \/+-- rqPathInfo: foo\/bar+-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\/:bar\", handler)])+-- [...]+--+-- rqContextPath: \/+-- rqPathInfo: foo\/bar+-- rqParams: fromList [(\"bar\",[\"bar\"])]+-- @ routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a routeLocal rts = do req <- getRequest@@ -212,7 +272,7 @@ hier = filter (not . B.null) $ B.splitWith (== (c2w '/')) r f s rt = if B.head s == c2w ':' then Capture (B.tail s) rt NoRoute- else Dir (Map.fromList [(s, rt)]) NoRoute+ else Dir (H.fromList [(s, rt)]) NoRoute {-# INLINE pRoute #-} @@ -231,28 +291,28 @@ where ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx) updateParams req = req- { rqParams = Map.unionWith (++) params (rqParams req) }+ { rqParams = Map.unionWith (flip (++)) params (rqParams req) } route' pre !ctx [] !params (Capture _ _ fb) = route' pre ctx [] params fb -route' pre !ctx (cwd:rest) !params (Capture p rt fb) =- m <|> (route' pre ctx (cwd:rest) params fb)+route' pre !ctx paths@(cwd:rest) !params (Capture p rt fb)+ | B.null cwd = fallback+ | otherwise = m <|> fallback where- m = do- maybe pass- (\cwd' -> let params' = Map.insertWith (++) p [cwd'] params+ fallback = route' pre ctx paths params fb+ m = maybe pass+ (\cwd' -> let params' = Map.insertWith (flip (++)) p [cwd'] params in route' pre (cwd:ctx) rest params' rt) (urlDecode cwd)- route' pre !ctx [] !params (Dir _ fb) = route' pre ctx [] params fb-route' pre !ctx (cwd:rest) !params (Dir rtm fb) = do+route' pre !ctx paths@(cwd:rest) !params (Dir rtm fb) = do cwd' <- maybe pass return $ urlDecode cwd- case Map.lookup cwd' rtm of+ case H.lookup cwd' rtm of Just rt -> (route' pre (cwd:ctx) rest params rt) <|>- (route' pre ctx (cwd:rest) params fb)- Nothing -> route' pre ctx (cwd:rest) params fb+ (route' pre ctx paths params fb)+ Nothing -> route' pre ctx paths params fb route' _ _ _ _ NoRoute = pass
src/Snap/Internal/Test/Assertions.hs view
@@ -1,36 +1,84 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Snap.Internal.Test.Assertions where -------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Monad (liftM)-import Data.ByteString.Char8 (ByteString)-import Data.Maybe (fromJust)-import Data.Monoid (mconcat)-import Test.HUnit (Assertion, assertBool, assertEqual)-import Text.Regex.Posix ((=~))-+import Control.Monad (liftM)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe (fromJust)+import Snap.Internal.Http.Types (Response (rspBody, rspStatus), getHeader, rspBodyToEnum)+import qualified System.IO.Streams as Streams+import Test.HUnit (Assertion, assertBool, assertEqual)+import Text.Regex.Posix ((=~))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat)+#endif -------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Iteratee (run_, consume, ($$)) ------------------------------------------------------------------------------+-- | Given a 'Response', return its body as a 'ByteString'.+--+-- Example:+--+-- @+-- ghci> 'getResponseBody' 'emptyResponse'+-- \"\"+-- @+-- getResponseBody :: Response -> IO ByteString-getResponseBody rsp = run_ $ enum $$ liftM toBS consume+getResponseBody rsp = do+ (os, grab) <- Streams.listOutputStream+ enum os+ liftM toBS grab+ where- enum = rspBodyToEnum $ rspBody rsp- toBS = toByteString . mconcat+ enum os = do+ os' <- rspBodyToEnum (rspBody rsp) os+ Streams.write Nothing os' + toBS = S.concat . L.toChunks . toLazyByteString . mconcat++ --------------------------------------------------------------------------------- | Given a Response, asserts that its HTTP status code is 200 (success).+-- | Given a 'Response', assert that its HTTP status code is 200 (success).+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Test.HUnit" as T+-- ghci> let test = T.runTestTT . T.TestCase+-- ghci> test $ 'assertSuccess' 'Snap.Core.emptyResponse'+-- Cases: 1 Tried: 1 Errors: 0 Failures: 0+-- Counts {cases = 1, tried = 1, errors = 0, failures = 0}+-- ghci> test $ 'assertSuccess' ('Snap.Core.setResponseStatus' 500 \"Internal Server Error\" 'Snap.Core.emptyResponse')+-- ### Failure:+-- Expected success (200) but got (500)+-- expected: 200+-- but got: 500+-- Cases: 1 Tried: 1 Errors: 0 Failures: 1+-- Counts {cases = 1, tried = 1, errors = 0, failures = 1}+-- @ assertSuccess :: Response -> Assertion assertSuccess rsp = assertEqual message 200 status where message = "Expected success (200) but got (" ++ (show status) ++ ")" status = rspStatus rsp + --------------------------------------------------------------------------------- | Given a Response, asserts that its HTTP status code is 404 (Not Found).+-- | Given a 'Response', assert that its HTTP status code is 404 (Not Found).+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'assert404' $ 'Snap.Core.setResponseStatus' 404 \"Not Found\" 'Snap.Core.emptyResponse'+-- ghci> 'assert404' 'Snap.Core.emptyResponse'+-- *** Exception: HUnitFailure \"Expected Not Found (404) but got (200)\\nexpected: 404\\n but got: 200\"+-- @ assert404 :: Response -> Assertion assert404 rsp = assertEqual message 404 status where@@ -39,9 +87,20 @@ --------------------------------------------------------------------------------- | Given a Response, asserts that its HTTP status code is between 300 and--- 399 (a redirect), and that the Location header of the Response points to--- the specified URI.+-- | Given a 'Response', assert that its HTTP status code is between 300 and 399+-- (a redirect), and that the Location header of the 'Response' points to the+-- specified URI.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let r' = 'Snap.Core.setResponseStatus' 301 \"Moved Permanently\" 'Snap.Core.emptyResponse'+-- ghci> let r = 'Snap.Core.setHeader' \"Location\" \"www.example.com\" r'+-- ghci> 'assertRedirectTo' \"www.example.com\" r+-- ghci> 'assertRedirectTo' \"www.example.com\" 'Snap.Core.emptyResponse'+-- *** Exception: HUnitFailure \"Expected redirect but got status code (200)\"+-- @ assertRedirectTo :: ByteString -- ^ The Response should redirect to this -- URI -> Response@@ -58,8 +117,17 @@ --------------------------------------------------------------------------------- | Given a Response, asserts that its HTTP status code is between 300 and--- 399 (a redirect).+-- | Given a 'Response', assert that its HTTP status code is between 300 and 399+-- (a redirect).+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'assertRedirect' $ 'Snap.Core.setResponseStatus' 301 \"Moved Permanently\" 'Snap.Core.emptyResponse'+-- ghci> 'assertRedirect' 'Snap.Core.emptyResponse'+-- *** Exception: HUnitFailure \"Expected redirect but got status code (200)\"+-- @ assertRedirect :: Response -> Assertion assertRedirect rsp = assertBool message (300 <= status && status <= 399) where@@ -69,8 +137,26 @@ --------------------------------------------------------------------------------- | Given a Response, asserts that its body matches the given regular+-- | Given a 'Response', assert that its body matches the given regular -- expression.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "System.IO.Streams" as Streams+-- ghci> import qualified "Data.ByteString.Builder" as Builder+-- ghci> :{+-- ghci| let r = 'Snap.Core.setResponseBody'+-- ghci| (\out -> do+-- ghci| Streams.write (Just $ Builder.byteString \"Hello, world!\") out+-- ghci| return out)+-- ghci| 'Snap.Core.emptyResponse'+-- ghci| :}+-- ghci> 'assertBodyContains' \"^Hello\" r+-- ghci> 'assertBodyContains' \"Bye\" r+-- *** Exception: HUnitFailure "Expected body to match regexp \\\"\\\"Bye\\\"\\\", but didn\'t"+-- @ assertBodyContains :: ByteString -- ^ Regexp that will match the body content -> Response -> Assertion
src/Snap/Internal/Test/RequestBuilder.hs view
@@ -1,73 +1,96 @@+{- Temporary workaround for https://ghc.haskell.org/trac/ghc/ticket/9127 -}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} module Snap.Internal.Test.RequestBuilder ( RequestBuilder- , buildRequest , MultipartParams , MultipartParam(..) , FileData (..) , RequestType (..)- , setQueryStringRaw- , setQueryString- , setRequestType , addHeader- , setHeader- , setContentType- , setSecure- , setHttpVersion- , setRequestPath+ , buildRequest+ , delete+ , evalHandler+ , evalHandlerM , get- , postUrlEncoded+ , head , postMultipart- , put , postRaw- , delete- , runHandler- , runHandler'- , dumpResponse+ , postUrlEncoded+ , put+ , requestToString , responseToString+ , runHandler+ , runHandlerM+ , setContentType+ , setHeader+ , addCookies+ , setHttpVersion+ , setQueryString+ , setQueryStringRaw+ , setRequestPath+ , setRequestType+ , setSecure ) where -------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-import Control.Monad.State hiding (get, put)-import qualified Control.Monad.State as State-import qualified Data.ByteString.Base16 as B16-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.CaseInsensitive (CI)-import Data.IORef-import qualified Data.Map as Map-import Data.Monoid-import Data.Word-import System.PosixCompat.Time-import System.Random.MWC+import Control.Monad (liftM, replicateM, void)+import Control.Monad.State.Strict (MonadIO (..), MonadState, MonadTrans, StateT, execStateT, modify)+import qualified Control.Monad.State.Strict as State+import Data.Bits (Bits ((.&.), unsafeShiftR))+import qualified Data.ByteString as S8+import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString, word8)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.CaseInsensitive (CI, original)+import qualified Data.Map as Map+import qualified Data.Vector as V+import Data.Word (Word8)+import Prelude hiding (head)+import Snap.Core (Cookie (Cookie), Method (DELETE, GET, HEAD, POST, PUT), MonadSnap, Params, Request (rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Response, Snap, deleteHeader, formatHttpTime, getHeader, parseUrlEncoded, printUrlEncoded, runSnap)+import Snap.Internal.Core (evalSnap, fixupResponse)+import Snap.Internal.Http.Types (Request (Request, rqBody), Response (rspBody, rspContentLength), rspBodyToEnum)+import qualified Snap.Internal.Http.Types as H+import qualified Snap.Types.Headers as H+import qualified System.IO.Streams as Streams+import System.PosixCompat.Time (epochTime)+import System.Random (randomIO)+import Text.Printf (printf)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative)+import Data.Monoid (Monoid (mappend, mconcat, mempty))+#endif -------------------------------------------------------------------------------import Snap.Internal.Http.Types hiding (addHeader,- setContentType,- setHeader)-import qualified Snap.Internal.Http.Types as H-import Snap.Internal.Parsing-import Snap.Iteratee hiding (map)-import Snap.Core hiding (addHeader, setContentType, setHeader)-import qualified Snap.Types.Headers as H + ------------------------------------------------------------------------------ -- | RequestBuilder is a monad transformer that allows you to conveniently -- build a snap 'Request' for testing. newtype RequestBuilder m a = RequestBuilder (StateT Request m a)- deriving (Monad, MonadIO, MonadTrans)+ deriving ( Applicative+ , Functor+ , Monad+#if MIN_VERSION_base(4,13,0)+ , MonadFail+#endif+ , MonadIO+ , MonadState Request+ , MonadTrans+ ) ------------------------------------------------------------------------------ mkDefaultRequest :: IO Request mkDefaultRequest = do- bodyRef <- newIORef $ SomeEnumerator enumEOF+ b <- Streams.fromList $! [] return $ Request "localhost"- 8080 "127.0.0.1" 60000 "127.0.0.1"@@ -75,21 +98,38 @@ "localhost" False H.empty- bodyRef+ b Nothing GET (1,1) [] ""- "" "/" "/" "" Map.empty+ Map.empty+ Map.empty ------------------------------------------------------------------------------ -- | Runs a 'RequestBuilder', producing the desired 'Request'.+--+-- N.B. /please/ don't use the request you get here in a real Snap application;+-- things will probably break. Don't say you weren't warned :-)+--+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty+-- GET \/foo\/bar HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ buildRequest :: MonadIO m => RequestBuilder m () -> m Request buildRequest mm = do let (RequestBuilder m) = (mm >> fixup)@@ -102,15 +142,19 @@ fixupMethod fixupCL fixupParams+ fixupHost fixupMethod = do rq <- rGet if (rqMethod rq == GET || rqMethod rq == DELETE || rqMethod rq == HEAD) then do+ -- drain the old request body and replace it with a new one+ !_ <- liftIO $ Streams.toList $ rqBody rq+ !b <- liftIO $ Streams.fromList $! [] -- These requests are not permitted to have bodies- let rq' = deleteHeader "Content-Type" rq- liftIO $ writeIORef (rqBody rq') (SomeEnumerator enumEOF)+ let rq' = deleteHeader "Content-Type" $+ rq { rqBody = b } rPut $ rq' { rqContentLength = Nothing } else return $! () @@ -123,19 +167,38 @@ fixupParams = do rq <- rGet- let q = rqQueryString rq- let pms = parseUrlEncoded q+ let !query = rqQueryString rq+ -- force the stuff from mkDefaultRequest that we just overwrite+ let !_ = rqPostParams rq+ let !_ = rqParams rq+ let !_ = rqQueryParams rq+ let !queryParams = parseUrlEncoded query+ let !mbCT = getHeader "Content-Type" rq - let mbCT = getHeader "Content-Type" rq- post <- if mbCT == Just "application/x-www-form-urlencoded"- then do- (SomeEnumerator e) <- liftIO $ readIORef $ rqBody rq- s <- liftM S.concat (liftIO $ run_ $ e $$ consume)- return $ parseUrlEncoded s- else return Map.empty+ (!postParams, rq') <-+ if mbCT == Just "application/x-www-form-urlencoded"+ then liftIO $ do+ !l <- Streams.toList $ rqBody rq+ -- snap-server regurgitates the parsed form body+ !b <- Streams.fromList l+ return (parseUrlEncoded (S.concat l), rq { rqBody = b })+ else return (Map.empty, rq)+ let !newParams = Map.unionWith (flip (++)) queryParams postParams - rPut $ rq { rqParams = Map.unionWith (++) pms post }+ rPut $ rq' { rqParams = newParams+ , rqPostParams = postParams+ , rqQueryParams = queryParams } + fixupHost = do+ rq <- rGet+ case H.getHeader "Host" rq of+ Nothing -> do+ let !hn = rqHostName rq+ rPut $ H.setHeader "Host" hn rq+ Just hn ->+ rPut $ rq { rqHostName = hn }++ ------------------------------------------------------------------------------ -- | A request body of type \"@multipart/form-data@\" consists of a set of -- named form parameters, each of which can by either a list of regular form@@ -144,6 +207,8 @@ ------------------------------------------------------------------------------+-- | A single \"@multipart/form-data@\" form parameter: either a list of regular+-- form values or a set of file uploads. data MultipartParam = FormData [ByteString] -- ^ a form variable consisting of the given 'ByteString' values.@@ -153,6 +218,7 @@ ------------------------------------------------------------------------------+-- | Represents a single file upload for the 'MultipartParam'. data FileData = FileData { fdFileName :: ByteString -- ^ the file's name , fdContentType :: ByteString -- ^ the file's content-type@@ -177,57 +243,96 @@ ------------------------------------------------------------------------------ -- | Sets the type of the 'Request' being built.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setRequestType' GetRequest+-- GET \/foo\/bar HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ setRequestType :: MonadIO m => RequestType -> RequestBuilder m () setRequestType GetRequest = do- rq <- rGet- liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF+ rq <- rGet+ body <- liftIO $ Streams.fromList $! []+ rPut $ rq { rqMethod = GET , rqContentLength = Nothing+ , rqBody = body } setRequestType DeleteRequest = do- rq <- rGet- liftIO $ writeIORef (rqBody rq) $ SomeEnumerator enumEOF+ rq <- rGet+ body <- liftIO $ Streams.fromList $! []+ rPut $ rq { rqMethod = DELETE , rqContentLength = Nothing+ , rqBody = body } setRequestType (RequestWithRawBody m b) = do rq <- rGet- liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b+ body <- liftIO $ Streams.fromList $! [ b ] rPut $ rq { rqMethod = m- , rqContentLength = Just $ S.length b+ , rqContentLength = Just $ fromIntegral $ S.length b+ , rqBody = body } setRequestType (MultipartPostRequest fp) = encodeMultipart fp setRequestType (UrlEncodedPostRequest fp) = do rq <- liftM (H.setHeader "Content-Type"- "application/x-www-form-urlencoded") rGet+ "application/x-www-form-urlencoded") rGet let b = printUrlEncoded fp- liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b+ body <- liftIO $ Streams.fromList $! [b]+ rPut $ rq { rqMethod = POST- , rqContentLength = Just $ S.length b+ , rqContentLength = Just $! fromIntegral $ S.length b+ , rqBody = body } ------------------------------------------------------------------------------ makeBoundary :: MonadIO m => m ByteString makeBoundary = do- xs <- liftIO $ withSystemRandom $ \rng ->- replicateM 16 ((uniform rng) :: IO Word8)+ xs <- liftIO $ replicateM 16 randomWord8 let x = S.pack $ map (toEnum . fromEnum) xs- return $ S.concat [ "snap-boundary-", B16.encode x ]+ return $ S.concat [ "snap-boundary-", encode x ] + where+ randomWord8 :: IO Word8+ randomWord8 = liftM (\c -> toEnum $ c .&. 0xff) randomIO + table = V.fromList [ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'+ , 'a', 'b', 'c', 'd', 'e', 'f' ]++ encode = toByteString . S8.foldl' f mempty++#if MIN_VERSION_base(4,5,0)+ shR = unsafeShiftR+#else+ shR = shiftR+#endif++ f m c = let low = c .&. 0xf+ hi = (c .&. 0xf0) `shR` 4+ k = \i -> word8 $! toEnum $! fromEnum $!+ V.unsafeIndex table (fromEnum i)+ in m `mappend` k hi `mappend` k low++ ------------------------------------------------------------------------------ multipartHeader :: ByteString -> ByteString -> Builder multipartHeader boundary name =- mconcat [ fromByteString boundary- , fromByteString "\r\ncontent-disposition: form-data"- , fromByteString "; name=\""- , fromByteString name- , fromByteString "\"\r\n" ]+ mconcat [ byteString boundary+ , byteString "\r\ncontent-disposition: form-data"+ , byteString "; name=\""+ , byteString name+ , byteString "\"\r\n" ] ------------------------------------------------------------------------------@@ -238,36 +343,39 @@ [] -> return mempty [v] -> return $ mconcat [ hdr , cr- , fromByteString v- , fromByteString "\r\n--" ]+ , byteString v+ , byteString "\r\n--" ] _ -> multi where hdr = multipartHeader boundary name- cr = fromByteString "\r\n"+ cr = byteString "\r\n" - oneVal b v = mconcat [ fromByteString b+ oneVal b v = mconcat [ byteString b , cr , cr- , fromByteString v- , fromByteString "\r\n--" ]+ , byteString v+ , byteString "\r\n--" ] multi = do b <- makeBoundary return $ mconcat [ hdr , multipartMixed b , cr- , fromByteString "--"+ , byteString "--" , mconcat (map (oneVal b) vals)- , fromByteString b- , fromByteString "--\r\n--" ]+ , byteString b+ , byteString "--\r\n--" ] ++------------------------------------------------------------------------------ multipartMixed :: ByteString -> Builder-multipartMixed b = mconcat [ fromByteString "Content-Type: multipart/mixed"- , fromByteString "; boundary="- , fromByteString b- , fromByteString "\r\n" ]+multipartMixed b = mconcat [ byteString "Content-Type: multipart/mixed"+ , byteString "; boundary="+ , byteString b+ , byteString "\r\n" ] + ------------------------------------------------------------------------------ encodeFiles :: ByteString -> ByteString -> [FileData] -> IO Builder encodeFiles boundary name files =@@ -278,39 +386,47 @@ return $ mconcat [ hdr , multipartMixed b , cr- , fromByteString "--"+ , byteString "--" , mconcat (map (oneVal b) files)- , fromByteString b- , fromByteString "--\r\n--"+ , byteString b+ , byteString "--\r\n--" ] where+ -------------------------------------------------------------------------- contentDisposition fn = mconcat [- fromByteString "Content-Disposition: attachment"- , fromByteString "; filename=\""- , fromByteString fn- , fromByteString "\"\r\n"+ byteString "Content-Disposition: attachment"+ , byteString "; filename=\""+ , byteString fn+ , byteString "\"\r\n" ] + -------------------------------------------------------------------------- contentType ct = mconcat [- fromByteString "Content-Type: "- , fromByteString ct+ byteString "Content-Type: "+ , byteString ct , cr ] - oneVal b (FileData fileName ct contents) =- mconcat [ fromByteString b+ --------------------------------------------------------------------------+ oneVal b fd =+ mconcat [ byteString b , cr , contentType ct , contentDisposition fileName- , fromByteString "Content-Transfer-Encoding: binary\r\n"+ , byteString "Content-Transfer-Encoding: binary\r\n" , cr- , fromByteString contents- , fromByteString "\r\n--"+ , byteString contents+ , byteString "\r\n--" ]+ where+ fileName = fdFileName fd+ ct = fdContentType fd+ contents = fdContents fd + -------------------------------------------------------------------------- hdr = multipartHeader boundary name- cr = fromByteString "\r\n"+ cr = byteString "\r\n" ------------------------------------------------------------------------------@@ -319,23 +435,25 @@ boundary <- liftIO $ makeBoundary builders <- liftIO $ mapM (handleOne boundary) kvps - let b = toByteString $- mconcat (fromByteString "--" : builders)- `mappend` finalBoundary boundary+ let b = toByteString $ mconcat (byteString "--" : builders)+ `mappend` finalBoundary boundary rq0 <- rGet- liftIO $ writeIORef (rqBody rq0) $ SomeEnumerator $ enumBS b++ body <- liftIO $ Streams.fromList [b]+ let rq = H.setHeader "Content-Type" (S.append "multipart/form-data; boundary=" boundary) rq0 rPut $ rq { rqMethod = POST- , rqContentLength = Just $ S.length b+ , rqContentLength = Just $ fromIntegral $ S.length b+ , rqBody = body } where- finalBoundary b = mconcat [fromByteString b, fromByteString "--\r\n"]+ finalBoundary b = mconcat [byteString b, byteString "--\r\n"] handleOne boundary (name, mp) = case mp of@@ -347,21 +465,35 @@ fixupURI :: Monad m => RequestBuilder m () fixupURI = do rq <- rGet- let u = S.concat [ rqSnapletPath rq- , rqContextPath rq- , rqPathInfo rq- , let q = rqQueryString rq- in if S.null q- then ""- else S.append "?" q- ]- rPut $ rq { rqURI = u }+ upd rq $! S.concat [ rqContextPath rq+ , rqPathInfo rq+ , let q = rqQueryString rq+ in if S.null q+ then ""+ else S.append "?" q+ ]+ where+ upd rq !u = let !_ = rqURI rq+ in rPut $ rq { rqURI = u } ------------------------------------------------------------------------------ -- | Sets the request's query string to be the raw bytestring provided, -- without any escaping or other interpretation. Most users should instead -- choose the 'setQueryString' function, which takes a parameter mapping.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryStringRaw' "param0=baz¶m1=qux"+-- GET \/foo\/bar?param0=baz¶m1=qux HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- params: param0: ["baz"], param1: ["qux"]+-- @ setQueryStringRaw :: Monad m => ByteString -> RequestBuilder m () setQueryStringRaw r = do rq <- rGet@@ -372,6 +504,19 @@ ------------------------------------------------------------------------------ -- | Escapes the given parameter mapping and sets it as the request's query -- string.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setQueryString' (M.fromList [("param0", ["baz"]), ("param1", ["qux"])])+-- GET \/foo\/bar?param0=baz¶m1=qux HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- params: param0: ["baz"], param1: ["qux"]+-- @ setQueryString :: Monad m => Params -> RequestBuilder m () setQueryString p = setQueryStringRaw $ printUrlEncoded p @@ -379,18 +524,99 @@ ------------------------------------------------------------------------------ -- | Sets the given header in the request being built, overwriting any header -- with the same name already present.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| 'buildRequest' $ do get \"\/foo\/bar\" M.empty+-- ghci| 'setHeader' \"Accept\" "text\/html"+-- ghci| 'setHeader' \"Accept\" "text\/plain"+-- ghci| :}+-- GET \/foo\/bar HTTP\/1.1+-- accept: text\/plain+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ setHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m () setHeader k v = rModify (H.setHeader k v) ------------------------------------------------------------------------------ -- | Adds the given header to the request being built.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> :{+-- ghci| 'buildRequest' $ do 'get' \"\/foo\/bar\" M.empty+-- ghci| 'addHeader' \"Accept\" "text\/html"+-- ghci| 'addHeader' \"Accept\" "text\/plain"+-- ghci| :}+-- GET \/foo\/bar HTTP\/1.1+-- accept: text\/html,text\/plain+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ addHeader :: (Monad m) => CI ByteString -> ByteString -> RequestBuilder m () addHeader k v = rModify (H.addHeader k v) +------------------------------------------------------------------------------+-- | Adds the given cookies to the request being built.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import "Snap.Core"+-- ghci> let cookie = 'Snap.Core.Cookie' "name" "value" Nothing Nothing Nothing False False+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'addCookies' [cookie]+-- GET \/foo\/bar HTTP\/1.1+-- cookie: name=value+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- cookies: Cookie {cookieName = "name", cookieValue = "value", ...}+-- @+addCookies :: (Monad m) => [Cookie] -> RequestBuilder m ()+addCookies cookies = do+ rModify $ \rq -> rq { rqCookies = rqCookies rq ++ cookies }+ allCookies <- liftM rqCookies rGet+ let cstr = map cookieToBS allCookies+ setHeader "Cookie" $ S.intercalate "; " cstr + ------------------------------------------------------------------------------+-- | Convert 'Cookie' into 'ByteString' for output.+cookieToBS :: Cookie -> ByteString+cookieToBS (Cookie k v !_ !_ !_ !_ !_) = cookie+ where+ cookie = S.concat [k, "=", v]+++------------------------------------------------------------------------------ -- | Sets the request's @content-type@ to the given MIME type.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/html" "some text" >> 'setContentType' "text\/plain"+-- PUT \/foo\/bar HTTP\/1.1+-- content-type: text\/plain+-- content-length: 9+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9+-- @ setContentType :: Monad m => ByteString -> RequestBuilder m () setContentType c = rModify (H.setHeader "Content-Type" c) @@ -398,12 +624,36 @@ ------------------------------------------------------------------------------ -- | Controls whether the test request being generated appears to be an https -- request or not.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setSecure' True+-- DELETE \/foo\/bar HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a secure+-- @ setSecure :: Monad m => Bool -> RequestBuilder m () setSecure b = rModify $ \rq -> rq { rqIsSecure = b } ------------------------------------------------------------------------------ -- | Sets the test request's http version+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty >> 'setHttpVersion' (1,0)+-- DELETE \/foo\/bar HTTP\/1.0+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ setHttpVersion :: Monad m => (Int,Int) -> RequestBuilder m () setHttpVersion v = rModify $ \rq -> rq { rqVersion = v } @@ -413,16 +663,43 @@ -- must /not/ contain a query string; if you want to provide a query string -- in your test request, you must use 'setQueryString' or 'setQueryStringRaw'. -- Note that 'rqContextPath' is never set by any 'RequestBuilder' function.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" M.empty >> 'setRequestPath' "\/bar\/foo"+-- GET \/bar\/foo HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ setRequestPath :: Monad m => ByteString -> RequestBuilder m ()-setRequestPath p = do- rModify $ \rq -> rq { rqSnapletPath = ""- , rqContextPath = ""+setRequestPath p0 = do+ rModify $ \rq -> rq { rqContextPath = "/" , rqPathInfo = p } fixupURI + where+ p = if S.isPrefixOf "/" p0 then S.drop 1 p0 else p0 + ------------------------------------------------------------------------------ -- | Builds an HTTP \"GET\" request with the given query parameters.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'get' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])])+-- GET \/foo\/bar?param0=baz¶m0=quux HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- params: param0: ["baz","quux"]+-- @ get :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters@@ -432,9 +709,45 @@ setQueryString params setRequestPath uri +------------------------------------------------------------------------------+-- | Builds an HTTP \"HEAD\" request with the given query parameters.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'head' \"\/foo\/bar\" (M.fromList ("param0", ["baz", "quux"])])+-- HEAD \/foo\/bar?param0=baz¶m0=quux HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- params: param0: ["baz","quux"]+-- @+-- @since 1.0.4.3 +head :: MonadIO m =>+ ByteString -- ^ request path+ -> Params -- ^ request's form parameters+ -> RequestBuilder m ()+head uri params = do+ setRequestType . RequestWithRawBody HEAD $ ""+ setQueryString params+ setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"DELETE\" request with the given query parameters.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'delete' \"\/foo\/bar\" M.empty+-- DELETE \/foo\/bar HTTP\/1.1+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a+-- @ delete :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters@@ -448,6 +761,21 @@ ------------------------------------------------------------------------------ -- | Builds an HTTP \"POST\" request with the given form parameters, using the -- \"application/x-www-form-urlencoded\" MIME type.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> 'buildRequest' $ 'postUrlEncoded' \"\/foo\/bar\" (M.fromList [("param0", ["baz", "quux"])])+-- POST \/foo\/bar HTTP\/1.1+-- content-type: application\/x-www-form-urlencoded+-- content-length: 22+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=22+-- params: param0: ["baz","quux"]+-- @ postUrlEncoded :: MonadIO m => ByteString -- ^ request path -> Params -- ^ request's form parameters@@ -460,6 +788,19 @@ ------------------------------------------------------------------------------ -- | Builds an HTTP \"POST\" request with the given form parameters, using the -- \"form-data/multipart\" MIME type.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'buildRequest' $ 'postMultipart' \"\/foo\/bar\" [("param0", FormData ["baz", "quux"])]+-- POST \/foo\/bar HTTP\/1.1+-- content-type: multipart\/form-data; boundary=snap-boundary-572334111ec0c05ad4812481e8585dfa+-- content-length: 406+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=406+-- @ postMultipart :: MonadIO m => ByteString -- ^ request path -> MultipartParams -- ^ multipart form parameters@@ -471,6 +812,19 @@ ------------------------------------------------------------------------------ -- | Builds an HTTP \"PUT\" request.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'buildRequest' $ 'put' \"\/foo\/bar\" "text\/plain" "some text"+-- PUT \/foo\/bar HTTP\/1.1+-- content-type: text/plain+-- content-length: 9+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9+-- @ put :: MonadIO m => ByteString -- ^ request path -> ByteString -- ^ request body MIME content-type@@ -485,6 +839,19 @@ ------------------------------------------------------------------------------ -- | Builds a \"raw\" HTTP \"POST\" request, with the given MIME type and body -- contents.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> 'buildRequest' $ 'postRaw' \"\/foo\/bar\" "text/plain" "some text"+-- POST \/foo\/bar HTTP\/1.1+-- content-type: text\/plain+-- content-length: 9+-- host: localhost+--+-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=9+-- @ postRaw :: MonadIO m => ByteString -- ^ request path -> ByteString -- ^ request body MIME content-type@@ -492,14 +859,51 @@ -> RequestBuilder m () postRaw uri contentType postData = do setRequestType $ RequestWithRawBody POST postData- setHeader "Content-Type" contentType+ setContentType contentType setRequestPath uri --------------------------------------------------------------------------------- | Given a web handler in some 'MonadSnap' monad, and a 'RequestBuilder'--- defining a test request, runs the handler, producing an HTTP 'Response'.-runHandler' :: (MonadIO m, MonadSnap n) =>+-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining+-- a test request, runs the handler, producing an HTTP 'Response'.+--+-- This function will produce almost exactly the same output as running the+-- handler in a real server, except that chunked transfer encoding is not+-- applied, and the \"Transfer-Encoding\" header is not set (this makes it+-- easier to test response output).+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import "Snap.Core"+-- ghci> 'runHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!")+-- HTTP\/1.1 200 OK+-- server: Snap/test+-- date: Thu, 17 Jul 2014 21:03:23 GMT+--+-- Hello, world!+-- @+runHandler :: MonadIO m =>+ RequestBuilder m () -- ^ a request builder+ -> Snap a -- ^ a web handler+ -> m Response+runHandler = runHandlerM rs+ where+ rs rq s = liftIO $ do+ (_,rsp) <- runSnap s (\x -> return $! (x `seq` ()))+ (\f -> let !_ = f 0 in return $! ())+ rq+ fixupResponse rq rsp+++------------------------------------------------------------------------------+-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function+-- specifying how to evaluate it within the context of the test monad, and a+-- 'RequestBuilder' defining a test request, runs the handler, producing an+-- HTTP 'Response'.+runHandlerM :: (MonadIO m, MonadSnap n) => (forall a . Request -> n a -> m Response) -- ^ a function defining how the 'MonadSnap' monad should be run -> RequestBuilder m ()@@ -507,48 +911,152 @@ -> n b -- ^ a web handler -> m Response-runHandler' rSnap rBuilder snap = do+runHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rsp <- rSnap rq snap++ -- simulate server logic t1 <- liftIO (epochTime >>= formatHttpTime)- return $ H.setHeader "Date" t1 rsp+ return $ H.setHeader "Date" t1+ $ H.setHeader "Server" "Snap/test"+ $ if rspContentLength rsp == Nothing &&+ rqVersion rq < (1,1)+ then H.setHeader "Connection" "close" rsp+ else rsp --------------------------------------------------------------------------------- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining--- a test request, runs the handler, producing an HTTP 'Response'.-runHandler :: MonadIO m =>- RequestBuilder m () -- ^ a request builder- -> Snap a -- ^ a web handler- -> m Response-runHandler = runHandler' rs+-- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining a+-- test request, runs the handler and returns the monadic value it produces.+--+-- Throws an exception if the 'Snap' handler early-terminates with+-- 'Snap.Core.finishWith' or 'Control.Monad.mzero'.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import "Control.Monad"+-- ghci> import qualified "Data.Map" as M+-- ghci> import "Snap.Core"+-- ghci> 'evalHandler' ('get' "foo/bar" M.empty) ('Snap.Core.writeBS' "Hello, world!" >> return 42)+-- 42+-- ghci> 'evalHandler' ('get' "foo/bar" M.empty) 'Control.Monad.mzero'+-- *** Exception: No handler for request: failure was pass+-- @+evalHandler :: MonadIO m =>+ RequestBuilder m ()+ -> Snap a+ -> m a+evalHandler = evalHandlerM rs where- rs rq s = do- (_,rsp) <- liftIO $ run_ $ runSnap s- (const $ return $! ())- (const $ return $! ())- rq- return rsp+ rs rq s = liftIO $ evalSnap s (const $ return $! ())+ (const $ return $! ())+ rq --------------------------------------------------------------------------------- | Dumps the given response to stdout.-dumpResponse :: Response -> IO ()-dumpResponse resp = responseToString resp >>= S.putStrLn+-- | Given a web handler in some arbitrary 'MonadSnap' monad, a function+-- specifying how to evaluate it within the context of the test monad, and a+-- 'RequestBuilder' defining a test request, runs the handler, returning the+-- monadic value it produces.+--+-- Throws an exception if the 'Snap' handler early-terminates with+-- 'Snap.Core.finishWith' or 'Control.Monad.mzero'.+evalHandlerM :: (MonadIO m, MonadSnap n) =>+ (forall a . Request -> n a -> m a) -- ^ a function defining+ -- how the 'MonadSnap'+ -- monad should be run+ -> RequestBuilder m () -- ^ a request builder+ -> n b -- ^ a web handler+ -> m b+evalHandlerM rSnap rBuilder snap = do+ rq <- buildRequest rBuilder+ rSnap rq snap --------------------------------------------------------------------------------- | Converts the given response to a bytestring.+-- | Converts the given 'Response' to a bytestring.+--+-- Example:+--+-- @+-- ghci> import "Snap.Core"+-- ghci> 'responseToString' 'Snap.Core.emptyResponse'+-- \"HTTP\/1.1 200 OK\\r\\n\\r\\n\"+-- @ responseToString :: Response -> IO ByteString responseToString resp = do- b <- run_ (rspBodyToEnum (rspBody resp) $$- liftM mconcat consume)+ let act = rspBodyToEnum $ rspBody resp - return $ toByteString $ fromShow resp `mappend` b+ (listOut, grab) <- Streams.listOutputStream+ void $ act listOut+ builder <- liftM mconcat grab + return $! toByteString $ fromShow resp `mappend` builder ------------------------------------------------------------------------------+-- | Converts the given 'Request' to a bytestring.+--+-- Since: 1.0.0.0+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> r <- 'buildRequest' $ get \"\/foo\/bar\" M.empty+-- ghci> 'requestToString' r+-- \"GET \/foo\/bar HTTP\/1.1\\r\\nhost: localhost\\r\\n\\r\\n\"+-- @+requestToString :: Request -> IO ByteString+requestToString req0 = do+ (req, is) <- maybeChunk+ body <- liftM S.concat $ Streams.toList is+ return $! toByteString $ mconcat [ statusLine+ , mconcat . map oneHeader . H.toList+ $ rqHeaders req+ , crlf+ , byteString body+ ]+ where+ maybeChunk = do+ if getHeader "Transfer-Encoding" req0 == Just "chunked"+ then do+ let req = deleteHeader "Content-Length" $+ req0 { rqContentLength = Nothing }+ is' <- Streams.map chunk $ rqBody req+ out <- eof >>= Streams.appendInputStream is'+ return (req, out)+ else return (req0, rqBody req0)+ where+ chunk s = S.concat [ S.pack $ printf "%x\r\n" (S.length s)+ , s+ , "\r\n"+ ]+ eof = Streams.fromList ["0\r\n\r\n"]++ (v1,v2) = rqVersion req0+ crlf = char8 '\r' `mappend` char8 '\n'+ statusLine = mconcat [ fromShow $ rqMethod req0+ , char8 ' '+ , byteString $ rqURI req0+ , byteString " HTTP/"+ , fromShow v1+ , char8 '.'+ , fromShow v2+ , crlf+ ]++ oneHeader (k,v) = mconcat [ byteString $ original k+ , byteString ": "+ , byteString v+ , crlf+ ]+++------------------------------------------------------------------------------ rGet :: Monad m => RequestBuilder m Request rGet = RequestBuilder State.get @@ -557,3 +1065,13 @@ rModify :: Monad m => (Request -> Request) -> RequestBuilder m () rModify f = RequestBuilder $ modify f+++------------------------------------------------------------------------------+toByteString :: Builder -> ByteString+toByteString = S.concat . L.toChunks . toLazyByteString+++------------------------------------------------------------------------------+fromShow :: Show a => a -> Builder+fromShow = stringUtf8 . show
− src/Snap/Internal/Types.hs
@@ -1,1044 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Snap.Internal.Types where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char.Utf8-import Control.Applicative-import Control.Exception (SomeException, throwIO, ErrorCall(..))-import Control.Monad-import Control.Monad.CatchIO-import qualified Control.Monad.Error.Class as EC-import Control.Monad.State-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.Int-import Data.IORef-import Data.Maybe-import Data.Monoid-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Data.Typeable-import Prelude hiding (catch, take)----------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Iteratee.Debug-import Snap.Util.Readable-import Snap.Iteratee------------------------------------------------------------------------------------ The Snap Monad---------------------------------------------------------------------------------{-|--'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you:--1. stateful access to fetch or modify an HTTP 'Request'--2. stateful access to fetch or modify an HTTP 'Response'--3. failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can- choose not to handle a given request, using 'empty' or its synonym 'pass',- and you can try alternative handlers with the '<|>' operator:-- > a :: Snap String- > a = pass- >- > b :: Snap String- > b = return "foo"- >- > c :: Snap String- > c = a <|> b -- try running a, if it fails then try b--4. convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText',- 'addToOutput') for queueing output to be written to the 'Response':-- > a :: (forall a . Enumerator a) -> Snap ()- > a someEnumerator = do- > writeBS "I'm a strict bytestring"- > writeLBS "I'm a lazy bytestring"- > writeText "I'm strict text"- > addToOutput someEnumerator--5. early termination: if you call 'finishWith':-- > a :: Snap ()- > a = do- > modifyResponse $ setResponseStatus 500 "Internal Server Error"- > writeBS "500 error"- > r <- getResponse- > finishWith r-- then any subsequent processing will be skipped and supplied 'Response'- value will be returned from 'runSnap' as-is.--6. access to the 'IO' monad through a 'MonadIO' instance:-- > a :: Snap ()- > a = liftIO fireTheMissiles--7. the ability to set a timeout which will kill the handler thread after @N@- seconds of inactivity (the default is 20 seconds):-- > a :: Snap ()- > a = setTimeout 30--8. throw and catch exceptions using a 'MonadCatchIO' instance:-- > foo :: Snap ()- > foo = bar `catch` \(e::SomeException) -> baz- > where- > bar = throw FooException--9. log a message to the error log:-- > foo :: Snap ()- > foo = logError "grumble."--You may notice that most of the type signatures in this module contain a-@(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which,-in essence, says \"you can get back to the 'Snap' monad from here\". Using-'MonadSnap' you can extend the 'Snap' monad with additional functionality and-still have access to most of the 'Snap' functions without writing 'lift'-everywhere. Instances are already provided for most of the common monad-transformers ('ReaderT', 'WriterT', 'StateT', etc.).---}----------------------------------------------------------------------------------- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes--- it easy to wrap 'Snap' inside monad transformers.-class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m,- Applicative m, Alternative m) => MonadSnap m where- liftSnap :: Snap a -> m a----------------------------------------------------------------------------------data SnapResult a = SnapValue a- | PassOnProcessing String- | EarlyTermination Response---------------------------------------------------------------------------------newtype Snap a = Snap {- unSnap :: StateT SnapState (Iteratee ByteString IO) (SnapResult a)- }----------------------------------------------------------------------------------data SnapState = SnapState- { _snapRequest :: Request- , _snapResponse :: Response- , _snapLogError :: ByteString -> IO ()- , _snapSetTimeout :: Int -> IO () }----------------------------------------------------------------------------------instance Monad Snap where- (>>=) = snapBind- return = snapReturn- fail = snapFail----------------------------------------------------------------------------------snapBind :: Snap a -> (a -> Snap b) -> Snap b-snapBind (Snap m) f = Snap $ do- res <- m-- case res of- SnapValue a -> unSnap $! f a- PassOnProcessing r -> return $! PassOnProcessing r- EarlyTermination r -> return $! EarlyTermination r-{-# INLINE snapBind #-}---snapReturn :: a -> Snap a-snapReturn = Snap . return . SnapValue-{-# INLINE snapReturn #-}---snapFail :: String -> Snap a-snapFail !m = Snap $! return $! PassOnProcessing m-{-# INLINE snapFail #-}----------------------------------------------------------------------------------instance MonadIO Snap where- liftIO m = Snap $ liftM SnapValue $ liftIO m----------------------------------------------------------------------------------instance MonadCatchIO Snap where- catch (Snap m) handler = Snap $ m `catch` h- where- h e = do- rethrowIfUncatchable $ fromException e- maybe (throw e)- (\e' -> let (Snap z) = handler e' in z)- (fromException e)-- block (Snap m) = Snap $ block m- unblock (Snap m) = Snap $ unblock m----------------------------------------------------------------------------------rethrowIfUncatchable :: (MonadCatchIO m) =>- Maybe UncatchableException ->- m ()-rethrowIfUncatchable Nothing = return ()-rethrowIfUncatchable (Just e) = throw e----------------------------------------------------------------------------------instance MonadPlus Snap where- mzero = Snap $ return $ PassOnProcessing ""-- a `mplus` b =- Snap $ do- r <- unSnap a- -- redundant just in case ordering by frequency helps here.- case r of- SnapValue _ -> return r- PassOnProcessing _ -> unSnap b- _ -> return r----------------------------------------------------------------------------------instance (EC.MonadError String) Snap where- throwError = fail- catchError act hndl = Snap $ do- r <- unSnap act- -- redundant just in case ordering by frequency helps here.- case r of- SnapValue _ -> return r- PassOnProcessing m -> unSnap $ hndl m- _ -> return r----------------------------------------------------------------------------------instance Functor Snap where- fmap = liftM----------------------------------------------------------------------------------instance Applicative Snap where- pure = return- (<*>) = ap----------------------------------------------------------------------------------instance Alternative Snap where- empty = mzero- (<|>) = mplus----------------------------------------------------------------------------------instance MonadSnap Snap where- liftSnap = id------------------------------------------------------------------------------------- | The Typeable instance is here so Snap can be dynamically executed with--- Hint.-snapTyCon :: TyCon-snapTyCon = mkTyCon "Snap.Core.Snap"-{-# NOINLINE snapTyCon #-}--instance Typeable1 Snap where- typeOf1 _ = mkTyConApp snapTyCon []----------------------------------------------------------------------------------liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a-liftIter i = liftSnap $ Snap (lift i >>= return . SnapValue)------------------------------------------------------------------------------------ | Sends the request body through an iteratee (data consumer) and--- returns the result.------ If the iteratee you pass in here throws an exception, Snap will attempt to--- clear the rest of the unread request body before rethrowing the exception.--- If your iteratee used 'terminateConnection', however, Snap will give up and--- immediately close the socket.-runRequestBody :: MonadSnap m => Iteratee ByteString IO a -> m a-runRequestBody iter = do- bumpTimeout <- liftM ($ 5) getTimeoutAction- req <- getRequest- senum <- liftIO $ readIORef $ rqBody req- let (SomeEnumerator enum) = senum-- -- make sure the iteratee consumes all of the output- let iter' = handle bumpTimeout req- (iter >>= \a -> skipToEnd bumpTimeout >> return a)-- -- run the iteratee- step <- liftIO $ runIteratee iter'- result <- liftIter $ enum step-- -- stuff a new dummy enumerator into the request, so you can only try to- -- read the request body from the socket once- resetEnum req- return result-- where- resetEnum req = liftIO $- writeIORef (rqBody req) $- SomeEnumerator $ joinI . take 0-- skipToEnd bump = killIfTooSlow bump 500 5 skipToEof `catchError` \e ->- throwError $ ConnectionTerminatedException e-- handle bump req =- (`catches` [- Handler $ \(e :: ConnectionTerminatedException) -> do- let en = SomeEnumerator $ const $ throwError e- liftIO $ writeIORef (rqBody req) en- throwError e- , Handler $ \(e :: SomeException) -> do- resetEnum req- skipToEnd bump- throwError e- ])------------------------------------------------------------------------------------ | Returns the request body as a lazy bytestring.------ This function is deprecated as of 0.6; it places no limits on the size of--- the request being read, and as such, if used, can result in a--- denial-of-service attack on your server. Please use 'readRequestBody'--- instead.-getRequestBody :: MonadSnap m => m L.ByteString-getRequestBody = liftM L.fromChunks $ runRequestBody consume-{-# INLINE getRequestBody #-}-{-# DEPRECATED getRequestBody- "As of 0.6, please use 'readRequestBody' instead" #-}------------------------------------------------------------------------------------ | Returns the request body as a lazy bytestring. /New in 0.6./-readRequestBody :: MonadSnap m =>- Int64 -- ^ size of the largest request body we're willing- -- to accept. If a request body longer than this is- -- received, a 'TooManyBytesReadException' is- -- thrown. See 'takeNoMoreThan'.- -> m L.ByteString-readRequestBody sz = liftM L.fromChunks $ runRequestBody $- joinI $ takeNoMoreThan sz $$ consume------------------------------------------------------------------------------------ | Normally Snap is careful to ensure that the request body is fully--- consumed after your web handler runs, but before the 'Response' enumerator--- is streamed out the socket. If you want to transform the request body into--- some output in O(1) space, you should use this function.------ Note that upon calling this function, response processing finishes early as--- if you called 'finishWith'. Make sure you set any content types, headers,--- cookies, etc. before you call this function.----transformRequestBody :: (forall a . Enumerator Builder IO a)- -- ^ the output 'Iteratee' is passed to this- -- 'Enumerator', and then the resulting 'Iteratee' is- -- fed the request body stream. Your 'Enumerator' is- -- responsible for transforming the input.- -> Snap ()-transformRequestBody trans = do- req <- getRequest- let ioref = rqBody req- senum <- liftIO $ readIORef ioref- let (SomeEnumerator enum') = senum- let enum = mapEnum toByteString fromByteString enum'- liftIO $ writeIORef ioref (SomeEnumerator enumEOF)-- origRsp <- getResponse- let rsp = setResponseBody- (\writeEnd -> do- let i = iterateeDebugWrapperWith showBuilder- "transformRequestBody"- $ trans writeEnd- st <- liftIO $ runIteratee i-- enum st)- $ origRsp { rspTransformingRqBody = True }- finishWith rsp------------------------------------------------------------------------------------ | Short-circuits a 'Snap' monad action early, storing the given--- 'Response' value in its state.-finishWith :: MonadSnap m => Response -> m a-finishWith = liftSnap . Snap . return . EarlyTermination-{-# INLINE finishWith #-}------------------------------------------------------------------------------------ | Capture the flow of control in case a handler calls 'finishWith'.------ /WARNING/: in the event of a call to 'transformRequestBody' it is possible--- to violate HTTP protocol safety when using this function. If you call--- 'catchFinishWith' it is suggested that you do not modify the body of the--- 'Response' which was passed to the 'finishWith' call.-catchFinishWith :: Snap a -> Snap (Either Response a)-catchFinishWith (Snap m) = Snap $ do- r <- m- case r of- SnapValue a -> return $! SnapValue $! Right a- PassOnProcessing e -> return $! PassOnProcessing e- EarlyTermination resp -> return $! SnapValue $! Left resp-{-# INLINE catchFinishWith #-}------------------------------------------------------------------------------------ | Fails out of a 'Snap' monad action. This is used to indicate--- that you choose not to handle the given request within the given--- handler.-pass :: MonadSnap m => m a-pass = empty------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only if the request's HTTP method matches--- the given method.-method :: MonadSnap m => Method -> m a -> m a-method m action = do- req <- getRequest- unless (rqMethod req == m) pass- action-{-# INLINE method #-}------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only if the request's HTTP method matches--- one of the given methods.-methods :: MonadSnap m => [Method] -> m a -> m a-methods ms action = do- req <- getRequest- unless (rqMethod req `elem` ms) pass- action-{-# INLINE methods #-}------------------------------------------------------------------------------------ Appends n bytes of the path info to the context path with a--- trailing slash.-updateContextPath :: Int -> Request -> Request-updateContextPath n req | n > 0 = req { rqContextPath = ctx- , rqPathInfo = pinfo }- | otherwise = req- where- ctx' = S.take n (rqPathInfo req)- ctx = S.concat [rqContextPath req, ctx', "/"]- pinfo = S.drop (n+1) (rqPathInfo req)------------------------------------------------------------------------------------ Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given--- predicate.-pathWith :: MonadSnap m- => (ByteString -> ByteString -> Bool)- -> ByteString- -> m a- -> m a-pathWith c p action = do- req <- getRequest- unless (c p (rqPathInfo req)) pass- localRequest (updateContextPath $ S.length p) action------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request--- starts with the given path. For example,------ > dir "foo" handler------ Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will--- add @\"foo\/\"@ to the handler's local 'rqContextPath'.-dir :: MonadSnap m- => ByteString -- ^ path component to match- -> m a -- ^ handler to run- -> m a-dir = pathWith f- where- f dr pinfo = dr == x- where- (x,_) = S.break (=='/') pinfo-{-# INLINE dir #-}------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is--- exactly equal to the given string. If the path matches, locally sets--- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\",--- and runs the given handler.-path :: MonadSnap m- => ByteString -- ^ path to match against- -> m a -- ^ handler to run- -> m a-path = pathWith (==)-{-# INLINE path #-}------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only when the first path component is--- successfully parsed as the argument to the supplied handler function.-pathArg :: (Readable a, MonadSnap m)- => (a -> m b)- -> m b-pathArg f = do- req <- getRequest- let (p,_) = S.break (=='/') (rqPathInfo req)- a <- fromBS p- localRequest (updateContextPath $ S.length p) (f a)------------------------------------------------------------------------------------ | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.-ifTop :: MonadSnap m => m a -> m a-ifTop = path ""-{-# INLINE ifTop #-}------------------------------------------------------------------------------------ | Local Snap version of 'get'.-sget :: Snap SnapState-sget = Snap $ liftM SnapValue get-{-# INLINE sget #-}------------------------------------------------------------------------------------ | Local Snap monad version of 'modify'.-smodify :: (SnapState -> SnapState) -> Snap ()-smodify f = Snap $ modify f >> return (SnapValue ())-{-# INLINE smodify #-}------------------------------------------------------------------------------------ | Grabs the 'Request' object out of the 'Snap' monad.-getRequest :: MonadSnap m => m Request-getRequest = liftSnap $ liftM _snapRequest sget-{-# INLINE getRequest #-}------------------------------------------------------------------------------------ | Grabs something out of the 'Request' object, using the given projection--- function. See 'gets'.-getsRequest :: MonadSnap m => (Request -> a) -> m a-getsRequest f = liftSnap $ liftM (f . _snapRequest) sget-{-# INLINE getsRequest #-}------------------------------------------------------------------------------------ | Grabs the 'Response' object out of the 'Snap' monad.-getResponse :: MonadSnap m => m Response-getResponse = liftSnap $ liftM _snapResponse sget-{-# INLINE getResponse #-}------------------------------------------------------------------------------------ | Grabs something out of the 'Response' object, using the given projection--- function. See 'gets'.-getsResponse :: MonadSnap m => (Response -> a) -> m a-getsResponse f = liftSnap $ liftM (f . _snapResponse) sget-{-# INLINE getsResponse #-}------------------------------------------------------------------------------------ | Puts a new 'Response' object into the 'Snap' monad.-putResponse :: MonadSnap m => Response -> m ()-putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r }-{-# INLINE putResponse #-}------------------------------------------------------------------------------------ | Puts a new 'Request' object into the 'Snap' monad.-putRequest :: MonadSnap m => Request -> m ()-putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r }-{-# INLINE putRequest #-}------------------------------------------------------------------------------------ | Modifies the 'Request' object stored in a 'Snap' monad.-modifyRequest :: MonadSnap m => (Request -> Request) -> m ()-modifyRequest f = liftSnap $- smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss }-{-# INLINE modifyRequest #-}------------------------------------------------------------------------------------ | Modifes the 'Response' object stored in a 'Snap' monad.-modifyResponse :: MonadSnap m => (Response -> Response) -> m ()-modifyResponse f = liftSnap $- smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss }-{-# INLINE modifyResponse #-}------------------------------------------------------------------------------------ | Performs a redirect by setting the @Location@ header to the given target--- URL/path and the status code to 302 in the 'Response' object stored in a--- 'Snap' monad. Note that the target URL is not validated in any way.--- Consider using 'redirect\'' instead, which allows you to choose the correct--- status code.-redirect :: MonadSnap m => ByteString -> m a-redirect target = redirect' target 302-{-# INLINE redirect #-}------------------------------------------------------------------------------------ | Performs a redirect by setting the @Location@ header to the given target--- URL/path and the status code (should be one of 301, 302, 303 or 307) in the--- 'Response' object stored in a 'Snap' monad. Note that the target URL is not--- validated in any way.-redirect' :: MonadSnap m => ByteString -> Int -> m a-redirect' target status = do- r <- getResponse-- finishWith- $ setResponseCode status- $ setContentLength 0- $ modifyResponseBody (const $ enumBuilder mempty)- $ setHeader "Location" target r--{-# INLINE redirect' #-}------------------------------------------------------------------------------------ | Log an error message in the 'Snap' monad-logError :: MonadSnap m => ByteString -> m ()-logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)- >> return (SnapValue ())-{-# INLINE logError #-}------------------------------------------------------------------------------------ | Adds the output from the given enumerator to the 'Response'--- stored in the 'Snap' monad state.-addToOutput :: MonadSnap m- => (forall a . Enumerator Builder IO a) -- ^ output to add- -> m ()-addToOutput enum = modifyResponse $ modifyResponseBody (>==> enum)------------------------------------------------------------------------------------ | Adds the given 'Builder' to the body of the 'Response' stored in the--- | 'Snap' monad state.-writeBuilder :: MonadSnap m => Builder -> m ()-writeBuilder b = addToOutput $ enumBuilder b-{-# INLINE writeBuilder #-}------------------------------------------------------------------------------------ | Adds the given strict 'ByteString' to the body of the 'Response' stored--- in the 'Snap' monad state.------ Warning: This function is intentionally non-strict. If any pure--- exceptions are raised by the expression creating the 'ByteString',--- the exception won't actually be raised within the Snap handler.-writeBS :: MonadSnap m => ByteString -> m ()-writeBS s = writeBuilder $ fromByteString s------------------------------------------------------------------------------------ | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored--- in the 'Snap' monad state.------ Warning: This function is intentionally non-strict. If any pure--- exceptions are raised by the expression creating the 'ByteString',--- the exception won't actually be raised within the Snap handler.-writeLBS :: MonadSnap m => L.ByteString -> m ()-writeLBS s = writeBuilder $ fromLazyByteString s------------------------------------------------------------------------------------ | Adds the given strict 'T.Text' to the body of the 'Response' stored in--- the 'Snap' monad state.------ Warning: This function is intentionally non-strict. If any pure--- exceptions are raised by the expression creating the 'ByteString',--- the exception won't actually be raised within the Snap handler.-writeText :: MonadSnap m => T.Text -> m ()-writeText s = writeBuilder $ fromText s------------------------------------------------------------------------------------ | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the--- 'Snap' monad state.------ Warning: This function is intentionally non-strict. If any pure--- exceptions are raised by the expression creating the 'ByteString',--- the exception won't actually be raised within the Snap handler.-writeLazyText :: MonadSnap m => LT.Text -> m ()-writeLazyText s = writeBuilder $ fromLazyText s------------------------------------------------------------------------------------ | Sets the output to be the contents of the specified file.------ Calling 'sendFile' will overwrite any output queued to be sent in the--- 'Response'. If the response body is not modified after the call to--- 'sendFile', Snap will use the efficient @sendfile()@ system call on--- platforms that support it.------ If the response body is modified (using 'modifyResponseBody'), the file--- will be read using @mmap()@.-sendFile :: (MonadSnap m) => FilePath -> m ()-sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing }------------------------------------------------------------------------------------ | Sets the output to be the contents of the specified file, within the--- given (start,end) range.------ Calling 'sendFilePartial' will overwrite any output queued to be sent in--- the 'Response'. If the response body is not modified after the call to--- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on--- platforms that support it.------ If the response body is modified (using 'modifyResponseBody'), the file--- will be read using @mmap()@.-sendFilePartial :: (MonadSnap m) => FilePath -> (Int64,Int64) -> m ()-sendFilePartial f rng = modifyResponse $ \r ->- r { rspBody = SendFile f (Just rng) }------------------------------------------------------------------------------------ | Runs a 'Snap' action with a locally-modified 'Request' state--- object. The 'Request' object in the Snap monad state after the call--- to localRequest will be unchanged.-localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a-localRequest f m = do- req <- getRequest-- runAct req <|> (putRequest req >> pass)-- where- runAct req = do- modifyRequest f- result <- m- putRequest req- return result-{-# INLINE localRequest #-}------------------------------------------------------------------------------------ | Fetches the 'Request' from state and hands it to the given action.-withRequest :: MonadSnap m => (Request -> m a) -> m a-withRequest = (getRequest >>=)-{-# INLINE withRequest #-}------------------------------------------------------------------------------------ | Fetches the 'Response' from state and hands it to the given action.-withResponse :: MonadSnap m => (Response -> m a) -> m a-withResponse = (getResponse >>=)-{-# INLINE withResponse #-}------------------------------------------------------------------------------------ | Modifies the 'Request' in the state to set the 'rqRemoteAddr'--- field to the value in the X-Forwarded-For header. If the header is--- not present, this action has no effect.------ This action should be used only when working behind a reverse http--- proxy that sets the X-Forwarded-For header. This is the only way to--- ensure the value in the X-Forwarded-For header can be trusted.------ This is provided as a filter so actions that require the remote--- address can get it in a uniform manner. It has specifically limited--- functionality to ensure that its transformation can be trusted,--- when used correctly.-ipHeaderFilter :: MonadSnap m => m ()-ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"------------------------------------------------------------------------------------ | Modifies the 'Request' in the state to set the 'rqRemoteAddr'--- field to the value from the header specified. If the header--- specified is not present, this action has no effect.------ This action should be used only when working behind a reverse http--- proxy that sets the header being looked at. This is the only way to--- ensure the value in the header can be trusted.------ This is provided as a filter so actions that require the remote--- address can get it in a uniform manner. It has specifically limited--- functionality to ensure that its transformation can be trusted,--- when used correctly.-ipHeaderFilter' :: MonadSnap m => CI ByteString -> m ()-ipHeaderFilter' header = do- headerContents <- getHeader header <$> getRequest-- let whitespace = " \t\r\n"- ipChrs = ".0123456789"- trim f s = f (`elem` s)-- clean = trim S.takeWhile ipChrs . trim S.dropWhile whitespace- setIP ip = modifyRequest $ \rq -> rq { rqRemoteAddr = clean ip }- maybe (return ()) setIP headerContents------------------------------------------------------------------------------------ | This function brackets a Snap action in resource acquisition and--- release. This is provided because MonadCatchIO's 'bracket' function--- doesn't work properly in the case of a short-circuit return from--- the action being bracketed.------ In order to prevent confusion regarding the effects of the--- aquisition and release actions on the Snap state, this function--- doesn't accept Snap actions for the acquire or release actions.------ This function will run the release action in all cases where the--- acquire action succeeded. This includes the following behaviors--- from the bracketed Snap action.------ 1. Normal completion------ 2. Short-circuit completion, either from calling 'fail' or 'finishWith'------ 3. An exception being thrown.-bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c-bracketSnap before after thing = block . Snap $ do- a <- liftIO before- let after' = liftIO $ after a- (Snap thing') = thing a- r <- unblock thing' `onException` after'- _ <- after'- return r------------------------------------------------------------------------------------ | This exception is thrown if the handler you supply to 'runSnap' fails.-data NoHandlerException = NoHandlerException String- deriving (Eq, Typeable)----------------------------------------------------------------------------------instance Show NoHandlerException where- show (NoHandlerException e) = "No handler for request: failure was " ++ e----------------------------------------------------------------------------------instance Exception NoHandlerException------------------------------------------------------------------------------------ | An exception hierarchy for exceptions that cannot be caught by--- user-defined error handlers-data UncatchableException = forall e. Exception e => UncatchableException e- deriving (Typeable)----------------------------------------------------------------------------------instance Show UncatchableException where- show (UncatchableException e) = "Uncatchable exception: " ++ show e----------------------------------------------------------------------------------instance Exception UncatchableException----------------------------------------------------------------------------------uncatchableExceptionToException :: Exception e => e -> SomeException-uncatchableExceptionToException = toException . UncatchableException----------------------------------------------------------------------------------uncatchableExceptionFromException :: Exception e => SomeException -> Maybe e-uncatchableExceptionFromException e = do- UncatchableException ue <- fromException e- cast ue----------------------------------------------------------------------------------data ConnectionTerminatedException =- ConnectionTerminatedException SomeException- deriving (Typeable)----------------------------------------------------------------------------------instance Show ConnectionTerminatedException where- show (ConnectionTerminatedException e) =- "Connection terminated with exception: " ++ show e----------------------------------------------------------------------------------instance Exception ConnectionTerminatedException where- toException = uncatchableExceptionToException- fromException = uncatchableExceptionFromException------------------------------------------------------------------------------------ | Terminate the HTTP session with the given exception.-terminateConnection :: (Exception e, MonadCatchIO m) => e -> m a-terminateConnection = throw . ConnectionTerminatedException . toException----- | This is exception is thrown if the handler chooses to escape regular HTTP--- traffic.-data EscapeHttpException = EscapeHttpException- ((Int -> IO ()) -> Iteratee ByteString IO () -> Iteratee ByteString IO ())- deriving (Typeable)----------------------------------------------------------------------------------instance Show EscapeHttpException where- show = const "HTTP traffic was escaped"----------------------------------------------------------------------------------instance Exception EscapeHttpException where- toException = uncatchableExceptionToException- fromException = uncatchableExceptionFromException------------------------------------------------------------------------------------ | Terminate the HTTP session and hand control to some external handler,--- escaping all further HTTP traffic.------ The external handler takes two arguments: a function to tickle the timeout--- manager, and a write end to the socket.-escapeHttp :: MonadCatchIO m- => ((Int -> IO ()) -> Iteratee ByteString IO () ->- Iteratee ByteString IO ())- -> m ()-escapeHttp = throw . EscapeHttpException------------------------------------------------------------------------------------ | Runs a 'Snap' monad action in the 'Iteratee IO' monad.-runSnap :: Snap a- -> (ByteString -> IO ())- -> (Int -> IO ())- -> Request- -> Iteratee ByteString IO (Request,Response)-runSnap (Snap m) logerr timeoutAction req = do- (r, ss') <- runStateT m ss-- let resp = case r of- SnapValue _ -> _snapResponse ss'- PassOnProcessing _ -> fourohfour- EarlyTermination x -> x-- return (_snapRequest ss', resp)-- where- fourohfour =- setContentLength 3 $- setResponseStatus 404 "Not Found" $- modifyResponseBody (>==> enumBuilder (fromByteString "404")) $- emptyResponse-- dresp = emptyResponse { rspHttpVersion = rqVersion req }-- ss = SnapState req dresp logerr timeoutAction-{-# INLINE runSnap #-}----------------------------------------------------------------------------------evalSnap :: Snap a- -> (ByteString -> IO ())- -> (Int -> IO ())- -> Request- -> Iteratee ByteString IO a-evalSnap (Snap m) logerr timeoutAction req = do- (r, _) <- runStateT m ss-- case r of- SnapValue x -> return x- PassOnProcessing e -> liftIO $ throwIO $ NoHandlerException e- EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"-- where- dresp = emptyResponse { rspHttpVersion = rqVersion req }- ss = SnapState req dresp logerr timeoutAction-{-# INLINE evalSnap #-}------------------------------------------------------------------------------------- | See 'rqParam'. Looks up a value for the given named parameter in the--- 'Request'. If more than one value was entered for the given parameter name,--- 'getParam' gloms the values together with:------ @ 'S.intercalate' \" \"@----getParam :: MonadSnap m- => ByteString -- ^ parameter name to look up- -> m (Maybe ByteString)-getParam k = do- rq <- getRequest- return $ liftM (S.intercalate " ") $ rqParam k rq------------------------------------------------------------------------------------ | See 'rqParams'. Convenience function to return 'Params' from the--- 'Request' inside of a 'MonadSnap' instance.-getParams :: MonadSnap m => m Params-getParams = getRequest >>= return . rqParams------------------------------------------------------------------------------------ | Gets the HTTP 'Cookie' with the specified name.-getCookie :: MonadSnap m- => ByteString- -> m (Maybe Cookie)-getCookie name = withRequest $- return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies------------------------------------------------------------------------------------ | Gets the HTTP 'Cookie' with the specified name and decodes it. If the--- decoding fails, the handler calls pass.-readCookie :: (MonadSnap m, Readable a)- => ByteString- -> m a-readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name------------------------------------------------------------------------------------ | Expire the given 'Cookie' in client's browser.-expireCookie :: (MonadSnap m)- => ByteString- -- ^ Cookie name- -> Maybe ByteString- -- ^ Cookie domain- -> m ()-expireCookie nm dm = do- let old = UTCTime (ModifiedJulianDay 0) 0- modifyResponse $ addResponseCookie- $ Cookie nm "" (Just old) Nothing dm False False------------------------------------------------------------------------------------ | Causes the handler thread to be killed @n@ seconds from now.-setTimeout :: MonadSnap m- => Int -> m ()-setTimeout n = do- t <- getTimeoutAction- liftIO $ t n------------------------------------------------------------------------------------ | Returns an 'IO' action which you can use to reset the handling thread's--- timeout value.-getTimeoutAction :: MonadSnap m => m (Int -> IO ())-getTimeoutAction = liftSnap $ liftM _snapSetTimeout sget
+ src/Snap/Internal/Util/FileServe.hs view
@@ -0,0 +1,809 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Contains web handlers to serve files from a directory.+module Snap.Internal.Util.FileServe+ ( -- * Helper functions+ getSafePath+ -- * Configuration for directory serving+ , MimeMap+ , HandlerMap+ , DirectoryConfig(..)+ , simpleDirectoryConfig+ , defaultDirectoryConfig+ , fancyDirectoryConfig+ , defaultIndexGenerator+ , defaultMimeTypes+ , fileType+ -- * File servers+ , serveDirectory+ , serveDirectoryWith+ , serveFile+ , serveFileAs+ -- * Internal functions+ , decodeFilePath+ , checkRangeReq+ ) where++------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>)), Applicative ((*>), (<*)), (<$>))+import Control.Exception.Lifted (SomeException, catch, evaluate)+import Control.Monad (Monad ((>>), (>>=), return), filterM, forM_, liftM, unless, void, when, (=<<))+import Control.Monad.IO.Class (MonadIO (..))+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, option, string)+import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S (append, concat, intercalate, isSuffixOf, null, pack, takeWhile)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map (empty, fromList, lookup)+import Data.List (drop, dropWhile, elem, filter, foldl', null, sort, (++))+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid (Monoid (mappend, mconcat))+import qualified Data.Text as T (Text, pack, unpack)+import qualified Data.Text.Encoding as T (decodeUtf8, encodeUtf8)+import Data.Word (Word64)+import Prelude (Bool (..), Eq (..), FilePath, IO, Maybe (Just, Nothing), Num (..), Ord (..), Show (show), String, const, either, flip, fromIntegral, id, maybe, not, ($), ($!), (.), (||))+import qualified Prelude+import Snap.Core (MonadSnap (..), Request (rqPathInfo, rqQueryString, rqURI), deleteHeader, emptyResponse, finishWith, formatHttpTime, getHeader, getRequest, modifyResponse, parseHttpTime, pass, redirect, sendFile, sendFilePartial, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, urlDecode, writeBS)+import Snap.Internal.Debug (debug)+import Snap.Internal.Parsing (fullyParse, parseNum)+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)+import System.FilePath (isRelative, joinPath, splitDirectories, takeExtensions, takeFileName, (</>))+import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)+++------------------------------------------------------------------------------+-- | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is+-- safe to use for opening files. A path is safe if it is a relative path+-- and has no ".." elements to escape the intended directory structure.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> import qualified "Data.ByteString.Char8" as B8+-- ghci> T.runHandler (T.get \"\/foo\/bar\" M.empty) ('getSafePath' >>= 'writeBS' . B8.pack)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Fri, 08 Aug 2014 16:13:20 GMT+--+-- foo\/bar+-- ghci> T.runHandler (T.get \"\/foo\/..\/bar\" M.empty) ('getSafePath' >>= 'writeBS' . B8.pack)+-- HTTP\/1.1 404 Not Found+-- ...+-- @+getSafePath :: MonadSnap m => m FilePath+getSafePath = do+ req <- getRequest+ let mp = urlDecode $ rqPathInfo req++ p <- maybe pass (return . T.unpack . T.decodeUtf8) mp++ -- relative paths only!+ when (not $ isRelative p) pass++ -- check that we don't have any sneaky .. paths+ let dirs = splitDirectories p+ when (elem ".." dirs) pass++ return $! joinPath dirs+++------------------------------------------------------------------------------+-- | A type alias for dynamic handlers+type HandlerMap m = HashMap FilePath (FilePath -> m ())+++------------------------------------------------------------------------------+-- | A type alias for MIME type+type MimeMap = HashMap FilePath ByteString+++------------------------------------------------------------------------------+-- | The default set of mime type mappings we use when serving files. Its+-- value:+--+-- > Map.fromList [+-- > ( ".asc" , "text/plain" ),+-- > ( ".asf" , "video/x-ms-asf" ),+-- > ( ".asx" , "video/x-ms-asf" ),+-- > ( ".au" , "audio/basic" ),+-- > ( ".avi" , "video/x-msvideo" ),+-- > ( ".bmp" , "image/bmp" ),+-- > ( ".bz2" , "application/x-bzip" ),+-- > ( ".c" , "text/plain" ),+-- > ( ".class" , "application/octet-stream" ),+-- > ( ".conf" , "text/plain" ),+-- > ( ".cpp" , "text/plain" ),+-- > ( ".css" , "text/css" ),+-- > ( ".csv" , "text/csv" ),+-- > ( ".cxx" , "text/plain" ),+-- > ( ".doc" , "application/msword" ),+-- > ( ".docx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".wordprocessingml.document" ),+-- > ( ".dotx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".wordprocessingml.template" ),+-- > ( ".dtd" , "application/xml-dtd" ),+-- > ( ".dvi" , "application/x-dvi" ),+-- > ( ".exe" , "application/octet-stream" ),+-- > ( ".flv" , "video/x-flv" ),+-- > ( ".gif" , "image/gif" ),+-- > ( ".gz" , "application/x-gzip" ),+-- > ( ".hs" , "text/plain" ),+-- > ( ".htm" , "text/html" ),+-- > ( ".html" , "text/html" ),+-- > ( ".ico" , "image/x-icon" ),+-- > ( ".jar" , "application/x-java-archive" ),+-- > ( ".jpeg" , "image/jpeg" ),+-- > ( ".jpg" , "image/jpeg" ),+-- > ( ".js" , "text/javascript" ),+-- > ( ".json" , "application/json" ),+-- > ( ".log" , "text/plain" ),+-- > ( ".m3u" , "audio/x-mpegurl" ),+-- > ( ".m3u8" , "application/x-mpegURL" ),+-- > ( ".mka" , "audio/x-matroska" ),+-- > ( ".mk3d" , "video/x-matroska" ),+-- > ( ".mkv" , "video/x-matroska" ),+-- > ( ".mov" , "video/quicktime" ),+-- > ( ".mp3" , "audio/mpeg" ),+-- > ( ".mp4" , "video/mp4" ),+-- > ( ".mpeg" , "video/mpeg" ),+-- > ( ".mpg" , "video/mpeg" ),+-- > ( ".ogg" , "application/ogg" ),+-- > ( ".pac" , "application/x-ns-proxy-autoconfig" ),+-- > ( ".pdf" , "application/pdf" ),+-- > ( ".png" , "image/png" ),+-- > ( ".potx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".presentationml.template" ),+-- > ( ".ppsx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".presentationml.slideshow" ),+-- > ( ".ppt" , "application/vnd.ms-powerpoint" ),+-- > ( ".pptx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".presentationml.presentation" ),+-- > ( ".ps" , "application/postscript" ),+-- > ( ".qt" , "video/quicktime" ),+-- > ( ".rtf" , "text/rtf" ),+-- > ( ".sig" , "application/pgp-signature" ),+-- > ( ".sldx" , S.append "application/vnd.openxmlformats-officedocument"+-- > ".presentationml.slide" ),+-- > ( ".spl" , "application/futuresplash" ),+-- > ( ".svg" , "image/svg+xml" ),+-- > ( ".swf" , "application/x-shockwave-flash" ),+-- > ( ".tar" , "application/x-tar" ),+-- > ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),+-- > ( ".tar.gz" , "application/x-tgz" ),+-- > ( ".tbz" , "application/x-bzip-compressed-tar" ),+-- > ( ".text" , "text/plain" ),+-- > ( ".tgz" , "application/x-tgz" ),+-- > ( ".tif" , "image/tiff" ),+-- > ( ".tiff" , "image/tiff" ),+-- > ( ".torrent" , "application/x-bittorrent" ),+-- > ( ".ts" , "video/mp2t" ),+-- > ( ".txt" , "text/plain" ),+-- > ( ".wav" , "audio/x-wav" ),+-- > ( ".wax" , "audio/x-ms-wax" ),+-- > ( ".webm" , "video/webm" ),+-- > ( ".wma" , "audio/x-ms-wma" ),+-- > ( ".wmv" , "video/x-ms-wmv" ),+-- > ( ".xbm" , "image/x-xbitmap" ),+-- > ( ".xlam" , "application/vnd.ms-excel.addin.macroEnabled.12" ),+-- > ( ".xls" , "application/vnd.ms-excel" ),+-- > ( ".xlsb" , "application/vnd.ms-excel.sheet.binary.macroEnabled.12" ),+-- > ( ".xlsx" , S.append "application/vnd.openxmlformats-officedocument."+-- > "spreadsheetml.sheet" ),+-- > ( ".xltx" , S.append "application/vnd.openxmlformats-officedocument."+-- > "spreadsheetml.template" ),+-- > ( ".xml" , "text/xml" ),+-- > ( ".xpm" , "image/x-xpixmap" ),+-- > ( ".xwd" , "image/x-xwindowdump" ),+-- > ( ".zip" , "application/zip" ) ]++defaultMimeTypes :: MimeMap+defaultMimeTypes =+ Map.fromList [+ ( ".asc" , "text/plain" ),+ ( ".asf" , "video/x-ms-asf" ),+ ( ".asx" , "video/x-ms-asf" ),+ ( ".au" , "audio/basic" ),+ ( ".avi" , "video/x-msvideo" ),+ ( ".bmp" , "image/bmp" ),+ ( ".bz2" , "application/x-bzip" ),+ ( ".c" , "text/plain" ),+ ( ".class" , "application/octet-stream" ),+ ( ".conf" , "text/plain" ),+ ( ".cpp" , "text/plain" ),+ ( ".css" , "text/css" ),+ ( ".csv" , "text/csv" ),+ ( ".cxx" , "text/plain" ),+ ( ".doc" , "application/msword" ),+ ( ".docx" , S.append "application/vnd.openxmlformats-officedocument"+ ".wordprocessingml.document" ),+ ( ".dotx" , S.append "application/vnd.openxmlformats-officedocument"+ ".wordprocessingml.template" ),+ ( ".dtd" , "application/xml-dtd" ),+ ( ".dvi" , "application/x-dvi" ),+ ( ".exe" , "application/octet-stream" ),+ ( ".flv" , "video/x-flv" ),+ ( ".gif" , "image/gif" ),+ ( ".gz" , "application/x-gzip" ),+ ( ".hs" , "text/plain" ),+ ( ".htm" , "text/html" ),+ ( ".html" , "text/html" ),+ ( ".ico" , "image/x-icon" ),+ ( ".jar" , "application/x-java-archive" ),+ ( ".jpeg" , "image/jpeg" ),+ ( ".jpg" , "image/jpeg" ),+ ( ".js" , "text/javascript" ),+ ( ".json" , "application/json" ),+ ( ".log" , "text/plain" ),+ ( ".m3u" , "audio/x-mpegurl" ),+ ( ".m3u8" , "application/x-mpegURL" ),+ ( ".mka" , "audio/x-matroska" ),+ ( ".mk3d" , "video/x-matroska" ),+ ( ".mkv" , "video/x-matroska" ),+ ( ".mov" , "video/quicktime" ),+ ( ".mp3" , "audio/mpeg" ),+ ( ".mp4" , "video/mp4" ),+ ( ".mpeg" , "video/mpeg" ),+ ( ".mpg" , "video/mpeg" ),+ ( ".ogg" , "application/ogg" ),+ ( ".pac" , "application/x-ns-proxy-autoconfig" ),+ ( ".pdf" , "application/pdf" ),+ ( ".png" , "image/png" ),+ ( ".potx" , S.append "application/vnd.openxmlformats-officedocument"+ ".presentationml.template" ),+ ( ".ppsx" , S.append "application/vnd.openxmlformats-officedocument"+ ".presentationml.slideshow" ),+ ( ".ppt" , "application/vnd.ms-powerpoint" ),+ ( ".pptx" , S.append "application/vnd.openxmlformats-officedocument"+ ".presentationml.presentation" ),+ ( ".ps" , "application/postscript" ),+ ( ".qt" , "video/quicktime" ),+ ( ".rtf" , "text/rtf" ),+ ( ".sig" , "application/pgp-signature" ),+ ( ".sldx" , S.append "application/vnd.openxmlformats-officedocument"+ ".presentationml.slide" ),+ ( ".spl" , "application/futuresplash" ),+ ( ".svg" , "image/svg+xml" ),+ ( ".swf" , "application/x-shockwave-flash" ),+ ( ".tar" , "application/x-tar" ),+ ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),+ ( ".tar.gz" , "application/x-tgz" ),+ ( ".tbz" , "application/x-bzip-compressed-tar" ),+ ( ".text" , "text/plain" ),+ ( ".tgz" , "application/x-tgz" ),+ ( ".tiff" , "image/tiff" ),+ ( ".tif" , "image/tiff" ),+ ( ".torrent" , "application/x-bittorrent" ),+ ( ".ts" , "video/mp2t" ),+ ( ".ttf" , "font/ttf" ),+ ( ".txt" , "text/plain" ),+ ( ".wav" , "audio/x-wav" ),+ ( ".wax" , "audio/x-ms-wax" ),+ ( ".webm" , "video/webm" ),+ ( ".wma" , "audio/x-ms-wma" ),+ ( ".wmv" , "video/x-ms-wmv" ),+ ( ".xbm" , "image/x-xbitmap" ),+ ( ".xlam" , "application/vnd.ms-excel.addin.macroEnabled.12" ),+ ( ".xls" , "application/vnd.ms-excel" ),+ ( ".xlsb" , "application/vnd.ms-excel.sheet.binary.macroEnabled.12" ),+ ( ".xlsx" , S.append "application/vnd.openxmlformats-officedocument."+ "spreadsheetml.sheet" ),+ ( ".xltx" , S.append "application/vnd.openxmlformats-officedocument."+ "spreadsheetml.template" ),+ ( ".xml" , "text/xml" ),+ ( ".xpm" , "image/x-xpixmap" ),+ ( ".xwd" , "image/x-xwindowdump" ),+ ( ".zip" , "application/zip" ) ]+++------------------------------------------------------------------------------+-- | A collection of options for serving static files out of a directory.+data DirectoryConfig m = DirectoryConfig {+ -- | Files to look for when a directory is requested (e.g., index.html)+ indexFiles :: [FilePath],++ -- | Handler to generate a directory listing if there is no index.+ indexGenerator :: FilePath -> m (),++ -- | Map of extensions to pass to dynamic file handlers. This could be+ -- used, for example, to implement CGI dispatch, pretty printing of source+ -- code, etc.+ dynamicHandlers :: HandlerMap m,++ -- | MIME type map to look up content types.+ mimeTypes :: MimeMap,++ -- | Handler that is called before a file is served. It will only be+ -- called when a file is actually found, not for generated index pages.+ preServeHook :: FilePath -> m ()+ }+++------------------------------------------------------------------------------+-- | Style information for the default directory index generator.+snapIndexStyles :: ByteString+snapIndexStyles =+ S.intercalate "\n"+ [ "body { margin: 0px 0px 0px 0px; font-family: sans-serif }"+ , "div.header {"+ , "padding: 40px 40px 0px 40px; height:35px;"+ , "background:rgb(25,50,87);"+ , "background-image:-webkit-gradient("+ , "linear,left bottom,left top,"+ , "color-stop(0.00, rgb(31,62,108)),"+ , "color-stop(1.00, rgb(19,38,66)));"+ , "background-image:-moz-linear-gradient("+ , "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"+ , "text-shadow:-1px 3px 1px rgb(16,33,57);"+ , "font-size:16pt; letter-spacing: 2pt; color:white;"+ , "border-bottom:10px solid rgb(46,93,156) }"+ , "div.content {"+ , "background:rgb(255,255,255);"+ , "background-image:-webkit-gradient("+ , "linear,left bottom, left top,"+ , "color-stop(0.50, rgb(255,255,255)),"+ , "color-stop(1.00, rgb(224,234,247)));"+ , "background-image:-moz-linear-gradient("+ , "center bottom, white 50%, rgb(224,234,247) 100%);"+ , "padding: 40px 40px 40px 40px }"+ , "div.footer {"+ , "padding: 16px 0px 10px 10px; height:31px;"+ , "border-top: 1px solid rgb(194,209,225);"+ , "color: rgb(160,172,186); font-size:10pt;"+ , "background: rgb(245,249,255) }"+ , "table { max-width:100%; margin: 0 auto;" `S.append`+ " border-collapse: collapse; }"+ , "tr:hover { background:rgb(256,256,224) }"+ , "td { border:0; font-family:monospace; padding: 2px 0; }"+ , "td.filename, td.type { padding-right: 2em; }"+ , "th { border:0; background:rgb(28,56,97);"+ , "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"+ ]+++------------------------------------------------------------------------------+-- | An automatic index generator, which is fairly small and does not rely on+-- any external files (which may not be there depending on external request+-- routing).+--+-- A 'MimeMap' is passed in to display the types of files in the directory+-- listing based on their extension. Preferably, this is the same as the map+-- in the 'DirectoryConfig'+--+-- The styles parameter allows you to apply styles to the directory listing.+-- The listing itself consists of a table, containing a header row using+-- th elements, and one row per file using td elements, so styles for those+-- pieces may be attached to the appropriate tags.+defaultIndexGenerator :: MonadSnap m+ => MimeMap -- ^ MIME type mapping for reporting types+ -> ByteString -- ^ Style info to insert in header+ -> FilePath -- ^ Directory to generate index for+ -> m ()+defaultIndexGenerator mm styles d = do+ modifyResponse $ setContentType "text/html; charset=utf-8"+ rq <- getRequest++ let uri = uriWithoutQueryString rq+ let pInfo = rqPathInfo rq++ writeBS "<!DOCTYPE html>\n<html>\n<head>"+ writeBS "<title>Directory Listing: "+ writeBS uri+ writeBS "</title>"+ writeBS "<style type='text/css'>"+ writeBS styles+ writeBS "</style></head><body>"+ writeBS "<div class=\"header\">Directory Listing: "+ writeBS uri+ writeBS "</div><div class=\"content\">"+ writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"+ writeBS "</th></tr>"++ when (pInfo /= "") $+ writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"++ entries <- liftIO $ getDirectoryContents d+ dirs <- liftIO $ filterM (doesDirectoryExist . (d </>)) entries+ files <- liftIO $ filterM (doesFileExist . (d </>)) entries++ forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f0 -> do+ f <- liftIO $ liftM (\s -> T.encodeUtf8 s `mappend` "/")+ $ decodeFilePath f0+ writeBS "<tr><td class='filename'><a href='"+ writeBS f+ writeBS "'>"+ writeBS f+ writeBS "</a></td><td class='type' colspan=2>DIR</td></tr>"++ forM_ (sort files) $ \f0 -> do+ f <- liftIO $ liftM T.encodeUtf8 $ decodeFilePath f0+ stat <- liftIO $ getFileStatus (d </> f0)+ tm <- liftIO $ formatHttpTime (modificationTime stat)+ writeBS "<tr><td class='filename'><a href='"+ writeBS f+ writeBS "'>"+ writeBS f+ writeBS "</a></td><td class='type'>"+ writeBS (fileType mm f0)+ writeBS "</td><td>"+ writeBS tm+ writeBS "</tr>"++ writeBS "</table></div><div class=\"footer\">Powered by "+ writeBS "<b><a href=\"http://snapframework.com/\">Snap</a></b></div>"+ writeBS "</body>"+++------------------------------------------------------------------------------+decodeFilePath :: FilePath -> IO T.Text+decodeFilePath fp = do+ evaluate (T.decodeUtf8 bs) `catch`+ (\(_::SomeException) -> return (T.pack fp))+ where+ bs = S.pack fp++------------------------------------------------------------------------------+-- | A very simple configuration for directory serving. This configuration+-- uses built-in MIME types from 'defaultMimeTypes', and has no index files,+-- index generator, dynamic file handlers, or 'preServeHook'.+simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m+simpleDirectoryConfig = DirectoryConfig {+ indexFiles = [],+ indexGenerator = const pass,+ dynamicHandlers = Map.empty,+ mimeTypes = defaultMimeTypes,+ preServeHook = const $ return $! ()+ }+++------------------------------------------------------------------------------+-- | A reasonable default configuration for directory serving. This+-- configuration uses built-in MIME types from 'defaultMimeTypes', serves+-- common index files @index.html@ and @index.htm@, but does not autogenerate+-- directory indexes, nor have any dynamic file handlers. The 'preServeHook'+-- will not do anything.+defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m+defaultDirectoryConfig = DirectoryConfig {+ indexFiles = ["index.html", "index.htm"],+ indexGenerator = const pass,+ dynamicHandlers = Map.empty,+ mimeTypes = defaultMimeTypes,+ preServeHook = const $ return $! ()+ }+++------------------------------------------------------------------------------+-- | A more elaborate configuration for file serving. This configuration+-- uses built-in MIME types from 'defaultMimeTypes', serves common index files+-- @index.html@ and @index.htm@, and autogenerates directory indexes with a+-- Snap-like feel. It still has no dynamic file handlers, nor 'preServeHook',+-- which should be added as needed.+--+-- Files recognized as indexes include @index.html@, @index.htm@,+-- @default.html@, @default.htm@, @home.html@+--+-- Example of how the autogenerated directory index looks like:+--+-- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAf8AAAFWCAIAAADogAPPAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB94IChYlE8/LMqEAACAASURBVHja7J13fBTFF8DfzOzutVwagST0KqH33nsHKwIWRAHpUhQUUSwoKCKoFCmiAlIEKUGaEHrvAqEJBEgigZByuX67O/P74y6Vu5DwQwJkvp/9fAh7uzNv3rx5++bt7C4q8kxb4HA4HE4hQwBAXAscDodT+Lw/d/4cDofDY38Oh8PhcO/P4XA4nKfU+yPu/DkcDofH/hwOh8MpDGCuAg6HwymUsT9P/XA4HA6P/TkcDodTOGJ/nvfncDicQuj9Ec/8cDgcTuGDZ344HA6nUMb+PPPD4XA4PPbncDgcTiGJ/Xnen8PhcHjsz+FwOJxCEfvzNT8cDofDY38Oh8PhFI7Yn6/54XA4HO79ORwOh1NIvD93/hwOh8Njfw6Hw+EUBvhdXw6HwymUsT9f8cnhcDg89udwOBxO4Yj9ed6fw+FwCqX355kfDofDKXzwzA+Hw+EUztifZ344HA6nEHp/nvjhcDgcHvtzOBwOp1DA8/4cDodTOGN/nvrhcDicwuj9eeaHw+FwCh8888PhcDiFMvbn7/nhcDgcHvtzOBwOp3DE/jzvz+FwOIXS+3Pnz+FwODz253A4HE5hgOf9ORwOh8f+HA6Hwykk3p8v+ORwOJxCCAZABbHh4I6T44/9lnM7svjU6o/nDm9RK4B4O0vb+JMF8cd++bWJvoDEzpRfX7bhoGdLaQtYjNw3ocwrX8Uf++38J1X09znyoSjWq04eny7Lw4ZDXvn5t/hV3csJGTtJUJ2eC1fNjzv2W/yxJfvee0b3+LciH63jW6HeCirzk16pevf8ZbPivhAJkl9gkbJlK/d6o3Kv55t9MuT7Rf84mJezMqQvMDQRL29b2j1s57QV6+Mf40s7yvIHysOR/5difejkcemyPIVCgRHPVoXri8/EK+miGqp+PuPlrkaw3vjn1B1X/NkU+YnNlHppHaeQZ34evTEzYKCqKmUAAKd/fm7gEZPHQyBAWBNWc+jkMRMa1fhkTv+rLy/YmZru/xmlzHps2ug6Pwh2s70gxyADQR9YJIeDfcxgwIAqzK1koLnJ+VAU61Unj0+X5akJzFi9cT2c/OveWy7kaRQpUqaaESBuTY/eqy4oBOMn9q2I97aOw71/ATgwyqjiVGUFAIBaFbtJAQDGAAEgot48NPOdVGHZ9HEVm0/pt7XN3JtOj/Uy6rI57KZbZj0RtYAKaLUSA0YVVaWe/zy2Lo1SKjsVRb2vnA9BsT508rh0Wd7aQKlUvWOEJmX/nzFOABEAGFMZQwIAJF+/YzEzQcdEjJDwJPr+zNZd87SOwymQAckYU5nKMpMDCCGMARBQRZVtSuqZBTP2mQDKdGtVRZP1PE3jL39POL3i1ya6LHu1LaYtjD/6+aA6jb/4eW780SU3/vr43QgpW4VScKtXB65eM/fG0SXxRxedXDr6o66ljT6ajnRhnd4YuHrNnJijS+KP/nRyyagJ7cL1mc5T02rGr1cXtQwA0Lf94NLRJYeHl9bkLCG82+DhGzfMj3NXt2zM5J7lA71U50tyodKAr+KPLjk1oaIu+/FNJ8+NP7pgQTNDHq45lFGVupXM2P06xKti3QZirP9i/+Ur59w4uiT+6JJ/Nn2+9L12DYNIjqyPT534LFnbdMr8+KNfDIqo0Ofd93b99XP80SXxu2esm9y1eQjxHqcEPTNg4gcHdi2JP7okZvOnc9+oXqnV2JijS3b2K5bVH5OwdtuOLok/+mm/ojg/FglMKvFcI13a4T2XbO76wket+S12bZ/yAFDz3XPRWxOi3q6ry6p4pC1Re/ik97ZvWhB7dEn80SU3dnyz7tOebcPuvTzkr7H3s0DIr4Vka52dOz1OuhkVwFveslaJdaIhSHJHjAyoKquylSrOpFNRp5QWrYtGNChK/o6nAICQABqJEAQAgHGWMtx/Fh/8zbDiLPbg0YTQsMRT/yoZByB9uRGzJk6oJUHi5ci1MYk4pH6bekM+qdul9qxnvzqVSHP4uogP5r8/tAKiCRcj195M1ZVo26n+qKm1m3w/ue9vcQ4ABq5Lvy+cHN/p41cqkGs7vlh/K+FcippFGhJce8qCMa+VAppwaeP62FRNaNO2dQZPqvNs04XPfrz/pnyvIu6VnF3f+tfpof1rd2hXb87VA9b0o/2rvtnWD1L2LD5lg/t2W7bfEfJ9vG/FAiBtvZEfb3glVP33/MY/Ym8r2nJ1G3V8qX/bJsV6vrrypD0j9PeuE5xLyZ4GhA+dPTnUeX7J78sXJktV23Ue0K3Pqhp+XV9bfcaR3UxDGnz764jnQ8By5dSq0ylC6Wo9h41vl+CQ0huH7m13bo32EhxryzVuE+g8vOWmlRCEEKOmnT8utJav8+7g+gGJ+6cvuWoy34xVSUaZUtnOK5f2bSApMceOr9iV5tIG12hcr2GXF5fWL/JSn18PWdiDNfa+FggAAGr+LOSe1nHHx3FnfgoIjwUKWNCmB2kMEQlhrDCgttuXkqB1aEClIgLEuwAAEAN2T/6CUUpdlAKAWNy69YU+Px8yI0QEBCT9UKnmoBETakmmXfO6fLDrugsBQnhmxWE/fDLx2be/PPTe27vNWfy/VPOtt4dWQKlRczpN3BMrI0BIWth5+co3mg59peu26WsTFabIcXs3/5xWaewrFcRr+5csv2zNmgvGxg7jh7xWCu5s+a7bJwfiZQQICcE1Jy6YOKTtWz+cvPTC6kTlPpIjRlXXvwfnH+43r3G9N+oaDu6zMgBgrEij9u11EL/mr1P2h5px8qpYt4z6CkNeCIXkXX36zN9voYAQEv7o8/2Mbxu1HVYncuBBm7shPnXiq2RGKXUxCgBCqGVTz5eXHrNSAITWH45fNnNSxTZvVokcfcqZxSP6tRnz5vMhcHXZ5z1nnUtmCCHxi7aDNn/d0s+Ta8pMNcnxO15se0ASwGJW864lxnDZNvXD1AufRjsZ0gBTmZLy96bIs6WEAYPrByScWr7ywB0koozkFfJrO+qFBpJ67Jv3XlzuMVCkK/POkq8nVGj8asTKQ8cdD9TY+1ngXcoYA6rky0JytI77fk5G5qeg1htlXAQylwwiTLCgw6IOUZfVBQCCQfBIyBijLofqSWV4TmSUqi67e+e1NRsO305VnBamyCy9ZKavMLhnCLCLn37+52WTSbabZLtJSY3+6dudd0DXqV+tEJwpANOUfa1rMMA/X07dcjXN5HKkKg6T/cqWSdMj5/505BZDjDKqOqni9NxNpS6quJgn040AAAXWGNRKB87jE77YGmP2lOC8fWT6p1tvA67Xp3l5Ed1Hcgaq4pRtcVG/HkkDbfveNdwSUhTYsXd1EWKXrotxMciPhu/Vc7bNq2IBEDBgKhMQgH947eIqs6cpdpNqjVnz/ujGnUYMOWhPb4hPnfgqmVGqOu2KygDg4vLIE8lmxWFWHCbFcuPg8RQAQ9lQLcrSChRQ9a02ekjbPeH7/betqarDpDpS47cu+GCPKz2vhQAQA8RUWbbdTUqIvXvX5KR5NUUGwHBw+3ahcG7vsTSMADHKVNmhyg5GKQAAc6myg1HVo0mGGFOurlw48auZY1dctNnTFLtJtqcqqVf2HEsG0IUZhQdr7H0tEAABY/mykHtah/lKR76lr/gsiMwPZJ2o5xAAEyyIKtX5awHAZXYxzwGMUeqiGSlshACAIaCqTBkAqDfOJbgQQggxjJHbpzNKQirU8ANQpMav9S9L3eVQYID8ggkALhtRVnvwjt0To+HAUjUDAP49efyujDBBwChVgCZHr1p8SeOHiAAEIVVAOH3ujAgiAiCcIaEY/kwlDHB574kUipC7BBVUm/nCgWO2zt2LR1TUo8tpkJvkCANCTHUmH1mzPqn56/U7tCt2fEWCSsIbvVkT4Mz6tXEqwxK6b1SLUOYl4F4lZ49771UsAFBVUVJP/7AmocMrER+uXD3u30u79h+L2ns46nDMTeaPRI1Hhlx04qNkAEapTCkDUOKvJsmYYMBUlVXZZkl1AACRMEKIpUunKV6lKgF2ad9Zq/v+EKiqk7luHd8RA60qAzDImQZ023ae15gyRkKq9yoP0V9HJyIREEYIIyIikq1RCGP3jWvGqOpKOhe18RxViV/RyrXLVygTWqZUyapVI5q3CAYALGbKn4/G5sUCEcq3heRsHQ/9OQWe+fGZEEIAGBmKVykCACkX78r3H7wAAE4z1Qk6LULYnT8BAEoVIvn5AYBQvveA8l7O1Pnp06fyVFWxqNUDgM3iFP1FUQTKVMVBXTaquihVMBEAESxqsSoDdueyNVhId4LugSrq9ADUYnZK/qIgAgOqOFWXhTpTE20AetFPQlkyFV4lx5hImEjUdumXtbdfH1RxQJuQ1b/dqdCjfQQoe3879i8T0CNYaMQAmMxcqQe+GNLpYv+RfVp3rla5S+/KXXq/CpB2av3K8d8dvOC+auamk/uiOkEraDUIkKo4mMPunkDgzNvUDFQFNH4GAKfZpWr8RSIApapsU1SL+a6V5kglElHQBAAAImLedcQoK1qvWXWI++qIWUESAgBCCNIySgFjAACkwZIOaPodWqYyVSHBNUZ8PHJsx9J6z17XrQvRl+PUkmWJj9vs92lsXiwQgXuGnA8L8dI6Difd+6MC8PDZKkU50tAI4SIN2tfDAPEnjyRTAHLPkSjLY0TuvxAT9ESkWdwXY6oqW1PtAHBtaYu+W66qBAAYU1WXhbqsWNAIuiAsaDwZY6ZQS5odAAxFDFoDljEQhjBRMcGiRgvI6c5kI0AIe0YXEgCR9AALqKIo1lQrgNa/mFFrsDIMAIAFYFQm+mIGANVmcrL7So6wiAUNVc2X1kaeHzSoWs/6Jdef6dcjFKz7Fx52ANbnrctyVbKPmzDZz8IMGFLSTq//ZdDmVYJfWI261Vs2q/dizzp1nh28Aic3//KyBSAXnfguGWVE6QjrMFHdlWGiZLkoIrdWVVWV01KsAMGBIQYp1gGYEYYBY1XxCzLg7MaAMEKikE27ebjOMaZv2K0S+nd91C23VAgBAiQgTNIbhRESs0wwCNJVGLXo64kRKPHwlinr/z75T9w/1++k2RwNPlvSqmxg9iW2eWts3izQM6nJu4V4ax33ehzPCHdnBR7xltUt5PwVENKVe/udhlqAC3/suSYjzykoy0nZjvcUiBDJWg4GBqA648+ddwCUq98owKY6U1VnKnWZmeIUwpq+N+GNMb0qBBPmKZxRV+KlaDNAePW6wQJCgBBCRBSkoNrjZl87+tOytkaPh0OZ0XuWGhkCxXHj7ysUoELjuoEexWJCEJH0FZvW1wHEX7zuuL/kiGAsaBAizthdC05SKN+4Z9MW3YtB0rYNR6wCQnnushx5IF994VWxGBAh2tKtRkwYM+WFIsSW4kq6cnLX5u+nTu08cFMcQEi9qqWkLBV504mvLoOssuH05mCEEEY5C2EIFMf1ExdUgIr1qvphhAAjRARChKCarUvnNAaE3Gkb93qfvG0U+ZV9vrZwZ9/R6yrJdqIvBRJseKbt6xEIEre8MWbR4i1HTl2+aXaYKdJUqhgIAAjj/DY2HxaYPwvx3Tq+FfoNF+gt33vvRmJtWNXh0z4YUw7gVuSHa267skkI93tzQPbSGCDz2R83pgCqMvmjdhVFlaoKVWXQlHz1i4nvvd77tSrYpeLMhLTt4uI/kwAqvjusbpiAABBCWCrZbHzPIFBiNkbbWcadNNWlAGiMOhFluUcKiCYdm7fTDto6n4+sH+4ugWESUHXc5z1DAc78ceCqcn/JEWCEJSxoQEnctuS4HUqNGtMmDO78/vsNGxYB/f9K9npkDsUijEWiLfHsWz0GvTu4exiiiktxmF02sy4kOABAvXM7Wc1+7/Renfgo2Ydsmf2AMva7tZp8Yu5fFvBv/ln/ygGeu/RicOO+X3TUeSkZS/6B/kUC9RLO2y1fynTPNGuqtezZccuBhDwpkDJVVRgAiKKe2lXFwVSZMVKq05BJdQAARImgfDY2XxaYdwvJtXV843d9C5Zar67+2epeSwFE9C8SUiZYAgC4e+C9QYuOWP2w+H9MVBECZjs4/fM5Nb4Z3mLkge2d/9x9JQEF1mjWuFEogpjNo+ZftyICAOlu3XFs1tR5DaYP7TTsYNXo9YfjzfribTpWLyfad09bvO5O5gpCJSk2EaBIg2Gbfrp2Nmr5qN/iHO65PU3d+tlXS5/55LWuww7WurDxcGyKFNqkba0qBkjZPWvo77dUZsjLzBsTggWNqjjuHvwjMrXhy0VFuLp5eQwCTB5ADQFtB/1RwZEzFe2Mnf3hr5uTaC43U5SEQ5OXdtjwWuMfty3us+30+STZv1T1nu0qGFnMd7OO5XhU4l6dPITnitxaZWlR0777o8GHL7w24VCj05vPJEP4M92blZQcAFrwrMRJhxRtvmr9q9Xh+vieX6xIpHlI+pOIjjX87X9vuKLk6SFYxih12S7+teRCrw+rtF+xKmDpjmtJOKBi3Ua9amsv/J1atFagsaiegJnmp6H5tcA8Wki+W8cpXHn/Aljzk2X5BwmpGhGS+ZNsjb14fvfWjfOX7rmi+AlaETDytjooa/7I6wHAEEaYACYs7cwXA9450b/v291qd3mhEgGw3b72588bZiw+clnWYuzJECNMEMbUdPrzN8acfrPfkG61XnqpGoAz7vTuKXN/XXDCzkQ9YPdsHMmxW979vu68IfVLVakcmFRMvyLeQTHCAiCsJO5/v9+4QwP7DO5S87kXqgC1/3vx8PfLfpuz8YpZG0xElD0W9rUmhyBRwrJA06KX7jC9/GLA6ZX7bjIJEZx3v5mZfNGFVo+49wgSrs2RjMtULANgqqy6zEdnfdgttt/Ylxo27dG1NYBquX1i87KFP67dckuPRG2mj/amE7v3Lsve3oy/s2VJMg7AgAVASL2zZ0xfNXp03wFtar/8DMiJVzd889FyvyFrh5Rw2mSaZTXRPRrI3ZMzKob1aBEon9r3t13w3OPNKjDKvoYKPHeOqP3S92+OcU0cMqh9gwEDG4Aj5ezRQ2P6/rrO2mtvZL/yLSJCl92JU/PR2HxYYJ4tJNfWcTiASjZ56xFXyaiiONIUuwkwEXUBSJDSF5kwpsqqy6IqTixoRF0gEXUZL4ehilO2pzDZRXRGQeOPMPHstCZT1SXoAgSNEWUPfKjiku2pqmwlREO0fpho3DsVpwWYQiSDoPFHREhfceFS7Kmq04ZFjaDxQ0QCxlTZrjrTAGFBFyRIBkCIMao6zbItBSEi6AKIqAfPYkdGFZdiS1UUGyFaQWtERARgVHGqDgulMtEYRa0/ImJmc3xL7l6wpDrSZMVv+B9LPit/cniXaRssBpTn2J9RWbGbFIcZE4lojUgQs19/CSIEIQyAvCqWAaMuu2JPZVQlGqP7LT2MKorTospWIuhEffoNc/cKSG868Vqyp+22FKo4s7adqi7FbqKyjWj8BE1Aer8wqrgUpyMsVHImW0xMj4nAKFVlq2KXm361YuNz4saRo4edUNOXXamguAAABAljct87nIyqisOsylYiGXL2AqOK0yLbUhAWREMRknGpY1RxWmVbMmNM1AUSSQcIMaqoLqtqtzCggi5Q1AZk2lWeG5tHC8y7heTWOg6nANf8MMaY4lTsJkAEkHvVDQNGARgWNILGHwu6XFePIN87M+6xiYLGDxilipPZ0txjjKkKAwVjDRa0CGU6CIxEIvkxSpnqVOxpgAUASlUFASGiHgsaSF8NghABRFTVhRxmYEAkAxABACEiYY0fAcoUWbabEBYAGKMyMEpEPZH0gMUcS0FyuYeBkIAEXbFmr4+qDCmRa6JMEhJIfjrLrWSqyg7KVJRNk4AFiWiNWNAi70/euV+4J2BBUp02xZmmyg6MEaOUUhkTCYt6lKUtuejERxvvvR/gs38RkYih1PClXw4udumDLu/+FMfcbk0q3WFMZ39wnd5yxeVeuMwAmCIrDhMACLoAhvXo/t6fUtUFgBCWIOfVAvlaCoUEEQsaKjtUl5mpTvfT0oyqgDEwxihljKH8NzaPFph3C8m1dRxOwbznB2MiEknHFJkhhBj1rHpDgIiEBImIOixoMcr29mmMCSEaChgT0b2ow10SFjUIE4IFjHHOmT4hBOkQworLxlQnoyogQAQT4kdEAxa12aIhz8FIddmo4mJUAUBYkIigJZIeESldUcQdmlGXjQEwRhFKX8+HMJL0GGFVziwBYZEIGizpiaDJ+pLL+0guhr/99eCXi/tXLGlE8tkPFly2EiPKz8ydIYyJiEUdqApDCBjN5tYYQ8yzAMSrYgEQIRLSGBEiquJgVKXuF/eIWizqiKRH2XrHu058lAwIu5esYELEjLZjRLCgAcZQjoMBI5q08o+YgcMqT93wY6dtp84nK4awim07VC9F7Hun/bQ1NXP5jOcpP/dZCOXhmTjARAAiEEHE2V9BygBjLBBRhzDBOMu7cRAioAGdv4oJVWVKFYwwwgKRtABMVZyYEPeqo3w3Nq8WmGcL8d06DgcK5mkvjImoQ0QESu+JVgnGBGFy79uAESZEayRURVjM+BUjQdAYgdHskWb2s0QtJiKliscDIoyw+0Xt3qoQdYhILP1ghAnCImCc6UcQICwJWn8m6gC5F2tmPo6AMCGSDglZSkAYYREwyeHf7yO5arlp969U0miPPTZ78jfLbolIk79pO0KESAZ39sBrF+D056G8KtajKEErYJFQA2MUgCFAgAWEBYRwjijZq058lYyRIGj9gNKsEwjAhEh64r4kZ01fMMpU+8Vfp3S89eyYPk1a9ezeGgAU8z/Htn288NdfT8pUG5ARTmMiifogAMB5e9oLEwFpjO5p4j3XBYRFrYgxIIyJkMNOBFGPiQiq6n6nBcIEYQEYI6LsbveDNTZPFphnC8mldRwOAKBSTQdzLTxeMEqpzBRFdVlV2YpFnagLwoJUOGfuVHEq9lRKFSLpsaBFCLsX3SiONISJYAgmoqHQvbSSWwjn4cT+3GAeN39HFcVpVp1WRlVMRCLqkSAU3tezYAwEU0WmdhMmdoTdL0+SAWMsGbAgFcKUBrcQzsPK/HCjedwiu/S7CIJAJAORdFnvThe6ySl2v7qHUNnBmMpUdzpEwqKeSHqEC2XAyy2E85C8P+dxC3YFQeMPogEQBiIU8oGNEAJBEpA/SHrGKDAGyJNnR4gUzoCXWwiHx/5P6+AmmC/NznoBAISIBETiquAWwnmY3p9/5o3D4XAKYxTBVcDhcDiFMfbnmR8Oh8MplN6fO38Oh8PhsT+Hw+FwCgM878/hcDiFMvYPLFuHa4HD4XB47M/hcDgc7v05HA6Hw70/h8PhcLj353A4HA73/hwOh8Ph3p/D4XA43PtzOBwOh3t/DofD4XDvz+FwOJxHD7p+x861wOFwODz253A4HA73/hwOh8N5GhH4+505HA6Hx/4cDofDKRyxP/+4C4fD4fDYn8PhcDiFI/bnoT+Hw+Hw2J/D4XA43PtzOBwO5ylFQDz1w+FwODz253A4HA73/hwOh8N5OhGAL/jncDicQuj9ue/ncDicQhn7c/fP4XA4hQ+e9+dwOJxCGfvz0J/D4XB47M/hcDgc7v05HA6H85TCn/XlcDgcHvtzOBwOh3t/DofD4XDvz+FwOJynB77ik8PhcAql9+fP+nI4HE6h9P7c/XM4HE7hg+f9ORwOp1DG/jzy53A4HB77czgcDod7fw6Hw+E8pfA3PXA4HA6P/TkcDofDvT+Hw+Fwnlb4mh8Oh8PhsT+Hw+FwCknszx/15XA4HB77czgcDqdwxP489OdwOBwe+3M4HA6ncMT+BfWOzzqd3uba53A4HDents1/1N6fP+vL4XA4Bc6jd8U888PhcDiFEe79ORwOh3v/xxltxa+2LI49lHPb82a4qIv4Yfvi2ENTR5cTIOvf+Sn24Mjy+vQZWEiXD2MPLb7ydXU/biDe0Xee66UvYg8tjo3sW1PD9VNASKUnrV8ce2jRsqa6h+EbtJXbdXyh9D3jSF9l3k5Pd0f1K+b52VBtXpRn546+xYQHEfvbz6tKOcavplSzGT9/d+PQ4th9079rW292voZ2jpI59/YwAiiQ7YFhaSnxt5PSt4SYZIWBkpbidJgtVvXBiy3Vr/9b5QVuEHnsBMu/8fG3k+JvJye63Hust24nxd9Oun7D5KBcP08+pMiLU7/eMaV70yCSy1GVWlYMwgAA2jK1G+gfSsVZx7Km7lt9e0cY8d3LW/ecO/6v1fR/D/PHmUfvhJ+MZ30ZU5kiMwYAzq3vj33riB0AAGGECSAENPaD5wZMJCIAMK2Lec7JQ7GUphcLAKXGvtd83YhdsbLCFJbXIgohlFJq2jN5XAMGAGLEkG92DgqFEz+2GXzMjAkiAkKEK6kgxghlikwZADD2f5suw7ryFf0ALDlKyjpkKAB+pm51/cGdaTi8bpVQ94hBAIw90NAGxhRqPucZyxgDFQOL6QHg9LzvBkWmqsDQcwMmEhEhkhevlb3kJ2Es87u+3jtSVRSHRXXbnCNZtiXJtiTZnkJlO1WcCi7z/e7lcUe+Gl2aKnarewC4fbcQFDHii0//PrA49tCCY4sGDqzhR7KZh6w43McDAAi1e3/SygiyXZYVd63uPvGv1uGHn2deO7Q49tDimC2fzn+9cjAGEtpmy6HFsev6D3p75K7ti2MPLTgy+6VOVeuOnznt0qHFsVFfLOhbzojhfjI8gc6fqYrLIltTZGuSy3JXllUAAGqWbcmKLL007+fYQ4t3vxEuuvNqVfoeO7Q4dutbTYrVWn5gcezOMQNf7r9h46LYQz+dXvxmv4oat8E/ZSoqoDEiK04L9Rn7eDdjAKlch34r18yJPbQ49tCis6vGTmodIqEiAxd/NrI4APj1nj8v5tuafumlUuqSHVYKAHB7zz8q6Cp0KCsyqqnbvDhA0t5oB3iuC55+bfnaoPXr58UeWhy7Y9rKd1tUNXg8KBEeJwAAIABJREFUnFCk+rhvvrxwaHHcrmk/9a8QhACAgSJnjuVKpd9bO2dBHQCA2h/Nid31diN9ac9P5UguNuO9ZOAT0ic388OoKssAAKDpOvOnUzt/O7Xzt1M7luz7pkUYRlnWSqmqIjNI9/7aMmPmjJ/QthS7eHrj/jhNtaaTfxwzqEx6eochxlSquNymvGFbAoC207svNjdQqmbG/iigxtSZfZ+N8Is9cmT9vuu2wFJdhw4ZVyU9jRjW6uOObMfyLdvvCsXrdVn004je7PT8lWfv6sO7jHp7aHnhPjI8qVNUBAgzYIwqarq/QQghmhK16qwToEKXemVEABArdawfBpC4c/ffNgAA0NWYPKpqyv6oVSfSilRp/tXctzoH46dSRQUzJ1MUj9u/J9T1ZcZSxe5LPmvfLOjWulVbFm6+QktXf3vqqMFlnJcPnI5jAACJ585sPJWqQIb7V6nsnl5bzkTFAAQ0b1BE0JfqEgGQdGJPvJzp/bFfmwkf/TasSb1Q5eqFG7FCsWYvDNj8Q7eqGgCxxLBZY0c3C/Mz34g6nFRpwJsvh7qlZJljWTGf2X7wlBUAwHb+6IbN5++oWZZE+rIZXyU/CbF/QWR+njjXExBSMiD9P+ZASRAwFtOD+SyXFQb+dXsMKgdw8ZdeQ6L+VaUyfT7ZNbLcwBdK/fJtjCPnfMsRvXheYq1pA8Nafj1o8/PRmdMDkG+v/va3C9rLv665lAqBz86fN7duQJVwwhLcIyJx9ruzpl6mZazVO4wpBUk7Bo3/+birWEr97z6rWLRecdG/WJ5keJLiBUxA44clHVNl1eHEbpVjvaALQowmHdmy3Vqre+mmXYtvnRUf2rN1EEDSunXXLHIEAwBwbHv/o4E7TVTcEv3zt59F1B/ZOvBIwtOmoscwK+TdjIuLWnu50gBw5+q+qL+2nU1ZtKl2BXv8mZiEhBlzG7RbMKakeeesme+eZYDxPSkK9e7p4zFQsVyLiqUOl66vAeeBg5ftTTKOEUq3mdw9EODmN69PnnneQYLrfb383T5Vek5qufet+NavVwSQo8f2nbYi3iaUf3HvH33LAQAiWEgfy65bG77+Fqo3/ak+XFg+f/gWq6qtnFG4r6G9YmtT7yVzvPHEeX/nlmFvDzziZAghjBEWmEIpdrkv7QhlvcKjsKoldAAQ8cb+vW9k7A2tHOqHYhws62UCAICmnp7x2e7n57Yu/fqwtxe6MnNDyf9EbTOjrs0mTHmuQd3qVYsiABAEqjjtDAAg4cT1uy4bTUu0AQDEn7uWkiIzescCAEgUxfBnvMkQUSyHDE/U5RdjggFEijAVqMcVIBETibnM8p2jP+1I694r7Pk2IQt31+seBhAXtfJiqoxtlAFA3PYTcQ6bjLDj8NG7EBFSulpo6eCnTkWPX7KOejVjEdIObt6YUq1X2Q7fLugAYIs5eXzd6rgjJ2xM9WPuWwiKgzEReUkRI0fciSOp/cpVbNyrc5EiACd3XDE3zLze+FeqVgEALv65/GS8iyLsOrw0KqXPy0E1m4QG7C0ZCgBXdu++kaio4LpyYF9y33LB4JlYuOuV7UxJn1dSF6OK6vkJgPoa2kWLnPJRMser93/invWlzhSXzQEIsKgTJD/GaGa2J6tPpx7bUU7O7zvjko2pgAiRDOBKNTG4J5BBDNS7e+dP3NP4x1alBw3KqExFxZr/smZ0RyOLP7F3028LdnYaOqIKYqrsqVSVZQpMVRR3+luxuxhQxaGoHqv1LoMzyfTU+TWGABhQxXRi+a6EXr0qdG7UVtu4JMDlP3b+46RUdF9QBT+JAJOpywEYAQBTC5GKCqhjfJux7HD9u31w12ub+3R/vl2DltWLlavbcmzdpo00bz+/Omtu2EeiwnZja7TSp1nV0b0BIH7H32lqw4z8kKy4VPc4dCduVadNVRkAMCqr7vtq7gQRVZnqGT3ZxnJWx4QIozQ948QYk73YjMZALbdTSrfwWvKTEVbxu773t2XmvofDMm7tej9Otsb9fcMJIJQs6bx25ejJa84mvce/3rJFMa/nIERE6krY+OWiw0rW3WKpts92NIJ8eHq7ATMmzt910YHSbZp5AmHJSMT05dVIQzR+iKTPXlWLdxmKsqfPsyFEEJEAYduFP1fGAZTp/uWroQBXf9uRLOOMm7hle3evbNT5Y79ynZoXAYCYUzFXCo2KCq5vfJgxpUUb9Rg/tHu9pMiB/QaWqzfgjT/TAIRaTUtrMWYMAIgo6gD7uAfPLH9HxQCACAApZ/fG08zIX3GlXDh1HQCqdO9Xt4So8SdF6rzSIRhAPr0nJvFqdBwAlG1UNzQISwZN8bpNi95rTTosSB6HSHSYZK5O9Dq033u1RYtisun+JXOyZX6erOAfYW2QqNcDQghhhEXGVG/unDEmp+xfsji24dBS3dauCNtwSd+2U5UgiD/9y0rF21UQCzrATkdM5Lgfuh4YUz69NmpJTHFCWU2tLkN7QVyFTh/XAQDQGCSUeaKEiAulBylYkBBS02esPmT4aYkC4lPn/REmIhE0iuvmqt9vjB5bJpgAnN285TbOmjSuOnzavlYXE4Ij6hUHMO3+dvu/SZbCoqJHBWn98ZQD1sxRYf17ycBd3szYqFFJpVdf7xwKTWvU2XnCEty8jT+A4+CuW07muG0FAMMLX3xW6fjqVz47k8ruDVVZwvFjN6FSaQDXuaOXXaRyxuCjsuufdVO29VjUqey7S2Y/G31HqlCutBbkM8smRyXaHZFzTjw/tV7DeQvGNNxnqda9bZV7zYlgQJ55B8ICYAwU5T60T803Wy/fv+THeQzx2P++tq0lkp6IOixoEMK5TRKs0Z+99uGMnddNpeq90KkKiTk2c+Tn0y/KPsIjHSEaxpwXFn81J9bjvKniTNwxa8jSc7elGu98Nnx4lZgZ8y9TgPJNyvln9BUC9yoYz5DwrDdNl8KrDJeezvVnCAtIkBCoMX9u+BsAgB5edTIBhCx3429+P33b9WKV6xVHiWc2vfPazG3JrFCp6BERGFK6RNGMrUpJKcW7GVeAEz93G/X71su4wXMvjHitTcWUM8umTBq5PUlVkzbNiTxrAQgJL6bTa5E3V0UE540jh9MAAC7svmHOMRjVpPXjh70+78DJ22LFauVKq7f2Lfu6w8A1F50Ayq3FI8ZP2RHnKN9wcJ9qcuR3X0bnc/5/j818O2Ly1+dd/2/JhW1OmGqRC6Ti6u0H5/1gKtudlrtAVUEfKGiMKGMqykBVbC5LEmOqqC+CEXLZUhhTRV0AMFAcaQBI0BoREajiZJQJkg6LeuSORRmosk22JVFKJUMwEXSqbJNtqapiRwgLGqOg9aeqU7GnAUKCxggIKY40xqioMQLCssOEAImGECJKisOiONIQESV9MAC4bMlUdQkaPwBQnVYvMgiajOzQkwtVXYojTXGYsaiVdMFY1ABjVHG4bCn6WkOOrng21HX87S5fb7LoVdku44prjnzRmlz9oNuHP8e7FKcZqEokP0BPs4oeaXe47G7DI5IfkfSeMYLcSxfsqsOcw4wFyQ8LEqUyUIYIYaqqyjamKoLWiAWN4jBT1SVojILWDxMJ3J6dMVW2uSxJDJio82eqqjjSGJWxqBe0flR2qopT1PgRjZGqTtmWApQSrT+RtFR2qU4zZVTQGhHCiiMNGAg6fyxoqWyX7akIkKgPAkRkewpjqqQPRkSQbalMlQWtv6AxUuryDHMfQ5uIWsZU7yUbgohoQORxX+FybseCR575eRrf8IwQAUKwoKGyQ3FZESDGVEREhpCvWysIYSxqiaRnVGGe57wAIQKAgDGquhAgxigwRhnFKA9zJoQxFpmg3CsDQ0/pe7URNtbrN/3V8tUbVwsFSNq0ZneaACRrW5nqSFMcMqMKFrRE1AJCTC1MKvqPYVRRXRaqONKzJgQTEdyPxGQ3Y3eChikyU2WkCoCAAcNERERCmCBMQGGqbEMIg5Zggr0MMQEjhBnC2PP8LcocS0TCok6VbarToso2YBQYI6JWEHUMEBacVHYoTguWHYyqjKp5d82+hjbCCCHJs/+BSi58iZ8nZcUnwkTUMEoxEbK5BcQQYCJoGKOYEMSQ+2+EBUwkpGUqJlRxAQAmIpb0mEiZyS7EECJY0CJGESIMIYxEIukZU5mqIEFCWECYCBqDqjiBMcCIiDpgFCOCMCGC1p3qBsCIECxosPvxdAAiaBDCmIhY0CCM7pXh6XgXAkIYEZGIOiSI6StDGGX+dVtUKwG2K1G/jZ15yYqM6J7TEMJY1BONDolaBEjw1k38dRH5T+JiLEjAKPO4egYACChCCBEJSSiHGbvHCABQBIyqwIAQDRa1RNQijImkZ8CAUkAoSyYTASZY1AIwhAWEEJZ0iEpY0iEiYqoCACICQhghImj8ECJUcTKmIkywoCGiHhENAhA0RgUwoy738QTpESKABYQzxy9ChAgaijAiBDAginMf2ohoEMKCBu4tGWEBeCzhPfNjLaDMT7t8ZH7cHpkBw1jIFmW4XzxCXcDAnShgVPb8jTEwylQVmMoAEGAgBGGCIMe5MjCG0l8e4q4IKAVCMBIAAXVHEMAAsDs+QoARQsxj6yIgDExhqgoIYSICAFVlYAxhATABuI8MT3CYyZh7noQAYywAQoxRSmXVYVGcZowF94wbABSXTbbeBcYEXSARNIDc72hydyVj7KlV0aPtDspU2W2WWcNJt/tjjOY0Y4QREhhQoApjDBhDCHuMFgFQlVIFUQaEYCxA+mT33uHGGMNEACCMKUCpuwTkvv5QlTLF/ZwtwgLGJD2DRKmqAFUZQu4jARAQghAwVfEU7vmbIUIACcBYZr25DG2fJZPHfzJ5LuqRZ36eiEGGEEEC8ZVfQVibdZKQ5TefZ2U5V5N7RZhg8JaAzpaVRiLCmf/FQtYy7yPDkxz7I0REyFiZQylVnKrTosg2AIRELcISZAkcGQJEBCRqs49DhNBTq6JHPRUTNL6TCsS7GQMG7C0BgAXibX8uww2BBCRHxwrEa3YBYSx4f+UyEoQsf5NspWWp1+fQ9l0yT/x4qdFUQLE/5ynDZrWfjr6wLWrfv7duVyhXunXzxjWrVtYbdKpKz124vHbjNlVVn+3WoWb1CEnkt3M5nMfgemOyce/PeQgoipqcmppw+67L5QoKDAwtGmww6BFCjDFTmjn+39uMseLFiwX6+2PMvyjH4TwG3j+Ne38Oh8MpfPAojMPhcLj3f5SkKd3CbZvS8vnTf1Hdwy754hz7M3qzv+G/qe4BhYzsphf99aK/vn1OqdIiu4W3f9ja/g/KzEd1jotzejyjF/0N7R+jLuBwHjfvX1Bfd/G8wcPr5i9svqXv7p99Z5rSLdy2Oe1Bq/Na5n/REKv6wyzaZ7efyfpfVfdAze+52SabE/5oEeDtp1s7HlzUtMhu4e1z9sv/WaZnY+ZdA2u3+eG6nN8uOPHDrKt9dt81WXc83C6gSft+eLNpRLDor9eUa9R7yvrLdvYfdFaWS3U2xbpurBvbopJR9DeW6jB2Tawr10Lkq7Pri/71Z8XID0MkZr2yfvKrjYoH6UX/gJItXv1qz23Fu0i+hHdvyo2fOxm8/5R720G+9dcXrzcpVVQv+ofVG/rLWatXzTPbjW3Th7QpF6IX/QNLpcvJ7BeXjm1fPlQv+uv9q3UYseKSDfJee+bO9K1o711mX7qSE/6a8kqD8CC96F+i/tvzT5hTI7sZxJZzY1QABMqNuQ39c5SWi7r+4w0DQgWzed6N858dX1ANUeGmFTWKwBg99qI+tmW6NyVm2WcHmk7uX1bKbxek3LQWbxQR+JC7QL3xa78+K4JHr76YlpySsHNmD9cfPxy1/AcND+i12a6YE9a2CMyqWOXagj6jD7eafzE14eLPTQ8N77/wquy7EJpyeFMMxjGRR1LYQxDJcnjmr3caf7Q5+rbt7s2dH5Rc3b/P/BjFm0jehXdv9Nbadz6/WMZf69tgvJ8Oafvf6/zmX+UmbDp313rr+Kwax34+4VXzlkPfLIqt8/7Gc4m2uzd2Tiq//s0+P8ZYz8/qN/Z06wXHbtuSbp+Z3er0hH4zLrjyXLt7p2dL2TawdOlXxzby9yo/mA990H3IgTpT911PMd/Y9WX16JWnbQgATi/+/ZqMQL76x+JTgFqtTFDMnorS/7ZHdQt41A6hQPP+Kts+3hquSwtrYP/D/WI1k9JVl2bUpRl11k2m9MPcO8Ns+1LVPmGZPzE7XTXGGhGYZjRaXpiuplAAADlWHt3EbNSllWziWJt7maHWqV/aagSmGYMtw9dSxZeQJqVrMcuYIdZwXVp4Q8f6OM9uOVYe1dBs1Jlbvqckqtnk3JOq9g3LXt3DUJb58rqPOxU36rQVW41YHeMEADBFdi1Wc8yQhuE6IbzhsPVxss+d3psW2VUnGHWCUdcuq6jMfnnVmFYRgYLRWP6F6QdTqO/adYIx7Pl9qXv6hKUX4qNMOXb16CYhRp1QssnwtbHpcoY2mvrlCzUCBWNwjeFr47J3AUvbP3U+DBvfPAD5aJEcu2ZUwyCjLqjle9vSu8At0nN7Uvf0Dcspw/+L7fyf0RVHv9+7Zqhe1AaXb/b658tmt2aRXcPTazGl/32fpj0Q8vXIpQmdp73frqSfoWSH8dO63Fqy/qbvvjWfWvtP5fdGV7684VRaNtmy/638u35MkyCjLrj1sHcahfpWl3/7uet/HNmjTgl/SRNYueu74565vOlSWv5EoklbPnz/bI8f3q+pzWfb6a0/v1hX4dtVnzxXK8yg8SvVcvjcma38vcs5e80PQzrXCPeTNIHPdHrnnQr/bL1sunk8sdqwoe3L+EuSf7k2Q0dWuXM01vlAg/BW5Fcbig0fVd/gXc6ETVNWl/7ql3EdKgVqdcGVO4364ZuWfgCGMm3g9xWXnM6Lv62TupT143l/ALDQnUbNyTvG5W3V98YoSQwgQNhs9zcn6FsEZjkscydZmeBvthu6BQAAO/GJbfx5Yf4ZY2Ks/jWnctEKQNnm0Y49zXSX7hh/aaqMHS3fpT7KBACLutYkbY43Hp+ON05yRTtykzPKT3PyjvG3Nsq4cUoyA2Bs6xjH/ja6f+74fWxULlpykfMhYdo2uO9CadSef5Nurnrx0sQBi264PYrlfJTflJN3Yn9rs3vcuC3JzPfOewnomSXSycB64pOe4893mn8mNTF202vOHRetPmrPPN0dv0R1C/BRJk3cPHrknmbLL9258UvTnWNHb7zrfoOn5cRa06DN8SnHp5fcOGlOti6Qry37dH/Tyf3Lij5axO5uHTNqf5vV/9w597FxR3oXeBPpYaEt36zEuekfL9h9Odl1348P5NK0B8Nx8/idEi2e8bgd/TOtiicevemzWNvFjaeDur34XLegMxsv2HwdxZK3jxu+q8mKi3eiJxv/Om/OqzNOPrbpenDtcJYfkVjq/k9G7Wv5/eSWQfl+rMn2T9Q/RapcGd+kmGDUGat3m7j1lpIZwYR7v2gp5pidc2dfq9ihYnCNF+rHL1q466ZZls3X9yz4Mb5+72r6+5zuDeeln6ZFN5/Up5yPB1Zsl3dcLt6tSdGcXlUo2aWvceMvh4/8uin0je4lHptHGws072/AQ4cLxY2o1VCpxCn5gjXnN9+9fgje818bXbIehszUtC6NdIH4uUmapkZANjXyNB48XChhRG1GSKVOKxdtPssEAxk2UihtQJV7iZVT6S1nnuQsfkK+YANkVTecwoOGCuFG1GaEVN2QveRcbmk88BbQdeWJzR91q+SvL1b/lcEVYnZcsbllqzF0eNvixvBWQ4cUP7H2gu+deVbsmSXrxSEz321d2k8XWOW5SR83NfqsPc9lno88XWrw8LYljCXajBhS6vT6ix456w4b2aG0wVi51+uVU09l6QJm3j91Pgyb0DwAg48WWaM3nCoxaGjrcGOJNiOGPYoukCLe2fD7q/Lykc2LFQko1eaNr/ckyDnqyvjbd9Pydz8psxXUnubSBOowsh2Z2GP8SQjSOE0O6uNc59XtB1CzDpUrd2iJDmy77gTvctrOrTtWfPDI9iWN4S2HDs2hQ183Y2xnf3hj4N4WX46uIeYmUo4usB2f+s6GmlOndQnBeeqdbMeo5sTEsxuvt1t43pKUcGxK+XWDB65MUH33tSmyq04IKlbp2TmBH/48rKKu1Ms/fBY2v2O1YrrgYhV7zCs66fu+pYQ8W2/GTtOeGYuVV99vXwT5EFu1JNr1xYwkQwajrt2mNAAQSnR5PWTd8HHbKr3VIRR7M5gC2Qo09hdQySAAACEQ+dmZOV/fYJPZDQuqGp5jYgaJdvCUGXS/MgkUMwIAIBGJGW/1vK+cNpamAKhwxw4lAz0VBTyKd+XJ8Rvf7fyMn59O8CvR90Ci2fPNWyGwZJDg/tfPlpCm+N6Z13qSb1hCqoZLeao9z1mrRLvRI1JQKT/7bU+/EGMxIwEAJBpEluUbfPK1ZZ/ub5YR+HttkWq+YzeWDPSU+Ui6AMTw9mMW7Tl3x3Xn4rqhRVa9/tLsq75066tpDx6n6fwlZ6qdgr7R1I1f14MUlyZA52P4Kgn7tqfU7h6h10f0rJWy5UCCDymVtASbsVS6YvOgQ5py8PNeHadpPtoyu0coybtIzujZw5eU+GTWc+EPFPdirTGowdhPXqsVotUERPSaOL7i2bXRNs9sb8utqO4BOSe1W+xySsLFP95O/nLI4uuOmF8GTIh/c/PZBFtywqW1b8VPGrAwRvZ9ug9lxf4+ZVel8YOr+c5bEUMRrT3RonpKzjIDJuFdXisfc7vB4JZFHqNF9rggV6IoLM4EgEAxMase+Yv3WQ+E3N/rdP9XQmX82PmE7McIUFQHnjJTmUWHjILvMiEvy49yyukpU0RheohPr8ik5HEx0/+x2Y58Nmpt+Wkn4s1y2s1fG/mnr3hQUuNMCiBQTPEWXTFPe73uRO7XGFGF5rpiRgou43f3fIIrT7Xf2y9eyxSMRXVmj0ipcRZdqFHIpQtY2oGpP8Kw8S0CUGYX3NMi0T9Mb4lPL/NRdEHmhvUl6vee+O4z17b/4yAilu0KAwSq9bZFzb915XElk650/dD4/Vc8E2Tblb3xxRqW1nlfoJN6bN2ZOxueDxP8wrpvvPP3hmMpDHmTU/QP06fdTPGhw3smFDfWvN3muVVV5h5ZMay6Ad9PpKzCO6/uPpu4Z3jFQJ3g57lR1O7PtDy3XVuidilNlp9YHlSKxMCKHUeNKhe98WLyhU0Xyg0Z3qFcoCQFVugwclSFi5suOfK5HtHx97xZNzt/+EJxwfdZ+kptysVtPZ5Mc5QDAELxV6Ossb+0Mz4s23gYW4Fmfqx0/jzltoUd+NEVX0+sps9VJwTCJHYomnl8lx6/3hPmj3Puj2MuE9001XnYDEhPetakC+cqty1s/zxXbE2hij7/zt+kdAmzbjL5kLOuWFUPSI971aWLflTuWNi+ea5z1v/e81CXXSaGoACt62bUrBnHLBmynZ0/b/dtS8KBH+fH132+qt7nTgSApPAqATd2nLxLczF1fc3Xezrnj5u5P87qMl3eNPXzw2aftSMARPzDpNhD0Sm5llmlZ83YhXP33Lbc2j9vXmzNXu5+8d4F8rVln+xv9kn/cmLWLrinRfqqverGL/px3x3LrX3z5j6KLkiLGtXn3V+izsSlOl3JFzfP/PZ8eLNy/iVqBV5c/uc/VlvcnjmzT1vva12RXcLaZbWuvLogsWzPV8O2vv/17nirLT5qxvtbir/2bBnR64nmsxsuVpt+2eRQrA7HuenVL23426rxJqe++vMNby38fnu8KXb3nHnnbLmYn+nEjJ4tR115JXL/98+X1uRBpGzCB/Tc6lCs7u322haBrVbdjuoRkOe2SxV6dbf9MGnZ2SSHnHoxcur0KzWer673ps+0nWNenbji4LU0p+JIPLvh6+nnSzQv71+qbkj0nDnbr6fJijlm59zvo0Pql9bk1h332A9N2vbFKr8hY5v441y6jIT3nNAxeuygOXuvW2Vn0qW/78j/V9j5VGd+/HCbJGfNEHPvKGHGt0IwAjApnbVphlDbvlT15dA0g9b6Z8YNGQMZOhAtbWf217l3ogaf6adVVAZUMQeHWxeCEGEAwKjbd9rme+wVQsz99pAZ34lFca5l5lnO1nedNUPMvXeQb2YKIRgAoc7faptG2cuHWCYlC1UewU18Y5OJH9Xa0qtkkdDW88QetTJq9KvS+u6EmiEle+9o9s3Mbp6kqtedAKCrNXJSo509wvy17f40AZgiO2sFQ+jz+1L3vBwqGNw7wdDgs8hpFf8cUCUgOLzDQmgTYfBdOwAY6g0dGLa0XVF/ne8ycbFu333XfE/vCiGl+u1pNeO7HkV92l2WpT7ZuuCeFqGQzt/Oahr1XPmQiEnJ7R5JFzQe+ZJu24QOVcIMwcWbTTzZ/LuVYyv7Vx/6ea/YMVVDw9os1L9Qx5h7Ecx8Zuu/lbpU1ud+h99rv4gVh6yY2WDngEoBxSq9vrfR7F/fruj95qP90qYTxg6tSgjumLNVZ+OJjZeYNzlRcMcZs9sc6ls5tNYUR5fqRuzzfqx5z6QPo5JS9n3auqhRKxi0gkHb6Jd/sReRvAuf99UNXk+XIkYvG6+b36u0X1BY/YlXnl34Ux/vOSRj45F9dH+OalwiQBtSpv2UK13mrxlb2Vh93Irp1XcOqldMF1i0+tCoGtNWjK+qyXvtAPKVZV8dqTdhQMX7vD8UB3X4IfLLMpsH1gg1Gso9t6Hmh580MTy+T3shq0MBTm7mqHSu7BxxydA94DGULbJz5e9GXMqeuPS680lBvjqnfbeznxyZ1yaL93+iW5S9dXM7dvt70uEf2wU+bm9WV+MXtWu5+7O/l7X042O+sFBg3/YyaJ+kZ/D3hT6gtFaHPzey/NxXrTB8z8WnuHXDdj1mrTPv/+zbWy+NaGP77aebVUbdZ1LCecpu6wdDAAAgAElEQVS8f0F98cbmfELcoknp/IxzxOXHMvZHni+2Zv9ciredTzRPX4seH/yqdzZM6Vqib9ozfb5d+1wY/8pOYQLZnDzzw+FwOIUO/oZnDofDKYwIfDLN4XA4hdH7F8THhDkcDodTwPDMD4fD4RTO2J+H/hwOh1MIY//H5eNTfMvLZorsVKztnyauCr5xc+LbE/2mh3xhkjsWs240Fe6LdUDPv+7s7PHonjxgpp1vVWv5/TWZx0kAAOrdvbP6NynvT7SSWKL+i5+uu2TN5V2npsiOxdo+iMWaIjtKRCsRrZTl9Myd9/zk8/Q8HJxXQ7BeXvdxn/phBoloDcUb9522y/3eUNf1NaObl9ERra5E69Frbrh8CJ+Bcn1Re9195Lm3TAA5fuPETuWDJKLVl2g1YvlVR/7kzOvpXoX31XbvyLe2ff5y3VCDRLRh9d6cd9yUEtlRQ5rMvqYAACgxsxtoc/bOQ+qjB4j9+ZDm+Lbka0vTX7jGAeX6z31e/i149LrLZnPa7b2zerpWf3/U/B9UFNDzL5fqSFzXMsf3iAJbrU5UHS73lmsQkO3I+x2cF8yHZvx8u8nkzZfv2k1xuz4stfqV3j9ek+Wr8/qMOtjyp39Md//5pfmBoa/+eEX2JTwAgHprzahPLpYNyO3bXt7KVONXvTlgfbmpB2/bUm78+aZ5Sv/vLrjyLqcjz6d7Fd57271ffNIOTOg8eH+dafvj0iz/7vmy5rkVp20AAKcW/X7VBeC6snrRSUDpvZO4rmVmTz3KqO4xyPyAna58x1LBaNLqzc9+paZQQADmy/KkDmlayVSmhf33GPf8VO4ombRFbXtTlZeKmrSS1edc1SR3LGIeNdhSVDIVrW9fF5e+s6jliym2KkaTNsA89A/qfrutGi+PapimldKaD7HXC7E+7vPfLFFJpqimyI56EuwX1GjIFyMbh9Z8/5gdAIFqvrxuUodwraQp02L47zFO5Gnv+lENA7VSUPMho+qFeAphKfu/7lkhQCLBtd9ced2V4zseafu+nAfDP2gRgE2RHYvUHDW4YVGJFK0/dF2c7Km9aKMvpjxfxUi0ATWG/hGn+q7oadhs5yOjK437oHftML2kDa7Y/PUvl89p6+9N2+7OKvrc3tQ9LxXN3mUP+oLnfL0P0uuRXvsa1Lt/vduwqERC6r29Jlb2WaZ/+wWR80f3qFvSX9IGVe7x7riIy39eMl3fsPRWl68/6FDSz1iyw/tfd/l3yfqbsk8Z2N0t7084++zs92tpc/kYvbcyTdHro58Z/9FLVYM0+qJ1XvtijHb9uuuuPMuZlOfTvSrQa5le34dKEzZ9vrr0179O6FgpWKsrUrnTmDkzWvsBGMq0hd+XX3K6Li5bK3Up5/f4vOOzwCpnxz62jjsvLo72N/1r6O+SL9gA0pS3eruk0X6JJv8/XqLj+7uuqwCB4nY5wHlX3zJQWHM3wCkbegT6LtZCdxi1Z5P9V7VR3hkjJ7m1a1bXmKTtt/3//hZvmOg65wQAtm2cfWdT/bVk4+f+SrT5sfc9gT23y6rz7rqWOdoulHj5ixcTF8+x9HkJ1v56zgGQtu2t3guk0XsTTbF/vHRpfP9F11UASN42btjOpiuvJZ//3H+7p72Qtm/8qz8Vm3ridvyfL0Z/8M6GOyzrVw2uLf1kf/NP+5eT3IqN3mGccjY5blWbPe+M2ZKu2ONrTIO33079+9sSGybOPuf0UdHTsenKtyhxdtpHC3b9k+zKGLVetZ3ZWa3W3FWd8s7cLDbvXty8p1840UjEWKpe70833nDlx/376mtLdJT/lLPJcb+33Tdm9Ka7efJGNOn4n9eCaheHm8fulGxZ2eDeb6jcumTikZtOX9eu1H2TR+5p9cOnrYJy83lO72V6vkGeXrIj7mScu/n/a+88w6K41gB8Zivbl94WFbCiYsHeQNQYTWJPtScxNpT0m2ZN1GiK3ZhritGYGwsq2AsgikaNHezS3KUKbO+7M/cHi1JmllkRWfR7H548cThtzpz99syZ4byapCF+sfs0TtvJdT07quvcPch+a7xz9E7wK318a86pWSEvjxcl/n727OaDAe+8ImO6zf7+jXYfbcA370Wz1nBjmmMenowx8z36ihCSsHZeFSx4mSHmY90ncFrlWO8aXCxWwJw9hxUowqLjOMEXrQ4BkIAZF88KEWBtRnLaqu0FZoQM9oTzjBnvs4JF2IDZnI6CJrscwW0e8+KQUHH4i8MG+GuzyiwISYbvvHpowcutxHy/7hOmt8o5dteAkCEj4XzwjPcHB4sCB8ye6Thfw7VtJ/zi541p5RXQ+91ZLTL2VDHAEupTSzeg2Z/1r9xrUxA5e05soCgwOm5G8MWEyo6NiosfEiIQtRk5ua36coGZoqJnA07bD/btnGT7a2YvX5FA1m/SitRCK3lvN8wjn2Mmu9ZoNxnVdw580Sbt7UHxqSqqpw6qtHE+TC774U/svkKKa13lssouJdzQ03gCkLF2wtsno7/9oCPHqLZwpTwGMpz9dPgnF5An16w24uTZdP8unZ0YuWL5MB/nWwnhZGV6dBjd8e73y/beUVlMpVe2LVxxoVxrwmm30+sxstdVJunilV1XYuRXON2QOmlIRc+rEULMoJcm+e6eHX+o5bQX/N3nLcvGW/mx4nk6RvuAmscLEk1DwtVctpobYDhVgsyEi8WysBApwhBiSxgiA6GzVVgXsAAxwhBicBAbRzhCmI0oMmDNKlNKWU12SoqxhTwPFoMt5Hkw7GY7QhiyFiR+NCRcwGUzuQFvnCrRmgmE2bRFBlEzKQtDiC2ROc7Xps5XXPywFZfLZvKavf1PfrHW/kixsnVBer9Fk8Me+kNY0pDK7CJDUWXHCgPETAwhBkfAxq04oqjoWfnhBA3++Le02+VW1d09cd7bx49dl2Ul6+0GvVtnCYM6jV34+wKfAxsv6yiSSaMTSu0W68OflBECimtd9bIaS3R257XjytNfvxy7jLvg8MaR/iwGT8Ixq404xu/13cHvuiOlmSvhka4mmK+vnblFtnj1uCBmXdo0sjLZQa//+uuI2x939+VJWk061uyVjn6+IqbDG3P8QcoIidN2Ml3NTuPcye0uAh8PY6nO7ii5dE+01PErdsCwyWHZxT2nR3sx4J0fhNiM5kL8elH1g3rb/DnWsOWiEoPEpOD3qr4NKIYQXqdO1kbI1QghZFPjWh4mpJposLAAPpGnRAghmwpXPUs73enPzp+zO2z5pRKDzaTY0ktMIIQQSxTA1+QpbQghm0rhOF+WRNY8eku+zREjLMmVz50cE//P+1fZZN+mkqttCCGbOl/L86PuWLKKnrn3pPnB3d/44uM22UfvlJL1tksj9rHAGCwG4UrZVNe6ymXV8QNEznZ8N+fteK//iO3tNp7fNauDAEPIo1l3P8XJu477Bf3dNIVvz+akk2JTVuq1B6kzwvlsJsdndJoqbawPxSsuFGWyg19ZdjRbY7VblFe+a32ztNXQVnza7UQuZadbJgm8VoNC5Qf+LSe5r2AFTUo1FP0xSOxOf1/VeNGfz5gyAv30gTlNTpjV+L6l5jNahHBksCKBJ+ZhwY+uNJ/XVUnPxPy5eHpmdf262jrEt/proHr7T+tthTri5AaHhZGidua4HvjGVTaFGk9ea8kwPEOhCbcaKi2MR1f+4OhDfsdxPQo2rjqmUMuT127IqLzrHz9Q8e3Xe+6qzdrclNUzPzqhdbzqs2VBer9F1V/10V/7af2JQl3RyQ0/53cdS92xZBU9G2iSZ7320a/Hr8pVZnP5rf0//ng9oF8oh6y3HSNW7M+Vp2cqq4/YpCG+j/VunyYlfvKCnRfkWotFnXtibfzXBbFTO9NfWKO61lUva9TY9lSXFVf/+/0rveOyJuxPXz+2mcNwxW4xalLgoU+XJyv0ekXyd58eCp48qjmbYtnq4Y1I6Z5oaXRCKcUrLqRlGlM/mrnutEJvMRRf2/3VWx9kjZo3IpBB1p+k7dTQzk7/3ElhBo747IXMD95dk5artZof3Lpa7N6vSjfiU1+sxxLBilbWSW00Ij/dz4jZVoiQmDlvPvPAKxqxj34Dh9VZWCW9kBk3DdsyUMPj6Ks9panx2ETIGFhmivDUjD3GWrma7cukMGkysKEreYPOGMJ8dIvNrI4ihLn5ooMmacijeROTw658VIVq/Vfce978TgdeCRb7RG/gvOzoQ4bX0JXrB515I8wncrF5WEcRA8MQwsT9V2x7u3RBbx++d/dPM7pO6CpECCPU6Us3oNmfD5BU6xNhxMCy/0R4Bo891mfl6peoO5a0omfiR9wr/nXeoU+GtPTli/z7fHqp79qdH7b1IettR49FxU0L3DLQh8d5+FyR0Fw7lN9qeFuB69daFDWlX+G6cW28BTzfzu/sly05sGGYN5P+Sz+k1xohYfvY8v9EeAaPO95v1aph3lTWWl3aF58nlypPLhjg48FmcthMDrvnbwWMlrP+t6Zn6uRwsWf4xBO912+b2ZJNNVDpvr3EJilTFDWp679xHcVCSfOXlt4d9EfKd9FVBieqq52aznSzkzae/NxJ18gYXkPXHVrWfP87Hbz5/JBRiZHzFvYWOX15q1Gf+mJWG/7szM7U1sHh5rlZwhGuvDlrV1gG9LMtyeTHPB9OO7ti04B+J5ZkbiM/X2vW2oHDri7+d1NsVbdi4uDw1XOzUlzsWKcVPYdYs9YNGnZ5/vlfBrud2RF4Dmk0syObpWqgktO8H6fkIVKL1SZ9li+19tSC7wtfnxNr+PPX++3mtqW6x2eHz0m/8zQqeg5hh8edvAPdADzv0b9BQq1Lc3+cOPudftyXNnVrzpq9vKmtn/XZmKDjMP43LwS8oW795pq9YwIYTb8iAADqwbO18gMAAADQnPuDKRsAAOA5BG7LAQAAIPoDAAAAzwdgdQcAAIC5PwAAAPC8RP9G/hNWa6y3LklDa0foG2t0MqaKyaKZ/rHb0GAVNWY/J8YyGUwmg8mMrXlSmsRY79gn3aUNUKYL1ZlurHlJxmQwWbHPzhWEH/h54js8N3IDJOzUcuFIOnvs6e0rf8AnnpHY7PTSP/ZW6g1cUSP188hUHMeVe2KkVc704a/KUx7/TNWJg7xik9RPtMyHepnkd9r0XZ1tdfUKXlj5Q9bEM0qbPeWJXUF14iAGg1nzp9aJPxnzhf5OwvxXu/hzGAwmN7Db68tSimyPfmvL/e9AD+dV46Unf5zYqxmfwWSw/LuMW5Bw20A0TJMsuTvn9g1mM5jsoP5zd+ZZqnZUlRYShpyDy6f2bcZjMJgeQTXPqMZP7TIRsimSPhscKmQwmJygfrO2ZZloXiZHG+qV3aXGI2vh4cXjOvlxGAymT9cp6y9olImDmIzua7LtCGHIlrOmG5NkIDXYWHpGvL42IlfP6NUWYzwzFQHOsWZvnn+q/+IpYa56JW3lufqgXm0lT/IKSkam4Dju+AaN2aOs+EfKyIaw8WnPfPdbcZ+Fh3JUJmPRifkhO98Y+1OWY78we8GOufNvOpUj2nJ/efW1rV7v78vWmQ0lZ9a8Ytm55qy2IZpkvbf+9VmnozdnazTZm/unz3xzwz1rRUdVzjMqs5/+9md51Jf7szUmY+GJReF7x4/dkEW+AxpZmfb8v6ZM3R227N8yoz7/wDvab8avpFAzIoQeXZ3KC1TP7C40ntCk/2fwO6e7rjhdYtA/SF8amfm/S3qEELq0afs9C0KWe9s3XUJYZRVPYSw5B28slOYYVI5QOUKaKt2N2/W2rbM1Mm45YqmGL7GU2qqmrJJeaY4RqWe+rRahclEn3Y48pxWRpTTnmt/rpERIGTVFFyGqLLN2Re6CVXVz139i/BBiBfSaue2e0TF6RO1nvh0lQkjUafqOPDPlQZLIhePKPTGOURBT/RLc2jq7n4yLEKvZ8CWnSm3UtVcbSjF7lJRlmnP/ntFVihCSdp3xd25lOyXdFiwcFcZFiBfxzvb7lmrna1cem9qy98q7ZsozMuduf6+TCCFR1JQZEaIatZO04QmN21p9KCX5MNvKTn4zvAUXIX77KVuzTPWp0F60ta/XC0kVxZYkvhnY7L1dv0VLqU9Nte9F775bi+w1DpM0yclQodOkktvfdpJNTFZXHFQfnyDrtPy2mayXamQv/rOv94v7VGS/M5OVWXpohF/PTXKb45OQt7F/t69vmGhcHUcp9ctOv/G2/C2DgoZuK7DVKFPYfHD7Tl9cMRovf9Gly/AwEWn0bwQab4IrYafgUlwpqDZHQMT5r3TvX2dtviUxFAumWGw39FVTsvYopTgudHxJ6uxHRbybavGuWNuceGuZk83Oa6ckiP1zDWmxgny16Bux7YauRpOqV+QOqA9PGbeJ88EplU6x99XbH0/clFOxdb7u+lHRNzfV+btiT8yJP+joBNKDVPPZGtM0pD//1cvvXx+6+ZbGUHxoiuX4DT1F7Y+yV4zglJESijLxB0lxcSn9/ydXy//XLzkuLulBxR+Yay/sVE9LKVVfXynb8/m6DBP1xL/2GRGl++fOSYvdla++8Y34WOUVJGvS04fQpH08/he/ZVdLCw6Py/zPnL0lj/8H9XjZ+QPZXp2DuQgRqrR5c07ErP0mxtPZq3oe4f1lGUu//Dn5drmFqKtJNIcKaZOIvH+LZdFtHNtMC9pEy0rO55nqujHT5hxbt+5eqyGteWS/NpGXiSGs6t+lmuSX5eaKz0VirFdsYtUtmrUnXvdlMBgMj8CuYxck5ZorlgTrlZ1u4w23j9wOHtHXt2ZUZYW8PF6057d/zvx+IPCdl2VMt4kqROOissRINXtVlf/UW6c1Vy/MpJFSZYkRqldlEQRBWLNNXWW6EzrqKmqn1FrHB6tXZRMEQVizjJHC6iVXrcgNKd0+wH/EYTVBqPbGCCNXZVkJgrBmr+oqm3hCR3HQcWp7Y6QxNU+txkH96WnNIxZmmuuunX6Z2tS3grs6mpS1smvw+FQtQaj2xoiifr5vIwgCL9nW12vIvkeF4KrjU1v2XnXPUlla7TPSpo4P7roq21FmpLBKdaRNemIjtnrhVf/58P91p6Y2j1qdbSUIwl7wex/ZGynax6sM111dOcgr8M3dRTaC0J79uLXfK3/l2+o8QUv+0eWT+oWJEGIH9njr2+MFFvImORkqdJqkShrsFZ1QThD6fz584aOzioRor8FJKqejoiLoiF/ceI9igJGWWZa/ZbB361m7binNxgeXf58chthDnFVEELhVm3955+f9vZpNS1Za65cdp9/4fUO8o3eVV00fszdvb4w0ZlfGpgFB7SJajku8t5tkwDQSbra4bSVydVj7QHqJWViIJ0IIsaSYyEBobK6ktBPFRixEihBCLE+GlIXcHqti74cxzXkYhmE+r58s0ZoqpmksaYgnCyHEkspEhiJHJ5AepFtPea7Op30gh1btNLFrS4wiR5M8Q0TGYm2F8YQp8hczEUIYR8DGrfaqE/95p/p/XWXFv/YZ2bXFRlGI1FGme11Bm0qhuBgfxsYwjBk09Ux+scb+OLP+8vTFQ6OXchcd3TTKn2m+vmr6H7Jv1rwaVPfUkR005NM/TmVp7PqcxLk+f78+au1dI0WTXBsq1ZvE4Ek4ZpURR/xePxz5/qHZ0cmzk1QCt6juHphdvvCdX3NI6yItkx30xubfRt76qLMnlxc64UjzEZF+vhX2XCQZmapMrX2Hh7GEQZ3HLf5joc++jReN9cuuo914psDHw/hAZ3ekV+19eAfMChw+NTy7qOf0GG83CrluFv3ZWAshcb2Q7uNZuaris0ZoeZiI6UpKFhbIJxQVB5VEExAQ6s9+NSsh/PsrSgtuL9ra+6FB0KaSqyo0ivlankMoTX4QIYQwJlY1ypJeAq8WwtLrhRZatVe+aVOHY5Ap8uNpHU1SKrQ8f2cXCxHqk0vWobgvB1T3StY4I5Y4kK9TVJbZeFeQyWZYDRYCIWTXVn6rsaQhLWK2FeOVM8nHWIAy526f1vulvyM2XdgT10GAIWS6l3z1Qcp7oWwMw6SjTqhOjJIOTKzDEcbgB3d/66tP2mYdvWOlaBLlUKHRJI/mPfwVaXcqLYx30hR+FGbHKoOFLWk57P348MykG6TeN4oy2cEjViTnGgmC0F77sc3N0tZDW9PYORxjOvyX9cxOt/G81oPD5PvPk5sdp5w0lf05GMyO1PCZb48i1sWbTsgJs9qe+I3ptJN3FfT29eushTo8bb1ZEcV5JKVTWwd6ahPVTlPymWOi8I3rbUU6PHWd6Zre7aM/bnloEDzyw/fnHhoE9dfWr0st1BWlrd+oeGjmIz2IEOIERkhzj1wodRb/+Z3eHmVaF//jCbnerL6T+M3i01rq2hFCTHEA9/6pDKXTMiNGd7r/09oThbrCE+s23O80KoLv9FWfGhN/0jPitx8Tpdi4/mSRrjB13bpGu4Lc4C6eN7ck3dUZFMlr1la84IEEkRNj5UsX7b6jNmtzkldO/zD14TBWJw70rCtq4+rzK17uPvPepENnNo6rVAlKRqbWXH1KJf9S0RyfPvbDTceu3leZzeW3kr7/ITOwX6g3RZOohgqdJrFbjJ4ceODjb48r9HrF8W8/Phg8ZXQL0he0NMmzXv9sS3q2ymwzlmQkLFuRGdw/jPR7grRMY8r709emK/QWQ/HVhC9fm3tv9IKRlWrG6v2pSY6bMH/7v3KtxaLOSV0dtzh/0NQu9npmp914ZuCoL4ZmzH1n1YlcrdX84Ka7mx1RY674V3/BpmL9C9fb/pihCWKXI4Zq6NfWMjv1ur9IPX2SWoDKBR31f+c5fUJAltKSZ54WqURI2WWyvr3I/df9DZnrRoeyEWKFDPviqyhJzF5VxdJ5xPRJnQUICTq++3eexREaah+sPOmcza81xxBCldmrvyFTeQlu/jGjTxAbIUbw0K9PltkpanfMIjX/zOvriRDCnJVpzvnftM4ShJCk87T/5ZgpV8xrrPg/DHZkZ2TJ2z4tUoiQoMvkGe1FjbTuT1jlO96O4CHECR21cGG3yp6xq86vfDVCjBCSdpmy8ZLaMYxx9YnprXqsuG2pq4qaH9NumxQ26jbUXJm/ueOLUR29MYQQkrQcNHfbbQNO2iRnQ4Vek8zZf8/q5cdAiOHfe/b2HDPFAMD1dxMXjenohSGEGN4RL322O8dEWVftMu3qyxsndhAihNj+nccuOig3U3WFXXVx47t9grkIISRoET3zt2savL7ZXWo8rr+1NS66OQ8hxPDp8saKtAdlNB4UNRKIaKLQj9Hu/xT3iUUitxhS9cJyb1XvllOPq/Bn5oyqn93qvi2nHFXi7jx+gOeGRntYhmHK+hdyQqp84ilr3Rt5IuDpPfgJjz9z9xk+u7npd+EiA25Co0X/+kZVtXVgC9P7uaK6n6fRTwkAAPDcgBEEAb0AAADwvAGb2QAAAED0BwAAACD6AwAAABD9AQAAAIj+AAAAAET/x0FtHYgpMUyJYdq6tiuhyO7pNGOdCVDD5G3YTqOxT8Cz3QAAAJp89JewUwlPQiWsvrm8eyBhpyrd8u8DKLYkbDAIdfLbrfqsfmQyetoNcLOvXgYWtSbbhhBCtuw1URijYb4I1YkDsQqqlE96kArTvT+n9/RjYhjTr+eMbVnmen+jE/rbCfPGdvZjYRjGCej62rLkIhtCCFlyd8zpE8jCMFZg3zk7cy3U7aydsp4VUUGakmb2+vc8shYcXjwm0peFYZh3l0nrL6iVtYYNOY0wqYKVH8DJSCbbcO355tJ/KxV9/73UgN/xjm0Y6jpIEf9urX7tw5sjExR6vXzXiOsfvLb6tqWeTdKeWfFrcd9Fh3PVZlNx2oKQHa+PqTA7vjbzdPQfOVptzh/902e8seGelbydZCnrWRHFkCVLSTt7fXue0KR/Oujt9KjvzjwwGkpPL+uU8ZfD7Fh12GCk+/w0xqTK3bbrUd8y/ydGiVB5QC/9X1mVaVjlfI6y87vG6VHKNh9b9ZV7t82YqhahcmFktb3bKn2N+ojKvdtIyqx777nKVqksVcSQ+p33Kzf3UlhmdlEipOz+rr6DuOH3EXq0eVb1HaNYiM8Rd3736+lRPm0+Pq8nCIKwqW8lPLQw/pVlqmzw7pldRAiJu78b10FcuRlZ+akllba/P7NrOCtqKVZqNEC1t6oXcOd9xx5hpGWS1t70dlWqUPRdNZmuOBR9e1WEJW/7Q2nl9ocb7Um6LVxUKa3cIbc+zU2cLLeWRoZOP62vtPVMD41cdstC4Ibbfz4Udi5NL7NTbslXt+Gl+M++Xi/se3BneSfZxBRNxUFN8gRZpxV3LGTttFCnrGdFNc+dLKXexdofu+ftBVsHBQ39q9BOY9iA3YVkwX3yWAvnQ7FaL018zf7RBLPDosBivLmM8+AXk+5NDkqwZBgRQgjp7MfEvFsaye5B1rlzrKUVvsY5hrRYQYFGvERsddj+qMqkvx6lsx8V8W5pJAmx1ri5DjHkoXj98b4CuUa8VGzN1DZ8z1BNQFjBby579cEv63RvvoYSNmcYEVIfnjz2v5wP09X6/MTXbn80YVOODSGi/FD8zON9t8s1t5aKjzoaTGjSPnprk9+318oKj7ya+WlcdQFhjYk/aQN014+KltzSFCTEnoibWyFcJCuTtPamCCvklQmiPb/+c+a3A4HvviJjIoQ/SJo9O6X/3wqN4u9+ybNnP5JW7lC9l1qmubFKtueztRmmp9hI0/0LJQG9Qx17EHuE9goouXDfpD//5Uvx11/847bWWHJ4qvnYDX3Va1oRg2hOP/Gy8/srzI7ni2UxjyyMMbKSc+RmRxPtlK5WVGPZirQiFe3s9cRw+/Dt4JFkZseaw+Z5X/enCL57MoWLX2GI+ViPSdxW2dY7FRYFLiN2GCtUzBw+nOWvwUsr7mMFzDlz2UEixsA5HrKLlkw9Qnp7wkXGzDnsQBFjUDw3UuC0TPpUqSj4giXTgIN3q64AABsKSURBVJDBvvMcY9YHbJmIERPn4aioUeA2jx02JFQcPnz4AH9NVqkFIclLezIPL36llZjv12PS9FbZx+4YEDJk7DwXPOuDITJRYEzcLEeDDde2pvh9MH9sa6+APu/NbnFtz3VDlRX/2ooVkp6JnDN3UJAocOCcmcEXEjINFGWS1t40w3/wy5N9d82KO9hq+lB/BkLIcH335Waz5g4KFgUPip/V7HJlHwqi4j94oZlA1Hb05Haqy/nmp9hG3KS2cEQejo82w0PMsahNuqu/7ubMWfdJbHOhh2e7cQsX9hM95mKB/tqaNyanxaz4MJJjVFu4Uh4DGc5+NPTjf5En16w2khqMcdopG6Ii22PU/ljYdSVGvkOR43haUPHVUmvYQPQnRbHXENNciWFKzEd/soRwGAQxJOBjLAYS8DGGnXDM3av6Go2E1k7payQv04WPfC0xpI0oNGDNKg82plYQ4wj4HiwGR8D3YNjNNoTILYw2TaFB1KzS4edosBMBIc0V/9peQNIySWtvouG/hqLPVWnl0/hMe0g4Fq0Jr/wu0Fg4Yg87qbDT5S+WxzQ7uuqApF9RjdcQSFOyaGevJ2B2dLnHMPTow6G3fTXLGv69WGnxtBcJeoud5qzia9TxMTGLwtfoUpl1VVRVDJlXXr0iN4HUwsgSB/I1eeXVPYiUAkJ6E39EKlwkK5O09qYa/qsr+lyTVj6d28GQKN+is7mOhRVT7rkiv27NRGTCzodTiDrdnAjVy+zomgPySVckfQwD5WMBZkfX4GARUvzIBcIR/3FksCKBJ+ZhwY/8YKpmECQJc1V8jd04Hah8jU7KpPleP5kY8tWe+IaVVrkaP77GdM3gTuGJ1MLI7/hqz4INK4/K1fLja9Y7GkwlIKT/qk9tLyBpmaS1Pxu4JK1ET+UPJjhho98QJ3y+9nSR0VCUvubz3dI3R4dKyISdjvkXDTdnPc2O9FO6WlGN/iRNyaedvb4zWTA7ukjOZl1z7OE7NnjmOm0ouxyxVMO+MERJNHtVle8F5Vb5r6rynZ/JagEqF0bqd9x34mskK9O59qvqcQoxpFVhntFZiZCyx3R9pEST+PTe+amgUqMojdmbW+W/KkoLo1WRMKOzECFxj+nxkZLYREoBIZlbkaDw0pF5AUmlhqS1N22TWuU/aUsrH9vs6EyZSY7x9h/vdvNGCGE+3aZtuWOkEnaSuTkbwuxI6musZ0VUr+KQpqSZvf49D2bHJk+pub+XJklFSwxpk5t6ynQp2iZzcjb5f3vK3qRsMKlb8VHP7OjvNTipHmO3jtqfbdzN7AiA2bFxnlY+CbNjg3KqigyyTjFkrMji7g5I7al5KwrfiI81bP0lLyK+HdUChRO3ImHOPbr9rmfnCut1g9T+bANmR8CtnmE13oqTW8ZKtXWgp+6EB3Pan8INYxgsRC2GxIl/VuhHf25Vt+GsS+K/0xpz90st6Dhc8PUg39fVbd5clzQmwNUnPurEgZ6jTni0n/bnmkiPp147AABPfAoOZkcAAIDnEJiDAQAAQPQHAAAAIPoDAAAAEP0BAAAAiP4AAAAARP9nkJqbQBA3VuuCMCXG0DZJr6ETP1FD7D3wlAWQNasz3Vg9PAjDGsq9BQAQ/Z8j9PYfvrdP/Edqx0VN0mvoxE9Uz20OSQP9k9k6sZZXku7FuvDD91kT/1HZ8SfsS7KXnvxhQk8ZD8Mwpm/nsfMSbusb4n1pcrshYbi5ZVb/ZnwMwzB+8wGzttwyUFbubmZHquz0pyn1E0NaFUmfDmrBxzCMHdhn5rZ7pjonSdXbQN8rCWbHZxAbkatn9G6LQX89PR7bK2krz9UH9W4recIXy5b7y7hXt3h9sD9HbzE++GftCMuO1WcbwlRDajfUXV8xNv5S7C/X1Waz+vovAy+/P3bFdfKw7n5mR/Ls9Kcp9RNDmvL/mjxld9i3F8pNhoKD72q/fmvlTcoOqbZ5ScXsgb5XEsyO9J2OZMZEcrMjWUp7uXXJcBUXlfPb6/7MrlbsB59oIzzLEVIOXmItt7tQO4kY8pHrsbrx8alvz0PiayR1K1IIF53uaVVtux4SBSBV7dWGUo0tsaqV6br+sMpmcxRnZMnb8V4nEUKiqCkzIkSub8jlKur9L3r3/bMYd7btnbSyGfU3O9awG97f/6JPv79KHLXjJX/18xl2QN1EzI6k2VW0N9SrpxhSfniEX89fFI5AYLv/c/9u39w003Y60q8dzI4uUNuYSGVhJHMrpn2k3+THu1YmOfKq/dM4yyMroc7+y2XWqn+lugJh33/M57S0aycVQz5yPbL2qjwJopFWfkh9jYjMrUh1kO48i0wBSFo7qReQtMzH0B/WmPiTKCRL98+JS4tNKNDcXCI+VnmxHk9VSA+P8AGyjCVf/Jx8u9xS54LPEzM7VtoNPSNf7674aWNKrtZq1eam/PSTvPvrHUm3S3JDsyNpdvq7RZkeT834qCIMYViVrVhM8ktyM0V27YnXfDAMw7gBXcbMT8o1u6KlBLOjC9Q2JlJZGMnciltTsA/mc1p7Mfq859HimvWRlZDPnP+Tx5BwTBDIWrhP8KKEdu2kYkh3Wbgn8zUiMrci1UGaGMgUgFS10y3TVf1hLb1M7TPSZyZclM2cMzBQFDwoPu5pXCxO248P7ppi3fZed28uN6jn+OXJhdRPJJ6M2bGK3VAYMn7jN4EbBoeKORxx6OB1vot/eiuEdJsuNzQ7kmanv1tUPcWQXh3HRt5dvmTPbZXFVHpl67zl/5Y/VJ/Vmg/ZCLOVwK3anMNftj0xNXpOispOu3YwO7pAbWMilYWRzK2oUNjjw5QYpmQG6c/k44+shGyspc9j1U4hhnSTVXASXyMicytSHaRbD6kCkKJ2uk9LXdQf1l7xr31Gdm2xURQidZT5dC4WO2jIp3+cytLY9TmJc33+fn3U2rtU8f8JmB2r2w1tOZsmfCKfdjhLZTar7h18L//TCf/NJq3dDc2OpNldiFKuqhmrV8QMemPzbyNvfdTZk8sLnXCk+YhIP1+Hgo3i9QSMJQzqPG7xHwt99m28aKB9mmB2dOlRak1jIpWFkcytGNKCta3YkyA8CcKTqP4qDoY9Vu2kYkg3gdTXiMjcilQHEUIIY2J1hSI2mQKQqvaKQuv0ArqmPyTzSpIoJMWBfJ1C1Si2SAY/uPtbX33SNuvoHSOTzbAaLARCyK6t/FZ7AtSyGxpuJN0ImzPnhTAJhyMJfzE+vtXN/TeNZFnd0OxImt2FNbf6VsQOHrEiOddIEIT22o9tbpa2Htqaxh7jGJPFIHCCfu1gdnQlotUyJlJZGGunFDAnxuJLF1nuqJE2x7ZyuiHV+dsXtSWOZL5GEjGkm0Dqa0RkbkWqgwghTmCENPfIhVJnMYpPpgCkqh3R8wK6pD8kfdWn9hnx24+JUmxcf7JIV5i6bt3TuFia49PHfrjp2NX7KrO5/FbS9z9kBvYLlQR38by5JemuzqBIXrP2Up3NoPN6JandkBvSzSdz1Zqj2RqrVZtzdO3qDJ9uzUiXzt3Q7Eia3YV7LtpqRtKKNCnvT1+brtBbDMVXE758be690QtGBjLIsmuS4ybM3/6vXGuxqHNSV8ctzh80tYuU9mmC2dGld35qGRMpzI5kbkW7yrryVbUYlSOpespGW4VBkJaskdrXSCaGpGX4anjIfI2kbkUK4WLF+eVsfq05hpwr68gUgOS2SBIvIEWZtPWHZF5JijOy5G2fFilESNBl8oz2Igp53hME193c8cWojt4YQghJWg6au+22ASes8h1vR/AQ4oSOWriwm6SKcfOJmR0RQt02KazajF/e7V3xrJQb3PvdXzJ0eFMxO1Jlp2m1fHw1I0Ko26b75Zc3TuwgRAix/TuPXXRQbqZ6yceuurjx3T4VfSxoET3zt2sa3AUtJZgdXYj+NONpQ0Texo/mDWCaJdxiSNXTfUjilWzSZwRmRwDMjjXX1KQ6RMOY+BD6Kenz2GW6u8Sx6eLEK/lMnB2YHQH3ofHMjiohuTGRdMmeZkr6NESZAAAATQcwOwIAADyPwL41AAAAEP0BAAAAiP4AAAAARH8AAAAAoj8AAAAA0f+JUXs/hsYqhFbJTUf3CGbHRux5TxBMAhD9n06klrBTlU/lRf4mpHsEs2M90R4bF9j7t4JH+3fhBb/19h95RNsw18uZMbFuEeCTN1A+NbMjaUonc5ea2Q3ZB5dP7hPCxTCMG+jIXs/aXXJqgtnxeQF0jw2KW5kdOX6tvQz5aps9f3N/7/6b8+02dYFe1EA7S1OoBEmkg6Sn3wAGyqdmdiRNyaeeu9TMfnrZxvvdvjqQozWbitIWh+95a8yGrPL61e6CUxPMjvR32qltTFRZYiTqhYu0YdxyxFO/s8NupZY4KpIMg8OUCJVjPuopP9nU9qplVtvDhySlK7JJ99A9gtmxUc2O9oLf+7WccUZb9FcsC7EGbivS/jMzrNO3ty2EvfzUkuEtuAjx20/5M9tM2TYXtgMiUwk+oL3ZEamBkiBrp5Oh0rhmR9KUrm/3hJds6+v94n51/Wqn79QEs6ML6zOkxkStfYeKm1omvbGKseczc4aJQuKot332niXsB7Ha7Fl2mtfhsvmivmqZVdcByFJS4ba6RzA7Nq7ZkSGUBRFFqgdn/rzi28Xn8pb0EmWBXiSTMjVpH721ye/ba2WFR17N/DRubwlO0Tb6UKkEa0sHSSE1UBJk7aQ/VKrx1MyONFJSP1axaXOOrV17r9ULrXnUZdIRQ9J3ajY1syNq5F3myDZe/vl+xXesua+Xdp+KIHTWqc3Vq7MrvlzNfWS6FC1B6KxTA5UvLDCnXLUrzU7LdJKydmOE6lVZBEEQ1mxTV5nuhI4gtNbxwepV2QRBENYsY6TQDbZ9Lt0+wH/EYXXFtCJyVZaVIAhr9qqusokndBQH6e8Jqj89rXnEwkxz3bXTL1Ob+lZwV0eTslZ2DR6fqq2YeEb9fN/mmKN5DakyHau+zzPpGWlTxwd3XZXtKDNS2NA7PJuuftE5ZvVvo/w6Lt79RRvvl39Z2zdg9BGN7tTU5lGrs60Vtwd9ZG+kaJ22jdaHImmwV3RCOUHo//nwhY/OKhKivQYnVZaAW7X5l3d+3t+r2bRkqs1CLflHl0/qFyZCiB3Y461vjxdYCNJ2OhkqTva5vrpykFfgm7uLbE7aSXkJqmSnX5GrO9o+vAUUv7jxntnlMmultOT9+VpAZcT0HfNHLsVNkmrfEO/oXeVV2xCzN29vjDRmV8amAUHtIlqOS7y32312eHa/JWsm5i9GCCGMg7Fxwo4oJI4C1nc7eaHnTO8MUHtyVS98Z6d8rkU/JXJn3SOYHRvX7Mj2a+1ZlLTupPilEdEvx3DT1u0tFMo8WTaVQnExPoyNYRgzaOqZ/GKNvd5tc2pMrCYdpLirIDFQGsna6fJQeWpmR9opSd8vkIxMJXCL6u6B2eUL3/nVcZdMWiYdMSR9pyaYHV2lbqschcTRuy934yFxttJTvo9zZ7nxDPX9Nf2U7qt7BLNjI5sdGUKZX2HyJfbgEa28Ikb2xK8kZ3NDpCyWNKRFzLaHi+x4ykhJvdtGQyXokA7W1eZHBkorWTudDZXaPDWzYz0ckFV6iC1pOez9+PDMpBuG+tVO36kJZkdXZ/oBXPxUBuEsIpFKHDW2uAnGXZdxo5Uw6Ak7F6OcdDhJ2YR0j2B2bGyzI9uvlQ+SDBzbno9EXcZEMRCSyqQsQeTEWPnSRbvvqM3anOSV0z9M1TptG53X/0lFhkYy6aCAdMCTGSi9ydrpZKjUHH5Py+zoqgOylppx1uufbUnPVpltxpKMhGUrMoP7h3Goy6QjhqTv1ASzo4u2PPyfeRpPVI6wyndpHq6kV/l/Eokjjmds0ceElCNUzg/VfnbAbqV6j4g0ZdPTPYLZsZHNjvaiLX18h+0pxQmCsN77sSMSjD2mIQjCrjq/8tUIMUJI2mXKxksVb5RRtI2e2ZFUJUglHaRroCRrp7Oh4iZmR4RQt03XEyhf5apxrXH93cRFYzp6YQghhnfES5/tzjE5q52OGNIlpyaYHZusKLGp6R7B7Ahmxyc+fgAwOzb4cj+mdM+bIdA9NiZgdgSAp0XjmR3dMFaC7hEAgOcGMDsCAAA8j8AWNQAAABD9AQAAAIj+AAAAAER/AAAAAKI/AAAAANEfAAAAgOgPAAAAQPQHAAAAIPoDAAAAEP0BAAAAiP4AAAAARH8AAAAAoj8AAAAA0R8AAACA6A8AAABA9AcAAAAg+gMAAAAQ/QEAAACI/gAAABD9AQAAAIj+AAAAAER/AAAAAKI/AAAAANEfAAAAgOgPAAAAQPQHAAAAIPoDAAAAEP0BAAAAiP4AAAAARH8AAAAAoj8AAAAA0R8AAACA6A8AAABA9AcAAAAg+gMAAAAQ/QEAAACI/gAAABD9AQAAAIj+AAAAAER/AAAAAKI/AAAA8KzAOnXtPvQCAADA8wamNxPQCwAAAM8bsPIDAAAA0R8AAACA6A8AAABA9AcAAAAg+gMAAAAQ/QEAAACI/gAAAABEfwAAAACiPwAAAADRHwAAAIDoDwAAAED0BwAAACD6AwAAABD9AQAAAIj+AAAAAER/AAAAAKI/AAAAANEfAAAAgOgPAADw/MJy9ktbafqRy4X4owNsgXdou3YdA3mN86VBmHPT028H9h7Skv+wAbgu52jag7aDu7fgYi4VZrqduWvJv2fPlOnsCJN4Rozq9dan7YP5MCQAAIDojxBCDL8uvbp7MxFChN1clnvj/MUMQWz3lnysSZ82ocnd8ubhM0qGb49WHfzw4jNZ1/84tEzNX/5jqACDUQEAAER/hJgcLp9XkcxD0DosK/d6id7eks80l+ZczMzL19oQSxAU3iYqnJuVdq64Zb+BzbiYTXn++IXioB7DIyVM3HDn1LmC8D7RMo5VKb+ckS1XWwm2UNaqXVSYlKXLPnamzMfLnFNk9enQs7e09Er1BBwMNxTe+/e6vMSI+D5BvhaCLJZbSm5dypSXGzEPvxZturfz0l5JP2ONGN7Tj4sQwvU30s6XtOoTLXt0d2AvKshSItQm+pNtUX4sZC+8+evs8/nK4jJzKE917eveR3M79XwlOOv4wVIDVxIZN3z6rGABZpX/7/ivP97MLcMR4gTEdp/yfa9WuksLB6QWduseK7hzIk1t8QqI/nz4+LFeHPgKAQDAvXFlCQe3lMkVKsT34TNxvTz93H17SNdXXho0orcM5VxJzyECAriaQrUVIbv+wQMrMpWV6XFEmJVyg6C5DweZis6fvaf3j3zppUEjewXb714+l28mEMItqhJ+u2Ev9Ormo/63VgK7Xn7mUiGndc9RL0X3C7IUGUijv7HQ4t9v6KCR/Vqw5Bn/5Fo8W/ixyhQlZgIhhOsK80yScN9qAZnVrGXPVgjdTv1qyPaNi8+eypCO/XPSos29mnlUFnn14o2QHjM29GvPUl/74djJPNx2+9y6L6/nCluPmj9weH9GUcrprTtVdoQQQrYLF2/Jot7+rk8kKkr7ZFfCNSsMLAAAmvrcHy88l7rz0Y2AsHlkZLgAGbIUKkGLoaESDwZC0pDOrQsO55RgnXxYimKVzZf3oBwLbOZVWlpmCeWUF+mEgX5cZJLLi1lBA1t68RgISWUdQ+XHc0pNnRDCBGEtvARcZCyuneBBualALWjRSyZkM5CkWet2uaXZJF9hooj2wVI2hiTBkeHyo/JSa7PgEPbF7FKLLJitVhRZvNv413gq4OE3avt473Vnk5Oyz/4uP/t7OmJIe34z+p03vR09EhA5/v2IUA8Ltufs9WO6/FI7q3vfr893UDL5fE3prTIJ45RJe99YEf1RSPdp87uGcFB7niI+7v653aVjOwVyYHABANCUoz/Dt1P3KG8WQojB5PA8WAyEELKbDVaMK+A67hwwjsCDYTXZhUH+WGaB1igptkhbBvroC/NVRm6+lh/cjocRGr0FN8mTD8oflS0wmAkmwtg8FoYQbiZJoNfqrYjDc1SEsYUeJDcrGJMrcszsGVwhB7OarQxRCxknNbfM5C/IKbD7d/KsEYsJk0mt4UbMHRk9D7MUl95Jubpz/pVzXxxq1e+tWDZCCCGxiM+qqJKFEIHjiDCWn1t1dM/O/HIr4nmzcISQvbI4qUTARAghjp9EgJCh0IzDyAIAoIlHf8Ty4IsENZIxODw2UWYw44jNQAgRFr0JZ4s4bFEzL/xKQYlGz28hFYh9WXcUhdkqrizCg4EwDo/NEAQNiQkTMyqWkYwGnMOz5iGEEIYQeQI2KihH5QZTRUWEzUgWVwm71WQjEAtDiLAYrYjL42AMj5AgXm5BYamgEPfp4Vmj/YRyb8KHnxd6DH75241tpf6+HcZ1yfn1Sl6WtqAMRwEVXykMxzeO454BL91x8Ne/in2njF7+Uag089D7b958tGwmVxQaIr1EhD67VIuQp8wDXqQFAMDNebwwhQkCg6X6nCu5ajOOW9SKK3d0Ipm/iMHylEmMOVmlHr5eHKbQX2ovzC5k+QXxGQhhPH+ZjznvSo7KhBN244Or6adT72jsVcokS6DlBDbzMeVeu6+x4HZtwb0barJZNa6+e19rQ4gwld7ONvu08OFhiMEPCONrbtwsQYEyr5rfcZh0cPcoETId3//Z8J1r4xKXv7g1IQsh3/Du4VRfh4TdZEcI2YxWQ07e8Q1ZRoTspsrGqG6snXR4x9IDP84rREjaZ4wPLPsAANDk5/7kXxqCZn172C9mXkq6bsPYwsDQzv1bChkIcTwDvbEHGl8vHoaYIj8vRqEmwFfIqIjuQb17Wi9lXNl/w0pgHC9Z2/4Rniyjskr4J0nAYUl7dTdfuHYhMQP38AqWSZgltb+LWEKJ9tbxZIvVzvAK7dRT5oEhhBg8WQvh1Wvm1l1FzNrt92n93q7hCUvOnTmdd/EOQmy+LLbriHl92ooQoSc9Y6b/G0PG/HMgcfv+xUe8O49qF3L6qvx6kcqGIYRQWOfBwfJjm8rMXgExX700sgMLBhYAAG4OpjcTz+q5WYqvHr4hjI4OlzTYQoxdfnHhgFR5xxd+3BPpxYThBAAARP9GhbCZdAZt7pXrJSE9Bobyawf/KaHfN2gDNud8DGMLAACI/k8bu+rOkVN5Nt9WA7q3kDbklBzm/gAAQPQHAAAAmgzwaiIAAABEfwAAAACiPwAAAADRHwAAAIDoDwAAAED0BwAAACD6AwAAABD9AQAAAIj+AAAAAER/AAAAoHH4P1Uc0MdGDHDoAAAAAElFTkSuQmCC>>++fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m+fancyDirectoryConfig = DirectoryConfig {+ indexFiles = ["index.html", "index.htm"],+ indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,+ dynamicHandlers = Map.empty,+ mimeTypes = defaultMimeTypes,+ preServeHook = const $ return $! ()+ }+++------------------------------------------------------------------------------+-- | Serves static files from a directory using the default configuration+-- as given in 'defaultDirectoryConfig'.+serveDirectory :: MonadSnap m+ => FilePath -- ^ Directory to serve from+ -> m ()+serveDirectory = serveDirectoryWith defaultDirectoryConfig+{-# INLINE serveDirectory #-}+++------------------------------------------------------------------------------+-- | Serves static files from a directory. Configuration options are+-- passed in a 'DirectoryConfig' that captures various choices about desired+-- behavior. The relative path given in 'rqPathInfo' is searched for a+-- requested file, and the file is served with the appropriate mime type if it+-- is found. Absolute paths and \"@..@\" are prohibited to prevent files from+-- being served from outside the sandbox.+serveDirectoryWith :: MonadSnap m+ => DirectoryConfig m -- ^ Configuration options+ -> FilePath -- ^ Directory to serve from+ -> m ()+serveDirectoryWith cfg base = do+ b <- directory <|> file <|> redir+ when (not b) pass++ where+ idxs = indexFiles cfg+ generate = indexGenerator cfg+ mimes = mimeTypes cfg+ dyns = dynamicHandlers cfg+ pshook = preServeHook cfg++ -- Serves a file if it exists; passes if not+ serve f = do+ liftIO (doesFileExist f) >>= flip unless pass+ let fname = takeFileName f+ let staticServe f' = pshook f >> serveFileAs (fileType mimes fname) f'+ lookupExt staticServe dyns fname f >> return True++ -- Serves a directory via indices if available. Returns True on success,+ -- False on failure to find an index. Passes /only/ if the request was+ -- not for a directory (no trailing slash).+ directory = do+ rq <- getRequest+ let uri = uriWithoutQueryString rq+ unless ("/" `S.isSuffixOf` uri) pass+ rel <- (base </>) <$> getSafePath+ b <- liftIO $ doesDirectoryExist rel+ if b then do let serveRel f = serve (rel </> f)+ foldl' (<|>) pass (Prelude.map serveRel idxs)+ <|> (generate rel >> return True)+ <|> return False+ else return False++ -- Serves a file requested by name. Passes if the file doesn't exist.+ file = serve =<< ((base </>) <$> getSafePath)++ -- If the request is for a directory but lacks a trailing slash, redirects+ -- to the directory name with a trailing slash.+ redir = do+ rel <- (base </>) <$> getSafePath+ liftIO (doesDirectoryExist rel) >>= flip unless pass+ rq <- getRequest+ let uri = uriWithoutQueryString rq+ let qss = queryStringSuffix rq+ let u = S.concat [uri, "/", qss]+ redirect u+++------------------------------------------------------------------------------+-- | Serves a single file specified by a full or relative path. If the file+-- does not exist, throws an exception (not that it does /not/ pass to the+-- next handler). The path restrictions on 'serveDirectory' don't apply to+-- this function since the path is not being supplied by the user.+serveFile :: MonadSnap m+ => FilePath -- ^ path to file+ -> m ()+serveFile fp = serveFileAs (fileType defaultMimeTypes (takeFileName fp)) fp+{-# INLINE serveFile #-}+++------------------------------------------------------------------------------+-- | Same as 'serveFile', with control over the MIME mapping used.+serveFileAs :: MonadSnap m+ => ByteString -- ^ MIME type+ -> FilePath -- ^ path to file+ -> m ()+serveFileAs mime fp = do+ reqOrig <- getRequest++ -- If-Range header must be ignored if there is no Range: header in the+ -- request (RFC 2616 section 14.27)+ let req = if isNothing $ getHeader "range" reqOrig+ then deleteHeader "if-range" reqOrig+ else reqOrig++ -- check "If-Modified-Since" and "If-Range" headers+ let mbH = getHeader "if-modified-since" req+ mbIfModified <- liftIO $ case mbH of+ Nothing -> return Nothing+ (Just s) -> liftM Just $ parseHttpTime s++ -- If-Range header could contain an entity, but then parseHttpTime will+ -- fail and return 0 which means a 200 response will be generated anyways+ mbIfRange <- liftIO $ case getHeader "if-range" req of+ Nothing -> return Nothing+ (Just s) -> liftM Just $ parseHttpTime s++ dbg $ "mbIfModified: " ++ Prelude.show mbIfModified+ dbg $ "mbIfRange: " ++ Prelude.show mbIfRange++ -- check modification time and bug out early if the file is not modified.+ --+ -- TODO: a stat cache would be nice here, but it'd need the date thread+ -- stuff from snap-server to be folded into snap-core+ filestat <- liftIO $ getFileStatus fp+ let mt = modificationTime filestat+ maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified++ let sz = fromIntegral $ fileSize filestat+ lm <- liftIO $ formatHttpTime mt++ -- ok, at this point we know the last-modified time and the+ -- content-type. set those.+ modifyResponse $ setHeader "Last-Modified" lm+ . setHeader "Accept-Ranges" "bytes"+ . setContentType mime+++ -- now check: is this a range request? If there is an 'If-Range' header+ -- with an old modification time we skip this check and send a 200+ -- response+ let skipRangeCheck = maybe (False)+ (\lt -> mt > lt)+ mbIfRange++ -- checkRangeReq checks for a Range: header in the request and sends a+ -- partial response if it matches.+ wasRange <- if skipRangeCheck+ then return False+ else liftSnap $ checkRangeReq req fp sz++ dbg $ "was this a range request? " ++ Prelude.show wasRange++ -- if we didn't have a range request, we just do normal sendfile+ unless wasRange $ do+ modifyResponse $ setResponseCode 200+ . setContentLength sz+ liftSnap $ sendFile fp++ where+ --------------------------------------------------------------------------+ notModified = finishWith $+ setResponseCode 304 emptyResponse+++------------------------------------------------------------------------------+lookupExt :: a -> HashMap FilePath a -> FilePath -> a+lookupExt def m f =+ if null ext+ then def+ else fromMaybe (lookupExt def m (next ext)) mbe++ where+ next = dropWhile (/= '.') . drop 1+ ext = takeExtensions f+ mbe = Map.lookup ext m+++------------------------------------------------------------------------------+-- | Determine a given file's MIME type from its filename and the provided MIME+-- map.+fileType :: MimeMap -> FilePath -> ByteString+fileType = lookupExt defaultMimeType+++------------------------------------------------------------------------------+defaultMimeType :: ByteString+defaultMimeType = "application/octet-stream"+++------------------------------------------------------------------------------+data RangeReq = RangeReq !Word64 !(Maybe Word64)+ | SuffixRangeReq !Word64+++------------------------------------------------------------------------------+rangeParser :: Parser RangeReq+rangeParser = string "bytes=" *>+ (byteRangeSpec <|> suffixByteRangeSpec) <*+ endOfInput+ where+ byteRangeSpec = do+ start <- fromIntegral <$> parseNum+ void $! char '-'+ end <- option Nothing $ liftM Just parseNum++ return $! RangeReq start (fromIntegral <$> end)++ suffixByteRangeSpec =+ liftM (SuffixRangeReq . fromIntegral) $ char '-' *> parseNum+++------------------------------------------------------------------------------+checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Word64 -> m Bool+checkRangeReq req fp sz = do+ -- TODO/FIXME: multiple ranges+ maybe (return False)+ (\s -> either (const $ return False)+ withRange+ (fullyParse s rangeParser))+ (getHeader "range" req)++ where+ withRange (RangeReq start mend) = do+ let end = fromMaybe (sz-1) mend+ dbg $ "withRange: start=" ++ Prelude.show start+ ++ ", end=" ++ Prelude.show end++ if start < 0 || end < start || start >= sz || end >= sz+ then send416+ else send206 start end++ withRange (SuffixRangeReq nbytes) = do+ let end = sz-1+ let start = sz - nbytes++ dbg $ "withRange: start=" ++ Prelude.show start+ ++ ", end=" ++ Prelude.show end++ if start < 0 || end < start || start >= sz || end >= sz+ then send416+ else send206 start end++ -- note: start and end INCLUSIVE here+ send206 start end = do+ dbg "inside send206"+ let !len = end-start+1+ let crng = S.concat . L.toChunks $+ toLazyByteString $+ mconcat [ byteString "bytes "+ , fromShow start+ , char8 '-'+ , fromShow end+ , char8 '/'+ , fromShow sz ]++ modifyResponse $ setResponseCode 206+ . setHeader "Content-Range" crng+ . setContentLength len++ dbg $ "send206: sending range (" ++ Prelude.show start+ ++ "," ++ Prelude.show (end+1) ++ ") to sendFilePartial"++ -- end here was inclusive, sendFilePartial is exclusive+ sendFilePartial fp (start,end+1)+ return True+++ send416 = do+ dbg "inside send416"+ -- if there's an "If-Range" header in the request, then we just send+ -- back 200+ if getHeader "If-Range" req /= Nothing+ then return False+ else do+ let crng = S.concat . L.toChunks $+ toLazyByteString $+ mconcat [ byteString "bytes */"+ , fromShow sz ]++ modifyResponse $ setResponseCode 416+ . setHeader "Content-Range" crng+ . setContentLength 0+ . deleteHeader "Content-Type"+ . deleteHeader "Content-Encoding"+ . deleteHeader "Transfer-Encoding"+ . setResponseBody (return . id)++ return True+++------------------------------------------------------------------------------+dbg :: (MonadIO m) => String -> m ()+dbg s = debug $ "FileServe:" ++ s+++------------------------------------------------------------------------------+uriWithoutQueryString :: Request -> ByteString+uriWithoutQueryString rq = S.takeWhile (/= '?') uri+ where+ uri = rqURI rq+++------------------------------------------------------------------------------+queryStringSuffix :: Request -> ByteString+queryStringSuffix rq = S.concat [ s, qs ]+ where+ qs = rqQueryString rq+ s = if S.null qs then "" else "?"+++------------------------------------------------------------------------------+fromShow :: Show a => a -> Builder+fromShow = stringUtf8 . show
+ src/Snap/Internal/Util/FileUploads.hs view
@@ -0,0 +1,1125 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Internal.Util.FileUploads+ ( -- * Functions+ handleFormUploads+ , foldMultipart+ , PartFold+ , FormParam+ , FormFile (..)+ , storeAsLazyByteString+ , withTemporaryStore+ -- ** Backwards compatible API+ , handleFileUploads+ , handleMultipart+ , PartProcessor++ -- * Uploaded parts+ , PartInfo(..)+ , PartDisposition(..)+ , toPartDisposition++ -- ** Policy+ -- *** General upload policy+ , UploadPolicy(..)+ , defaultUploadPolicy+ , doProcessFormInputs+ , setProcessFormInputs+ , getMaximumFormInputSize+ , setMaximumFormInputSize+ , getMaximumNumberOfFormInputs+ , setMaximumNumberOfFormInputs+ , getMinimumUploadRate+ , setMinimumUploadRate+ , getMinimumUploadSeconds+ , setMinimumUploadSeconds+ , getUploadTimeout+ , setUploadTimeout++ -- *** File upload policy+ , FileUploadPolicy(..)+ , defaultFileUploadPolicy+ , setMaximumFileSize+ , setMaximumNumberOfFiles+ , setSkipFilesWithoutNames+ , setMaximumSkippedFileSize++ -- *** Per-file upload policy+ , PartUploadPolicy(..)+ , disallow+ , allowWithMaximumSize++ -- * Exceptions+ , FileUploadException(..)+ , fileUploadExceptionReason+ , BadPartException(..)+ , PolicyViolationException(..)+ ) where++------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>)), Applicative (pure, (*>), (<*)))+import Control.Arrow (Arrow (first))+import Control.Exception.Lifted (Exception, SomeException (..), bracket, catch, finally, fromException, mask, throwIO, toException)+import qualified Control.Exception.Lifted as E (try)+import Control.Monad (Functor (fmap), Monad (return, (>>=)), MonadPlus (mzero), forM_, guard, liftM, sequence, unless, void, when, (>=>))+import Control.Monad.IO.Class (liftIO)+import Data.Attoparsec.ByteString.Char8 (Parser, isEndOfLine, string, takeWhile)+import qualified Data.Attoparsec.ByteString.Char8 as Atto (try)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Lazy.Internal as LB (ByteString (Empty), chunk)+import qualified Data.CaseInsensitive as CI (mk)+import Data.Int (Int, Int64)+import qualified Data.IORef as IORef+import Data.List (find, map, (++))+import qualified Data.Map as Map (insertWith)+import Data.Maybe (Maybe (..), fromMaybe, isJust, maybe)+import Data.Text (Text)+import qualified Data.Text as T (concat, pack, unpack)+import qualified Data.Text.Encoding as TE (decodeUtf8)+import Data.Typeable (Typeable, cast)+import Prelude (Bool (..), Double, Either (..), Eq (..), FilePath, IO, Ord (..), Show (..), String, const, either, foldr, fst, id, max, not, otherwise, seq, snd, succ, ($), ($!), (.), (^), (||))+import Snap.Core (HasHeaders (headers), Headers, MonadSnap, Request (rqParams, rqPostParams), getHeader, getRequest, getTimeoutModifier, putRequest, runRequestBody)+import Snap.Internal.Parsing (crlf, fullyParse, pContentTypeWithParameters, pHeaders, pValueWithParameters')+import qualified Snap.Types.Headers as H (fromList)+import System.Directory (removeFile)+import System.FilePath ((</>))+import System.IO (BufferMode (NoBuffering), Handle, hClose, hSetBuffering, openBinaryTempFile)+import System.IO.Error (isDoesNotExistError)+import System.IO.Streams (InputStream, MatchInfo (..), TooManyBytesReadException, search)+import qualified System.IO.Streams as Streams+import System.IO.Streams.Attoparsec (parseFromStream)+import System.PosixCompat.Temp (mkstemp)+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Reads uploaded files into a temporary directory and calls a user handler+-- to process them.+--+-- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's+-- @Content-type@ is not \"@multipart/formdata@\", this function skips+-- processing using 'pass'.+--+-- Given a temporary directory, global and file-specific upload policies, and a+-- user handler, this function consumes a request body uploaded with+-- @Content-type: multipart/form-data@. Each file is read into the temporary+-- directory, and is then passed to the user handler. After the user handler+-- runs (but before the 'Response' body is streamed to the client), the files+-- are deleted from disk; so if you want to retain or use the uploaded files in+-- the generated response, you need to move or otherwise process them.+--+-- The argument passed to the user handler is a tuple:+--+-- > (PartInfo, Either PolicyViolationException FilePath)+--+-- The first half of this tuple is a 'PartInfo', which contains the+-- information the client browser sent about the given upload part (like+-- filename, content-type, etc). The second half of this tuple is an 'Either'+-- stipulating that either:+--+-- 1. the file was rejected on a policy basis because of the provided+-- 'PartUploadPolicy' handler+--+-- 2. the file was accepted and exists at the given path.+--+-- /Exceptions/+--+-- If the client's upload rate passes below the configured minimum (see+-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function+-- terminates the connection. This setting is there to protect the server+-- against slowloris-style denial of service attacks.+--+-- If the given 'UploadPolicy' stipulates that you wish form inputs to be+-- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and+-- a form input exceeds the maximum allowable size, this function will throw a+-- 'PolicyViolationException'.+--+-- If an uploaded part contains MIME headers longer than a fixed internal+-- threshold (currently 32KB), this function will throw a 'BadPartException'.++handleFileUploads ::+ (MonadSnap m) =>+ FilePath -- ^ temporary directory+ -> UploadPolicy -- ^ general upload policy+ -> (PartInfo -> PartUploadPolicy) -- ^ per-part upload policy+ -> (PartInfo -> Either PolicyViolationException FilePath -> IO a)+ -- ^ user handler (see function+ -- description)+ -> m [a]+handleFileUploads tmpdir uploadPolicy partPolicy partHandler =+ handleMultipart uploadPolicy go++ where+ go partInfo stream = maybe disallowed takeIt mbFs+ where+ ctText = partContentType partInfo+ fnText = fromMaybe "" $ partFileName partInfo++ ct = TE.decodeUtf8 ctText+ fn = TE.decodeUtf8 fnText++ (PartUploadPolicy mbFs) = partPolicy partInfo++ takeIt maxSize = do+ str' <- Streams.throwIfProducesMoreThan maxSize stream+ fileReader tmpdir partHandler partInfo str' `catch` tooMany maxSize++ tooMany maxSize (_ :: TooManyBytesReadException) =+ partHandler partInfo+ (Left $+ PolicyViolationException $+ T.concat [ "File \""+ , fn+ , "\" exceeded maximum allowable size "+ , T.pack $ show maxSize ])++ disallowed =+ partHandler partInfo+ (Left $+ PolicyViolationException $+ T.concat [ "Policy disallowed upload of file \""+ , fn+ , "\" with content-type \""+ , ct+ , "\"" ] )+++------------------------------------------------------------------------------+-- | Contents of form field of type @file@+data FormFile a = FormFile+ { formFileName :: !ByteString+ -- ^ Name of a field+ , formFileValue :: a+ -- ^ Result of storing file+ } deriving (Eq, Ord, Show)++data UploadState a = UploadState+ { numUploadedFiles :: !Int+ , uploadedFiles :: !([FormFile a] -> [FormFile a])+ }++-- | Processes form data and calls provided storage function on+-- file parts.+--+-- You can use this together with 'withTemporaryStore', 'storeAsLazyByteString'+-- or provide your own callback to store uploaded files.+--+-- If you need to process uploaded file mime type or file name, do it in the+-- store callback function.+--+-- See also 'foldMultipart'.+--+-- Example using with small files which can safely be stored in memory.+--+-- @+--+-- import qualified Data.ByteString.Lazy as Lazy+--+-- handleSmallFiles :: MonadSnap m => [(ByteString, ByteString, Lazy.ByteString)]+-- handleSmallFiles = handleFormUploads uploadPolicy filePolicy store+--+-- where+-- uploadPolicy = defaultUploadPolicy+-- filePolicy = setMaximumFileSize (64*1024)+-- $ setMaximumNumberOfFiles 5+-- defaultUploadPolicy+-- store partInfo stream = do+-- content <- storeAsLazyByteString partInfo stream+-- let+-- fileName = partFileName partInfo+-- fileMime = partContentType partInfo+-- in (fileName, fileMime, content)+-- @+--+handleFormUploads ::+ (MonadSnap m) =>+ UploadPolicy -- ^ general upload policy+ -> FileUploadPolicy -- ^ Upload policy for files+ -> (PartInfo -> InputStream ByteString -> IO a)+ -- ^ A file storage function+ -> m ([FormParam], [FormFile a])+handleFormUploads uploadPolicy filePolicy partHandler = do+ (params, !st) <- foldMultipart uploadPolicy go (UploadState 0 id)+ return (params, uploadedFiles st [])+ where+ go !partInfo stream !st = do+ when (numUploads >= maxFiles) throwTooManyFiles++ case partFileName partInfo of+ Nothing -> onEmptyName+ Just _ -> takeIt++ where+ numUploads = numUploadedFiles st+ files = uploadedFiles st+ maxFiles = maxNumberOfFiles filePolicy+ maxFileSize = maxFileUploadSize filePolicy+ fnText = fromMaybe "" $ partFileName partInfo++ fn = TE.decodeUtf8 fnText++ takeIt = do+ str' <- Streams.throwIfProducesMoreThan maxFileSize stream+ r <- partHandler partInfo str' `catch` tooMany maxFileSize+ let f = FormFile (partFieldName partInfo) r+ return $! UploadState (succ numUploads) (files . ([f] ++) )++ skipIt maxSize = do+ str' <- Streams.throwIfProducesMoreThan maxSize stream+ !_ <- Streams.skipToEof str' `catch` tooMany maxSize+ return $! UploadState (succ numUploads) files++ onEmptyName = if skipEmptyFileName filePolicy+ then skipIt (maxEmptyFileNameSize filePolicy)+ else takeIt+++ throwTooManyFiles = throwIO . PolicyViolationException $ T.concat+ ["number of files exceeded the maximum of "+ ,T.pack (show maxFiles) ]++ tooMany maxSize (_ :: TooManyBytesReadException) =+ throwIO . PolicyViolationException $+ T.concat [ "File \""+ , fn+ , "\" exceeded maximum allowable size "+ , T.pack $ show maxSize ]+++------------------------------------------------------------------------------+-- | A type alias for a function that will process one of the parts of a+-- @multipart/form-data@ HTTP request body with accumulator.+type PartFold a = PartInfo -> InputStream ByteString -> a -> IO a+++------------------------------------------------------------------------------+-- | Given an upload policy and a function to consume uploaded \"parts\",+-- consume a request body uploaded with @Content-type: multipart/form-data@.+--+-- If 'setProcessFormInputs' is 'True', then parts with disposition @form-data@+-- (a form parameter) will be processed and returned as first element of+-- resulting pair. Parts with other disposition will be fed to 'PartFold'+-- handler.+--+-- If 'setProcessFormInputs' is 'False', then parts with any disposition will+-- be fed to 'PartFold' handler and first element of returned pair will be+-- empty. In this case it is important that you limit number of form inputs+-- and sizes of inputs in your 'PartFold' handler to avoid common DOS attacks.+--+-- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's+-- @Content-type@ is not \"@multipart/formdata@\", this function skips+-- processing using 'pass'.+--+-- Most users will opt for the higher-level 'handleFileUploads', which writes+-- to temporary files, rather than 'handleMultipart'. This function should be+-- chosen, however, if you need to stream uploaded files directly to your own+-- processing function: e.g. to a database or a remote service via RPC.+--+-- If the client's upload rate passes below the configured minimum (see+-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function+-- terminates the connection. This setting is there to protect the server+-- against slowloris-style denial of service attacks.+--+-- /Exceptions/+--+-- If the given 'UploadPolicy' stipulates that you wish form inputs to be+-- processed (using 'setProcessFormInputs'), and a form input exceeds the+-- maximum allowable size or the form exceeds maximum number of inputs, this+-- function will throw a 'PolicyViolationException'.+--+-- If an uploaded part contains MIME headers longer than a fixed internal+-- threshold (currently 32KB), this function will throw a 'BadPartException'.+--+-- /Since: 1.0.3.0/+foldMultipart ::+ (MonadSnap m) =>+ UploadPolicy -- ^ global upload policy+ -> PartFold a -- ^ part processor+ -> a -- ^ seed accumulator+ -> m ([FormParam], a)+foldMultipart uploadPolicy origPartHandler zero = do+ hdrs <- liftM headers getRequest+ let (ct, mbBoundary) = getContentType hdrs++ tickleTimeout <- liftM (. max) getTimeoutModifier+ let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy++ let partHandler = if doProcessFormInputs uploadPolicy+ then captureVariableOrReadFile+ (getMaximumFormInputSize uploadPolicy)+ origPartHandler+ else \x y acc -> liftM File $ origPartHandler x y acc++ -- not well-formed multipart? bomb out.+ guard (ct == "multipart/form-data")++ boundary <- maybe (throwIO $ BadPartException+ "got multipart/form-data without boundary")+ return+ mbBoundary++ -- RateTooSlowException will be caught and properly dealt with by+ -- runRequestBody+ runRequestBody (proc bumpTimeout boundary partHandler)++ where+ --------------------------------------------------------------------------+ uploadRate = minimumUploadRate uploadPolicy+ uploadSecs = minimumUploadSeconds uploadPolicy+ maxFormVars = maximumNumberOfFormInputs uploadPolicy++ --------------------------------------------------------------------------+ proc bumpTimeout boundary partHandler =+ Streams.throwIfTooSlow bumpTimeout uploadRate uploadSecs >=>+ internalFoldMultipart maxFormVars boundary partHandler zero++------------------------------------------------------------------------------+-- | A type alias for a function that will process one of the parts of a+-- @multipart/form-data@ HTTP request body without usinc accumulator.+type PartProcessor a = PartInfo -> InputStream ByteString -> IO a+++------------------------------------------------------------------------------+-- | A variant of 'foldMultipart' accumulating results into a list.+-- Also puts captured 'FormParam's into rqPostParams and rqParams maps.+--+handleMultipart ::+ (MonadSnap m) =>+ UploadPolicy -- ^ global upload policy+ -> PartProcessor a -- ^ part processor+ -> m [a]+handleMultipart uploadPolicy origPartHandler = do+ (captures, files) <- foldMultipart uploadPolicy partFold id+ procCaptures captures+ return $! files []++ where+ partFold info input acc = do+ x <- origPartHandler info input+ return $ acc . ([x]++)+ --------------------------------------------------------------------------+ procCaptures [] = pure ()+ procCaptures params = do+ rq <- getRequest+ putRequest $ modifyParams (\m -> foldr ins m params) rq++ --------------------------------------------------------------------------+ ins (!k, !v) = Map.insertWith (\_ ex -> (v:ex)) k [v]+ -- prepend value if key exists, since we are folding from right++ --------------------------------------------------------------------------+ modifyParams f r = r { rqPostParams = f $ rqPostParams r+ , rqParams = f $ rqParams r+ }++------------------------------------------------------------------------------+-- | Represents the disposition type specified via the @Content-Disposition@+-- header field. See <https://www.ietf.org/rfc/rfc1806.txt RFC 1806>.+data PartDisposition =+ DispositionAttachment -- ^ @Content-Disposition: attachment@.+ | DispositionFile -- ^ @Content-Disposition: file@.+ | DispositionFormData -- ^ @Content-Disposition: form-data@.+ | DispositionOther ByteString -- ^ Any other value.+ deriving (Eq, Show)+++------------------------------------------------------------------------------+-- | 'PartInfo' contains information about a \"part\" in a request uploaded+-- with @Content-type: multipart/form-data@.+data PartInfo =+ PartInfo+ { partFieldName :: !ByteString+ -- ^ Field name associated with this part (i.e., the name specified with+ -- @\<input name=\"partFieldName\" ...@).+ , partFileName :: !(Maybe ByteString)+ -- ^ Name of the uploaded file.+ , partContentType :: !ByteString+ -- ^ Content type of this part.+ , partDisposition :: !PartDisposition+ -- ^ Disposition type of this part. See 'PartDisposition'.+ , partHeaders :: !Headers+ -- ^ Remaining headers associated with this part.+ }+ deriving (Show)+++------------------------------------------------------------------------------+toPartDisposition :: ByteString -> PartDisposition+toPartDisposition s | s == "attachment" = DispositionAttachment+ | s == "file" = DispositionFile+ | s == "form-data" = DispositionFormData+ | otherwise = DispositionOther s+++------------------------------------------------------------------------------+-- | All of the exceptions defined in this package inherit from+-- 'FileUploadException', so if you write+--+-- > foo `catch` \(e :: FileUploadException) -> ...+--+-- you can catch a 'BadPartException', a 'PolicyViolationException', etc.+data FileUploadException = forall e . (ExceptionWithReason e, Show e) =>+ WrappedFileUploadException e+ deriving (Typeable)+++------------------------------------------------------------------------------+class Exception e => ExceptionWithReason e where+ exceptionReason :: e -> Text+++------------------------------------------------------------------------------+instance Show FileUploadException where+ show (WrappedFileUploadException e) = show e+++------------------------------------------------------------------------------+instance Exception FileUploadException+++------------------------------------------------------------------------------+-- | Human-readable error message corresponding to the 'FileUploadException'.+fileUploadExceptionReason :: FileUploadException -> Text+fileUploadExceptionReason (WrappedFileUploadException e) = exceptionReason e+++------------------------------------------------------------------------------+uploadExceptionToException :: ExceptionWithReason e => e -> SomeException+uploadExceptionToException = toException . WrappedFileUploadException+++------------------------------------------------------------------------------+uploadExceptionFromException :: ExceptionWithReason e => SomeException -> Maybe e+uploadExceptionFromException x = do+ WrappedFileUploadException e <- fromException x+ cast e+++------------------------------------------------------------------------------+-- | Thrown when a part is invalid in some way (e.g. the headers are too large).+data BadPartException = BadPartException {+ -- | Human-readable error message corresponding to the 'BadPartException'.+ badPartExceptionReason :: Text+ }+ deriving (Typeable)++instance Exception BadPartException where+ toException = uploadExceptionToException+ fromException = uploadExceptionFromException++instance ExceptionWithReason BadPartException where+ exceptionReason (BadPartException e) = T.concat ["Bad part: ", e]++instance Show BadPartException where+ show = T.unpack . exceptionReason+++------------------------------------------------------------------------------+-- | Thrown when an 'UploadPolicy' or 'PartUploadPolicy' is violated.+data PolicyViolationException = PolicyViolationException {+ -- | Human-readable error message corresponding to the+ -- 'PolicyViolationException'.+ policyViolationExceptionReason :: Text+ } deriving (Typeable)++instance Exception PolicyViolationException where+ toException e@(PolicyViolationException _) =+ uploadExceptionToException e+ fromException = uploadExceptionFromException++instance ExceptionWithReason PolicyViolationException where+ exceptionReason (PolicyViolationException r) =+ T.concat ["File upload policy violation: ", r]++instance Show PolicyViolationException where+ show (PolicyViolationException s) = "File upload policy violation: "+ ++ T.unpack s+++------------------------------------------------------------------------------+-- | 'UploadPolicy' controls overall policy decisions relating to+-- @multipart/form-data@ uploads, specifically:+--+-- * whether to treat parts without filenames as form input (reading them into+-- the 'rqParams' map)+--+-- * because form input is read into memory, the maximum size of a form input+-- read in this manner, and the maximum number of form inputs+--+-- * the minimum upload rate a client must maintain before we kill the+-- connection; if very low-bitrate uploads were allowed then a Snap server+-- would be vulnerable to a trivial denial-of-service using a+-- \"slowloris\"-type attack+--+-- * the minimum number of seconds which must elapse before we start killing+-- uploads for having too low an upload rate.+--+-- * the amount of time we should wait before timing out the connection+-- whenever we receive input from the client.+data UploadPolicy = UploadPolicy {+ processFormInputs :: Bool+ , maximumFormInputSize :: Int64+ , maximumNumberOfFormInputs :: Int+ , minimumUploadRate :: Double+ , minimumUploadSeconds :: Int+ , uploadTimeout :: Int+}+++------------------------------------------------------------------------------+-- | A reasonable set of defaults for upload policy. The default policy is:+--+-- [@maximum form input size@] 128kB+--+-- [@maximum number of form inputs@] 10+--+-- [@minimum upload rate@] 1kB/s+--+-- [@seconds before rate limiting kicks in@] 10+--+-- [@inactivity timeout@] 20 seconds+--+defaultUploadPolicy :: UploadPolicy+defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout+ where+ maxSize = 2^(17::Int)+ maxNum = 10+ minRate = 1000+ minSeconds = 10+ tout = 20+++------------------------------------------------------------------------------+-- | Does this upload policy stipulate that we want to treat parts without+-- filenames as form input?+doProcessFormInputs :: UploadPolicy -> Bool+doProcessFormInputs = processFormInputs+++------------------------------------------------------------------------------+-- | Set the upload policy for treating parts without filenames as form input.+setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy+setProcessFormInputs b u = u { processFormInputs = b }+++------------------------------------------------------------------------------+-- | Get the maximum size of a form input which will be read into our+-- 'rqParams' map.+getMaximumFormInputSize :: UploadPolicy -> Int64+getMaximumFormInputSize = maximumFormInputSize+++------------------------------------------------------------------------------+-- | Set the maximum size of a form input which will be read into our+-- 'rqParams' map.+setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy+setMaximumFormInputSize s u = u { maximumFormInputSize = s }+++------------------------------------------------------------------------------+-- | Get the maximum size of a form input which will be read into our+-- 'rqParams' map.+getMaximumNumberOfFormInputs :: UploadPolicy -> Int+getMaximumNumberOfFormInputs = maximumNumberOfFormInputs+++------------------------------------------------------------------------------+-- | Set the maximum size of a form input which will be read into our+-- 'rqParams' map.+setMaximumNumberOfFormInputs :: Int -> UploadPolicy -> UploadPolicy+setMaximumNumberOfFormInputs s u = u { maximumNumberOfFormInputs = s }+++------------------------------------------------------------------------------+-- | Get the minimum rate (in /bytes\/second/) a client must maintain before+-- we kill the connection.+getMinimumUploadRate :: UploadPolicy -> Double+getMinimumUploadRate = minimumUploadRate+++------------------------------------------------------------------------------+-- | Set the minimum rate (in /bytes\/second/) a client must maintain before+-- we kill the connection.+setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy+setMinimumUploadRate s u = u { minimumUploadRate = s }+++------------------------------------------------------------------------------+-- | Get the amount of time which must elapse before we begin enforcing the+-- upload rate minimum+getMinimumUploadSeconds :: UploadPolicy -> Int+getMinimumUploadSeconds = minimumUploadSeconds+++------------------------------------------------------------------------------+-- | Set the amount of time which must elapse before we begin enforcing the+-- upload rate minimum+setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy+setMinimumUploadSeconds s u = u { minimumUploadSeconds = s }+++------------------------------------------------------------------------------+-- | Get the \"upload timeout\". Whenever input is received from the client,+-- the connection timeout is set this many seconds in the future.+getUploadTimeout :: UploadPolicy -> Int+getUploadTimeout = uploadTimeout+++------------------------------------------------------------------------------+-- | Set the upload timeout.+setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy+setUploadTimeout s u = u { uploadTimeout = s }+++------------------------------------------------------------------------------++-- | File upload policy, if any policy is violated then+-- 'PolicyViolationException' is thrown+data FileUploadPolicy = FileUploadPolicy+ { maxFileUploadSize :: !Int64+ , maxNumberOfFiles :: !Int+ , skipEmptyFileName :: !Bool+ , maxEmptyFileNameSize :: !Int64+ }++-- | A default 'FileUploadPolicy'+--+-- [@maximum file size@] 1MB+--+-- [@maximum number of files@] 10+--+-- [@skip files without name@] yes+--+-- [@maximum size of skipped file@] 0+--+--+defaultFileUploadPolicy :: FileUploadPolicy+defaultFileUploadPolicy = FileUploadPolicy maxFileSize maxFiles+ skipEmptyName maxEmptySize+ where+ maxFileSize = 1048576 -- 1MB+ maxFiles = 10+ skipEmptyName = True+ maxEmptySize = 0++-- | Maximum size of single uploaded file.+setMaximumFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy+setMaximumFileSize maxSize s =+ s { maxFileUploadSize = maxSize }++-- | Maximum number of uploaded files.+setMaximumNumberOfFiles :: Int -> FileUploadPolicy -> FileUploadPolicy+setMaximumNumberOfFiles maxFiles s =+ s { maxNumberOfFiles = maxFiles }++-- | Skip files with empty file names.+--+-- If set, parts without filenames will not be fed to storage function.+--+-- HTML5 form data encoding standard states that form input fields of type+-- file, without value set, are encoded same way as if file with empty body,+-- empty file name, and type @application/octet-stream@ was set as value.+--+-- You most likely want to use this with zero bytes allowed to avoid storing+-- such fields (see 'setMaximumSkippedFileSize').+--+-- By default files without names are skipped.+--+-- /Since: 1.0.3.0/+setSkipFilesWithoutNames :: Bool -> FileUploadPolicy -> FileUploadPolicy+setSkipFilesWithoutNames shouldSkip s =+ s { skipEmptyFileName = shouldSkip }++-- | Maximum size of file without name which can be skipped.+--+-- Ignored if 'setSkipFilesWithoutNames' is @False@.+--+-- If skipped file is larger than this setting then 'FileUploadException'+-- is thrown.+--+-- By default maximum file size is 0.+--+-- /Since: 1.0.3.0/+setMaximumSkippedFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy+setMaximumSkippedFileSize maxSize s =+ s { maxEmptyFileNameSize = maxSize }+++------------------------------------------------------------------------------+-- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'),+-- but handlers can also make policy decisions on individual files\/parts+-- uploaded. For each part uploaded, handlers can decide:+--+-- * whether to allow the file upload at all+--+-- * the maximum size of uploaded files, if allowed+data PartUploadPolicy = PartUploadPolicy (Maybe Int64)+++------------------------------------------------------------------------------+-- | Disallows the file to be uploaded.+disallow :: PartUploadPolicy+disallow = PartUploadPolicy Nothing+++------------------------------------------------------------------------------+-- | Allows the file to be uploaded, with maximum size /n/ in bytes.+allowWithMaximumSize :: Int64 -> PartUploadPolicy+allowWithMaximumSize = PartUploadPolicy . Just+++------------------------------------------------------------------------------+-- | Stores file body in memory as Lazy ByteString.+storeAsLazyByteString :: InputStream ByteString -> IO LB.ByteString+storeAsLazyByteString !str = do+ f <- Streams.fold (\f c -> f . LB.chunk c) id str+ return $! f LB.Empty+++------------------------------------------------------------------------------+-- | Store files in a temporary directory, and clean up on function exit.+--+-- Files are safe to move until function exists.+--+-- If asynchronous exception is thrown during cleanup, temporary files may+-- remain.+--+-- @+-- uploadsHandler = withTemporaryStore "/var/tmp" "upload-" $ \store -> do+-- (inputs, files) <- handleFormUploads defaultUploadpolicy+-- defaultFileUploadPolicy+-- (const store)+-- saveFiles files+--+-- @+--+withTemporaryStore ::+ MonadSnap m+ => FilePath -- ^ temporary directory+ -> String -- ^ file name pattern+ -> ((InputStream ByteString -> IO FilePath) -> m a)+ -- ^ Action taking store function+ -> m a+withTemporaryStore tempdir pat act = do+ ioref <- liftIO $ IORef.newIORef []+ let+ modifyIORef' ref f = do -- ghc 7.4 does not have modifyIORef'+ x <- IORef.readIORef ref+ let x' = f x+ x' `seq` IORef.writeIORef ref x'++ go input = do+ (fn, h) <- openBinaryTempFile tempdir pat+ modifyIORef' ioref (fn:)+ hSetBuffering h NoBuffering+ output <- Streams.handleToOutputStream h+ Streams.connect input output+ hClose h+ pure fn++ cleanup = liftIO $ do+ files <- IORef.readIORef ioref+ forM_ files $ \fn ->+ removeFile fn `catch` handleExists+ handleExists e = unless (isDoesNotExistError e) $ throwIO e++ act go `finally` cleanup+++------------------------------------------------------------------------------+-- private exports follow. FIXME: organize+------------------------------------------------------------------------------++------------------------------------------------------------------------------+captureVariableOrReadFile ::+ Int64 -- ^ maximum size of form input+ -> PartFold a -- ^ file reading code+ -> PartInfo -> InputStream ByteString+ -> a+ -> IO (Capture a)+captureVariableOrReadFile maxSize fileHandler partInfo stream acc =+ if isFile+ then liftM File $ fileHandler partInfo stream acc+ else variable `catch` handler++ where+ isFile = isJust (partFileName partInfo) ||+ partDisposition partInfo == DispositionFile++ variable = do+ !x <- liftM S.concat $+ Streams.throwIfProducesMoreThan maxSize stream >>= Streams.toList+ return $! Capture fieldName x++ fieldName = partFieldName partInfo++ handler (_ :: TooManyBytesReadException) =+ throwIO $ PolicyViolationException $+ T.concat [ "form input '"+ , TE.decodeUtf8 fieldName+ , "' exceeded maximum permissible size ("+ , T.pack $ show maxSize+ , " bytes)" ]+++------------------------------------------------------------------------------+data Capture a = Capture !ByteString !ByteString+ | File a+++------------------------------------------------------------------------------+fileReader :: FilePath+ -> (PartInfo -> Either PolicyViolationException FilePath -> IO a)+ -> PartProcessor a+fileReader tmpdir partProc partInfo input =+ withTempFile tmpdir "snap-upload-" $ \(fn, h) -> do+ hSetBuffering h NoBuffering+ output <- Streams.handleToOutputStream h+ Streams.connect input output+ hClose h+ partProc partInfo $ Right fn+++------------------------------------------------------------------------------+data MultipartState a = MultipartState+ { numFormVars :: {-# UNPACK #-} !Int+ , numFormFiles :: {-# UNPACK #-} !Int+ , capturedFields :: !([FormParam] -> [FormParam])+ , accumulator :: !a+ }++------------------------------------------------------------------------------+-- | A form parameter name-value pair+type FormParam = (ByteString, ByteString)++------------------------------------------------------------------------------+addCapture :: ByteString -> ByteString -> MultipartState a -> MultipartState a+addCapture !k !v !ms =+ let !kv = (k,v)+ f = capturedFields ms . ([kv]++)+ !ms' = ms { capturedFields = f+ , numFormVars = succ (numFormVars ms) }+ in ms'+++------------------------------------------------------------------------------+internalFoldMultipart ::+ Int -- ^ max num fields+ -> ByteString -- ^ boundary value+ -> (PartInfo -> InputStream ByteString -> a -> IO (Capture a)) -- ^ part processor+ -> a+ -> InputStream ByteString+ -> IO ([FormParam], a)+internalFoldMultipart !maxFormVars !boundary clientHandler !zeroAcc !stream = go+ where+ --------------------------------------------------------------------------+ initialState = MultipartState 0 0 id zeroAcc++ --------------------------------------------------------------------------+ go = do+ -- swallow the first boundary+ _ <- parseFromStream (parseFirstBoundary boundary) stream+ bmstream <- search (fullBoundary boundary) stream+ ms <- foldParts goPart bmstream initialState+ return $ (capturedFields ms [], accumulator ms)++ --------------------------------------------------------------------------+ pBoundary !b = Atto.try $ do+ _ <- string "--"+ string b++ --------------------------------------------------------------------------+ fullBoundary !b = S.concat ["\r\n", "--", b]+ pLine = takeWhile (not . isEndOfLine . c2w) <* eol+ parseFirstBoundary !b = pBoundary b <|> (pLine *> parseFirstBoundary b)+++ --------------------------------------------------------------------------+ takeHeaders !str = hdrs `catch` handler+ where+ hdrs = do+ str' <- Streams.throwIfProducesMoreThan mAX_HDRS_SIZE str+ liftM toHeaders $ parseFromStream pHeadersWithSeparator str'++ handler (_ :: TooManyBytesReadException) =+ throwIO $ BadPartException "headers exceeded maximum size"++ --------------------------------------------------------------------------+ goPart !str !state = do+ hdrs <- takeHeaders str++ -- are we using mixed?+ let (contentType, mboundary) = getContentType hdrs+ let (fieldName, fileName, disposition) = getFieldHeaderInfo hdrs++ if contentType == "multipart/mixed"+ then maybe (throwIO $ BadPartException $+ "got multipart/mixed without boundary")+ (processMixed fieldName str state)+ mboundary+ else do+ let info = PartInfo fieldName fileName contentType disposition hdrs+ handlePart info str state++ --------------------------------------------------------------------------+ handlePart !info !str !ms = do+ r <- clientHandler info str (accumulator ms)+ case r of+ Capture !k !v -> do+ when (maxFormVars <= numFormVars ms) throwTooMuchVars+ return $! addCapture k v ms+ File !newAcc -> return $! ms { accumulator = newAcc+ , numFormFiles = succ (numFormFiles ms)+ }++ throwTooMuchVars =+ throwIO . PolicyViolationException+ $ T.concat [ "number of form inputs exceeded maximum of "+ , T.pack $ show maxFormVars ]++ --------------------------------------------------------------------------+ processMixed !fieldName !str !state !mixedBoundary = do+ -- swallow the first boundary+ _ <- parseFromStream (parseFirstBoundary mixedBoundary) str+ bm <- search (fullBoundary mixedBoundary) str+ foldParts (mixedStream fieldName) bm state+++ --------------------------------------------------------------------------+ mixedStream !fieldName !str !acc = do+ hdrs <- takeHeaders str++ let (contentType, _) = getContentType hdrs+ let (_, fileName, disposition) = getFieldHeaderInfo hdrs++ let info = PartInfo fieldName fileName contentType disposition hdrs+ handlePart info str acc+++------------------------------------------------------------------------------+getContentType :: Headers+ -> (ByteString, Maybe ByteString)+getContentType hdrs = (contentType, boundary)+ where+ contentTypeValue = fromMaybe "text/plain" $+ getHeader "content-type" hdrs++ eCT = fullyParse contentTypeValue pContentTypeWithParameters+ (!contentType, !params) = either (const ("text/plain", [])) id eCT++ boundary = findParam "boundary" params+++------------------------------------------------------------------------------+getFieldHeaderInfo :: Headers -> (ByteString, Maybe ByteString, PartDisposition)+getFieldHeaderInfo hdrs = (fieldName, fileName, disposition)+ where+ contentDispositionValue = fromMaybe "unknown" $+ getHeader "content-disposition" hdrs++ eDisposition = fullyParse contentDispositionValue $ pValueWithParameters' (const True)++ (!dispositionType, dispositionParameters) =+ either (const ("unknown", [])) id eDisposition++ disposition = toPartDisposition dispositionType++ fieldName = fromMaybe "" $ findParam "name" dispositionParameters++ fileName = findParam "filename" dispositionParameters+++------------------------------------------------------------------------------+findParam :: (Eq a) => a -> [(a, b)] -> Maybe b+findParam p = fmap snd . find ((== p) . fst)+++------------------------------------------------------------------------------+partStream :: InputStream MatchInfo -> IO (InputStream ByteString)+partStream st = Streams.makeInputStream go++ where+ go = do+ s <- Streams.read st+ return $! s >>= f++ f (NoMatch s) = return s+ f _ = mzero+++++------------------------------------------------------------------------------+-- | Assuming we've already identified the boundary value and split the input+-- up into parts which match and parts which don't, run the given 'ByteString'+-- InputStream over each part and grab a list of the resulting values.+--+-- TODO/FIXME: fix description+foldParts :: (InputStream ByteString -> MultipartState a -> IO (MultipartState a))+ -> InputStream MatchInfo+ -> (MultipartState a)+ -> IO (MultipartState a)+foldParts partFunc stream = go+ where+ part acc pStream = do+ isLast <- parseFromStream pBoundaryEnd pStream++ if isLast+ then return Nothing+ else do+ !x <- partFunc pStream acc+ Streams.skipToEof pStream+ return $! Just x++ go !acc = do+ cap <- partStream stream >>= part acc+ maybe (return acc) go cap++ pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)+++------------------------------------------------------------------------------+eol :: Parser ByteString+eol = (string "\n") <|> (string "\r\n")+++------------------------------------------------------------------------------+pHeadersWithSeparator :: Parser [(ByteString,ByteString)]+pHeadersWithSeparator = pHeaders <* crlf+++------------------------------------------------------------------------------+toHeaders :: [(ByteString,ByteString)] -> Headers+toHeaders kvps = H.fromList kvps'+ where+ kvps' = map (first CI.mk) kvps+++------------------------------------------------------------------------------+mAX_HDRS_SIZE :: Int64+mAX_HDRS_SIZE = 32768+++------------------------------------------------------------------------------+withTempFile :: FilePath+ -> String+ -> ((FilePath, Handle) -> IO a)+ -> IO a+withTempFile tmpl temp handler =+ mask $ \restore -> bracket make cleanup (restore . handler)++ where+ make = mkstemp $ tmpl </> (temp ++ "XXXXXXX")+ cleanup (fp,h) = sequence $ map gobble [hClose h, removeFile fp]++ t :: IO z -> IO (Either SomeException z)+ t = E.try++ gobble = void . t
− src/Snap/Iteratee.hs
@@ -1,750 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}----------------------------------------------------------------------------------- | Snap Framework type aliases and utilities for iteratees. Note that as a--- convenience, this module also exports everything from @Data.Enumerator@ in--- the @enumerator@ library.--module Snap.Iteratee- (- -- * Enumerators- enumBS- , enumLBS- , enumBuilder- , enumFile- , enumFilePartial- , InvalidRangeException--- -- * Iteratee utilities- , joinI'- , countBytes- , drop'- , mkIterateeBuffer- , unsafeBufferIterateeWithBuffer- , unsafeBufferIteratee- , take- , drop- , takeExactly- , takeNoMoreThan- , skipToEof- , mapEnum- , mapIter- , enumBuilderToByteString- , unsafeEnumBuilderToByteString- , enumByteStringToBuilder- , killIfTooSlow-- , TooManyBytesReadException- , ShortWriteException- , RateTooSlowException-- -- * Re-export types and functions from @Data.Enumerator@- , Stream (..)- , Step (..)- , Iteratee (..)- , Enumerator- , Enumeratee-- -- ** Primitives- -- *** Combinators- -- | These are common patterns which occur whenever iteratees are- -- being defined.- , returnI- , yield- , continue- , throwError- , catchError- , liftI- , (>>==)- , (==<<)- , ($$)- , (>==>)- , (<==<)- , ($=)- , (=$)-- -- *** Iteratees- , run- , run_- , consume- , Data.Enumerator.isEOF- , liftTrans- , liftFoldL- , liftFoldL'- , liftFoldM- , printChunks- , head- , peek-- -- *** Enumerators- , enumEOF- , enumList- , concatEnums- -- *** Enumeratees- , checkDone- , Data.Enumerator.List.map- , Data.Enumerator.sequence- , joinI---{-- -- ** Iteratee utilities- , drop'---}- ) where----------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Enumerator-import Control.DeepSeq-import Control.Exception (SomeException, assert)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Unsafe as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Enumerator hiding (consume, drop, head)-import qualified Data.Enumerator as I-import Data.Enumerator.Binary (enumHandle)-import Data.Enumerator.List hiding (take, drop)-import qualified Data.Enumerator.List as IL-import qualified Data.List as List-import Data.Monoid (mappend)-import Data.Time.Clock.POSIX (getPOSIXTime)-import Data.Typeable-import Foreign hiding (peek)-import Foreign.C.Types-import GHC.ForeignPtr-import Prelude hiding (catch, drop, head, take)-import System.IO--#ifndef PORTABLE-import System.IO.Posix.MMap-import System.PosixCompat.Files-import System.PosixCompat.Types-#endif---------------------------------------------------------------------------------instance (Functor m, MonadCatchIO m) =>- MonadCatchIO (Iteratee s m) where- --catch :: Exception e => m a -> (e -> m a) -> m a- catch m handler = insideCatch (m `catchError` h)- where- insideCatch !mm = Iteratee $ do- ee <- try $ runIteratee mm- case ee of- (Left e) -> runIteratee $ handler e- (Right v) -> step v-- step (Continue !k) = do- return $ Continue (\s -> insideCatch $ k s)- -- don't worry about Error here because the error had to come from the- -- handler (because of 'catchError' above)- step y = return y-- -- we can only catch iteratee errors if "e" matches "SomeException"- h e = maybe (throwError e)- (handler)- (fromException e)-- --block :: m a -> m a- block m = Iteratee $ block $ (runIteratee m >>= step)- where- step (Continue k) = return $ Continue (\s -> block (k s))- step y = return y-- unblock m = Iteratee $ unblock $ (runIteratee m >>= step)- where- step (Continue k) = return $ Continue (\s -> unblock (k s))- step y = return y------------------------------------------------------------------------------------ | Get the length of a bytestring Stream-streamLength :: Stream ByteString -> Int-streamLength (Chunks xs) = List.foldl' (\c s -> c + S.length s) 0 xs-streamLength EOF = 0------------------------------------------------------------------------------------ | Enumerates a Builder.-enumBuilder :: (Monad m) => Builder -> Enumerator Builder m a-enumBuilder = enumList 1 . (:[])-{-# INLINE enumBuilder #-}------------------------------------------------------------------------------------ | Enumerates a strict bytestring.-enumBS :: (Monad m) => ByteString -> Enumerator ByteString m a-enumBS = enumList 1 . (:[])-{-# INLINE enumBS #-}------------------------------------------------------------------------------------ | Enumerates a lazy bytestring.--enumLBS :: (Monad m) => L.ByteString -> Enumerator ByteString m a-enumLBS bs = enumList 1 (L.toChunks bs)-{-# INLINE enumLBS #-}----------------------------------------------------------------------------------skipToEof :: (Monad m) => Iteratee a m ()-skipToEof = continue k- where- k EOF = yield () EOF- k _ = skipToEof------------------------------------------------------------------------------------ | Wraps an 'Iteratee', counting the number of bytes consumed by it.-countBytes :: (Monad m) => forall a .- Iteratee ByteString m a- -> Iteratee ByteString m (a, Int64)-countBytes i = Iteratee $ do- step <- runIteratee i- case step of- (Continue k) -> return (Continue $ go 0 k)- (Yield x s) -> return $ Yield (x,0) s- (Error e) -> return $ Error e-- where- go !n k str = Iteratee $ do- let len = toEnum $ streamLength str- step <- runIteratee (k str)- case step of- (Continue k') -> return (Continue $ go (n + len) k')- (Yield x s) -> let len' = n + len - (toEnum $ streamLength s)- in return (Yield (x, len') s)- (Error e) -> return (Error e)----------------------------------------------------------------------------------bUFSIZ :: Int-bUFSIZ = 8192------------------------------------------------------------------------------------ | Creates a buffer to be passed into 'unsafeBufferIterateeWithBuffer'.-mkIterateeBuffer :: IO (ForeignPtr CChar)-mkIterateeBuffer = mallocPlainForeignPtrBytes bUFSIZ------------------------------------------------------------------------------------ | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer--- which we'll re-use, meaning that if you hold on to any of the bytestring--- data passed into your iteratee (instead of, let's say, shoving it right out--- a socket) it'll get changed out from underneath you, breaking referential--- transparency. Use with caution!-unsafeBufferIteratee :: Iteratee ByteString IO a- -> IO (Iteratee ByteString IO a)-unsafeBufferIteratee step = do- buf <- mkIterateeBuffer- return $ unsafeBufferIterateeWithBuffer buf step------------------------------------------------------------------------------------ | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer--- which we'll re-use, meaning that if you hold on to any of the bytestring--- data passed into your iteratee (instead of, let's say, shoving it right out--- a socket) it'll get changed out from underneath you, breaking referential--- transparency. Use with caution!------ This version accepts a buffer created by 'mkIterateeBuffer'.----unsafeBufferIterateeWithBuffer :: ForeignPtr CChar- -> Iteratee ByteString IO a- -> Iteratee ByteString IO a-unsafeBufferIterateeWithBuffer buf iter = Iteratee $ do- step <- runIteratee iter- start step-- where- --------------------------------------------------------------------------- start :: Step ByteString IO a -> IO (Step ByteString IO a)- start (Continue k) = return $ Continue $ go 0 k- start s@_ = return s--- --------------------------------------------------------------------------- sendBuf :: Int- -> (Stream ByteString -> Iteratee ByteString IO a)- -> IO (Step ByteString IO a)- sendBuf n k =- {-# SCC "unsafeBufferIteratee/sendBuf" #-} do- assert (n > 0) (return ())- assert (n <= bUFSIZ) (return ())-- withForeignPtr buf $ \ptr -> do- !s <- S.unsafePackCStringLen (ptr, n)- runIteratee $ k $ Chunks [s]--- --------------------------------------------------------------------------- copy EOF = EOF- copy (Chunks xs) = zs `deepseq` Chunks ys- where- !ys = Prelude.map S.copy xs- !zs = Prelude.map (`seq` ()) ys-- --------------------------------------------------------------------------- go :: Int- -> (Stream ByteString -> Iteratee ByteString IO a)- -> (Stream ByteString -> Iteratee ByteString IO a)- go !n !k EOF = Iteratee $ do- if n == 0- then runIteratee $ k EOF- else do- assert (n > 0) (return ())- assert (n <= bUFSIZ) (return ())-- step <- sendBuf n k- step2 <- runIteratee $ enumEOF step- return $ copyStep step2--- go !n !k (Chunks xs) = Iteratee $ do- assert (n >= 0) (return ())- assert (n <= bUFSIZ) (return ())-- let s = S.concat xs- let m = S.length s- if m+n >= bUFSIZ- then overflow n k s m- else copyAndCont n k s m--- --------------------------------------------------------------------------- copyStep (Yield x r) = let !z = copy r in Yield x z- copyStep x = x--- --------------------------------------------------------------------------- copyAndCont :: Int- -> (Stream ByteString -> Iteratee ByteString IO a)- -> ByteString- -> Int- -> IO (Step ByteString IO a)- copyAndCont !n k !s !m =- {-# SCC "unsafeBufferIteratee/copyAndCont" #-} do- assert (n >= 0) (return ())- assert (n+m < bUFSIZ) (return ())- S.unsafeUseAsCStringLen s $ \(p,sz) -> do- assert (m == sz) (return ())- withForeignPtr buf $ \bufp -> do- let b' = plusPtr bufp n- copyBytes b' p sz-- return $ Continue $ go (n+m) k---- --------------------------------------------------------------------------- overflow :: Int- -> (Stream ByteString -> Iteratee ByteString IO a)- -> ByteString- -> Int- -> IO (Step ByteString IO a)- overflow !n k !s !m =- {-# SCC "unsafeBufferIteratee/overflow" #-} do- assert (n+m >= bUFSIZ) (return ())- assert (n < bUFSIZ) (return ())-- let rest = bUFSIZ - n- let m2 = m - rest-- let (s1,s2) = S.splitAt rest s-- S.unsafeUseAsCStringLen s1 $ \(p,_) ->- withForeignPtr buf $ \bufp -> do- let b' = plusPtr bufp n- copyBytes b' p rest-- iv <- sendBuf bUFSIZ k- case iv of- (Yield x r) -> let !z = copy r- in return $ Yield x $ (z `mappend` Chunks [s2])- (Error e) -> return $ Error e- (Continue k') -> do- -- check the size of the remainder; if it's bigger than the- -- buffer size then just send it- if m2 >= bUFSIZ- then do- step <- runIteratee $ k' $ Chunks [s2]- case step of- (Yield x r) -> let !z = copy r- in return $! Yield x z- (Error e) -> return $ Error e- (Continue k'') -> return $ Continue $ go 0 k''-- else copyAndCont 0 k' s2 m2------------------------------------------------------------------------------------ | Skip n elements of the stream, if there are that many-drop :: (Monad m) => Int -> Iteratee ByteString m ()-drop k = drop' (toEnum k)----------------------------------------------------------------------------------- | Skip n elements of the stream, if there are that many-drop' :: (Monad m) => Int64 -> Iteratee ByteString m ()-drop' 0 = return ()-drop' !n = continue k-- where- k EOF = return ()- k (Chunks xs) = chunks n xs-- chunks !m [] = drop' m- chunks !m (x:xs) = do- let strlen = toEnum $ S.length x- if strlen <= m- then chunks (m-strlen) xs- else yield () $ Chunks ((S.drop (fromEnum m) x):xs)----------------------------------------------------------------------------------data ShortWriteException = ShortWriteException deriving (Typeable)-data RateTooSlowException = RateTooSlowException deriving (Typeable)-data TooManyBytesReadException = TooManyBytesReadException deriving (Typeable)--instance Show ShortWriteException where- show ShortWriteException = "Short write"--instance Show RateTooSlowException where- show RateTooSlowException = "Input rate too slow"--instance Show TooManyBytesReadException where- show TooManyBytesReadException = "Too many bytes read"--instance Exception ShortWriteException-instance Exception RateTooSlowException-instance Exception TooManyBytesReadException----------------------------------------------------------------------------------take :: (Monad m) => Int -> Enumeratee ByteString ByteString m a-take k = take' (toEnum k)----------------------------------------------------------------------------------take' :: (Monad m) => Int64 -> Enumeratee ByteString ByteString m a-take' _ y@(Yield _ _ ) = return y-take' _ (Error e ) = throwError e-take' !n st@(Continue k) = do- if n == 0- then lift $ runIteratee $ k EOF- else do- mbX <- head- maybe (lift $ runIteratee $ k EOF)- check- mbX-- where- check x | S.null x = take' n st- | strlen <= n = do- newStep <- lift $ runIteratee $ k $ Chunks [x]- take' (n-strlen) newStep- | otherwise = do- step1 <- lift $ runIteratee $ k $ Chunks [s1]- step2 <- lift $ runIteratee $ enumEOF step1-- case step2 of- (Yield v _) -> yield (Yield v EOF) (Chunks [s2])- (Error e) -> throwError e- (Continue _) -> error "divergent iteratee"- where- strlen = toEnum $ S.length x- (s1,s2) = S.splitAt (fromEnum n) x------------------------------------------------------------------------------------ | Reads n bytes from a stream and applies the given iteratee to the stream--- of the read elements. Reads exactly n bytes, and if the stream is short--- propagates an error.-takeExactly :: (Monad m)- => Int64- -> Enumeratee ByteString ByteString m a-takeExactly !n y@(Yield _ _ ) = drop' n >> return y-takeExactly _ (Error e ) = throwError e-takeExactly !n st@(Continue !k) = do- if n == 0- then lift $ runIteratee $ k EOF- else do- mbX <- head- maybe (throwError ShortWriteException)- check- mbX-- where- check !x | S.null x = takeExactly n st- | strlen < n = do- newStep <- lift $ runIteratee $ k $ Chunks [x]- takeExactly (n-strlen) newStep- | otherwise = do- let (s1,s2) = S.splitAt (fromEnum n) x- !step1 <- lift $ runIteratee $ k $ Chunks [s1]- !step2 <- lift $ runIteratee $ enumEOF step1-- case step2 of- (Continue _) -> error "divergent iteratee"- (Error e) -> throwError e- (Yield v _) -> yield (Yield v EOF) (Chunks [s2])-- where- !strlen = toEnum $ S.length x----------------------------------------------------------------------------------takeNoMoreThan :: (Monad m) =>- Int64 -> Enumeratee ByteString ByteString m a-takeNoMoreThan _ y@(Yield _ _) = return y-takeNoMoreThan _ (Error e ) = throwError e-takeNoMoreThan !n st@(Continue k) = do- mbX <- head- maybe (lift $ runIteratee $ k EOF)- check- mbX-- where- check x | S.null x = takeNoMoreThan n st- | strlen <= n = do- newStep <- lift $ runIteratee $ k $ Chunks [x]- takeNoMoreThan (n-strlen) newStep- | otherwise = do- step1 <- lift $ runIteratee $ k $ Chunks [s1]- case step1 of- (Yield v rest) -> yield (Yield v EOF)- (rest `mappend` Chunks [s2])- (Error e) -> throwError e- (Continue _) -> throwError TooManyBytesReadException- where- strlen = toEnum $ S.length x- (s1,s2) = S.splitAt (fromEnum n) x----------------------------------------------------------------------------------{-# INLINE _enumFile #-}-_enumFile :: FilePath- -> Enumerator ByteString IO a-_enumFile fp iter = do- h <- liftIO $ openBinaryFile fp ReadMode- enumHandle 32678 h iter `finally` (liftIO $ hClose h)----------------------------------------------------------------------------------data InvalidRangeException = InvalidRangeException- deriving (Typeable)----------------------------------------------------------------------------------instance Show InvalidRangeException where- show InvalidRangeException = "Invalid range"----------------------------------------------------------------------------------instance Exception InvalidRangeException----------------------------------------------------------------------------------{-# INLINE _enumFilePartial #-}-_enumFilePartial :: FilePath- -> (Int64,Int64)- -> Enumerator ByteString IO a-_enumFilePartial fp (start,end) iter = do- let len = end - start-- bracket (liftIO $ openBinaryFile fp ReadMode)- (liftIO . hClose)- (\h -> do- unless (start == 0) $ liftIO $- hSeek h AbsoluteSeek $ toInteger start- step <- lift $ runIteratee $ joinI $ takeExactly len iter- enumHandle 32678 h step)----------------------------------------------------------------------------------enumFile :: FilePath -> Enumerator ByteString IO a-enumFilePartial :: FilePath- -> (Int64,Int64)- -> Enumerator ByteString IO a---#ifdef PORTABLE--enumFile = _enumFile-enumFilePartial fp rng@(start,end) iter = do- when (end < start) $ throwError InvalidRangeException- _enumFilePartial fp rng iter--#else---- 40MB limit-maxMMapFileSize :: FileOffset-maxMMapFileSize = 41943040----------------------------------------------------------------------------------tooBigForMMap :: FilePath -> IO Bool-tooBigForMMap fp = do- stat <- getFileStatus fp- return $ fileSize stat > maxMMapFileSize----------------------------------------------------------------------------------enumFile _ (Error e) = throwError e-enumFile _ (Yield x _) = yield x EOF-enumFile fp st@(Continue k) = do- -- for small files we'll use mmap to save ourselves a copy, otherwise- -- we'll stream it- tooBig <- lift $ tooBigForMMap fp-- if tooBig- then _enumFile fp st- else do- es <- try $ lift $ unsafeMMapFile fp- case es of- (Left (e :: SomeException)) -> throwError e- (Right s) -> k $ Chunks [s]----------------------------------------------------------------------------------enumFilePartial _ _ (Error e) = throwError e-enumFilePartial _ _ (Yield x _) = yield x EOF-enumFilePartial fp rng@(start,end) st@(Continue k) = do- when (end < start) $ throwError InvalidRangeException-- let len = end - start-- tooBig <- lift $ tooBigForMMap fp-- if tooBig- then _enumFilePartial fp rng st- else do- es <- try $ lift $ unsafeMMapFile fp-- case es of- (Left (e::SomeException)) -> throwError e- (Right s) -> k $ Chunks [ S.take (fromEnum len) $- S.drop (fromEnum start) s ]--#endif----------------------------------------------------------------------------------mapEnum :: (Monad m) =>- (aOut -> aIn)- -> (aIn -> aOut)- -> Enumerator aIn m a- -> Enumerator aOut m a-mapEnum f g enum outStep = do- let z = IL.map g outStep- let p = joinI z- let q = enum $$ p- (I.joinI . IL.map f) $$ q----------------------------------------------------------------------------------mapIter :: (Monad m) =>- (aOut -> aIn)- -> (aIn -> aOut)- -> Iteratee aIn m a- -> Iteratee aOut m a-mapIter f g iter = do- step <- lift $ runIteratee iter- mapStep step- where- -- mapStep :: Step aIn m a -> Iteratee aOut m a- mapStep (Continue k) = continue $ wrapK k- mapStep (Yield x rest) = yield x (fmap g rest)- mapStep (Error e) = throwError e-- -- wrapK :: (Stream aIn -> Iteratee aIn m a)- -- -> (Stream aOut -> Iteratee aOut m a)- wrapK k streamOut = mapIter f g iterIn- where- streamIn = fmap f streamOut- iterIn = k streamIn----------------------------------------------------------------------------------enumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a-enumBuilderToByteString = builderToByteString---------------------------------------------------------------------------------unsafeEnumBuilderToByteString :: MonadIO m- => Enumeratee Builder ByteString m a-unsafeEnumBuilderToByteString =- builderToByteStringWith (reuseBufferStrategy (allocBuffer bufsize))- where- bufsize = (2::Int) ^ (14::Int)---------------------------------------------------------------------------------enumByteStringToBuilder :: MonadIO m => Enumeratee ByteString Builder m a-enumByteStringToBuilder = IL.map fromByteString----------------------------------------------------------------------------------joinI' :: Monad m => Iteratee a m (Step a m b)- -> Iteratee a m b-joinI' outer = outer >>= check where- check (Continue k) = k EOF >>== \s -> case s of- Continue _ -> error "joinI: divergent iteratee"- _ -> check s- check (Yield x r) = yield x r- check (Error e) = throwError e----------------------------------------------------------------------------------killIfTooSlow :: (MonadIO m) =>- m () -- ^ action to bump timeout- -> Double -- ^ minimum data rate, in bytes per- -- second- -> Int -- ^ minimum amount of time to let- -- the iteratee run for- -> Iteratee ByteString m a -- ^ iteratee consumer to wrap- -> Iteratee ByteString m a-killIfTooSlow !bump !minRate !minSeconds' !inputIter = do- !_ <- lift bump- startTime <- liftIO getTime- step <- lift $ runIteratee inputIter- wrap startTime (0::Int64) step-- where- minSeconds = fromIntegral minSeconds'-- wrap !startTime = proc- where- proc !nb (Continue !k) = continue $ cont nb k- proc _ !z = returnI z-- cont _ !k EOF = k EOF- cont !nBytesRead !k !stream = do- let !slen = toEnum $ streamLength stream- now <- liftIO getTime- let !delta = now - startTime- let !newBytes = nBytesRead + slen- when (delta > minSeconds+1 &&- fromIntegral newBytes / (delta-minSeconds) < minRate) $- throwError RateTooSlowException-- -- otherwise bump the timeout and continue running the iteratee- !_ <- lift bump- lift (runIteratee $! k stream) >>= proc newBytes----------------------------------------------------------------------------------getTime :: IO Double-getTime = realToFrac `fmap` getPOSIXTime
src/Snap/Test.hs view
@@ -13,9 +13,13 @@ -- ** Building Requests and testing handlers , buildRequest , runHandler+ , runHandlerM+ , evalHandler+ , evalHandlerM -- *** Convenience functions for generating common types of HTTP requests , get+ , head , postUrlEncoded , postMultipart , put@@ -26,6 +30,7 @@ , addHeader , setContentType , setHeader+ , addCookies , setHttpVersion , setQueryString , setQueryStringRaw@@ -43,13 +48,11 @@ -- * Getting response bodies , getResponseBody - -- * Dumping HTTP Responses- , dumpResponse+ -- * Dumping HTTP Messages+ , requestToString , responseToString ) where -import Snap.Internal.Test.Assertions-import Snap.Internal.Test.RequestBuilder--+import Snap.Internal.Test.Assertions (assert404, assertBodyContains, assertRedirect, assertRedirectTo, assertSuccess, getResponseBody)+import Snap.Internal.Test.RequestBuilder (FileData (..), MultipartParam (..), MultipartParams, RequestBuilder, RequestType (..), addCookies, addHeader, buildRequest, delete, evalHandler, evalHandlerM, get, postMultipart, postRaw, postUrlEncoded, put, requestToString, responseToString, runHandler, runHandlerM, setContentType, setHeader, setHttpVersion, setQueryString, setQueryStringRaw, setRequestPath, setRequestType, setSecure)
− src/Snap/Types.hs
@@ -1,6 +0,0 @@--- | As of Snap 0.6, the "Snap.Types" module is deprecated: please use--- "Snap.Core" instead.-module Snap.Types {-# DEPRECATED "As of 0.6, use Snap.Core instead" #-}- ( module Snap.Core ) where--import Snap.Core
src/Snap/Types/Headers.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} -- | An opaque data type for HTTP headers. Intended to be imported qualified, -- i.e:@@ -26,95 +26,324 @@ -- * Adding/setting headers , insert+ , unsafeInsert , set -- * Deleting , delete -- * Traversal- , fold+ , foldl'+ , foldr+ , foldedFoldl'+ , foldedFoldr -- * Lists , toList , fromList + , unsafeFromCaseFoldedList+ , unsafeToCaseFoldedList+ ) where -import Data.ByteString.Char8 (ByteString)-import Data.CaseInsensitive (CI)-import Data.List (foldl')-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.Maybe (isJust)-import Prelude hiding (null, lookup)+------------------------------------------------------------------------------+import Control.Arrow (first)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import qualified Data.CaseInsensitive.Unsafe as CI+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import Prelude (Bool (..), Eq (..), Maybe (..), Show (..), fst, id, map, otherwise, uncurry, ($), ($!), (.))+------------------------------------------------------------------------------ -------------------------------------------------------------------------------newtype Headers = H { unH :: HashMap (CI ByteString) [ByteString] }+-- | A key-value map that represents a collection of HTTP header fields. Keys+-- are case-insensitive.+newtype Headers = H { unH :: [(ByteString, ByteString)] } deriving (Show) ------------------------------------------------------------------------------+-- | An empty collection of HTTP header fields.+--+-- Example:+--+-- @+-- ghci> H.'empty'+-- H {unH = []}+-- @ empty :: Headers-empty = H (Map.empty)+empty = H [] ------------------------------------------------------------------------------+-- | Is a given collection of HTTP header fields empty?+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'null' H.'empty'+-- True+-- ghci> H.'null' $ H.'fromList' [(\"Host\", \"localhost\")]+-- False+-- @ null :: Headers -> Bool-null = Map.null . unH+null = List.null . unH {-# INLINE null #-} ------------------------------------------------------------------------------+-- | Does this collection of HTTP header fields contain a given field?+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'member' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]+-- True+-- ghci> H.'member' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]+-- False+-- @ member :: CI ByteString -> Headers -> Bool-member k = f . unH+member k0 = f . unH where- f m = isJust $ Map.lookup k m+ k = CI.foldedCase k0+ f m = List.any ((k ==) . fst) m {-# INLINE member #-} -------------------------------------------------------------------------------lookup :: CI ByteString -> Headers -> Maybe [ByteString]-lookup k (H m) = Map.lookup k m+-- | Look up the value of a given HTTP header field.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'lookup' \"host\" $ H.'fromList' [(\"Host\", \"localhost\")]+-- Just \"localhost\"+-- ghci> H.'lookup' \"Accept\" $ H.'fromList' [(\"Host\", \"localhost\")]+-- Nothing+-- @+lookup :: CI ByteString -> Headers -> Maybe ByteString+lookup k (H m) = List.lookup (CI.foldedCase k) m {-# INLINE lookup #-} -------------------------------------------------------------------------------lookupWithDefault :: ByteString -> CI ByteString -> Headers -> [ByteString]-lookupWithDefault d k (H m) = Map.lookupDefault [d] k m+-- | Look up the value of a given HTTP header field or return the provided+-- default value when that header field is not present.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let hdrs = H.'fromList' [(\"Host\", \"localhost\")]+-- ghci> H.'lookupWithDefault' \"host\" \"127.0.0.1\" $ hdrs+-- \"localhost\"+-- ghci> H.'lookupWithDefault' \"Accept\" \"text\/plain\" $ hdrs+-- \"text\/plain\"+-- @+lookupWithDefault :: ByteString -> CI ByteString -> Headers -> ByteString+lookupWithDefault d k m = fromMaybe d $ lookup k m ------------------------------------------------------------------------------+-- | Insert a key-value pair into the headers map. If the key already exists in+-- the map, the values are catenated with ", ".+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let hdrs = H.'insert' \"Accept\" \"text\/plain\" $ H.'empty'+-- ghci> hdrs+-- H {unH = [(\"accept\",\"text\/plain\")]}+-- ghci> H.'insert' \"Accept\" \"text\/html\" $ hdrs+-- H {unH = [(\"accept\",\"text\/plain,text\/html\")]}+-- @ insert :: CI ByteString -> ByteString -> Headers -> Headers-insert k v (H m) = H $ Map.insertWith (flip (++)) k [v] m+insert k0 v (H m) = H $! go id m+ where+ k = CI.foldedCase k0 + go dl [] = dl [(k, v)]+ go dl (z@(x,y):xs) | k == x = dl ((k, concatHeaderValues v y):xs)+ | otherwise = go (dl . (z:)) xs + concatHeaderValues :: ByteString -> ByteString -> ByteString+ concatHeaderValues new old = S.concat [old, ",", new]++ ------------------------------------------------------------------------------+-- | Insert a key-value pair into the headers map, without checking whether the+-- header already exists. The key /must/ be already case-folded, or none of the+-- lookups will work!+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let hdrs = H.'unsafeInsert' \"accept\" \"text\/plain\" $ H.'empty'+-- ghci> hdrs+-- H {unH = [(\"accept\",\"text\/plain\")]}+-- ghci> let hdrs' = H.'unsafeInsert' \"accept\" \"text\/html\" $ hdrs+-- ghci> hdrs'+-- H {unH = [(\"accept\",\"text\/html\"), (\"accept\",\"text\/plain\")]}+-- ghci> H.'lookup' \"accept\" hdrs'+-- Just \"text\/html\"+-- @+unsafeInsert :: ByteString -> ByteString -> Headers -> Headers+unsafeInsert k v (H hdrs) = H ((k,v):hdrs)+++------------------------------------------------------------------------------+-- | Set the value of a HTTP header field to a given value, replacing the old+-- value.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'set' \"accept\" \"text\/plain\" $ H.'empty'+-- H {unH = [(\"accept\",\"text\/plain\")]}+-- ghci> H.'set' \"accept\" \"text\/html\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]+-- H {unH = [(\"accept\",\"text\/html\")]}+-- @ set :: CI ByteString -> ByteString -> Headers -> Headers-set k v (H m) = H $ Map.insert k [v] m+set k0 v (H m) = H $ go m+ where+ k = CI.foldedCase k0 + go [] = [(k,v)]+ go (x@(k',_):xs) | k == k' = (k,v) : List.filter ((k /=) . fst) xs+ | otherwise = x : go xs + ------------------------------------------------------------------------------+-- | Delete all key-value pairs associated with the given key from the headers+-- map.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'delete' \"accept\" $ H.'fromList' [(\"Accept\", \"text\/plain\")]+-- H {unH = []}+-- @ delete :: CI ByteString -> Headers -> Headers-delete k (H m) = H $ Map.delete k m+delete k (H m) = H $ List.filter ((k' /=) . fst) m+ where+ k' = CI.foldedCase k -------------------------------------------------------------------------------fold :: (a -> CI ByteString -> [ByteString] -> a)- -> a- -> Headers- -> a-fold f a (H m) = Map.foldlWithKey' f a m+-- | Strict left fold over all key-value pairs in the headers map.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import "Data.Monoid"+-- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]+-- ghci> let f (cntr, acc) _ val = (cntr+1, val <> \";\" <> acc)+-- ghci> H.'foldl'' f (0, \"\") hdrs+-- (2,\"text\/html;text\/plain;\")+-- @+foldl' :: (a -> CI ByteString -> ByteString -> a)+ -> a+ -> Headers+ -> a+foldl' f a (H m) = List.foldl' f' a m+ where+ f' v (x,y) = f v (CI.unsafeMk x) y -------------------------------------------------------------------------------toList :: Headers -> [(CI ByteString, ByteString)]-toList (H m) = (Map.foldlWithKey' f id m) []+-- | Same as 'foldl'', but the key parameter is of type 'ByteString' instead of+-- 'CI' 'ByteString'. The key is case-folded (lowercase).+foldedFoldl' :: (a -> ByteString -> ByteString -> a)+ -> a+ -> Headers+ -> a+foldedFoldl' f a (H m) = List.foldl' f' a m where- f !dl k vs = dl . ((map (\v -> (k,v)) vs) ++)+ f' v (x,y) = f v x y -------------------------------------------------------------------------------fromList :: [(CI ByteString, ByteString)] -> Headers-fromList = foldl' f empty+-- | Right fold over all key-value pairs in the headers map.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import "Data.Monoid"+-- ghci> let hdrs = H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]+-- ghci> let f _ val (cntr, acc) = (cntr+1, val <> \";\" <> acc)+-- ghci> H.'foldr' f (0, \"\") hdrs+-- (2,\"text\/plain;text\/html;\")+-- @+foldr :: (CI ByteString -> ByteString -> a -> a)+ -> a+ -> Headers+ -> a+foldr f a (H m) = List.foldr f' a m where- f m (k,v) = insert k v m+ f' (x, y) v = f (CI.unsafeMk x) y v+++------------------------------------------------------------------------------+-- | Same as 'foldr', but the key parameter is of type 'ByteString' instead of+-- 'CI' 'ByteString'. The key is case-folded (lowercase).+foldedFoldr :: (ByteString -> ByteString -> a -> a)+ -> a+ -> Headers+ -> a+foldedFoldr f a (H m) = List.foldr (uncurry f) a m+++------------------------------------------------------------------------------+-- | Convert a 'Headers' value to a list of key-value pairs.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> let l = [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]+-- ghci> H.'toList' . H.'fromList' $ l+-- [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]+-- @+toList :: Headers -> [(CI ByteString, ByteString)]+toList = map (first CI.unsafeMk) . unH+++------------------------------------------------------------------------------+-- | Build a 'Headers' value from a list of key-value pairs.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> H.'fromList' [(\"Accept\", \"text\/plain\"), (\"Accept\", \"text\/html\")]+-- H {unH = [(\"accept\",\"text\/plain\"),(\"accept\",\"text\/html\")]}+-- @+fromList :: [(CI ByteString, ByteString)] -> Headers+fromList = H . map (first CI.foldedCase)+++------------------------------------------------------------------------------+-- | Like 'fromList', but the keys are assumed to be already case-folded (in+-- lowercase).+unsafeFromCaseFoldedList :: [(ByteString, ByteString)] -> Headers+unsafeFromCaseFoldedList = H+++------------------------------------------------------------------------------+-- | Like 'toList', but does not convert the keys to 'CI' 'ByteString', so key+-- comparisons will be case-sensitive.+unsafeToCaseFoldedList :: Headers -> [(ByteString, ByteString)]+unsafeToCaseFoldedList = unH
+ src/Snap/Util/CORS.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Add <http://www.w3.org/TR/cors/ CORS> (cross-origin resource sharing)+-- headers to a Snap application. CORS headers can be added either conditionally+-- or unconditionally to the entire site, or you can apply CORS headers to a+-- single route.+--+-- To use in a snaplet, simply use 'wrapSite':+--+-- @+-- wrapSite $ applyCORS defaultOptions+-- @+module Snap.Util.CORS+ ( -- * Applying CORS to a specific response+ applyCORS++ -- * Option Specification+ , CORSOptions(..)+ , defaultOptions++ -- ** Origin lists+ , OriginList(..)+ , OriginSet, mkOriginSet, origins++ -- * Internals+ , HashableURI(..), HashableMethod (..)+ ) where++import Control.Applicative+import Control.Monad (join, when)+import Data.CaseInsensitive (CI)+import Data.Hashable (Hashable(..))+import Data.Maybe (fromMaybe)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.URI (URI (..), URIAuth (..), parseURI)++import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.ByteString.Char8 as S+import qualified Data.CaseInsensitive as CI+import qualified Data.HashSet as HashSet+import qualified Data.Text as Text++import qualified Snap.Core as Snap+import Snap.Internal.Parsing (pTokens)++-- | A set of origins. RFC 6454 specifies that origins are a scheme, host and+-- port, so the 'OriginSet' wrapper around a 'HashSet.HashSet' ensures that each+-- 'URI' constists of nothing more than this.+newtype OriginSet = OriginSet { origins :: HashSet.HashSet HashableURI }++-- | Used to specify the contents of the @Access-Control-Allow-Origin@ header.+data OriginList+ = Everywhere+ -- ^ Allow any origin to access this resource. Corresponds to+ -- @Access-Control-Allow-Origin: *@+ | Nowhere+ -- ^ Do not allow cross-origin requests+ | Origins OriginSet+ -- ^ Allow cross-origin requests from these origins.++-- | Specify the options to use when building CORS headers for a response. Most+-- of these options are 'Snap.Handler' actions to allow you to conditionally+-- determine the setting of each header.+data CORSOptions m = CORSOptions+ { corsAllowOrigin :: m OriginList+ -- ^ Which origins are allowed to make cross-origin requests.++ , corsAllowCredentials :: m Bool+ -- ^ Whether or not to allow exposing the response when the omit credentials+ -- flag is unset.++ , corsExposeHeaders :: m (HashSet.HashSet (CI S.ByteString))+ -- ^ A list of headers that are exposed to clients. This allows clients to+ -- read the values of these headers, if the response includes them.++ , corsAllowedMethods :: m (HashSet.HashSet HashableMethod)+ -- ^ A list of request methods that are allowed.++ , corsAllowedHeaders :: HashSet.HashSet S.ByteString -> m (HashSet.HashSet S.ByteString)+ -- ^ An action to determine which of the request headers are allowed.+ -- This action is supplied the parsed contents of+ -- @Access-Control-Request-Headers@.+ }++-- | Liberal default options. Specifies that:+--+-- * All origins may make cross-origin requests+-- * @allow-credentials@ is true.+-- * No extra headers beyond simple headers are exposed.+-- * @GET@, @POST@, @PUT@, @DELETE@ and @HEAD@ are all allowed.+-- * All request headers are allowed.+--+-- All options are determined unconditionally.+defaultOptions :: Monad m => CORSOptions m+defaultOptions = CORSOptions+ { corsAllowOrigin = return Everywhere+ , corsAllowCredentials = return True+ , corsExposeHeaders = return HashSet.empty+ , corsAllowedMethods = return $! defaultAllowedMethods+ , corsAllowedHeaders = return+ }++defaultAllowedMethods :: HashSet.HashSet HashableMethod+defaultAllowedMethods = HashSet.fromList $ map HashableMethod+ [ Snap.GET, Snap.POST, Snap.PUT, Snap.DELETE, Snap.HEAD ]+++-- | Apply CORS headers to a specific request. This is useful if you only have+-- a single action that needs CORS headers, and you don't want to pay for+-- conditional checks on every request.+--+-- You should note that 'applyCORS' needs to be used before you add any+-- 'Snap.method' combinators. For example, the following won't do what you want:+--+-- > method POST $ applyCORS defaultOptions $ myHandler+--+-- This fails to work as CORS requires an @OPTIONS@ request in the preflighting+-- stage, but this would get filtered out. Instead, use+--+-- > applyCORS defaultOptions $ method POST $ myHandler+applyCORS :: Snap.MonadSnap m => CORSOptions m -> m () -> m ()+applyCORS options m =+ (join . fmap decodeOrigin <$> getHeader "Origin") >>= maybe m corsRequestFrom++ where+ corsRequestFrom origin = do+ originList <- corsAllowOrigin options+ if origin `inOriginList` originList+ then Snap.method Snap.OPTIONS (preflightRequestFrom origin)+ <|> handleRequestFrom origin+ else m++ preflightRequestFrom origin = do+ maybeMethod <- fmap (parseMethod . S.unpack) <$>+ getHeader "Access-Control-Request-Method"++ case maybeMethod of+ Nothing -> m++ Just method -> do+ allowedMethods <- corsAllowedMethods options++ if method `HashSet.member` allowedMethods+ then do+ maybeHeaders <-+ fromMaybe (Just HashSet.empty) . fmap splitHeaders+ <$> getHeader "Access-Control-Request-Headers"++ case maybeHeaders of+ Nothing -> m+ Just headers -> do+ allowedHeaders <- corsAllowedHeaders options headers++ if not $ HashSet.null $+ headers `HashSet.difference` allowedHeaders+ then m+ else do+ addAccessControlAllowOrigin origin+ addAccessControlAllowCredentials++ commaSepHeader+ "Access-Control-Allow-Headers"+ id (HashSet.toList allowedHeaders)++ commaSepHeader+ "Access-Control-Allow-Methods"+ (S.pack . show) (HashSet.toList allowedMethods)++ else m++ handleRequestFrom origin = do+ addAccessControlAllowOrigin origin+ addAccessControlAllowCredentials++ exposeHeaders <- corsExposeHeaders options+ when (not $ HashSet.null exposeHeaders) $+ commaSepHeader+ "Access-Control-Expose-Headers"+ CI.original (HashSet.toList exposeHeaders)++ m++ addAccessControlAllowOrigin origin =+ addHeader "Access-Control-Allow-Origin"+ (encodeUtf8 $ Text.pack $ show origin)++ addAccessControlAllowCredentials = do+ allowCredentials <- corsAllowCredentials options+ when (allowCredentials) $+ addHeader "Access-Control-Allow-Credentials" "true"++ decodeOrigin :: S.ByteString -> Maybe URI+ decodeOrigin = fmap simplifyURI . parseURI . Text.unpack . decodeUtf8++ addHeader k v = Snap.modifyResponse (Snap.addHeader k v)++ commaSepHeader k f vs =+ case vs of+ [] -> return ()+ _ -> addHeader k $ S.intercalate ", " (map f vs)++ getHeader = Snap.getsRequest . Snap.getHeader++ splitHeaders = either (const Nothing) (Just . HashSet.fromList) .+ Attoparsec.parseOnly pTokens++mkOriginSet :: [URI] -> OriginSet+mkOriginSet = OriginSet . HashSet.fromList .+ map (HashableURI . simplifyURI)++simplifyURI :: URI -> URI+simplifyURI uri = uri { uriAuthority =+ fmap simplifyURIAuth (uriAuthority uri)+ , uriPath = ""+ , uriQuery = ""+ , uriFragment = ""+ }+ where simplifyURIAuth auth = auth { uriUserInfo = "" }++--------------------------------------------------------------------------------+parseMethod :: String -> HashableMethod+parseMethod "GET" = HashableMethod Snap.GET+parseMethod "POST" = HashableMethod Snap.POST+parseMethod "HEAD" = HashableMethod Snap.HEAD+parseMethod "PUT" = HashableMethod Snap.PUT+parseMethod "DELETE" = HashableMethod Snap.DELETE+parseMethod "TRACE" = HashableMethod Snap.TRACE+parseMethod "OPTIONS" = HashableMethod Snap.OPTIONS+parseMethod "CONNECT" = HashableMethod Snap.CONNECT+parseMethod "PATCH" = HashableMethod Snap.PATCH+parseMethod s = HashableMethod $ Snap.Method (S.pack s)++--------------------------------------------------------------------------------+-- | A @newtype@ over 'URI' with a 'Hashable' instance.+newtype HashableURI = HashableURI URI+ deriving (Eq)++instance Show HashableURI where+ show (HashableURI u) = show u++instance Hashable HashableURI where+ hashWithSalt s (HashableURI (URI scheme authority path query fragment)) =+ s `hashWithSalt`+ scheme `hashWithSalt`+ fmap hashAuthority authority `hashWithSalt`+ path `hashWithSalt`+ query `hashWithSalt`+ fragment++ where+ hashAuthority (URIAuth userInfo regName port) =+ s `hashWithSalt`+ userInfo `hashWithSalt`+ regName `hashWithSalt`+ port++inOriginList :: URI -> OriginList -> Bool+_ `inOriginList` Nowhere = False+_ `inOriginList` Everywhere = True+origin `inOriginList` (Origins (OriginSet xs)) =+ HashableURI origin `HashSet.member` xs+++--------------------------------------------------------------------------------+newtype HashableMethod = HashableMethod Snap.Method+ deriving (Eq)++instance Hashable HashableMethod where+ hashWithSalt s (HashableMethod Snap.GET) = s `hashWithSalt` (0 :: Int)+ hashWithSalt s (HashableMethod Snap.HEAD) = s `hashWithSalt` (1 :: Int)+ hashWithSalt s (HashableMethod Snap.POST) = s `hashWithSalt` (2 :: Int)+ hashWithSalt s (HashableMethod Snap.PUT) = s `hashWithSalt` (3 :: Int)+ hashWithSalt s (HashableMethod Snap.DELETE) = s `hashWithSalt` (4 :: Int)+ hashWithSalt s (HashableMethod Snap.TRACE) = s `hashWithSalt` (5 :: Int)+ hashWithSalt s (HashableMethod Snap.OPTIONS) = s `hashWithSalt` (6 :: Int)+ hashWithSalt s (HashableMethod Snap.CONNECT) = s `hashWithSalt` (7 :: Int)+ hashWithSalt s (HashableMethod Snap.PATCH) = s `hashWithSalt` (8 :: Int)+ hashWithSalt s (HashableMethod (Snap.Method m)) =+ s `hashWithSalt` (9 :: Int) `hashWithSalt` m++instance Show HashableMethod where+ show (HashableMethod m) = show m
src/Snap/Util/FileServe.hs view
@@ -1,712 +1,47 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}- -- | Contains web handlers to serve files from a directory.-module Snap.Util.FileServe-(- getSafePath- -- * Configuration for directory serving-, MimeMap-, HandlerMap-, DirectoryConfig(..)-, simpleDirectoryConfig-, defaultDirectoryConfig-, fancyDirectoryConfig-, defaultIndexGenerator-, defaultMimeTypes-, fileType- -- * File servers-, serveDirectory-, serveDirectoryWith-, serveFile-, serveFileAs-) where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-import Control.Applicative-import Control.Exception (SomeException, evaluate)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans-import Data.Attoparsec.Char8-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Char8 (ByteString)-import Data.ByteString.Internal (c2w)-import Data.Int-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe, isNothing)-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Prelude hiding (catch, show, Show)-import qualified Prelude-import System.Directory-import System.FilePath-import System.PosixCompat.Files--------------------------------------------------------------------------------import Snap.Core-import Snap.Internal.Debug-import Snap.Internal.Parsing-import Snap.Iteratee hiding (drop)------------------------------------------------------------------------------------ | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is--- safe to use for opening files. A path is safe if it is a relative path--- and has no ".." elements to escape the intended directory structure.-getSafePath :: MonadSnap m => m FilePath-getSafePath = do- req <- getRequest- let mp = urlDecode $ rqPathInfo req-- p <- maybe pass (return . S.unpack) mp-- -- relative paths only!- when (not $ isRelative p) pass-- -- check that we don't have any sneaky .. paths- let dirs = splitDirectories p- when (elem ".." dirs) pass-- return $ joinPath dirs------------------------------------------------------------------------------------ | A type alias for dynamic handlers-type HandlerMap m = Map FilePath (FilePath -> m ())------------------------------------------------------------------------------------ | A type alias for MIME type-type MimeMap = Map FilePath ByteString------------------------------------------------------------------------------------ | The default set of mime type mappings we use when serving files. Its--- value: ----- > Map.fromList [--- > ( ".asc" , "text/plain" ),--- > ( ".asf" , "video/x-ms-asf" ),--- > ( ".asx" , "video/x-ms-asf" ),--- > ( ".avi" , "video/x-msvideo" ),--- > ( ".bz2" , "application/x-bzip" ),--- > ( ".c" , "text/plain" ),--- > ( ".class" , "application/octet-stream" ),--- > ( ".conf" , "text/plain" ),--- > ( ".cpp" , "text/plain" ),--- > ( ".css" , "text/css" ),--- > ( ".cxx" , "text/plain" ),--- > ( ".dtd" , "text/xml" ),--- > ( ".dvi" , "application/x-dvi" ),--- > ( ".gif" , "image/gif" ),--- > ( ".gz" , "application/x-gzip" ),--- > ( ".hs" , "text/plain" ),--- > ( ".htm" , "text/html" ),--- > ( ".html" , "text/html" ),--- > ( ".jar" , "application/x-java-archive" ),--- > ( ".jpeg" , "image/jpeg" ),--- > ( ".jpg" , "image/jpeg" ),--- > ( ".js" , "text/javascript" ),--- > ( ".json" , "application/json" ),--- > ( ".log" , "text/plain" ),--- > ( ".m3u" , "audio/x-mpegurl" ),--- > ( ".mov" , "video/quicktime" ),--- > ( ".mp3" , "audio/mpeg" ),--- > ( ".mpeg" , "video/mpeg" ),--- > ( ".mpg" , "video/mpeg" ),--- > ( ".ogg" , "application/ogg" ),--- > ( ".pac" , "application/x-ns-proxy-autoconfig" ),--- > ( ".pdf" , "application/pdf" ),--- > ( ".png" , "image/png" ),--- > ( ".ps" , "application/postscript" ),--- > ( ".qt" , "video/quicktime" ),--- > ( ".sig" , "application/pgp-signature" ),--- > ( ".spl" , "application/futuresplash" ),--- > ( ".svg" , "image/svg+xml" ),--- > ( ".swf" , "application/x-shockwave-flash" ),--- > ( ".tar" , "application/x-tar" ),--- > ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),--- > ( ".tar.gz" , "application/x-tgz" ),--- > ( ".tbz" , "application/x-bzip-compressed-tar" ),--- > ( ".text" , "text/plain" ),--- > ( ".tgz" , "application/x-tgz" ),--- > ( ".torrent" , "application/x-bittorrent" ),--- > ( ".txt" , "text/plain" ),--- > ( ".wav" , "audio/x-wav" ),--- > ( ".wax" , "audio/x-ms-wax" ),--- > ( ".wma" , "audio/x-ms-wma" ),--- > ( ".wmv" , "video/x-ms-wmv" ),--- > ( ".xbm" , "image/x-xbitmap" ),--- > ( ".xml" , "text/xml" ),--- > ( ".xpm" , "image/x-xpixmap" ),--- > ( ".xwd" , "image/x-xwindowdump" ),--- > ( ".zip" , "application/zip" ) ]+-- Example usage: ---defaultMimeTypes :: MimeMap-defaultMimeTypes = Map.fromList [- ( ".asc" , "text/plain" ),- ( ".asf" , "video/x-ms-asf" ),- ( ".asx" , "video/x-ms-asf" ),- ( ".avi" , "video/x-msvideo" ),- ( ".bz2" , "application/x-bzip" ),- ( ".c" , "text/plain" ),- ( ".class" , "application/octet-stream" ),- ( ".conf" , "text/plain" ),- ( ".cpp" , "text/plain" ),- ( ".css" , "text/css" ),- ( ".cxx" , "text/plain" ),- ( ".dtd" , "text/xml" ),- ( ".dvi" , "application/x-dvi" ),- ( ".gif" , "image/gif" ),- ( ".gz" , "application/x-gzip" ),- ( ".hs" , "text/plain" ),- ( ".htm" , "text/html" ),- ( ".html" , "text/html" ),- ( ".jar" , "application/x-java-archive" ),- ( ".jpeg" , "image/jpeg" ),- ( ".jpg" , "image/jpeg" ),- ( ".js" , "text/javascript" ),- ( ".json" , "application/json" ),- ( ".log" , "text/plain" ),- ( ".m3u" , "audio/x-mpegurl" ),- ( ".mov" , "video/quicktime" ),- ( ".mp3" , "audio/mpeg" ),- ( ".mpeg" , "video/mpeg" ),- ( ".mpg" , "video/mpeg" ),- ( ".ogg" , "application/ogg" ),- ( ".pac" , "application/x-ns-proxy-autoconfig" ),- ( ".pdf" , "application/pdf" ),- ( ".png" , "image/png" ),- ( ".ps" , "application/postscript" ),- ( ".qt" , "video/quicktime" ),- ( ".sig" , "application/pgp-signature" ),- ( ".spl" , "application/futuresplash" ),- ( ".svg" , "image/svg+xml" ),- ( ".swf" , "application/x-shockwave-flash" ),- ( ".tar" , "application/x-tar" ),- ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),- ( ".tar.gz" , "application/x-tgz" ),- ( ".tbz" , "application/x-bzip-compressed-tar" ),- ( ".text" , "text/plain" ),- ( ".tgz" , "application/x-tgz" ),- ( ".torrent" , "application/x-bittorrent" ),- ( ".ttf" , "application/x-font-truetype" ),- ( ".txt" , "text/plain" ),- ( ".wav" , "audio/x-wav" ),- ( ".wax" , "audio/x-ms-wax" ),- ( ".wma" , "audio/x-ms-wma" ),- ( ".wmv" , "video/x-ms-wmv" ),- ( ".xbm" , "image/x-xbitmap" ),- ( ".xml" , "text/xml" ),- ( ".xpm" , "image/x-xpixmap" ),- ( ".xwd" , "image/x-xwindowdump" ),- ( ".zip" , "application/zip" ) ]------------------------------------------------------------------------------------ | A collection of options for serving static files out of a directory.-data DirectoryConfig m = DirectoryConfig {- -- | Files to look for when a directory is requested (e.g., index.html)- indexFiles :: [FilePath],-- -- | Handler to generate a directory listing if there is no index.- indexGenerator :: FilePath -> m (),-- -- | Map of extensions to pass to dynamic file handlers. This could be- -- used, for example, to implement CGI dispatch, pretty printing of source- -- code, etc.- dynamicHandlers :: HandlerMap m,-- -- | MIME type map to look up content types.- mimeTypes :: MimeMap,-- -- | Handler that is called before a file is served. It will only be- -- called when a file is actually found, not for generated index pages.- preServeHook :: FilePath -> m ()- }------------------------------------------------------------------------------------ | Style information for the default directory index generator.-snapIndexStyles :: ByteString-snapIndexStyles =- S.intercalate "\n"- [ "body { margin: 0px 0px 0px 0px; font-family: sans-serif }"- , "div.header {"- , "padding: 40px 40px 0px 40px; height:35px;"- , "background:rgb(25,50,87);"- , "background-image:-webkit-gradient("- , "linear,left bottom,left top,"- , "color-stop(0.00, rgb(31,62,108)),"- , "color-stop(1.00, rgb(19,38,66)));"- , "background-image:-moz-linear-gradient("- , "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"- , "text-shadow:-1px 3px 1px rgb(16,33,57);"- , "font-size:16pt; letter-spacing: 2pt; color:white;"- , "border-bottom:10px solid rgb(46,93,156) }"- , "div.content {"- , "background:rgb(255,255,255);"- , "background-image:-webkit-gradient("- , "linear,left bottom, left top,"- , "color-stop(0.50, rgb(255,255,255)),"- , "color-stop(1.00, rgb(224,234,247)));"- , "background-image:-moz-linear-gradient("- , "center bottom, white 50%, rgb(224,234,247) 100%);"- , "padding: 40px 40px 40px 40px }"- , "div.footer {"- , "padding: 16px 0px 10px 10px; height:31px;"- , "border-top: 1px solid rgb(194,209,225);"- , "color: rgb(160,172,186); font-size:10pt;"- , "background: rgb(245,249,255) }"- , "table { max-width:100%; margin: 0 auto;" `S.append`- " border-collapse: collapse; }"- , "tr:hover { background:rgb(256,256,224) }"- , "td { border:0; font-family:monospace; padding: 2px 0; }"- , "td.filename, td.type { padding-right: 2em; }"- , "th { border:0; background:rgb(28,56,97);"- , "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"- ]------------------------------------------------------------------------------------ | An automatic index generator, which is fairly small and does not rely on--- any external files (which may not be there depending on external request--- routing).+-- @+-- {-# LANGUAGE OverloadedStrings #-} ----- A 'MimeMap' is passed in to display the types of files in the directory--- listing based on their extension. Preferably, this is the same as the map--- in the 'DirectoryConfig'+-- module Main where ----- The styles parameter allows you to apply styles to the directory listing.--- The listing itself consists of a table, containing a header row using--- th elements, and one row per file using td elements, so styles for those--- pieces may be attached to the appropriate tags.-defaultIndexGenerator :: MonadSnap m- => MimeMap -- ^ MIME type mapping for reporting types- -> ByteString -- ^ Style info to insert in header- -> FilePath -- ^ Directory to generate index for- -> m ()-defaultIndexGenerator mm styles d = do- modifyResponse $ setContentType "text/html; charset=utf-8"- rq <- getRequest-- let uri = uriWithoutQueryString rq- let pInfo = rqPathInfo rq-- writeBS "<!DOCTYPE html>\n<html>\n<head>"- writeBS "<title>Directory Listing: "- writeBS uri- writeBS "</title>"- writeBS "<style type='text/css'>"- writeBS styles- writeBS "</style></head><body>"- writeBS "<div class=\"header\">Directory Listing: "- writeBS uri- writeBS "</div><div class=\"content\">"- writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"- writeBS "</th></tr>"-- when (pInfo /= "") $- writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"-- entries <- liftIO $ getDirectoryContents d- dirs <- liftIO $ filterM (doesDirectoryExist . (d </>)) entries- files <- liftIO $ filterM (doesFileExist . (d </>)) entries-- forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f0 -> do- f <- liftIO $ liftM (\s -> T.encodeUtf8 s `mappend` "/") $ packFn f0- writeBS "<tr><td class='filename'><a href='"- writeBS f- writeBS "/'>"- writeBS f- writeBS "</a></td><td class='type' colspan=2>DIR</td></tr>"-- forM_ (sort files) $ \f0 -> do- f <- liftIO $ liftM T.encodeUtf8 $ packFn f0- stat <- liftIO $ getFileStatus (d </> f0)- tm <- liftIO $ formatHttpTime (modificationTime stat)- writeBS "<tr><td class='filename'><a href='"- writeBS f- writeBS "'>"- writeBS f- writeBS "</a></td><td class='type'>"- writeBS (fileType mm f0)- writeBS "</td><td>"- writeBS tm- writeBS "</tr>"-- writeBS "</table></div><div class=\"footer\">Powered by "- writeBS "<b><a href=\"http://snapframework.com\">Snap</a></b></div>"- writeBS "</body>"- where- packFn fp = do- tryFirst [ T.decodeUtf8- , T.decodeUtf16LE- , T.decodeUtf16BE- , T.decodeUtf32LE- , T.decodeUtf32BE- , const (T.pack fp) ]- where- tryFirst [] = error "No valid decoding"- tryFirst (f:fs) =- evaluate (f bs) `catch` \(_::SomeException) -> tryFirst fs-- bs = S.pack fp----------------------------------------------------------------------------------- | A very simple configuration for directory serving. This configuration--- uses built-in MIME types from 'defaultMimeTypes', and has no index files,--- index generator, dynamic file handlers, or 'preServeHook'.-simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m-simpleDirectoryConfig = DirectoryConfig {- indexFiles = [],- indexGenerator = const pass,- dynamicHandlers = Map.empty,- mimeTypes = defaultMimeTypes,- preServeHook = const $ return ()- }------------------------------------------------------------------------------------ | A reasonable default configuration for directory serving. This--- configuration uses built-in MIME types from 'defaultMimeTypes', serves--- common index files @index.html@ and @index.htm@, but does not autogenerate--- directory indexes, nor have any dynamic file handlers. The 'preServeHook'--- will not do anything.-defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m-defaultDirectoryConfig = DirectoryConfig {- indexFiles = ["index.html", "index.htm"],- indexGenerator = const pass,- dynamicHandlers = Map.empty,- mimeTypes = defaultMimeTypes,- preServeHook = const $ return ()- }------------------------------------------------------------------------------------ | A more elaborate configuration for file serving. This configuration--- uses built-in MIME types from 'defaultMimeTypes', serves common index files--- @index.html@ and @index.htm@, and autogenerates directory indexes with a--- Snap-like feel. It still has no dynamic file handlers, nor 'preServeHook',--- which should be added as needed.+-- import "Snap.Core" (Snap, route)+-- import "Snap.Http.Server" (quickHttpServe)+-- import "Snap.Util.FileServe" ----- Files recognized as indexes include @index.html@, @index.htm@,--- @default.html@, @default.htm@, @home.html@-fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m-fancyDirectoryConfig = DirectoryConfig {- indexFiles = ["index.html", "index.htm"],- indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,- dynamicHandlers = Map.empty,- mimeTypes = defaultMimeTypes,- preServeHook = const $ return ()- }------------------------------------------------------------------------------------ | Serves static files from a directory using the default configuration--- as given in 'defaultDirectoryConfig'.-serveDirectory :: MonadSnap m- => FilePath -- ^ Directory to serve from- -> m ()-serveDirectory = serveDirectoryWith defaultDirectoryConfig-{-# INLINE serveDirectory #-}------------------------------------------------------------------------------------ | Serves static files from a directory. Configuration options are--- passed in a 'DirectoryConfig' that captures various choices about desired--- behavior. The relative path given in 'rqPathInfo' is searched for a--- requested file, and the file is served with the appropriate mime type if it--- is found. Absolute paths and \"@..@\" are prohibited to prevent files from--- being served from outside the sandbox.-serveDirectoryWith :: MonadSnap m- => DirectoryConfig m -- ^ Configuration options- -> FilePath -- ^ Directory to serve from- -> m ()-serveDirectoryWith cfg base = do- b <- directory <|> file <|> redir- when (not b) pass-- where-- idxs = indexFiles cfg- generate = indexGenerator cfg- mimes = mimeTypes cfg- dyns = dynamicHandlers cfg- pshook = preServeHook cfg-- -- Serves a file if it exists; passes if not- serve f = do- liftIO (doesFileExist f) >>= flip unless pass- let fname = takeFileName f- let staticServe f' = pshook f >> serveFileAs (fileType mimes fname) f'- lookupExt staticServe dyns fname f >> return True <|> return False-- -- Serves a directory via indices if available. Returns True on success,- -- False on failure to find an index. Passes /only/ if the request was- -- not for a directory (no trailing slash).- directory = do- rq <- getRequest- let uri = uriWithoutQueryString rq- unless ("/" `S.isSuffixOf` uri) pass- rel <- (base </>) <$> getSafePath- b <- liftIO $ doesDirectoryExist rel- if b then do let serveRel f = serve (rel </> f)- foldl' (<|>) pass (Prelude.map serveRel idxs)- <|> (generate rel >> return True)- <|> return False- else return False-- -- Serves a file requested by name. Passes if the file doesn't exist.- file = serve =<< ((base </>) <$> getSafePath)-- -- If the request is for a directory but lacks a trailing slash, redirects- -- to the directory name with a trailing slash.- redir = do- rel <- (base </>) <$> getSafePath- liftIO (doesDirectoryExist rel) >>= flip unless pass- rq <- getRequest- let uri = uriWithoutQueryString rq- let qss = queryStringSuffix rq- let u = S.concat [uri, "/", qss]- redirect u------------------------------------------------------------------------------------ | Serves a single file specified by a full or relative path. If the file--- does not exist, throws an exception (not that it does /not/ pass to the--- next handler). The path restrictions on 'serveDirectory' don't apply to--- this function since the path is not being supplied by the user.-serveFile :: MonadSnap m- => FilePath -- ^ path to file- -> m ()-serveFile fp = serveFileAs (fileType defaultMimeTypes (takeFileName fp)) fp-{-# INLINE serveFile #-}------------------------------------------------------------------------------------ | Same as 'serveFile', with control over the MIME mapping used.-serveFileAs :: MonadSnap m- => ByteString -- ^ MIME type- -> FilePath -- ^ path to file- -> m ()-serveFileAs mime fp = do- reqOrig <- getRequest-- -- If-Range header must be ignored if there is no Range: header in the- -- request (RFC 2616 section 14.27)- let req = if isNothing $ getHeader "range" reqOrig- then deleteHeader "if-range" reqOrig- else reqOrig-- -- check "If-Modified-Since" and "If-Range" headers- let mbH = getHeader "if-modified-since" req- mbIfModified <- liftIO $ case mbH of- Nothing -> return Nothing- (Just s) -> liftM Just $ parseHttpTime s-- -- If-Range header could contain an entity, but then parseHttpTime will- -- fail and return 0 which means a 200 response will be generated anyways- mbIfRange <- liftIO $ case getHeader "if-range" req of- Nothing -> return Nothing- (Just s) -> liftM Just $ parseHttpTime s-- dbg $ "mbIfModified: " ++ Prelude.show mbIfModified- dbg $ "mbIfRange: " ++ Prelude.show mbIfRange-- -- check modification time and bug out early if the file is not modified.- --- -- TODO: a stat cache would be nice here, but it'd need the date thread- -- stuff from snap-server to be folded into snap-core- filestat <- liftIO $ getFileStatus fp- let mt = modificationTime filestat- maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified-- let sz = fromIntegral $ fileSize filestat- lm <- liftIO $ formatHttpTime mt-- -- ok, at this point we know the last-modified time and the- -- content-type. set those.- modifyResponse $ setHeader "Last-Modified" lm- . setHeader "Accept-Ranges" "bytes"- . setContentType mime--- -- now check: is this a range request? If there is an 'If-Range' header- -- with an old modification time we skip this check and send a 200- -- response- let skipRangeCheck = maybe (False)- (\lt -> mt > lt)- mbIfRange-- -- checkRangeReq checks for a Range: header in the request and sends a- -- partial response if it matches.- wasRange <- if skipRangeCheck- then return False- else liftSnap $ checkRangeReq req fp sz-- dbg $ "was this a range request? " ++ Prelude.show wasRange-- -- if we didn't have a range request, we just do normal sendfile- unless wasRange $ do- modifyResponse $ setResponseCode 200- . setContentLength sz- liftSnap $ sendFile fp-- where- --------------------------------------------------------------------------- notModified = finishWith $- setResponseCode 304 emptyResponse----------------------------------------------------------------------------------lookupExt :: a -> Map FilePath a -> FilePath -> a-lookupExt def m f =- if null ext- then def- else fromMaybe (lookupExt def m (drop 1 ext)) mbe-- where- ext = takeExtensions f- mbe = Map.lookup ext m----------------------------------------------------------------------------------fileType :: MimeMap -> FilePath -> ByteString-fileType = lookupExt defaultMimeType----------------------------------------------------------------------------------defaultMimeType :: ByteString-defaultMimeType = "application/octet-stream"----------------------------------------------------------------------------------data RangeReq = RangeReq { _rangeFirst :: !Int64- , _rangeLast :: !(Maybe Int64)- }- | SuffixRangeReq { _suffixLength :: !Int64 }- deriving (Eq, Prelude.Show)----------------------------------------------------------------------------------rangeParser :: Parser RangeReq-rangeParser = string "bytes=" *>- (byteRangeSpec <|> suffixByteRangeSpec) <*- endOfInput- where- byteRangeSpec = do- start <- parseNum- char '-'- end <- option Nothing $ liftM Just parseNum-- return $ RangeReq start end-- suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum----------------------------------------------------------------------------------checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Int64 -> m Bool-checkRangeReq req fp sz = do- -- TODO/FIXME: multiple ranges- dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz- maybe (return False)- (\s -> either (const $ return False)- withRange- (fullyParse s rangeParser))- (getHeader "range" req)-- where- withRange rng@(RangeReq start mend) = do- dbg $ "withRange: got Range request: " ++ Prelude.show rng- let end = fromMaybe (sz-1) mend- dbg $ "withRange: start=" ++ Prelude.show start- ++ ", end=" ++ Prelude.show end-- if start < 0 || end < start || start >= sz || end >= sz- then send416- else send206 start end-- withRange rng@(SuffixRangeReq nbytes) = do- dbg $ "withRange: got Range request: " ++ Prelude.show rng- let end = sz-1- let start = sz - nbytes-- dbg $ "withRange: start=" ++ Prelude.show start- ++ ", end=" ++ Prelude.show end-- if start < 0 || end < start || start >= sz || end >= sz- then send416- else send206 start end-- -- note: start and end INCLUSIVE here- send206 start end = do- dbg "inside send206"- let len = end-start+1- let crng = toByteString $- mconcat [ fromByteString "bytes "- , fromShow start- , fromWord8 (c2w '-')- , fromShow end- , fromWord8 (c2w '/')- , fromShow sz ]-- modifyResponse $ setResponseCode 206- . setHeader "Content-Range" crng- . setContentLength len-- dbg $ "send206: sending range (" ++ Prelude.show start- ++ "," ++ Prelude.show (end+1) ++ ") to sendFilePartial"-- -- end here was inclusive, sendFilePartial is exclusive- sendFilePartial fp (start,end+1)- return True--- send416 = do- dbg "inside send416"- -- if there's an "If-Range" header in the request, then we just send- -- back 200- if getHeader "If-Range" req /= Nothing- then return False- else do- let crng = toByteString $- mconcat [ fromByteString "bytes */"- , fromShow sz ]-- modifyResponse $ setResponseCode 416- . setHeader "Content-Range" crng- . setContentLength 0- . deleteHeader "Content-Type"- . deleteHeader "Content-Encoding"- . deleteHeader "Transfer-Encoding"- . setResponseBody (enumBuilder mempty)-- return True----------------------------------------------------------------------------------dbg :: (MonadIO m) => String -> m ()-dbg s = debug $ "FileServe:" ++ s----------------------------------------------------------------------------------uriWithoutQueryString :: Request -> ByteString-uriWithoutQueryString rq = S.takeWhile (/= '?') uri- where- uri = rqURI rq-+-- site :: Snap ()+-- site = 'Snap.Core.route'+-- [ (\"\/files\", 'serveDirectory' \"static\")+-- , (\"\/simple\", 'serveDirectoryWith' 'simpleDirectoryConfig' \"static\")+-- , (\"\/default\", 'serveDirectoryWith' 'defaultDirectoryConfig' \"static\")+-- , (\"\/fancy\", 'serveDirectoryWith' 'fancyDirectoryConfig' \"static\")+-- , (\"\/paper\", 'serveFile' \"static\/paper.pdf\")+-- , (\"\/thesis\", 'serveFileAs' \"application\/pdf\" \"static\/thesis.pdf\")+-- ]+--+-- main :: IO ()+-- main = 'Snap.Http.Server.quickHttpServe' site+-- @+module Snap.Util.FileServe+ ( -- * Helper functions+ getSafePath+ -- * Configuration for directory serving+ , MimeMap+ , HandlerMap+ , DirectoryConfig(..)+ , simpleDirectoryConfig+ , defaultDirectoryConfig+ , fancyDirectoryConfig+ , defaultIndexGenerator+ , defaultMimeTypes+ , fileType+ -- * File servers+ , serveDirectory+ , serveDirectoryWith+ , serveFile+ , serveFileAs+ ) where --------------------------------------------------------------------------------queryStringSuffix :: Request -> ByteString-queryStringSuffix rq = S.concat [ s, qs ]- where- qs = rqQueryString rq- s = if S.null qs then "" else "?"+import Snap.Internal.Util.FileServe (DirectoryConfig (..), HandlerMap, MimeMap, defaultDirectoryConfig, defaultIndexGenerator, defaultMimeTypes, fancyDirectoryConfig, fileType, getSafePath, serveDirectory, serveDirectoryWith, serveFile, serveFileAs, simpleDirectoryConfig)
src/Snap/Util/FileUploads.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}- ------------------------------------------------------------------------------ -- | This module contains primitives and helper functions for handling -- requests with @Content-type: multipart/form-data@, i.e. HTML forms and file@@ -15,9 +8,8 @@ -- specified by the user. -- -- Users who wish to handle their file uploads differently can use the--- lower-level streaming 'Iteratee' interface called 'handleMultipart'. That--- function takes uploaded files and streams them to an 'Iteratee' consumer of--- the user's choosing.+-- lower-level interface called 'handleMultipart'. That function takes+-- uploaded files and streams them to a consumer of the user's choosing. -- -- Using these functions requires making \"policy\" decisions which Snap can't -- really make for users, such as \"what's the largest PDF file a user is@@ -26,13 +18,69 @@ -- 'UploadPolicy'), and on a per-file basis (using 'PartUploadPolicy', which -- allows you to reject or limit the size of certain uploaded -- @Content-type@s).+--+-- Example usage:+--+-- @+-- {-\# LANGUAGE OverloadedStrings #-}+--+-- module Main where+--+-- import qualified Data.ByteString.Char8 as B8+-- import Data.Functor ((\<$>))+-- import "Snap.Core" ('Snap.Core.Snap', 'Snap.Core.route', 'Snap.Core.writeBS')+-- import Snap.Http.Server (quickHttpServe)+-- import "Snap.Util.FileUploads"+-- import System.Posix (FileOffset, fileSize, getFileStatus)+--+-- uploadForm :: 'Snap.Core.Snap' ()+-- uploadForm = 'Snap.Core.writeBS' \"\<form enctype=\\\"multipart\/form-data\\\" action=\\"\/do-upload\\\" method=\\\"POST\\\">\\+-- \\\<input name=\\\"file\\\" type=\\\"file\\\" \/>\\+-- \\\<input type=\\\"submit\\\" value=\\\"Send File\\\" \/>\\+-- \\\<\/form>\"+--+-- getFileSize :: FilePath -> IO FileOffset+-- getFileSize path = fileSize \<$> getFileStatus path+--+-- -- Upload handler that prints out the uploaded file\'s size.+-- doUpload :: 'Snap.Core.Snap' ()+-- doUpload = do+-- l \<- 'handleFileUploads' \"\/tmp\" 'defaultUploadPolicy'+-- (const $ 'allowWithMaximumSize' ('getMaximumFormInputSize' 'defaultUploadPolicy'))+-- (\\pinfo mbfname -> do fsize \<- either (const $ return 0) getFileSize mbfname+-- return ('partFileName' pinfo, fsize))+-- 'writeBS' . B8.pack . show $ l+--+-- site :: 'Snap.Core.Snap' ()+-- site = 'Snap.Core.route'+-- [ (\"\/upload\", uploadForm)+-- , (\"\/do-upload\", doUpload)]+--+-- main :: IO ()+-- main = quickHttpServe site+-- @ module Snap.Util.FileUploads ( -- * Functions- handleFileUploads+ handleFormUploads+ , foldMultipart+ , PartFold+ , FormParam+ , FormFile (..)+ , storeAsLazyByteString+ , withTemporaryStore+ -- ** Backwards compatible API+ , handleFileUploads , handleMultipart+ , PartProcessor -- * Uploaded parts- , PartInfo(..)+ , PartInfo+ , PartDisposition(..)+ , partFieldName+ , partFileName+ , partContentType+ , partHeaders+ , partDisposition -- ** Policy -- *** General upload policy@@ -42,6 +90,8 @@ , setProcessFormInputs , getMaximumFormInputSize , setMaximumFormInputSize+ , getMaximumNumberOfFormInputs+ , setMaximumNumberOfFormInputs , getMinimumUploadRate , setMinimumUploadRate , getMinimumUploadSeconds@@ -49,6 +99,14 @@ , getUploadTimeout , setUploadTimeout + -- *** File upload policy+ , FileUploadPolicy+ , defaultFileUploadPolicy+ , setMaximumFileSize+ , setMaximumNumberOfFiles+ , setSkipFilesWithoutNames+ , setMaximumSkippedFileSize+ -- *** Per-file upload policy , PartUploadPolicy , disallow@@ -63,875 +121,5 @@ , policyViolationExceptionReason ) where --------------------------------------------------------------------------------import Control.Arrow-import Control.Applicative-import Control.Concurrent.MVar-import Control.Exception (SomeException(..))-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans-import qualified Data.Attoparsec.Char8 as Atto-import Data.Attoparsec.Char8-import Data.Attoparsec.Enumerator-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Char8 (ByteString)-import Data.ByteString.Internal (c2w)-import qualified Data.CaseInsensitive as CI-import qualified Data.DList as D-import Data.Enumerator.Binary (iterHandle)-import Data.IORef-import Data.Int-import Data.List hiding (takeWhile)-import qualified Data.Map as Map-import Data.Maybe-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.Encoding as TE-import Data.Typeable-import Prelude hiding (catch, getLine, takeWhile)-import System.Directory-import System.IO hiding (isEOF)--------------------------------------------------------------------------------import Snap.Core-import Snap.Iteratee hiding (map)-import qualified Snap.Iteratee as I-import Snap.Internal.Debug-import Snap.Internal.Iteratee.Debug-import Snap.Internal.Iteratee.BoyerMooreHorspool-import Snap.Internal.Parsing-import qualified Snap.Types.Headers as H -#ifdef USE_UNIX-import System.FilePath ((</>))-import System.Posix.Temp (mkstemp)-#endif----------------------------------------------------------------------------------- | Reads uploaded files into a temporary directory and calls a user handler--- to process them.------ Given a temporary directory, global and file-specific upload policies, and--- a user handler, this function consumes a request body uploaded with--- @Content-type: multipart/form-data@. Each file is read into the temporary--- directory, and then a list of the uploaded files is passed to the user--- handler. After the user handler runs (but before the 'Response' body--- 'Enumerator' is streamed to the client), the files are deleted from disk;--- so if you want to retain or use the uploaded files in the generated--- response, you would need to move or otherwise process them.------ The argument passed to the user handler is a list of:------ > (PartInfo, Either PolicyViolationException FilePath)------ The first half of this tuple is a 'PartInfo', which contains the--- information the client browser sent about the given upload part (like--- filename, content-type, etc). The second half of this tuple is an 'Either'--- stipulating that either:------ 1. the file was rejected on a policy basis because of the provided--- 'PartUploadPolicy' handler------ 2. the file was accepted and exists at the given path.------ If the request's @Content-type@ was not \"@multipart/formdata@\", this--- function skips processing using 'pass'.------ If the client's upload rate passes below the configured minimum (see--- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function--- terminates the connection. This setting is there to protect the server--- against slowloris-style denial of service attacks.------ If the given 'UploadPolicy' stipulates that you wish form inputs to be--- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and--- a form input exceeds the maximum allowable size, this function will throw a--- 'PolicyViolationException'.------ If an uploaded part contains MIME headers longer than a fixed internal--- threshold (currently 32KB), this function will throw a 'BadPartException'.--handleFileUploads ::- (MonadSnap m) =>- FilePath -- ^ temporary directory- -> UploadPolicy -- ^ general upload policy- -> (PartInfo -> PartUploadPolicy) -- ^ per-part upload policy- -> ([(PartInfo, Either PolicyViolationException FilePath)] -> m a)- -- ^ user handler (see function- -- description)- -> m a-handleFileUploads tmpdir uploadPolicy partPolicy handler = do- uploadedFiles <- newUploadedFiles-- (do- xs <- handleMultipart uploadPolicy (iter uploadedFiles)- handler xs- ) `finally` (cleanupUploadedFiles uploadedFiles)-- where- iter uploadedFiles partInfo = maybe disallowed takeIt mbFs- where- ctText = partContentType partInfo- fnText = fromMaybe "" $ partFileName partInfo-- ct = TE.decodeUtf8 ctText- fn = TE.decodeUtf8 fnText-- (PartUploadPolicy mbFs) = partPolicy partInfo-- retVal (_,x) = (partInfo, Right x)-- takeIt maxSize = do- debug "handleFileUploads/takeIt: begin"- let it = fmap retVal $- joinI' $- iterateeDebugWrapper "takeNoMoreThan" $- takeNoMoreThan maxSize $$- fileReader uploadedFiles tmpdir partInfo-- it `catches` [- Handler $ \(_ :: TooManyBytesReadException) -> do- debug $ "handleFileUploads/iter: " ++- "caught TooManyBytesReadException"- skipToEof- tooMany maxSize- , Handler $ \(e :: SomeException) -> do- debug $ "handleFileUploads/iter: caught " ++ show e- debug "handleFileUploads/iter: rethrowing"- throw e- ]-- tooMany maxSize =- return ( partInfo- , Left $ PolicyViolationException- $ T.concat [ "File \""- , fn- , "\" exceeded maximum allowable size "- , T.pack $ show maxSize ] )-- disallowed =- return ( partInfo- , Left $ PolicyViolationException- $ T.concat [ "Policy disallowed upload of file \""- , fn- , "\" with content-type \""- , ct- , "\"" ] )------------------------------------------------------------------------------------ | Given an upload policy and a function to consume uploaded \"parts\",--- consume a request body uploaded with @Content-type: multipart/form-data@.--- Normally most users will want to use 'handleFileUploads' (which writes--- uploaded files to a temporary directory and passes their names to a given--- handler) rather than this function; the lower-level 'handleMultipart'--- function should be used if you want to stream uploaded files to your own--- iteratee function.------ If the request's @Content-type@ was not \"@multipart/formdata@\", this--- function skips processing using 'pass'.------ If the client's upload rate passes below the configured minimum (see--- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function--- terminates the connection. This setting is there to protect the server--- against slowloris-style denial of service attacks.------ If the given 'UploadPolicy' stipulates that you wish form inputs to be--- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and--- a form input exceeds the maximum allowable size, this function will throw a--- 'PolicyViolationException'.------ If an uploaded part contains MIME headers longer than a fixed internal--- threshold (currently 32KB), this function will throw a 'BadPartException'.----handleMultipart ::- (MonadSnap m) =>- UploadPolicy -- ^ global upload policy- -> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor- -> m [a]-handleMultipart uploadPolicy origPartHandler = do- hdrs <- liftM headers getRequest- let (ct, mbBoundary) = getContentType hdrs-- tickleTimeout <- getTimeoutAction- let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy-- let partHandler = if doProcessFormInputs uploadPolicy- then captureVariableOrReadFile- (getMaximumFormInputSize uploadPolicy)- origPartHandler- else (\p -> fmap File (origPartHandler p))-- -- not well-formed multipart? bomb out.- when (ct /= "multipart/form-data") $ do- debug $ "handleMultipart called with content-type=" ++ S.unpack ct- ++ ", passing"- pass-- when (isNothing mbBoundary) $- throw $ BadPartException $- "got multipart/form-data without boundary"-- let boundary = fromJust mbBoundary- captures <- runRequestBody (iter bumpTimeout boundary partHandler)-- procCaptures [] captures-- where- rateLimit bump m =- killIfTooSlow bump- (minimumUploadRate uploadPolicy)- (minimumUploadSeconds uploadPolicy)- m- `catchError` \e -> do- debug $ "rateLimit: caught " ++ show e- let (me::Maybe RateTooSlowException) = fromException e- maybe (throwError e)- terminateConnection- me-- iter bump boundary ph = iterateeDebugWrapper "killIfTooSlow" $- rateLimit bump $- internalHandleMultipart boundary ph-- ins k v = Map.insertWith' (flip (++)) k [v]-- maxFormVars = maximumNumberOfFormInputs uploadPolicy-- procCaptures l [] = return $ reverse l- procCaptures l ((File x):xs) = procCaptures (x:l) xs- procCaptures l ((Capture k v):xs) = do- rq <- getRequest- let n = Map.size $ rqParams rq- when (n >= maxFormVars) $- throw $ PolicyViolationException $- T.concat [ "number of form inputs exceeded maximum of "- , T.pack $ show maxFormVars ]- modifyRequest $ rqModifyParams (ins k v)- procCaptures l xs------------------------------------------------------------------------------------ | 'PartInfo' contains information about a \"part\" in a request uploaded--- with @Content-type: multipart/form-data@.-data PartInfo =- PartInfo { partFieldName :: !ByteString- , partFileName :: !(Maybe ByteString)- , partContentType :: !ByteString- }- deriving (Show)------------------------------------------------------------------------------------ | All of the exceptions defined in this package inherit from--- 'FileUploadException', so if you write------ > foo `catch` \(e :: FileUploadException) -> ...------ you can catch a 'BadPartException', a 'PolicyViolationException', etc.-data FileUploadException =- GenericFileUploadException {- _genericFileUploadExceptionReason :: Text- }- | forall e . (Exception e, Show e) =>- WrappedFileUploadException {- _wrappedFileUploadException :: e- , _wrappedFileUploadExceptionReason :: Text- }- deriving (Typeable)----------------------------------------------------------------------------------instance Show FileUploadException where- show (GenericFileUploadException r) = "File upload exception: " ++- T.unpack r- show (WrappedFileUploadException e _) = show e----------------------------------------------------------------------------------instance Exception FileUploadException----------------------------------------------------------------------------------fileUploadExceptionReason :: FileUploadException -> Text-fileUploadExceptionReason (GenericFileUploadException r) = r-fileUploadExceptionReason (WrappedFileUploadException _ r) = r----------------------------------------------------------------------------------uploadExceptionToException :: Exception e => e -> Text -> SomeException-uploadExceptionToException e r =- SomeException $ WrappedFileUploadException e r----------------------------------------------------------------------------------uploadExceptionFromException :: Exception e => SomeException -> Maybe e-uploadExceptionFromException x = do- WrappedFileUploadException e _ <- fromException x- cast e----------------------------------------------------------------------------------data BadPartException = BadPartException { badPartExceptionReason :: Text }- deriving (Typeable)--instance Exception BadPartException where- toException e@(BadPartException r) = uploadExceptionToException e r- fromException = uploadExceptionFromException--instance Show BadPartException where- show (BadPartException s) = "Bad part: " ++ T.unpack s----------------------------------------------------------------------------------data PolicyViolationException = PolicyViolationException {- policyViolationExceptionReason :: Text- } deriving (Typeable)--instance Exception PolicyViolationException where- toException e@(PolicyViolationException r) =- uploadExceptionToException e r- fromException = uploadExceptionFromException--instance Show PolicyViolationException where- show (PolicyViolationException s) = "File upload policy violation: "- ++ T.unpack s------------------------------------------------------------------------------------ | 'UploadPolicy' controls overall policy decisions relating to--- @multipart/form-data@ uploads, specifically:------ * whether to treat parts without filenames as form input (reading them into--- the 'rqParams' map)------ * because form input is read into memory, the maximum size of a form input--- read in this manner, and the maximum number of form inputs------ * the minimum upload rate a client must maintain before we kill the--- connection; if very low-bitrate uploads were allowed then a Snap server--- would be vulnerable to a trivial denial-of-service using a--- \"slowloris\"-type attack------ * the minimum number of seconds which must elapse before we start killing--- uploads for having too low an upload rate.------ * the amount of time we should wait before timing out the connection--- whenever we receive input from the client.-data UploadPolicy = UploadPolicy {- processFormInputs :: Bool- , maximumFormInputSize :: Int64- , maximumNumberOfFormInputs :: Int- , minimumUploadRate :: Double- , minimumUploadSeconds :: Int- , uploadTimeout :: Int-} deriving (Show, Eq)------------------------------------------------------------------------------------ | A reasonable set of defaults for upload policy. The default policy is:------ [@maximum form input size@] 128kB------ [@maximum number of form inputs@] 10------ [@minimum upload rate@] 1kB/s------ [@seconds before rate limiting kicks in@] 10------ [@inactivity timeout@] 20 seconds----defaultUploadPolicy :: UploadPolicy-defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout- where- maxSize = 2^(17::Int)- maxNum = 10- minRate = 1000- minSeconds = 10- tout = 20------------------------------------------------------------------------------------ | Does this upload policy stipulate that we want to treat parts without--- filenames as form input?-doProcessFormInputs :: UploadPolicy -> Bool-doProcessFormInputs = processFormInputs------------------------------------------------------------------------------------ | Set the upload policy for treating parts without filenames as form input.-setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy-setProcessFormInputs b u = u { processFormInputs = b }------------------------------------------------------------------------------------ | Get the maximum size of a form input which will be read into our--- 'rqParams' map.-getMaximumFormInputSize :: UploadPolicy -> Int64-getMaximumFormInputSize = maximumFormInputSize------------------------------------------------------------------------------------ | Set the maximum size of a form input which will be read into our--- 'rqParams' map.-setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy-setMaximumFormInputSize s u = u { maximumFormInputSize = s }------------------------------------------------------------------------------------ | Get the minimum rate (in /bytes\/second/) a client must maintain before--- we kill the connection.-getMinimumUploadRate :: UploadPolicy -> Double-getMinimumUploadRate = minimumUploadRate------------------------------------------------------------------------------------ | Set the minimum rate (in /bytes\/second/) a client must maintain before--- we kill the connection.-setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy-setMinimumUploadRate s u = u { minimumUploadRate = s }------------------------------------------------------------------------------------ | Get the amount of time which must elapse before we begin enforcing the--- upload rate minimum-getMinimumUploadSeconds :: UploadPolicy -> Int-getMinimumUploadSeconds = minimumUploadSeconds------------------------------------------------------------------------------------ | Set the amount of time which must elapse before we begin enforcing the--- upload rate minimum-setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy-setMinimumUploadSeconds s u = u { minimumUploadSeconds = s }------------------------------------------------------------------------------------ | Get the \"upload timeout\". Whenever input is received from the client,--- the connection timeout is set this many seconds in the future.-getUploadTimeout :: UploadPolicy -> Int-getUploadTimeout = uploadTimeout------------------------------------------------------------------------------------ | Set the upload timeout.-setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy-setUploadTimeout s u = u { uploadTimeout = s }------------------------------------------------------------------------------------ | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'),--- but handlers can also make policy decisions on individual files\/parts--- uploaded. For each part uploaded, handlers can decide:------ * whether to allow the file upload at all------ * the maximum size of uploaded files, if allowed-data PartUploadPolicy = PartUploadPolicy {- _maximumFileSize :: Maybe Int64-} deriving (Show, Eq)------------------------------------------------------------------------------------ | Disallows the file to be uploaded.-disallow :: PartUploadPolicy-disallow = PartUploadPolicy Nothing------------------------------------------------------------------------------------ | Allows the file to be uploaded, with maximum size /n/.-allowWithMaximumSize :: Int64 -> PartUploadPolicy-allowWithMaximumSize = PartUploadPolicy . Just------------------------------------------------------------------------------------ private exports follow. FIXME: organize----------------------------------------------------------------------------------------------------------------------------------------------------------------captureVariableOrReadFile ::- Int64 -- ^ maximum size of form input- -> (PartInfo -> Iteratee ByteString IO a) -- ^ file reading code- -> (PartInfo -> Iteratee ByteString IO (Capture a))-captureVariableOrReadFile maxSize fileHandler partInfo =- case partFileName partInfo of- Nothing -> iter- _ -> liftM File $ fileHandler partInfo- where- iter = varIter `catchError` handler-- fieldName = partFieldName partInfo-- varIter = do- var <- liftM S.concat $- joinI' $- takeNoMoreThan maxSize $$ consume- return $ Capture fieldName var-- handler e = do- debug $ "captureVariableOrReadFile/handler: caught " ++ show e- let m = fromException e :: Maybe TooManyBytesReadException- case m of- Nothing -> do- debug "didn't expect this error, rethrowing"- throwError e- Just _ -> do- debug "rethrowing as PolicyViolationException"- throwError $ PolicyViolationException $- T.concat [ "form input '"- , TE.decodeUtf8 fieldName- , "' exceeded maximum permissible size ("- , T.pack $ show maxSize- , " bytes)" ]----------------------------------------------------------------------------------data Capture a = Capture ByteString ByteString- | File a- deriving (Show)----------------------------------------------------------------------------------fileReader :: UploadedFiles- -> FilePath- -> PartInfo- -> Iteratee ByteString IO (PartInfo, FilePath)-fileReader uploadedFiles tmpdir partInfo = do- debug "fileReader: begin"- (fn, h) <- openFileForUpload uploadedFiles tmpdir- let i = iterateeDebugWrapper "fileReader" $ iter fn h- i `catch` \(e::SomeException) -> throwError e-- where- iter fileName h = do- iterHandle h- debug "fileReader: closing active file"- closeActiveFile uploadedFiles- return (partInfo, fileName)----------------------------------------------------------------------------------internalHandleMultipart ::- ByteString -- ^ boundary value- -> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor- -> Iteratee ByteString IO [a]-internalHandleMultipart boundary clientHandler = go `catch` errorHandler-- where- --------------------------------------------------------------------------- errorHandler :: SomeException -> Iteratee ByteString IO a- errorHandler e = do- skipToEof- throwError e-- --------------------------------------------------------------------------- go = do- -- swallow the first boundary- _ <- iterParser $ parseFirstBoundary boundary- step <- iterateeDebugWrapper "boyer-moore" $- (bmhEnumeratee (fullBoundary boundary) $$ processParts iter)- liftM concat $ lift $ run_ $ returnI step-- --------------------------------------------------------------------------- pBoundary b = Atto.try $ do- _ <- string "--"- string b-- --------------------------------------------------------------------------- fullBoundary b = S.concat ["\r\n", "--", b]- pLine = takeWhile (not . isEndOfLine . c2w) <* eol- takeLine = pLine *> pure ()- parseFirstBoundary b = pBoundary b <|> (takeLine *> parseFirstBoundary b)--- --------------------------------------------------------------------------- takeHeaders = hdrs `catchError` handler- where- hdrs = liftM toHeaders $- iterateeDebugWrapper "header parser" $- joinI' $- takeNoMoreThan mAX_HDRS_SIZE $$- iterParser pHeadersWithSeparator-- handler e = do- debug $ "internalHandleMultipart/takeHeaders: caught " ++ show e- let m = fromException e :: Maybe TooManyBytesReadException- case m of- Nothing -> throwError e- Just _ -> throwError $ BadPartException $- "headers exceeded maximum size"-- --------------------------------------------------------------------------- iter = do- hdrs <- takeHeaders- debug $ "internalHandleMultipart/iter: got headers"-- -- are we using mixed?- let (contentType, mboundary) = getContentType hdrs-- let (fieldName, fileName) = getFieldName hdrs-- if contentType == "multipart/mixed"- then maybe (throwError $ BadPartException $- "got multipart/mixed without boundary")- (processMixed fieldName)- mboundary- else do- let info = PartInfo fieldName fileName contentType- liftM (:[]) $ clientHandler info--- --------------------------------------------------------------------------- processMixed fieldName mixedBoundary = do- -- swallow the first boundary- _ <- iterParser $ parseFirstBoundary mixedBoundary- step <- iterateeDebugWrapper "boyer-moore" $- (bmhEnumeratee (fullBoundary mixedBoundary) $$- processParts (mixedIter fieldName))- lift $ run_ $ returnI step--- --------------------------------------------------------------------------- mixedIter fieldName = do- hdrs <- takeHeaders-- let (contentType, _) = getContentType hdrs- let (_, fileName) = getFieldName hdrs-- let info = PartInfo fieldName fileName contentType- clientHandler info----------------------------------------------------------------------------------getContentType :: Headers- -> (ByteString, Maybe ByteString)-getContentType hdrs = (contentType, boundary)- where- contentTypeValue = fromMaybe "text/plain" $- getHeader "content-type" hdrs-- eCT = fullyParse contentTypeValue pContentTypeWithParameters- (contentType, params) = either (const ("text/plain", [])) id eCT-- boundary = findParam "boundary" params----------------------------------------------------------------------------------getFieldName :: Headers -> (ByteString, Maybe ByteString)-getFieldName hdrs = (fieldName, fileName)- where- contentDispositionValue = fromMaybe "" $- getHeader "content-disposition" hdrs-- eDisposition = fullyParse contentDispositionValue pValueWithParameters-- (_, dispositionParameters) =- either (const ("", [])) id eDisposition-- fieldName = fromMaybe "" $ findParam "name" dispositionParameters-- fileName = findParam "filename" dispositionParameters----------------------------------------------------------------------------------findParam :: (Eq a) => a -> [(a, b)] -> Maybe b-findParam p = fmap snd . find ((== p) . fst)------------------------------------------------------------------------------------ | Given a 'MatchInfo' stream which is partitioned by boundary values, read--- up until the next boundary and send all of the chunks into the wrapped--- iteratee-processPart :: (Monad m) => Enumeratee MatchInfo ByteString m a-processPart st = {-# SCC "pPart/outer" #-}- case st of- (Continue k) -> go k- _ -> yield st (Chunks [])- where- go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)- -> Iteratee MatchInfo m (Step ByteString m a)- go !k = {-# SCC "pPart/go" #-}- I.head >>= maybe finished process- where- -- called when outer stream is EOF- finished = {-# SCC "pPart/finish" #-}- lift $ runIteratee $ k EOF-- -- no match ==> pass the stream chunk along- process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do- !step <- lift $ runIteratee $ k $ Chunks [s]- case step of- (Continue k') -> go k'- _ -> yield step (Chunks [])-- process (Match _) = {-# SCC "pPart/match" #-}- lift $ runIteratee $ k EOF------------------------------------------------------------------------------------ | Assuming we've already identified the boundary value and run--- 'bmhEnumeratee' to split the input up into parts which match and parts--- which don't, run the given 'ByteString' iteratee over each part and grab a--- list of the resulting values.-processParts :: Iteratee ByteString IO a- -> Iteratee MatchInfo IO [a]-processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty- where- iter = {-# SCC "processParts/iter" #-} do- isLast <- bParser- if isLast- then return Nothing- else do- x <- partIter- skipToEof- return $ Just x-- go soFar = {-# SCC "processParts/go" #-} do- b <- isEOF-- if b- then return $ D.toList soFar- else do- -- processPart $$ iter- -- :: Iteratee MatchInfo m (Step ByteString m a)- innerStep <- processPart $$ iter-- -- output :: Maybe a- output <- lift $ run_ $ returnI innerStep-- case output of- Just x -> go (D.append soFar $ D.singleton x)- Nothing -> return $ D.toList soFar-- bParser = iterateeDebugWrapper "boundary debugger" $- iterParser $ pBoundaryEnd-- pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)----------------------------------------------------------------------------------eol :: Parser ByteString-eol = (string "\n") <|> (string "\r\n")----------------------------------------------------------------------------------pHeadersWithSeparator :: Parser [(ByteString,ByteString)]-pHeadersWithSeparator = pHeaders <* crlf----------------------------------------------------------------------------------toHeaders :: [(ByteString,ByteString)] -> Headers-toHeaders kvps = H.fromList kvps'- where- kvps' = map (first CI.mk) kvps----------------------------------------------------------------------------------mAX_HDRS_SIZE :: Int64-mAX_HDRS_SIZE = 32768------------------------------------------------------------------------------------ We need some code to keep track of the files we have already successfully--- created in case an exception is thrown by the request body enumerator or--- one of the client iteratees.-data UploadedFilesState = UploadedFilesState {- -- | This is the file which is currently being written to. If the- -- calling function gets an exception here, it is responsible for- -- closing and deleting this file.- _currentFile :: Maybe (FilePath, Handle)-- -- | .. and these files have already been successfully read and closed.- , _alreadyReadFiles :: [FilePath]-}----------------------------------------------------------------------------------emptyUploadedFilesState :: UploadedFilesState-emptyUploadedFilesState = UploadedFilesState Nothing []----------------------------------------------------------------------------------data UploadedFiles = UploadedFiles (IORef UploadedFilesState)- (MVar ())----------------------------------------------------------------------------------newUploadedFiles :: MonadIO m => m UploadedFiles-newUploadedFiles = liftIO $ do- r <- newIORef emptyUploadedFilesState- m <- newMVar ()- let u = UploadedFiles r m- addMVarFinalizer m $ cleanupUploadedFiles u- return u----------------------------------------------------------------------------------cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()-cleanupUploadedFiles (UploadedFiles stateRef _) = liftIO $ do- state <- readIORef stateRef- killOpenFile state- mapM_ killFile $ _alreadyReadFiles state- writeIORef stateRef emptyUploadedFilesState-- where- killFile = eatException . removeFile-- killOpenFile state = maybe (return ())- (\(fp,h) -> do- eatException $ hClose h- eatException $ removeFile fp)- (_currentFile state)----------------------------------------------------------------------------------openFileForUpload :: (MonadIO m) =>- UploadedFiles- -> FilePath- -> m (FilePath, Handle)-openFileForUpload ufs@(UploadedFiles stateRef _) tmpdir = liftIO $ do- state <- readIORef stateRef-- -- It should be an error to open a new file with this interface if there- -- is already a file handle active.- when (isJust $ _currentFile state) $ do- cleanupUploadedFiles ufs- throw $ GenericFileUploadException alreadyOpenMsg-- fph@(_,h) <- makeTempFile tmpdir "snap-"- hSetBuffering h NoBuffering-- writeIORef stateRef $ state { _currentFile = Just fph }- return fph-- where- alreadyOpenMsg =- T.concat [ "Internal error! UploadedFiles: "- , "opened new file with pre-existing open handle" ]----------------------------------------------------------------------------------closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()-closeActiveFile (UploadedFiles stateRef _) = liftIO $ do- state <- readIORef stateRef- let m = _currentFile state- maybe (return ())- (\(fp,h) -> do- eatException $ hClose h- writeIORef stateRef $- state { _currentFile = Nothing- , _alreadyReadFiles = fp:(_alreadyReadFiles state) })- m----------------------------------------------------------------------------------eatException :: (MonadCatchIO m) => m a -> m ()-eatException m =- (m >> return ()) `catch` (\(_ :: SomeException) -> return ())---makeTempFile :: FilePath -> String -> IO (FilePath, Handle)-#ifdef USE_UNIX-makeTempFile fp temp = mkstemp $ fp </> (temp ++ "XXXXXXX")-#else-makeTempFile = openBinaryTempFile-#endif+import Snap.Internal.Util.FileUploads (BadPartException (badPartExceptionReason), FileUploadException, FileUploadPolicy, FormFile (..), FormParam, PartDisposition (..), PartFold, PartInfo (..), PartProcessor, PartUploadPolicy, PolicyViolationException (policyViolationExceptionReason), UploadPolicy, allowWithMaximumSize, defaultFileUploadPolicy, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, foldMultipart, getMaximumFormInputSize, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleFormUploads, handleMultipart, setMaximumFileSize, setMaximumFormInputSize, setMaximumNumberOfFiles, setMaximumNumberOfFormInputs, setMaximumSkippedFileSize, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setSkipFilesWithoutNames, setUploadTimeout, storeAsLazyByteString, withTemporaryStore)
src/Snap/Util/GZip.hs view
@@ -1,49 +1,52 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -module Snap.Util.GZip-( withCompression-, withCompression'-, noCompression ) where--import Blaze.ByteString.Builder-import qualified Codec.Zlib.Enum as Z-import Control.Applicative-import Control.Exception-import Control.Monad-import Control.Monad.Trans-import Data.Attoparsec.Char8-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.Char as Char-import Data.Maybe-import Data.Monoid-import qualified Data.Set as Set-import Data.Set (Set)-import Data.Typeable-import Prelude hiding (catch, takeWhile)-+--------------------------------------------------------------------------------+-- | Helpers for running a 'Snap' web handler with compression. ------------------------------------------------------------------------------import Snap.Core-import Snap.Internal.Debug-import Snap.Internal.Parsing-import Snap.Iteratee-import qualified Snap.Iteratee as I+module Snap.Util.GZip+ ( withCompression+ , withCompression'+ , noCompression+ , BadAcceptEncodingException+ , compressibleMimeTypes+ ) where +import Control.Applicative (Alternative ((<|>), many), Applicative ((*>), (<*), pure), (<$>))+import Control.Exception (Exception, throwIO)+import Control.Monad (Functor (fmap), Monad ((>>), (>>=), return), MonadPlus (mplus), void, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, isAlpha_ascii, isDigit, skipSpace, string, takeWhile, takeWhile1)+import Data.ByteString.Builder (Builder)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S (takeWhile)+import qualified Data.Char as Char (isSpace)+import Data.Maybe (Maybe (Just, Nothing), fromMaybe, isJust, maybe)+import Data.Set (Set)+import qualified Data.Set as Set (fromList, member)+import Data.Typeable (Typeable)+import Prelude (Either (..), Eq (..), IO, Show (show), id, not, ($), ($!), (&&), (++), (||))+import Snap.Core (MonadSnap, clearContentLength, finishWith, getHeader, getRequest, getResponse, modifyResponse, modifyResponseBody, setHeader)+import Snap.Internal.Debug (debug)+import Snap.Internal.Parsing (fullyParse)+import System.IO.Streams (OutputStream)+import qualified System.IO.Streams as Streams (compressBuilder, gzipBuilder) ------------------------------------------------------------------------------ -- | Runs a 'Snap' web handler with compression if available. ----- If the client has indicated support for @gzip@ or @compress@ in its+-- If the client has indicated support for @gzip@ or @deflate@ in its -- @Accept-Encoding@ header, and the @Content-Type@ in the response is one of -- the following types: -- -- * @application/x-javascript@ --+-- * @application/json@+-- -- * @text/css@ -- -- * @text/html@@@ -65,6 +68,32 @@ -- that's contained within the 'Snap' monad state will be passed to -- 'finishWith' to prevent further processing. --+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"/\" M.empty >> T.addHeader \"Accept-Encoding\" \"gzip,deflate\"+-- ghci> let h = 'Snap.Core.modifyResponse' ('Snap.Core.setContentType' \"text\/plain\") >> 'Snap.Core.writeBS' \"some text\"+-- ghci> T.runHandler r h+-- HTTP\/1.1 200 OK+-- content-type: text\/plain+-- server: Snap\/test+-- date: Fri, 08 Aug 2014 15:40:45 GMT+--+-- some text+-- ghci> T.runHandler r ('withCompression' h)+-- HTTP\/1.1 200 OK+-- content-type: text\/plain+-- vary: Accept-Encoding+-- content-encoding: gzip+-- server: Snap\/test+-- date: Fri, 08 Aug 2014 15:40:10 GMT+--+--+-- @ withCompression :: MonadSnap m => m a -- ^ the web handler to run -> m ()@@ -110,20 +139,23 @@ types <- liftIO $ parseAcceptEncoding s - chooseType types+ chooseType Nothing types + chooseType !m [] = maybe (return $! ()) id m+ chooseType !_ ("gzip":_) = gzipCompression "gzip"+ chooseType !m ("deflate":xs) =+ chooseType (m `mplus` Just (compressCompression "deflate")) xs - chooseType [] = return $! ()- chooseType ("gzip":_) = gzipCompression "gzip"- chooseType ("compress":_) = compressCompression "compress"- chooseType ("x-gzip":_) = gzipCompression "x-gzip"- chooseType ("x-compress":_) = compressCompression "x-compress"- chooseType (_:xs) = chooseType xs+ chooseType !_ ("x-gzip":_) = gzipCompression "x-gzip"+ chooseType !m ("x-deflate":xs) =+ chooseType (m `mplus` Just (compressCompression "x-deflate")) xs+ chooseType !m (_:xs) = chooseType m xs ------------------------------------------------------------------------------ -- | Turn off compression by setting \"Content-Encoding: identity\" in the--- response headers.+-- response headers. 'withCompression' is a no-op when a content-encoding is+-- already set. noCompression :: MonadSnap m => m () noCompression = modifyResponse $ setHeader "Content-Encoding" "identity" @@ -137,6 +169,7 @@ compressibleMimeTypes :: Set ByteString compressibleMimeTypes = Set.fromList [ "application/x-font-truetype" , "application/x-javascript"+ , "application/json" , "text/css" , "text/html" , "text/javascript"@@ -150,48 +183,34 @@ gzipCompression :: MonadSnap m => ByteString -> m () gzipCompression ce = modifyResponse f where- f = setHeader "Content-Encoding" ce .- setHeader "Vary" "Accept-Encoding" .- clearContentLength .- modifyResponseBody gcompress+ f r = setHeader "Content-Encoding" ce $+ setHeader "Vary" "Accept-Encoding" $+ clearContentLength $+ modifyResponseBody gcompress r ------------------------------------------------------------------------------ compressCompression :: MonadSnap m => ByteString -> m () compressCompression ce = modifyResponse f where- f = setHeader "Content-Encoding" ce .- setHeader "Vary" "Accept-Encoding" .- clearContentLength .- modifyResponseBody ccompress+ f r = setHeader "Content-Encoding" ce $+ setHeader "Vary" "Accept-Encoding" $+ clearContentLength $+ modifyResponseBody ccompress r -------------------------------------------------------------------------------gcompress :: forall a . Enumerator Builder IO a- -> Enumerator Builder IO a-gcompress e st = e $$ iFinal- where- i0 = returnI st- iB = mapFlush =$ i0- iZ = Z.gzip =$ iB- iFinal = enumBuilderToByteString =$ iZ-- mapFlush :: Monad m => Enumeratee ByteString Builder m b- mapFlush = I.map ((`mappend` flush) . fromByteString)+gcompress :: (OutputStream Builder -> IO (OutputStream Builder))+ -> OutputStream Builder+ -> IO (OutputStream Builder)+gcompress body stream = Streams.gzipBuilder 5 stream >>= body -------------------------------------------------------------------------------ccompress :: forall a . Enumerator Builder IO a- -> Enumerator Builder IO a-ccompress e st = e $$ iFinal- where- i0 = returnI st- iB = mapFlush =$ i0- iZ = Z.compress 5 Z.defaultWindowBits =$ iB- iFinal = enumBuilderToByteString =$ iZ-- mapFlush :: Monad m => Enumeratee ByteString Builder m b- mapFlush = I.map ((`mappend` flush) . fromByteString)+ccompress :: (OutputStream Builder -> IO (OutputStream Builder))+ -> OutputStream Builder+ -> IO (OutputStream Builder)+ccompress body stream = Streams.compressBuilder 5 stream >>= body ------------------------------------------------------------------------------@@ -199,37 +218,38 @@ -- that order. acceptParser :: Parser [ByteString] acceptParser = do- xs <- option [] $ (:[]) <$> encoding+ xs <- ((:[]) <$> encoding) <|> (return $! []) ys <- many (char ',' *> encoding) endOfInput- return $ xs ++ ys+ return $! xs ++ ys where encoding = skipSpace *> c <* skipSpace c = do x <- coding- option () qvalue+ qvalue <|> (return $! ()) return x qvalue = do skipSpace- char ';'+ void $! char ';' skipSpace- char 'q'+ void $! char 'q' skipSpace- char '='+ void $! char '=' float- return ()+ return $! () - coding = string "*" <|> takeWhile isCodingChar+ coding = string "*" <|> takeWhile1 isCodingChar isCodingChar ch = isDigit ch || isAlpha_ascii ch || ch == '-' || ch == '_' float = takeWhile isDigit >>- option () (char '.' >> takeWhile isDigit >> pure ())+ (char '.' >> takeWhile isDigit >> (pure $! ())) <|> (pure $! ()) ------------------------------------------------------------------------------+-- | Thrown when the 'Accept-Encoding' request header has invalid format. data BadAcceptEncodingException = BadAcceptEncodingException deriving (Typeable) @@ -251,4 +271,3 @@ Right x -> return x where r = fullyParse s acceptParser-
+ src/Snap/Util/Proxy.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides facilities for patching incoming 'Requests' to+-- correct the value of 'rqClientAddr' if the snap server is running behind a+-- proxy.+--+-- Example usage:+--+-- @+-- m :: Snap ()+-- m = undefined -- code goes here+--+-- applicationHandler :: Snap ()+-- applicationHandler = behindProxy X_Forwarded_For m+-- @+--+module Snap.Util.Proxy+ ( ProxyType(..)+ , behindProxy+ ) where++------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>)))+import Control.Monad (mfilter)+import qualified Data.ByteString.Char8 as S (breakEnd, dropWhile, null, readInt, spanEnd)+import Data.Char (isSpace)+import Data.Maybe (fromMaybe)+import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), getHeader, modifyRequest)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | What kind of proxy is this? Affects which headers 'behindProxy' pulls the+-- original remote address from.+--+-- Currently only proxy servers that send @X-Forwarded-For@ or @Forwarded-For@+-- are supported.+data ProxyType = NoProxy -- ^ no proxy, leave the request alone+ | X_Forwarded_For -- ^ Use the @Forwarded-For@ or+ -- @X-Forwarded-For@ header+ deriving (Read, Show, Eq, Ord)+++------------------------------------------------------------------------------+-- | Rewrite 'rqClientAddr' if we're behind a proxy.+--+-- Example:+--+-- @+-- ghci> :set -XOverloadedStrings+-- ghci> import qualified "Data.Map" as M+-- ghci> import qualified "Snap.Test" as T+-- ghci> let r = T.get \"\/foo\" M.empty >> T.addHeader \"X-Forwarded-For\" \"1.2.3.4\"+-- ghci> let h = 'Snap.Core.getsRequest' 'rqClientAddr' >>= 'Snap.Core.writeBS')+-- ghci> T.runHandler r h+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Fri, 08 Aug 2014 14:32:29 GMT+--+-- 127.0.0.1+-- ghci> T.runHandler r ('behindProxy' 'X_Forwarded_For' h)+-- HTTP\/1.1 200 OK+-- server: Snap\/test+-- date: Fri, 08 Aug 2014 14:33:02 GMT+--+-- 1.2.3.4+-- @+behindProxy :: MonadSnap m => ProxyType -> m a -> m a+behindProxy NoProxy = id+behindProxy X_Forwarded_For = ((modifyRequest xForwardedFor) >>)+{-# INLINE behindProxy #-}+++------------------------------------------------------------------------------+xForwardedFor :: Request -> Request+xForwardedFor req = req { rqClientAddr = ip+ , rqClientPort = port+ }+ where+ extract = fst . S.spanEnd isSpace . S.dropWhile isSpace . snd . S.breakEnd (== ',')++ ip = fromMaybe (rqClientAddr req) $ mfilter (not . S.null) $ fmap extract $+ getHeader "Forwarded-For" req <|>+ getHeader "X-Forwarded-For" req++ port = maybe (rqClientPort req) fst $ (S.readInt =<<) $ fmap extract $+ getHeader "Forwarded-Port" req <|>+ getHeader "X-Forwarded-Port" req+{-# INLINE xForwardedFor #-}
− src/Snap/Util/Readable.hs
@@ -1,36 +0,0 @@-module Snap.Util.Readable- ( Readable(..)- ) where---------------------------------------------------------------------------------import Data.ByteString.Char8 (ByteString)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding-import Data.Text.Read------------------------------------------------------------------------------------ | Monadic analog to Read that uses ByteString instead of String.-class Readable a where- fromBS :: Monad m => ByteString -> m a------------------------------------------------------------------------------------ | Fails if the input wasn't parsed completely.-checkComplete :: Monad m => (t, Text) -> m t-checkComplete (a,rest)- | T.null rest = return a- | otherwise = fail "Readable: could not parse completely"---instance Readable ByteString where- fromBS = return-instance Readable Text where- fromBS = return . decodeUtf8-instance Readable Int where- fromBS = either fail checkComplete . decimal . decodeUtf8-instance Readable Integer where- fromBS = either fail checkComplete . decimal . decodeUtf8-instance Readable Double where- fromBS = either fail checkComplete . double . decodeUtf8
+ test/Snap/Core/Tests.hs view
@@ -0,0 +1,954 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++-- Deprecations warnings turned off due to ErrorT deprecation+--+-- It's a pain that this setting is per-module, because we might end up hiding+-- deprecation warnings that we want to see. TODO: move any code that emits+-- these warnings to isolated modules.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++------------------------------------------------------------------------------+module Snap.Core.Tests ( tests ) where+------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>)), Applicative ((<*>), pure), (<$>))+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.DeepSeq (deepseq)+import Control.Exception.Lifted (ErrorCall (..), Exception, SomeException (..), catch, fromException, mask, throwIO, try)+import Control.Monad (Functor (fmap), Monad ((>>), (>>=), return), MonadPlus (mplus, mzero), forM_, liftM, void)+import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.IO.Class (liftIO)+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (ErrorT (runErrorT))+#endif+import Data.ByteString.Builder (byteString)+#if MIN_VERSION_transformers(0,4,0)+import Control.Monad.Trans.Except (runExceptT)+#endif+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.List (ListT (runListT))+#endif+import Control.Monad.Trans.Reader (ReaderT (runReaderT))+import qualified Control.Monad.Trans.RWS.Lazy as LRWS (RWST (runRWST))+import Control.Monad.Trans.RWS.Strict (RWST (runRWST))+import qualified Control.Monad.Trans.State.Lazy as LState (evalStateT)+import Control.Monad.Trans.State.Strict (evalStateT)+import qualified Control.Monad.Trans.Writer.Lazy as LWriter (WriterT (runWriterT))+import Control.Monad.Trans.Writer.Strict (WriterT (runWriterT))+import Control.Parallel.Strategies (rdeepseq, using)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S (length, pack, replicate)+import qualified Data.ByteString.Lazy.Char8 as L (ByteString, fromChunks, isPrefixOf)+import qualified Data.IntMap as IM (toList)+import Data.IORef (newIORef, readIORef, writeIORef)+import qualified Data.Map as Map (empty, fromList)+import Data.Maybe (isJust)+import Data.Monoid (mappend)+import Data.Text (Text)+import qualified Data.Text.Encoding as T (encodeUtf8)+import Data.Text.Lazy ()+import Prelude (Bool (..), Either (..), Enum (..), Eq (..), IO, Int, Maybe (Just, Nothing), Num (..), Show (..), String, const, either, fail, flip, id, map, maybe, not, seq, undefined, ($), ($!), (&&), (++), (.))+import Snap.Internal.Core (EscapeSnap (..), MonadSnap (..), NoHandlerException (NoHandlerException), Snap, addToOutput, bracketSnap, catchFinishWith, dir, escapeHttp, evalSnap, finishWith, getParam, getParams, getPostParam, getPostParams, getQueryParam, getQueryParams, getRequest, getResponse, getsResponse, ifTop, ipHeaderFilter, localRequest, logError, method, methods, modifyResponse, pass, path, pathArg, putRequest, putResponse, readRequestBody, redirect, redirect', runRequestBody, runSnap, setTimeout, terminateConnection, transformRequestBody, updateContextPath, withRequest, withResponse, writeBS, writeLBS, writeLazyText, writeText)+import Snap.Internal.Http.Types (Cookie (Cookie), Method (..), Request (rqBody, rqClientAddr, rqContextPath, rqIsSecure, rqURI), Response (rspContentLength, rspStatus, rspStatusReason, rspTransformingRqBody), addHeader, deleteHeader, emptyResponse, getHeader, rqRemoteAddr, setContentLength, setHeader, setResponseCode, setResponseStatus, statusReasonMap)+import Snap.Internal.Parsing (urlDecode, urlEncode)+import qualified Snap.Test as Test (RequestType (RequestWithRawBody), buildRequest, evalHandler, get, getResponseBody, postRaw, runHandler, setRequestType)+import Snap.Test.Common (coverEqInstance, coverOrdInstance, coverReadInstance, coverShowInstance, coverTypeableInstance, expectExceptionH, forceSameType, waitabit)+import System.IO.Streams (InputStream)+import qualified System.IO.Streams as Streams (fromList, makeInputStream, nullInput, nullOutput, read, throwIfTooSlow, toList, write)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertable (assert), assertBool, assertEqual, assertFailure)+import Test.QuickCheck (Gen, arbitrary, elements, oneof, variant)+------------------------------------------------------------------------------+++tests :: [Test]+tests = [ testFail+ , testAlternative+ , testEarlyTermination+ , testEscapeHttp+ , testCatchFinishWith+ , testRqBody+ , testRqBodyException+ , testRqBodyTermination+ , testRqBodyTooLong+ , testRqBodyTooSlow+ , testTrivials+ , testMethod+ , testMethods+ , testMethodEq+ , testMethodNotEq+ , testDir+ , testCatchIO+ , testWrites+ , testParam+ , testURLEncode1+ , testURLEncode2+ , testDir2+ , testIpHeaderFilter+ , testMZero404+ , testEvalSnap+ , testLocalRequest+ , testRedirect+ , testBracketSnap+ , testCoverInstances+ , testPathArgs+ , testStateTAndExceptions+ , test304Fixup+ , testChunkedFixup+ ]+++------------------------------------------------------------------------------+expectSpecificException :: Exception e => e -> IO a -> IO ()+expectSpecificException e0 m = do+ r <- try m++ let b = either (\se -> isJust $+ forceSameType (Just e0) (fromException se))+ (const False)+ r+ assertBool ("expected specific exception: " ++ show e0) b+++------------------------------------------------------------------------------+expect404 :: IO (Request,Response) -> IO ()+expect404 m = do+ (_,r) <- m+ assertBool "expected 404" (rspStatus r == 404)+++------------------------------------------------------------------------------+expectNo404 :: IO (Request,Response) -> IO ()+expectNo404 m = do+ (_,r) <- m+ assertBool ("expected 200, got " ++ show (rspStatus r))+ (rspStatus r /= 404)+++------------------------------------------------------------------------------+mkRequest :: ByteString -> IO Request+mkRequest uri = Test.buildRequest $ Test.get uri Map.empty+++------------------------------------------------------------------------------+mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request+mkRequestQuery uri k v =+ Test.buildRequest $ Test.get uri $ Map.fromList [(k,v)]+++------------------------------------------------------------------------------+mkZomgRq :: IO Request+mkZomgRq = Test.buildRequest $ Test.get "/" Map.empty+++------------------------------------------------------------------------------+mkMethodRq :: Method -> IO Request+mkMethodRq m = Test.buildRequest $ do+ Test.get "/" Map.empty+ Test.setRequestType $ Test.RequestWithRawBody m ""+++------------------------------------------------------------------------------+mkIpHeaderRq :: IO Request+mkIpHeaderRq = do+ rq <- mkZomgRq+ return $ setHeader "X-Forwarded-For" "1.2.3.4"+ $ deleteHeader "X-Forwarded-For"+ $ setHeader "X-Forwarded-For" "1.2.3.4" rq+++------------------------------------------------------------------------------+mkRqWithBody :: IO Request+mkRqWithBody = Test.buildRequest $ Test.postRaw "/" "text/plain" "zazzle"+++------------------------------------------------------------------------------+mkRqWithEnum :: (InputStream ByteString) -> IO Request+mkRqWithEnum str = do+ rq <- Test.buildRequest $ Test.postRaw "/" "text/plain" ""++ return $! rq { rqBody = str }+++------------------------------------------------------------------------------+testCatchIO :: Test+testCatchIO = testCase "core/catchIO" $ do+ (_,rsp) <- go f+ (_,rsp2) <- go g++ assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp+ assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2++ where+ f :: Snap ()+ f = (mask $ \restore -> restore $ throwIO $ NoHandlerException "")+ `catch` h++ g :: Snap ()+ g = return () `catch` h++ h :: SomeException -> Snap ()+ h e = e `seq` modifyResponse $ addHeader "foo" "bar"+++------------------------------------------------------------------------------+go :: Snap a -> IO (Request,Response)+go m = do+ zomgRq <- mkZomgRq+ runSnap m dummy timeoutModifier zomgRq+ where+ dummy !x = return $! (show x `using` rdeepseq) `seq` ()+ timeoutModifier !f = return $! f 0 `seq` ()+++------------------------------------------------------------------------------+goMeth :: Method -> Snap a -> IO (Request,Response)+goMeth m s = do+ methRq <- mkMethodRq m+ runSnap s dummy timeoutModifier methRq+ where+ dummy !x = return $! (show x `using` rdeepseq) `seq` ()+ timeoutModifier !f = return $! f 0 `seq` ()+++------------------------------------------------------------------------------+goIP :: Snap a -> IO (Request,Response)+goIP m = do+ rq <- mkIpHeaderRq+ runSnap m dummy timeoutModifier rq+ where+ timeoutModifier !f = return $! f 0 `seq` ()+ dummy = const $ return ()+++------------------------------------------------------------------------------+goPath :: ByteString -> Snap a -> IO (Request,Response)+goPath s m = do+ rq <- mkRequest s+ runSnap m dummy timeoutModifier rq+ where+ timeoutModifier !f = return $! f 0 `seq` ()+ dummy = const $ return ()+++------------------------------------------------------------------------------+goPathQuery :: ByteString+ -> ByteString+ -> [ByteString]+ -> Snap a+ -> IO (Request,Response)+goPathQuery s k v m = do+ rq <- mkRequestQuery s k v+ runSnap m dummy (const (return ())) rq+ where+ dummy = const $ return ()+++------------------------------------------------------------------------------+goBody :: Snap a -> IO (Request,Response)+goBody m = do+ rq <- mkRqWithBody+ runSnap m dummy (const (return ())) rq+ where+ dummy = const $ return ()+++------------------------------------------------------------------------------+goEnum :: InputStream ByteString+ -> Snap b+ -> IO (Request,Response)+goEnum enum m = do+ rq <- mkRqWithEnum enum+ runSnap m logerr tout rq+++------------------------------------------------------------------------------+testFail :: Test+testFail = testCase "failure" $ expect404 (go pass)+++------------------------------------------------------------------------------+setFoo :: ByteString -> Snap ()+setFoo s = do+ modifyResponse (addHeader "Foo" s)+ fmap id $ pure ()+ pure id <*> (liftIO $ return ())+ !x <- liftBase $! return $! ()+ return $! x+++------------------------------------------------------------------------------+testAlternative :: Test+testAlternative = testCase "core/alternative" $ do+ (_,resp) <- go (pass <|> setFoo "Bar")+ assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp++ (_,resp2) <- go (fail "fail should not error"+ <|> fail2+ <|> setFoo "Bar"+ <|> setFoo "Baz")+ assertEqual "alternative chooses correct branch"+ (Just "Bar") $ getHeader "Foo" resp2++ where+ fail2 :: Snap ()+ fail2 = pass >>= \_ -> return ()+++------------------------------------------------------------------------------+sampleResponse :: Response+sampleResponse = addHeader "Foo" "Quux" $ emptyResponse+++------------------------------------------------------------------------------+testEarlyTermination :: Test+testEarlyTermination = testCase "core/earlyTermination" $ do+ (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar")+ assertEqual "foo" (Just "Quux") $ getHeader "Foo" resp+++------------------------------------------------------------------------------+testStateTAndExceptions :: Test+testStateTAndExceptions = testCase "core/stateT_exceptions" $ do+ Test.evalHandler (return ()) h1 >>= assertEqual "h1" True+ Test.evalHandler (return ()) h2 >>= assertEqual "h2" True+ Test.evalHandler (return ()) h3 >>= assertEqual "h3" True+ Test.evalHandler (return ()) h4 >>= assertEqual "h4" True+ Test.evalHandler (return ()) h5 >>= assertEqual "h5" True++ where+ useState = do rq <- getRequest+ return (rqURI rq == "/")++ h1 = do let m = ((try mzero) :: Snap (Either SomeException Int))+ (m >> return False) <|> useState++ h2 = do catchFinishWith (getResponse >>= finishWith)+ useState++ h3 = do catchFinishWith (return ())+ useState++ h4 = do (void (catchFinishWith mzero)) <|> return ()+ useState++ h5 = do let m1 = (void (getResponse >>= finishWith)) `mplus` return ()+ void (catchFinishWith m1)+ useState+++------------------------------------------------------------------------------+testEscapeHttp :: Test+testEscapeHttp = testCase "core/escapeHttp" $ flip catch catchEscape $ do+ (_, _) <- go (escapeHttp escaper)+ assertFailure "HTTP escape was ignored"+ where+ escaper _ _ _ = liftIO $ assert True+ tickle _ = return ()++ catchEscape (ex :: EscapeSnap) =+ case ex of+ EscapeHttp e -> do+ input <- Streams.nullInput+ output <- Streams.nullOutput+ e tickle input output+ _ -> assertFailure "got TerminateConnection"+++------------------------------------------------------------------------------+isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False+++------------------------------------------------------------------------------+isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False+++------------------------------------------------------------------------------+logerr :: ByteString -> IO ()+logerr !_ = return $! ()+++------------------------------------------------------------------------------+tout :: (Int -> Int) -> IO ()+tout !f = let !_ = f 2 in return $! ()+++------------------------------------------------------------------------------+testBracketSnap :: Test+testBracketSnap = testCase "core/bracketSnap" $ do+ rq <- mkZomgRq++ ref <- newIORef 0++ expectSpecificException (NoHandlerException "") $+ evalSnap (act ref) logerr tout rq++ y <- readIORef ref+ assertEqual "bracketSnap/after1" (1::Int) y++ expectSpecificException (ErrorCall "no value") $+ evalSnap (act ref <|> finishWith emptyResponse)+ logerr+ tout+ rq++ y' <- readIORef ref+ assertEqual "bracketSnap/after" 2 y'+++ expectSpecificException (ErrorCall "foo") $+ evalSnap (act2 ref)+ logerr+ tout+ rq++ y'' <- readIORef ref+ assertEqual "bracketSnap/after" 3 y''++ where+ act ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` mzero)++ act2 ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")+++------------------------------------------------------------------------------+testCatchFinishWith :: Test+testCatchFinishWith = testCase "core/catchFinishWith" $ do+ rq <- mkZomgRq+ x <- evalSnap (catchFinishWith $ finishWith emptyResponse)+ logerr tout rq+ assertBool "catchFinishWith" $ isLeft x+ let (Left resp) = x+ assertEqual "code" 200 (rspStatus resp)++ y <- evalSnap (catchFinishWith $ return $! ())+ logerr tout rq+ assertBool "catchFinishWith" $ isRight y+ let (Right val) = y+ assertEqual "val" () val++ expectExceptionH $ evalSnap (catchFinishWith pass) logerr tout rq+++------------------------------------------------------------------------------+testRqBody :: Test+testRqBody = testCase "core/requestBodies" $ do+ mvar1 <- newEmptyMVar+ mvar2 <- newEmptyMVar++ _ <- goBody $ f mvar1 mvar2++ v1 <- takeMVar mvar1+ v2 <- takeMVar mvar2++ assertEqual "rq body" "zazzle" v1+ assertEqual "rq body 2" "" v2++ (_,rsp) <- goBody (g >> putResponse emptyResponse)+ bd <- getBody rsp++ assertEqual "detached rq body" "zazzle" bd+ assertBool "transforming" (rspTransformingRqBody rsp)++ where+ f mvar1 mvar2 = do+ readRequestBody 100000 >>= liftIO . putMVar mvar1+ readRequestBody 100000 >>= liftIO . putMVar mvar2++ g = transformRequestBody (return . id)+++------------------------------------------------------------------------------+testRqBodyTooLong :: Test+testRqBodyTooLong = testCase "core/requestBodyTooLong" $ do+ expectExceptionH $ goBody $ f 2+ (_, rsp) <- goBody $ f 200000+ bd <- getBody rsp+ assertEqual "detached rq body" "zazzle" bd+ where+ f sz = readRequestBody sz >>= writeLBS+++------------------------------------------------------------------------------+testRqBodyException :: Test+testRqBodyException = testCase "core/requestBodyException" $ do+ str <- Streams.fromList listData+ (req,resp) <- goEnum str hndlr+ bd <- getBody resp+ b' <- Streams.toList $ rqBody req+ assertEqual "request body was consumed" [] b'+ assertEqual "response body was produced" "OK" bd+ where+ listData = ["the", "quick", "brown", "fox"]++ h0 = runRequestBody $ \str -> do+ !_ <- Streams.read str+ throwIO $ ErrorCall "foo"++ hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"+++------------------------------------------------------------------------------+testRqBodyTooSlow :: Test+testRqBodyTooSlow = testCase "core/requestBodyTooSlow" $ do+ str <- Streams.makeInputStream strFunc >>=+ Streams.throwIfTooSlow (return ()) 100000.0 1+ expectExceptionH (goEnum str hndlr)++ where+ strFunc = waitabit >> return (Just "1")+ hndlr = runRequestBody $ \_ -> throwIO $ ErrorCall "foo"+++------------------------------------------------------------------------------+testRqBodyTermination :: Test+testRqBodyTermination = testCase "core/requestBodyTermination" $ do+ str <- Streams.fromList ["the", "quick", "brown", "fox"]+ expectExceptionH $ goEnum str h0+ where+ h0 = (runRequestBody $ \str -> do+ !_ <- Streams.read str+ throwIO $ TerminateConnection+ $ SomeException $ ErrorCall "foo")+ `catch` tc++ tc (ex :: EscapeSnap) = case ex of+ TerminateConnection e -> terminateConnection e+ _ -> throwIO ex+++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "core/trivials" $ do+ (rq,rsp) <- go $ do+ req <- getRequest+ putRequest $ req { rqIsSecure=True }+ putResponse $ setResponseStatus 333 "333" sampleResponse+ r <- getResponse+ liftIO $ assertEqual "rsp status" 333 $ rspStatus r+ code <- getsResponse rspStatus+ liftIO $ assertEqual "rsp status 2" 333 code+ !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do+ q <- getRequest+ liftIO $ assertEqual "localrq" False $ rqIsSecure q+ return ()++ !_ <- logError "foo"+ writeText "zzz"+ writeLazyText "zzz"++ let req' = updateContextPath 0 req+ let cp1 = rqContextPath req+ let cp2 = rqContextPath req'++ setTimeout 30+ !_ <- getParams+ !_ <- getPostParams+ !_ <- getQueryParams++ liftIO $ assertEqual "updateContextPath 0" cp1 cp2++ withRequest $ return . (`seq` ())+ withResponse $ return . (`seq` ())++ return ()++ b <- getBody rsp+ coverShowInstance b+ coverShowInstance $ NoHandlerException ""+ coverShowInstance GET+ coverReadInstance GET+ coverEqInstance GET+ coverEqInstance $ NoHandlerException ""+ coverOrdInstance GET++ Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)+ `deepseq` return ()++ let cookie = Cookie "" "" Nothing Nothing Nothing False False+ coverEqInstance cookie+ coverShowInstance cookie++ assertEqual "rq secure" True $ rqIsSecure rq+ assertEqual "rsp status" 333 $ rspStatus rsp+ coverTypeableInstance (undefined :: Snap ())+ coverShowInstance (EscapeHttp undefined)++ -- number serialization+ forM_ [ 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 10000000000+ , 100000000000+ ] $ \i -> do+ let s = show i+ rsp_cl <- Test.runHandler (return ()) (clHandler i)+ assertEqual ("number " ++ s)+ (Just $ S.pack s)+ (getHeader "content-length" rsp_cl)+ where+ clHandler i = do modifyResponse (setContentLength i)+ writeBS (S.replicate (fromEnum i) ' ')++------------------------------------------------------------------------------+testMethod :: Test+testMethod = testCase "core/method" $ do+ expect404 $ go (method POST $ return ())+ expectNo404 $ go (method GET $ return ())+++------------------------------------------------------------------------------+testMethods :: Test+testMethods = testCase "core/methods" $ do+ expect404 $ go (methods [POST,PUT,PATCH,Method "MOVE"] $ return ())+ expectNo404 $ go (methods [GET] $ return ())+ expectNo404 $ go (methods [POST,GET] $ return ())+ expectNo404 $ go (methods [PUT,GET] $ return ())+ expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())+ expectNo404 $ go (methods [GET,PUT,DELETE,PATCH] $ return ())+ expectNo404 $ go (methods [GET,Method "COPY"] $ return ())+ expect404 $ goMeth PATCH (methods [POST,PUT,GET,Method "FOO"] $ return ())+ expect404 $ goMeth (Method "Baz")+ (methods [GET,POST,Method "Foo"] $ return ())+ expectNo404 $ goMeth (Method "Baz")+ (method (Method "Baz") $ return ())+ expectNo404 $ goMeth (Method "Foo")+ (methods [Method "Baz",PATCH,GET,Method "Foo"] $ return ())++ expectNo404 $ goMeth GET (method (Method "GET") $ return ())+ expectNo404 $ goMeth (Method "GET") (method GET $ return ())+++------------------------------------------------------------------------------+methodGen :: Int -> Gen Method+methodGen n = variant n $ oneof+ [ elements [ GET, HEAD, POST, PUT, DELETE+ , TRACE, OPTIONS, CONNECT, PATCH ]+ , Method <$> arbitrary+ ]+++------------------------------------------------------------------------------+testMethodEq :: Test+testMethodEq = testProperty "core/Method/eq" $ prop+ where+ prop n = do+ m <- methodGen n+ return $ m == m && toMeth m == m+ toMeth GET = Method "GET"+ toMeth HEAD = Method "HEAD"+ toMeth POST = Method "POST"+ toMeth PUT = Method "PUT"+ toMeth DELETE = Method "DELETE"+ toMeth TRACE = Method "TRACE"+ toMeth OPTIONS = Method "OPTIONS"+ toMeth CONNECT = Method "CONNECT"+ toMeth PATCH = Method "PATCH"+ toMeth (Method a) = Method a+++------------------------------------------------------------------------------+testMethodNotEq :: Test+testMethodNotEq = testProperty "core/Method/noteq" $ prop+ where+ prop n = do+ m <- methodGen n+ m' <- methodGen (n + 1)+ return $ (m /= m') == not (m == m')+++------------------------------------------------------------------------------+testDir :: Test+testDir = testCase "core/dir" $ do+ expect404 $ goPath "foo/bar" (dir "zzz" $ return ())+ expectNo404 $ goPath "foo/bar" (dir "foo" $ return ())+ expect404 $ goPath "fooz/bar" (dir "foo" $ return ())+ expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ())+ expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ())+ expectNo404 $ goPath "" (ifTop $ return ())+ expect404 $ goPath "a" (ifTop $ return ())+++------------------------------------------------------------------------------+testParam :: Test+testParam = testCase "core/getParam" $ do+ expect404 $ goPath "/foo" f+ expectNo404 $ goPathQuery "/foo" "param" ["foo"] f+ expectNo404 $ goPathQuery "/foo" "param" ["foo"] fQ+ expect404 $ goPathQuery "/foo" "param" ["foo"] fP++ where+ p gp = do+ mp <- gp "param"+ maybe pass+ (\s -> if s == "foo" then return () else pass)+ mp++ f = p getParam+ fQ = p getQueryParam+ fP = p getPostParam+++------------------------------------------------------------------------------+getBody :: Response -> IO L.ByteString+getBody r = liftM (L.fromChunks . (:[])) $ Test.getResponseBody r+++------------------------------------------------------------------------------+testWrites :: Test+testWrites = testCase "core/writes" $ do+ (_,r) <- go h+ b <- getBody r+ assertEqual "output functions" "Foo1Foo2Foo3" b+ where+ h :: Snap ()+ h = do+ addToOutput f+ writeBS "Foo2"+ writeLBS "Foo3"++ f str = do+ Streams.write (Just $ byteString "Foo1") str+ return str+++------------------------------------------------------------------------------+testURLEncode1 :: Test+testURLEncode1 = testCase "core/urlEncoding1" $ do+ let b = urlEncode "the quick brown fox~#"+ assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b+ assertEqual "fail" Nothing $ urlDecode "%"+++------------------------------------------------------------------------------+testURLEncode2 :: Test+testURLEncode2 = testProperty "core/urlEncoding2" prop+ where+ prop s = (urlDecode $ urlEncode s) == Just s+++------------------------------------------------------------------------------+testDir2 :: Test+testDir2 = testCase "core/dir2" $ do+ (_,resp) <- goPath "foo/bar" f+ b <- getBody resp+ assertEqual "context path" "/foo/bar/" b++ where+ f = dir "foo" $ dir "bar" $ do+ p <- liftM rqContextPath getRequest+ addToOutput $ \s -> do+ Streams.write (Just $ byteString p) s+ return s+++------------------------------------------------------------------------------+testIpHeaderFilter :: Test+testIpHeaderFilter = testCase "core/ipHeaderFilter" $ do+ (_,r) <- goIP f+ b <- getBody r+ assertEqual "ipHeaderFilter" "1.2.3.4" b+++ (_,r2) <- go f'+ b2 <- getBody r2+ assertEqual "ipHeaderFilter" "127.0.0.1" b2++ where+ f = do+ ipHeaderFilter+ ip <- liftM rqClientAddr getRequest+ writeBS ip++ f' = do+ ipHeaderFilter+ ip <- liftM rqRemoteAddr getRequest+ writeBS ip+++------------------------------------------------------------------------------+testMZero404 :: Test+testMZero404 = testCase "core/mzero404" $ do+ (_,r) <- go mzero+ b <- getBody r+ assertBool "mzero 404" ("<!DOCTYPE html" `L.isPrefixOf` b)+++testEvalSnap :: Test+testEvalSnap = testCase "core/evalSnap-exception" $ do+ rq <- mkZomgRq+ expectExceptionH (evalSnap f logerr tout rq >> return ())+ where+ f = do+ logError "zzz"+ v <- withResponse (return . rspStatus)+ liftIO $ assertEqual "evalSnap rsp status" 200 v+ finishWith emptyResponse+++------------------------------------------------------------------------------+testLocalRequest :: Test+testLocalRequest = testCase "core/localRequest" $ do+ rq1 <- mkZomgRq+ rq2 <- mkRequest "zzz/zz/z"++ let h = localRequest (const rq2) mzero++ (rq',_) <- go (h <|> return ())++ let u1 = rqURI rq1+ let u2 = rqURI rq'++ assertEqual "localRequest backtrack" u1 u2+++------------------------------------------------------------------------------+testRedirect :: Test+testRedirect = testCase "core/redirect" $ do+ (_,rsp) <- go (redirect "/foo/bar")++ b <- getBody rsp+ assertEqual "no response body" "" b+ assertEqual "response content length" (Just 0) $ rspContentLength rsp+ assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp+ assertEqual "redirect status" 302 $ rspStatus rsp+ assertEqual "status description" "Found" $ rspStatusReason rsp+++ (_,rsp2) <- go (redirect' "/bar/foo" 307)++ assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2+ assertEqual "redirect status" 307 $ rspStatus rsp2+ assertEqual "status description" "Temporary Redirect" $+ rspStatusReason rsp2+++------------------------------------------------------------------------------+testCoverInstances :: Test+testCoverInstances = testCase "core/instances" $ do+#if !MIN_VERSION_transformers(0,6,0)+ coverErrorT+ coverListT+#endif+#if MIN_VERSION_transformers(0,4,0)+ coverExceptT+#endif+ coverRWST+ coverLRWS+ coverReaderT+ coverStateT+ coverLStateT+ coverWriterT+ coverLWriterT++ where+ snap :: MonadSnap m => m ()+ snap = liftSnap $ writeBS "OK"++ cover :: MonadSnap m => (m () -> Snap ()) -> IO ()+ cover runFunc = do+ !_ <- Test.runHandler (return ()) (runFunc snap)+ return ()++ rwst :: RWST () () () Snap () -> Snap ()+ rwst m = void $ runRWST m () ()++ lrwst :: LRWS.RWST () () () Snap () -> Snap ()+ lrwst m = void $ LRWS.runRWST m () ()++ wt :: WriterT () Snap () -> Snap ()+ wt m = void $ runWriterT m++ lwt :: LWriter.WriterT () Snap () -> Snap ()+ lwt m = void $ LWriter.runWriterT m++#if !MIN_VERSION_transformers(0,6,0)+ coverErrorT = cover (\m -> do+ (_ :: Either String ()) <- runErrorT m+ return ())+ coverListT = cover (void . runListT)+#endif+#if MIN_VERSION_transformers(0,4,0)+ coverExceptT = cover (\m -> do+ (_ :: Either String ()) <- runExceptT m+ return ())+#endif+ coverRWST = cover rwst+ coverLRWS = cover lrwst+ coverReaderT = cover (flip runReaderT ())+ coverStateT = cover (flip evalStateT ())+ coverLStateT = cover (flip LState.evalStateT ())+ coverWriterT = cover wt+ coverLWriterT = cover lwt+++------------------------------------------------------------------------------+testPathArgs :: Test+testPathArgs = testCase "core/pathArgs" $ do+ (_, rsp) <- goPath "%e4%b8%ad" m+ b <- getBody rsp+ assertEqual "pathargs url- and utf8-decodes" "ok" b++ Test.evalHandler (Test.get "/%zzzz" Map.empty) m2 >>= assertEqual "m2" True+ Test.evalHandler (Test.get "/z/foo" Map.empty) m3 >>= assertEqual "m3" "/z/"++ where+ m = pathArg f++ m2 = pathArg (\(_ :: Text) -> return False) <|> return True++ m3 = pathArg (\(_ :: Text) -> rqContextPath <$> getRequest)+++ f x = if x == ("\x4e2d" :: Text)+ then writeBS "ok"+ else writeBS $ "not ok: " `mappend` T.encodeUtf8 x++------------------------------------------------------------------------------+test304Fixup :: Test+test304Fixup = testCase "core/304fixup" $ do+ rsp1 <- Test.runHandler (return ()) h1+ assertEqual "code1" (rspStatus rsp1) 304+ assertEqual "cl1" Nothing (rspContentLength rsp1)+ Test.getResponseBody rsp1 >>= assertEqual "body1" ""+ assertBool "date" $ getHeader "date" rsp1 /= (Just "zzz")+ assertEqual "cl-header" Nothing $ getHeader "content-length" rsp1+ assertEqual "transfer-encoding" Nothing $ getHeader "transfer-encoding" rsp1++ where+ h1 = do let s = "this should get eaten"+ modifyResponse (setResponseCode 304 .+ setContentLength (toEnum $ S.length s) .+ setHeader "content-length" "zzz" .+ setHeader "transfer-encoding" "chunked" .+ setHeader "date" "zzz")+ writeBS s+++------------------------------------------------------------------------------+testChunkedFixup :: Test+testChunkedFixup = testCase "core/chunked-fixup" $ do+ rsp1 <- Test.runHandler (return ()) h1+ Test.getResponseBody rsp1 >>= assertEqual "body1" "OK"+ assertEqual "transfer-encoding" (Just "chunked")+ $ getHeader "transfer-encoding" rsp1+ assertEqual "baz" (Just "baz") $ getHeader "baz" rsp1+ assertEqual "foo" (Just "foo") $ getHeader "foo" rsp1++ where+ h1 = do modifyResponse $ setHeader "baz" "baz" .+ setHeader "transfer-encoding" "chunked" .+ setHeader "foo" "foo" .+ setHeader "bar" "bar"+ writeBS "OK"
+ test/Snap/Internal/Http/Types/Tests.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++------------------------------------------------------------------------------+module Snap.Internal.Http.Types.Tests ( tests ) where+------------------------------------------------------------------------------+import Control.Parallel.Strategies (rdeepseq, using)+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as S (concat)+import Data.ByteString.Lazy.Char8 ()+import Data.List (sort)+import qualified Data.Map as Map (empty, insert, lookup)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.Time.Clock (UTCTime (UTCTime))+import Snap.Internal.Http.Types (Cookie (Cookie), HasHeaders (headers, updateHeaders), Method (CONNECT, DELETE, GET, HEAD, Method, OPTIONS, PATCH, POST, PUT, TRACE), Request (rqCookies, rqIsSecure, rqContentLength, rqParams), Response (rspContentLength, rspStatus, rspStatusReason), addHeader, addResponseCookie, cookieToBS, deleteResponseCookie, emptyResponse, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, rqModifyParams, rqParam, rqSetParam, setContentLength, setContentType, setResponseBody, setResponseCode, setResponseStatus)+import Snap.Internal.Parsing (urlDecode)+import qualified Snap.Test as Test (buildRequest, get, getResponseBody)+import qualified Snap.Types.Headers as H (lookup, set)+import qualified System.IO.Streams as Streams (write)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertEqual)+import Text.Regex.Posix ((=~))++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testTypes+ , testCookies+ , testCookieToBS+ , testUrlDecode+ , testFormatLogTime+ , testAddHeader+ , testHeaderOrd+ ]+++------------------------------------------------------------------------------+mkRq :: IO Request+mkRq = Test.buildRequest $ Test.get "/" Map.empty+++------------------------------------------------------------------------------+testHeaderOrd :: Test+testHeaderOrd = testCase "httpTypes/methodOrd" $ do+ let methods = [GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT,+ PATCH, Method "Foo"]+ mapM_ (\m -> assertEqual "method" (compare m m) EQ) methods+ mapM_ (\m -> assertEqual "ord" (compare GET m) LT) $ tail methods+ assertEqual "ord2" LT (compare (Method "a") (Method "b"))++------------------------------------------------------------------------------+testFormatLogTime :: Test+testFormatLogTime = testCase "httpTypes/formatLogTime" $ do+ b <- formatLogTime 3804938++ let re = S.concat [ "^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}"+ , ":[0-9]{2} (-|\\+)[0-9]{4}$" ]++ assertBool "formatLogTime" $ b =~ re+++------------------------------------------------------------------------------+testAddHeader :: Test+testAddHeader = testCase "httpTypes/addHeader" $ do+ defReq <- mkRq++ let req = addHeader "foo" "bar" $+ addHeader "foo" "baz" defReq+++ let x = getHeader "foo" req+ assertEqual "addHeader x 2" (Just "baz,bar") x+ assertEqual "listHeaders" [ ("foo","baz,bar")+ , ("Host", "localhost") ] $+ sort $ listHeaders req++ let hdrs = updateHeaders (H.set "zzz" "bbb") $ headers req+ assertEqual "listHeaders 2"+ [ ("foo", "baz,bar")+ , ("Host", "localhost")+ , ("zzz", "bbb") ]+ (sort (listHeaders $ headers hdrs))+++------------------------------------------------------------------------------+testUrlDecode :: Test+testUrlDecode = testCase "httpTypes/urlDecode" $ do+ assertEqual "bad hex" Nothing $ urlDecode "%qq"+++------------------------------------------------------------------------------+testTypes :: Test+testTypes = testCase "httpTypes/show" $ do+ defReq <- mkRq++ let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $+ updateHeaders (H.set "zzz" "bbb") $+ rqSetParam "foo" ["bar"] $+ defReq++ let req2 = (addHeader "zomg" "1234" req)+ { rqCookies = [ cook, cook2 ]+ , rqIsSecure = True+ , rqContentLength = Just 10+ }++ let !a = show req `using` rdeepseq+ let !_ = show req2 `using` rdeepseq++ -- we don't care about the show instance really, we're just trying to shut+ -- up hpc+ assertBool "show" $ a /= b+ assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req)+ assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req)+ assertEqual "lookup 2" (Just "bbb") (H.lookup "zzz" $ headers req)++ assertEqual "response status" 555 $ rspStatus resp+ assertEqual "response status reason" "bogus" $ rspStatusReason resp+ assertEqual "content-length" (Just 4) $ rspContentLength resp++ bd <- Test.getResponseBody resp+ assertEqual "response body" "PING" $ bd++ let !_ = show GET+ let !_ = GET == POST+ let !_ = headers $ headers defReq+ let !_ = show resp2 `using` rdeepseq++ assertEqual "999" "Unknown" (rspStatusReason resp3)++ where+ enum os = Streams.write (Just $ byteString "PING") os >> return os++ resp = addResponseCookie cook $+ setContentLength 4 $+ modifyResponseBody id $+ setResponseBody enum $+ setContentType "text/plain" $+ setResponseStatus 555 "bogus" $+ emptyResponse+ !b = show resp `using` rdeepseq++ resp2 = addResponseCookie cook2 resp++ resp3 = setResponseCode 999 resp2++ utc = UTCTime (ModifiedJulianDay 55226) 0+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") False False+++------------------------------------------------------------------------------+testCookieToBS :: Test+testCookieToBS = testCase "httpTypes/cookieToBS" $ do+ let [b0, b1, b2] = map cookieToBS [cookie0, cookie1, cookie2]+ assertEqual "cookie0" "foo=bar; HttpOnly" b0+ assertEqual "cookie1" "foo=bar; Secure" b1+ assertEqual "cookie2" "foo=bar; path=/; expires=Sat, 30 Jan 2010 00:00:00 GMT; domain=.foo.com; HttpOnly" b2+ where+ utc = UTCTime (ModifiedJulianDay 55226) 0+ cookie0 = Cookie "foo" "bar" Nothing Nothing Nothing False True+ cookie1 = Cookie "foo" "bar" Nothing Nothing Nothing True False+ cookie2 = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True+++testCookies :: Test+testCookies = testCase "httpTypes/cookies" $ do+ assertEqual "cookie" (Just cook) rCook+ assertEqual "cookie2" (Just cook2) rCook2+ assertEqual "cookie3" (Just cook3) rCook3+ assertEqual "empty response cookie3" (Just cook3) rCook3e+ assertEqual "removed cookie" Nothing nilCook+ assertEqual "multiple cookies" [cook, cook2] cks+ assertEqual "cookie modification" (Just cook3) rCook3Mod+ assertEqual "modify nothing" Nothing (getResponseCookie "boo" resp5)++ return ()++ where+ resp = addResponseCookie cook $+ setContentType "text/plain" $+ emptyResponse++ f !_ = cook3++ resp' = deleteResponseCookie "foo" resp+ resp'' = modifyResponseCookie "foo" f resp+ resp2 = addResponseCookie cook2 resp+ resp3 = addResponseCookie cook3 resp2+ resp4 = addResponseCookie cook3 emptyResponse+ resp5 = modifyResponseCookie "boo" id emptyResponse++ utc = UTCTime (ModifiedJulianDay 55226) 0+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") True False+ cook3 = Cookie "boo" "baz" Nothing Nothing Nothing False False++ rCook = getResponseCookie "foo" resp+ nilCook = getResponseCookie "foo" resp'+ rCook2 = getResponseCookie "zoo" resp2+ rCook3 = getResponseCookie "boo" resp3+ rCook3e = getResponseCookie "boo" resp4+ rCook3Mod = getResponseCookie "boo" resp''++ cks = getResponseCookies resp2
+ test/Snap/Internal/Parsing/Tests.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++------------------------------------------------------------------------------+module Snap.Internal.Parsing.Tests ( tests ) where+------------------------------------------------------------------------------+import Control.Applicative (many)+import Data.Attoparsec.ByteString.Char8 (IResult (..), char, string, (<?>))+import qualified Data.ByteString.Char8 as S (concat)+import qualified Data.Map as Map (fromList)+import Data.Word (Word8)+import Snap.Internal.Http.Types (Cookie (Cookie, cookieDomain, cookieExpires, cookieHttpOnly, cookieName, cookiePath, cookieSecure, cookieValue))+import Snap.Internal.Parsing (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, pQuotedString', parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat, pTokens)+import Snap.Test.Common (expectExceptionH)+import System.Random (Random (random, randomR))+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertEqual)+import Test.QuickCheck (Arbitrary (arbitrary), choose)+------------------------------------------------------------------------------++tests :: [Test]+tests = [ testAvPairs+ , testCookie+ , testHeaderParse+ , testQuotedString+ , testQuotedString'+ , testUnsafeFromHex+ , testUnsafeFromInt+ , testUrlEncoded+ , testFailParse+ , testTokens+ ]+++------------------------------------------------------------------------------+testAvPairs :: Test+testAvPairs = testCase "parsing/avpairs" $ do+ let x = fullyParse txt pAvPairs+ assertEqual "avpairs" (Right [ ("foo" , "bar")+ , ("bar" , "baz")+ , ("quux", "" )+ ]) x+ where+ txt = "foo = bar; bar = baz; quux"+++------------------------------------------------------------------------------+testCookie :: Test+testCookie =+ testCase "parsing/parseCookie" $ do+ assertEqual "cookie parsing" (Just [cv]) cv2+ let (Just [c]) = cv2+ -- stupid assertions to cover the accessors+ assertEqual "c1" (cookieName c) nm+ assertEqual "c2" (cookieValue c) v+ assertEqual "c3" (cookieExpires c) Nothing+ assertEqual "c4" (cookieDomain c) Nothing+ assertEqual "c5" (cookiePath c) Nothing+ assertEqual "c6" (cookieSecure c) False+ assertEqual "c7" (cookieHttpOnly c) False++ where+ cv = Cookie nm v Nothing Nothing Nothing False False+ cv2 = parseCookie ct++ nm = "foo"+ v = "bar"++ ct = S.concat [ nm , "=" , v ]+++------------------------------------------------------------------------------+testHeaderParse :: Test+testHeaderParse = testCase "parsing/headers" $ do+ let e = fullyParse txt pHeaders+ assertEqual "parse" (Right [("foo", "bar baz quux")]) e++ let f = fullyParse bad pHeaders+ assertEqual "bad parse" (Right []) f++ where+ txt = S.concat [ "foo: bar\r\n"+ , " baz\r\n"+ , " quux\r\n"+ ]++ bad = "%&^%&^*^(*&^*&^*%*&%^^#$"+++------------------------------------------------------------------------------+testQuotedString :: Test+testQuotedString = testCase "parsing/quoted-string" $ do+ let e = fullyParse txt pQuotedString+ assertEqual "q-s" (Right "foo\"bar\"baz") e++ where+ txt = "\"foo\\\"bar\\\"baz\""++------------------------------------------------------------------------------+testQuotedString' :: Test+testQuotedString' = testCase "parsing/quoted-string-utf8" $ do+ let e = fullyParse qdtext $ pQuotedString' (const True)+ assertEqual "q-s" (Right txt) e++ where+ txt = "\xd1\x82\xd0\xb5\xd1\x81\xd1\x82" -- "тест" as UTF-8+ qdtext = S.concat ["\"", txt, "\""]+++------------------------------------------------------------------------------+-- older random didn't have a Word8 instance.....+data WrappedWord8 = W { _unW :: Word8 }++instance Show WrappedWord8 where+ show (W w) = show w++instance Random WrappedWord8 where+ randomR (W a, W b) g = case randomR (fromIntegral a :: Int,+ fromIntegral b :: Int) g+ of (x, g') -> (W $! fromIntegral x, g')+ random = randomR (W minBound, W maxBound)++instance Arbitrary WrappedWord8 where+ arbitrary = choose (W minBound, W maxBound)+++------------------------------------------------------------------------------+testUnsafeFromHex :: Test+testUnsafeFromHex = testCase "parsing/unsafeFromHex" $ do+ expectExceptionH $ return $! ((unsafeFromHex "zz") :: Int)+ let x = unsafeFromHex "a"+ assertEqual "a" (10 :: Int) x+++------------------------------------------------------------------------------+testUnsafeFromInt :: Test+testUnsafeFromInt = testCase "parsing/unsafeFromNat" $ do+ expectExceptionH $ return $! ((unsafeFromNat "zz") :: Int)+ let x = unsafeFromNat "10"+ assertEqual "10" (10 :: Int) x+++------------------------------------------------------------------------------+testUrlEncoded :: Test+testUrlEncoded = testCase "parsing/urlEncoded" $ do+ let x = parseUrlEncoded "foo=h%20i&bar=baz+baz&baz=quux&baz=zzz&%zz"+ assertEqual "map" (Map.fromList [ ("foo", ["h i"])+ , ("bar", ["baz baz"])+ , ("baz", ["quux", "zzz"]) ]) x+++------------------------------------------------------------------------------+testFailParse :: Test+testFailParse = testCase "parsing/failParse" $ do+ let (Left a) = fullyParse "foo" ((string "bar" <?> "foo") <?> "bar")+ let (Left b) = fullyParse "foo" (fail "bar")+ let (Left c) = fullyParse "aaaaa" (many (char 'a') >> string "b")+ let f = const $ Partial f+ let (Left d) = fullyParse' (const f) (const f) "aaaaa" (string "b")+ let e@(Just "aaaa") = parseToCompletion (many (char 'a')) "aaaa"+ let (Left g) = fullyParse "\x09" crlf+ let (Done z (0::Int)) = finish $! Partial $! \s ->+ s `seq` Partial (\t -> t `seq` Done t 0)+++ return $! length a `seq` length b `seq` length c `seq` length d `seq` e+ `seq` length g `seq` z `seq` ()+++------------------------------------------------------------------------------+testTokens :: Test+testTokens = testCase "parsing/tokens" $ do+ assertEqual "without whitespace" (Right ["Foo","Bar"]) $+ fullyParse "Foo,Bar" pTokens+ assertEqual "with whitespace" (Right ["Foo","Bar"]) $+ fullyParse " Foo ,Bar " pTokens
+ test/Snap/Internal/Routing/Tests.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Internal.Routing.Tests+ ( tests ) where++------------------------------------------------------------------------------+import Control.Applicative ((<|>))+import Control.Exception (ErrorCall (..), throwIO)+import Control.Monad (liftM, unless)+import Control.Monad.Trans (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as S (append, isPrefixOf)+import qualified Data.Map as Map (empty)+import Data.Maybe (fromJust)+import Snap.Internal.Core (Snap, getParam, getRequest, modifyRequest, pass)+import Snap.Internal.Http.Types (Request (rqContextPath, rqPathInfo), rqParam, rqSetParam)+import Snap.Internal.Routing (Route (NoRoute), route, routeEarliestNC, routeHeight, routeLocal)+import Snap.Test (evalHandler, get)+import Snap.Test.Common (expectExceptionH)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertEqual)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+------------------------------------------------------------------------------+++tests :: [Test]+tests = [ testRouting1+ , testRouting2+ , testRouting3+ , testRouting4+ , testRouting5+ , testRouting6+ , testRouting7+ , testRouting8+ , testRouting9+ , testRouting10+ , testRouting11+ , testRouting12+ , testRouting13+ , testRouting14+ , testRouting15+ , testRouting16+ , testRouting17+ , testRouting18+ , testRouting19+ , testRouting20+ , testRouting21+ , testRouting22+ , testRouting23+ , testRouting24+ , testRouting25+ , testRouting26+ , testRouting27+ , testRouting28+ , testRouteLocal+ , testRouteUrlDecode+ , testRouteUrlEncodedPath+ , testRouteEmptyCapture+ , testRouteCaptureConflicts+ , testTrivials+ , testParamUnification+ , testFailedUrlDecode+ , testDirFallthrough+ ]+++------------------------------------------------------------------------------+go :: Snap a -> ByteString -> IO a+go m s0 = evalHandler (get s Map.empty) m+ where+ s = if S.isPrefixOf "/" s0+ then s0+ else S.append "/" s0+++------------------------------------------------------------------------------+routes :: Snap ByteString+routes = route [ ("foo" , topFoo )+ , ("foo/bar" , fooBar )+ , ("foo/bar/baz" , getRqPathInfo )+ , ("foo/:id" , fooCapture )+ , ("bar/:id" , fooCapture )+ , ("herp/:derp/" , getRqPathInfo )+ , ("nerp/:derp/" , getRqContextPath)+ , ("a b c d" , return "OK" )+ , ("bar/quux" , barQuux )+ , ("bar" , bar )+ , ("z/:a/:b/:c/d" , zabc ) ]+++------------------------------------------------------------------------------+routesLocal :: Snap ByteString+routesLocal = routeLocal [ ("foo/bar/baz" , getRqPathInfo )+ , ("bar" , pass )+ , ("quux/zzz" , getRqContextPath)+ ]+++------------------------------------------------------------------------------+routes2 :: Snap ByteString+routes2 = route [ ("" , topTop )+ , ("foo" , topFoo ) ]+++------------------------------------------------------------------------------+routes3 :: Snap ByteString+routes3 = route [ (":foo" , topCapture )+ , ("" , topTop ) ]+++------------------------------------------------------------------------------+routes4 :: Snap ByteString+routes4 = route [ (":foo" , pass )+ , (":foo" , topCapture )+ , (":qqq/:id" , fooCapture )+ , (":id2/baz" , fooCapture2 ) ]+++------------------------------------------------------------------------------+routes5 :: Snap ByteString+routes5 = route [ ("" , pass )+ , ("" , topTop ) ]+++------------------------------------------------------------------------------+routes6 :: Snap ByteString+routes6 = route [ (":a/:a" , dblA ) ]+++------------------------------------------------------------------------------+routes7 :: Snap ByteString+routes7 = route [ ("foo/:id" , fooCapture )+ , ("foo/:id/:id2" , fooCapture2)+ , ("fooo/:id/:id2" , fooCapture2)+ , ("foooo/bar/baz" , bar )+ , ("" , topTop ) ]+++------------------------------------------------------------------------------+routesEmptyCapture :: Snap ByteString+routesEmptyCapture = route [ ("foo/:id", fooCapture) ]+++------------------------------------------------------------------------------+topTop, topFoo, fooBar, fooCapture, getRqPathInfo, bar,+ getRqContextPath, barQuux, dblA, zabc, topCapture,+ fooCapture2 :: Snap ByteString++dblA = do+ ma <- getParam "a"++ unless (ma == Just "a a") pass+ return "ok"+++zabc = do+ ma <- getParam "a"+ mb <- getParam "b"+ mc <- getParam "c"++ unless ( ma == Just "a"+ && mb == Just "b"+ && mc == Just "c" ) pass++ return "ok"+++topCapture = do+ mp <- getParam "foo"+ maybe pass return mp++topTop = return "topTop"+topFoo = return "topFoo"+fooBar = return "fooBar"+fooCapture = liftM (head . fromJust . rqParam "id") getRequest+fooCapture2 = liftM (head . fromJust . rqParam "id2") getRequest+getRqPathInfo = liftM rqPathInfo getRequest+getRqContextPath = liftM rqContextPath getRequest+barQuux = return "barQuux"+bar = return "bar"+++ -----------+ -- Tests --+ -----------+++------------------------------------------------------------------------------+-- TODO more useful test names+testRouting1 :: Test+testRouting1 = testCase "route/1" $ do+ r1 <- go routes "foo"+ assertEqual "/foo" "topFoo" r1+++------------------------------------------------------------------------------+testRouting2 :: Test+testRouting2 = testCase "route/2" $ do+ r2 <- go routes "foo/baz"+ assertEqual "/foo/baz" "baz" r2+++------------------------------------------------------------------------------+testRouting3 :: Test+testRouting3 = testCase "route/3" $ do+ expectExceptionH $ go routes "/xsaxsaxsax"+++------------------------------------------------------------------------------+testRouting4 :: Test+testRouting4 = testCase "route/4" $ do+ r3 <- go routes "foo/bar"+ assertEqual "/foo/bar" "fooBar" r3+++------------------------------------------------------------------------------+testRouting5 :: Test+testRouting5 = testCase "route/5" $ do+ r4 <- go routes "foo/bar/baz/quux"+ assertEqual "/foo/bar/baz/quux" "quux" r4+++------------------------------------------------------------------------------+testRouting6 :: Test+testRouting6 = testCase "route/6" $ do+ r5 <- go routes "foo/bar/sproing"+ assertEqual "/foo/bar/sproing" "fooBar" r5+++------------------------------------------------------------------------------+testRouting7 :: Test+testRouting7 = testCase "route/7" $ do+ r <- go routes "bar"+ assertEqual "/bar" "bar" r+++------------------------------------------------------------------------------+testRouting8 :: Test+testRouting8 = testCase "route/8" $ do+ r2 <- go routes "bar/quux"+ assertEqual "/bar/quux" "barQuux" r2+++------------------------------------------------------------------------------+testRouting9 :: Test+testRouting9 = testCase "route/9" $ do+ r3 <- go routes "bar/whatever"+ assertEqual "/bar/whatever" "whatever" r3+++------------------------------------------------------------------------------+testRouting10 :: Test+testRouting10 = testCase "route/10" $ do+ r4 <- go routes "bar/quux/whatever"+ assertEqual "/bar/quux/whatever" "barQuux" r4+++------------------------------------------------------------------------------+testRouting11 :: Test+testRouting11 = testCase "route/11" $ do+ r1 <- go routes2 ""+ assertEqual "/" "topTop" r1+++------------------------------------------------------------------------------+testRouting12 :: Test+testRouting12 = testCase "route/12" $ do+ r1 <- go routes2 "foo"+ assertEqual "/foo" "topFoo" r1+++------------------------------------------------------------------------------+testRouting13 :: Test+testRouting13 = testCase "route/13" $ do+ r1 <- go routes3 "zzzz"+ assertEqual "/zzzz" "zzzz" r1+++------------------------------------------------------------------------------+testRouting14 :: Test+testRouting14 = testCase "route/14" $ do+ r1 <- go routes3 ""+ assertEqual "/" "topTop" r1+++------------------------------------------------------------------------------+testRouting15 :: Test+testRouting15 = testCase "route/15" $ do+ r1 <- go routes4 "zzzz"+ assertEqual "/zzzz" "zzzz" r1+++------------------------------------------------------------------------------+testRouting16 :: Test+testRouting16 = testCase "route/16" $ do+ r1 <- go routes5 ""+ assertEqual "/" "topTop" r1+++------------------------------------------------------------------------------+testRouting17 :: Test+testRouting17 = testCase "route/17" $ do+ r1 <- go routes "z/a/b/c/d"+ assertEqual "/z/a/b/c/d" "ok" r1+++------------------------------------------------------------------------------+testRouting18 :: Test+testRouting18 = testCase "route/18" $ do+ r1 <- go routes6 "a/a"+ assertEqual "/a/a" "ok" r1+++------------------------------------------------------------------------------+testRouting19 :: Test+testRouting19 = testCase "route/19" $ do+ r1 <- go routes7 "foo"+ assertEqual "/foo" "topTop" r1+++------------------------------------------------------------------------------+testRouting20 :: Test+testRouting20 = testCase "route/20" $ do+ r1 <- go routes7 "foo/baz"+ assertEqual "/foo/baz" "baz" r1+++------------------------------------------------------------------------------+testRouting21 :: Test+testRouting21 = testCase "route/21" $ do+ r1 <- go routes7 "foo/baz/quux"+ assertEqual "/foo/baz/quux" "quux" r1+++------------------------------------------------------------------------------+testRouting22 :: Test+testRouting22 = testCase "route/22" $ do+ r1 <- go routes7 "fooo/baz"+ assertEqual "/fooo/baz" "topTop" r1+++------------------------------------------------------------------------------+testRouting23 :: Test+testRouting23 = testCase "route/23" $ do+ r1 <- go routes7 "fooo/baz/quux"+ assertEqual "/fooo/baz/quux" "quux" r1+++------------------------------------------------------------------------------+testRouting24 :: Test+testRouting24 = testCase "route/24" $ do+ r1 <- go routes7 "foooo/bar/bax"+ assertEqual "/foooo/bar/bax" "topTop" r1+++------------------------------------------------------------------------------+testRouting25 :: Test+testRouting25 = testCase "route/25" $ do+ r1 <- go routes7 "foooo/bar/baz"+ assertEqual "/foooo/bar/baz" "bar" r1+++------------------------------------------------------------------------------+testRouting26 :: Test+testRouting26 = testCase "route/26" $ do+ r1 <- go routes4 "foo/bar"+ assertEqual "capture union" "bar" r1+++------------------------------------------------------------------------------+testRouting27 :: Test+testRouting27 = testCase "route/27" $ do+ r1 <- go routes4 "foo"+ assertEqual "capture union" "foo" r1+++------------------------------------------------------------------------------+testRouting28 :: Test+testRouting28 = testCase "route/28" $ do+ r1 <- go routes4 "quux/baz"+ assertEqual "capture union" "quux" r1+++------------------------------------------------------------------------------+testRouteUrlDecode :: Test+testRouteUrlDecode = testCase "route/urlDecode" $ do+ r1 <- go routes "herp/%7Bderp%7D/"+ assertEqual "rqPathInfo on urldecode" "" r1+ r2 <- go routes "foo/%7Bderp%7D/"+ assertEqual "urldecoded capture" "{derp}" r2+ r3 <- go routes "nerp/%7Bderp%7D/"+ assertEqual "rqContextPath on urldecode" "/nerp/%7Bderp%7D/" r3+++------------------------------------------------------------------------------+testRouteUrlEncodedPath :: Test+testRouteUrlEncodedPath = testCase "route/urlEncodedPath" $ do+ -- make sure path search urlDecodes.+ r1 <- go routes "a+b+c+d"+ assertEqual "urlEncoded search works" "OK" r1+++------------------------------------------------------------------------------+testRouteLocal :: Test+testRouteLocal = testCase "route/routeLocal" $ do+ r4 <- go routesLocal "foo/bar/baz/quux"+ assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4+ expectExceptionH $ go routesLocal "bar"++ go routesLocal "quux/zzz" >>= assertEqual "context" "/"+++------------------------------------------------------------------------------+testRouteEmptyCapture :: Test+testRouteEmptyCapture = testCase "route/emptyCapture" $ do+ r <- go m "foo"+ assertEqual "empty capture must fail" expected r++ r2 <- go m "foo/"+ assertEqual "empty capture must fail" expected r2++ where+ expected = "ZOMG_OK"+ m = routesEmptyCapture <|> return expected+++------------------------------------------------------------------------------+testRouteCaptureConflicts :: Test+testRouteCaptureConflicts = testCase "route/captureConflicts" $ do+ go h1 "ok/ok/ok" >>= assertEqual "earliest non-capture/1" "ok"+ go h2 "ok/ok/ok" >>= assertEqual "earliest non-capture/2" "ok"+ go h3 "foo/ok/ok/ok" >>= assertEqual "earliest non-capture/3" "ok"+ go h4 "foo/ok/ok/ok" >>= assertEqual "earliest non-capture/4" "ok"+ go h5 "zz/aa/zz" >>= assertEqual "fallback" "fb1"+ go h6 "zz" >>= assertEqual "rightmost" "fb2"++ where+ puke = liftIO . throwIO . ErrorCall+ ok = return ("ok" :: String)+ fb1 = return ("fb1" :: String)+ fb2 = return ("fb2" :: String)++ -- rule: earliest non-capture+ h1 = route [ (":a/:b/:c", puke "h1")+ , (":b/:c/ok", ok )+ ]++ h2 = route [ (":a/:b/ok", ok )+ , (":b/:c/:d", puke "h2")+ ]++ -- same, with a prefix+ h3 = route [ ("foo/:a/:b/:c", puke "h1")+ , ("foo/:b/:c/ok", ok )+ ]++ h4 = route [ ("foo/:a/:b/ok", ok )+ , ("foo/:b/:c/:d", puke "h2")+ ]++ -- test fallback+ h5 = route [ ("", fb1)+ , (":a/aa/bb", puke "h5-1")+ , (":b/:c/bb", puke "h5-2")+ ]++ -- all else equal, rightmost wins+ h6 = route [ (":a", fb1), (":b", fb2) ]+++------------------------------------------------------------------------------+testParamUnification :: Test+testParamUnification = testCase "route/paramUnification" $ do+ go h1 "a/b" >>= assertEqual "++" ["0", "a", "b"]+ where+ h1 = do+ modifyRequest $ rqSetParam "a" ["0"]+ route [ (":a/:a", fromJust . rqParam "a" <$> getRequest) ]+++------------------------------------------------------------------------------+testFailedUrlDecode :: Test+testFailedUrlDecode = testCase "route/failedUrlDecode" $ do+ expectExceptionH $ go h1 "%zz"+ expectExceptionH $ go h2 "%zz"+ where+ h1 = route [(":a", return ())]+ h2 = route [("a/", return ())]+++------------------------------------------------------------------------------+testDirFallthrough :: Test+testDirFallthrough = testCase "route/dirFallthrough" $ do+ go m1 "a/a" >>= assertEqual "1" 1+ where+ m1 = route [ ("" , return (1::Int) )+ , ("a/a", pass )+ , ("a/a", pass )+ ]++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "route/trivials" $ do+ -- routeHeight and routeEarliestNC can't actually be called on NoRoute (it+ -- never appears in the children of captures or directories), so cover this+ -- case here+ assertEqual "trivials/routeHeight" 1 (routeHeight NoRoute)+ assertEqual "trivials/routeEarliestNC" 1 (routeEarliestNC NoRoute 1)
+ test/Snap/Test/Common.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Snap.Test.Common+ ( coverEqInstance+ , coverOrdInstance+ , coverReadInstance+ , coverShowInstance+ , coverTypeableInstance+ , forceSameType+ , expectException+ , expectExceptionH+ , liftQ+ , eatException+ , waitabit+ , seconds+ ) where+------------------------------------------------------------------------------+import Control.Concurrent (threadDelay)+import Control.DeepSeq (deepseq)+import Control.Exception.Lifted (SomeException (..), catch, evaluate, try)+import Control.Monad (Monad ((>>), return), liftM, replicateM)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.ByteString as S+import Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Lazy as L+import Data.Typeable (Typeable, typeOf)+import Prelude (Either (..), Eq (..), IO, Int, Num (..), Ord (..), Ordering (..), Read (..), Show (..), fail, map, seq, ($), (.), (^))+import Test.QuickCheck (Arbitrary (arbitrary), choose)+import Test.QuickCheck.Monadic (PropertyM)+import qualified Test.QuickCheck.Monadic as QC+------------------------------------------------------------------------------++------------------------------------------------------------------------------+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+++------------------------------------------------------------------------------+eatException :: (MonadBaseControl IO m) => m a -> m ()+eatException a = (a >> return ()) `catch` handler+ where+ handler :: (MonadBaseControl IO m) => SomeException -> m ()+ handler _ = return ()+++------------------------------------------------------------------------------+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 ()+++------------------------------------------------------------------------------+expectException :: IO a -> PropertyM IO ()+expectException m = do+ e <- liftQ $ try m+ case e of+ Left (z::SomeException) -> (forceList $ show z) `seq` return ()+ Right _ -> fail "expected exception, didn't get one"+++------------------------------------------------------------------------------+expectExceptionH :: IO a -> IO ()+expectExceptionH act = do+ e <- try act+ case e of+ Left (z::SomeException) -> (forceList $ show z) `seq` return ()+ Right _ -> fail "expected exception, didn't get one"+++------------------------------------------------------------------------------+forceList :: [a] -> ()+forceList [] = ()+forceList (x:xs) = x `seq` forceList xs+++------------------------------------------------------------------------------+liftQ :: forall a m . (Monad m) => m a -> PropertyM m a+liftQ = QC.run+++------------------------------------------------------------------------------+waitabit :: IO ()+waitabit = threadDelay $ 2*seconds+++------------------------------------------------------------------------------+seconds :: Int+seconds = (10::Int) ^ (6::Int)+
+ test/Snap/Test/Tests.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Test.Tests+ ( tests+ ) where++------------------------------------------------------------------------------+import Control.Applicative (Applicative (..))+import Control.Exception (ErrorCall (..), evaluate)+import Control.Monad (MonadPlus (mzero), liftM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans (lift)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.Functor (Functor (fmap, (<$)))+import qualified Data.Map as Map+import Data.Maybe (fromJust, isJust)+import Data.Text (Text)+import Data.Time.Clock (getCurrentTime)+import Prelude (Bool (True, False), IO, Int, Maybe (Just, Nothing), Monad (..), Ord (..), const, fail, fromIntegral, return, seq, show, ($), ($!), (*), (.))+import Snap.Core (Cookie (Cookie, cookieExpires), Method (DELETE, GET, HEAD, Method, PATCH, POST, PUT), Request (rqContentLength, rqContextPath, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Snap, expireCookie, extendTimeout, getCookie, getHeader, getParam, logError, readCookie, redirect, runSnap, terminateConnection, writeBS)+import Snap.Internal.Http.Types (Request (..), Response (rspCookies))+import qualified Snap.Internal.Http.Types as T+import Snap.Internal.Test.RequestBuilder (FileData (FileData), MultipartParam (Files, FormData), RequestBuilder, RequestType (DeleteRequest, GetRequest, MultipartPostRequest, RequestWithRawBody, UrlEncodedPostRequest), addCookies, addHeader, buildRequest, delete, evalHandler, get, postMultipart, postRaw, postUrlEncoded, put, requestToString, responseToString, runHandler, setContentType, setHeader, setHttpVersion, setQueryStringRaw, setRequestPath, setRequestType, setSecure)+import Snap.Test (assert404, assertBodyContains, assertRedirect, assertRedirectTo, assertSuccess, getResponseBody)+import Snap.Test.Common (coverShowInstance, expectExceptionH)+import Snap.Util.FileUploads (defaultUploadPolicy, handleMultipart, partContentType, partFieldName, partFileName)+import qualified System.IO.Streams as Streams+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertEqual)+import Text.Regex.Posix ((=~))+------------------------------------------------------------------------------++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testDefaultBuild+ , testRequestToString+ , testSetRequestType+ , testSetQueryString+ , testSetQueryStringRaw+ , testHeaders+ , testMisc+ , testMultipart+ , testPost+ , testFormEncoded+ , testToString+ , testAssert404+ , testAssertBodyContains+ , testAssertRedirect+ , testCookies+ , testTerminate+ , testTrivials+ , testHostName+ ]+++------------------------------------------------------------------------------+testDefaultBuild :: Test+testDefaultBuild = testCase "test/requestBuilder/defaultBuild" $ do+ req <- buildRequest $ setRequestType GetRequest+ Streams.toList (rqBody req) >>= assertEqual "body" []+ assertEqual "pathInfo" "" $ rqPathInfo req+ assertEqual "ctx" "/" $ rqContextPath req+ assertEqual "uri" "/" $ rqURI req+ assertEqual "qs" "" $ rqQueryString req+ assertEqual "p1" Map.empty $ rqParams req+ assertEqual "p2" Map.empty $ rqQueryParams req+ assertEqual "p3" Map.empty $ rqPostParams req++------------------------------------------------------------------------------+testFormEncoded :: Test+testFormEncoded = testCase "test/requestBuilder/postFormEncoded" $ do+ req <- buildRequest $ postUrlEncoded "/foo/bar"+ $ Map.fromList [("baz", ["qux"])]+ assertEqual "post params" [("baz", ["qux"])] $ Map.toList $ rqPostParams req+------------------------------------------------------------------------------+testSetRequestType :: Test+testSetRequestType = testCase "test/requestBuilder/setRequestType" $ do+ request1 <- buildRequest $ setRequestType GetRequest+ assertEqual "setRequestType/1" GET (rqMethod request1)++ request2 <- buildRequest $ setRequestType DeleteRequest+ assertEqual "setRequestType/2" DELETE (rqMethod request2)++ request3 <- buildRequest $ setRequestType $ RequestWithRawBody PUT "foo"+ assertEqual "setRequestType/3/Method" PUT (rqMethod request3)++ rqBody3 <- getRqBody request3+ assertEqual "setRequestType/3/Body" "foo" rqBody3++ request4 <- buildRequest $ setRequestType rt4+ assertEqual "setRequestType/4/Method" POST (rqMethod request4)+ -- will test correctness of multipart generation code in another test++ request5 <- buildRequest $ setRequestType $+ UrlEncodedPostRequest $ Map.fromList [("foo", ["foo"])]+ assertEqual "setRequestType/5/Method" POST (rqMethod request5)++ request6 <- buildRequest $ setRequestType $+ RequestWithRawBody (Method "MOVE") "foo"+ assertEqual "setRequestType/6/Method" (Method "MOVE") (rqMethod request6)++ request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar"+ assertEqual "setRequestType/7/Method" PATCH (rqMethod request7)++ request8 <- buildRequest $ setRequestType $ RequestWithRawBody HEAD ""+ assertEqual "setRequestType/8/Method" HEAD (rqMethod request8)++ where+ rt4 = MultipartPostRequest [ ("foo", FormData ["foo"])+ , ("bar", Files [fd4])+ ]++ fd4 = FileData "bar.txt" "text/plain" "bar"+++------------------------------------------------------------------------------+testSetQueryString :: Test+testSetQueryString = testCase "test/requestBuilder/testSetQueryString" $ do+ request <- buildRequest $ get "/" params+ assertEqual "setQueryString" params $ rqParams request+ assertEqual "queryString" "bar=bar&foo=foo&foo=foo2" $+ rqQueryString request++ where+ params = Map.fromList [ ("foo", ["foo", "foo2"])+ , ("bar", ["bar"]) ]+++------------------------------------------------------------------------------+testSetQueryStringRaw :: Test+testSetQueryStringRaw = testCase "test/requestBuilder/testSetQueryStringRaw" $ do+ request <- buildRequest $ do+ postUrlEncoded "/" $ Map.fromList [("foo", ["foo0"])]+ addCookies [c1, c2]+ setQueryStringRaw "foo=foo&foo=foo2&bar=bar"+ assertEqual "setQueryStringRaw" params $ rqParams request+ assertEqual "cookie" (Just "k=v; k2=v2") $ getHeader "cookie" request++ where+ c1 = Cookie "k" "v" Nothing Nothing Nothing False False+ c2 = Cookie "k2" "v2" Nothing Nothing Nothing False False+ params = Map.fromList [ ("foo", ["foo0", "foo", "foo2"])+ , ("bar", ["bar"]) ]+++------------------------------------------------------------------------------+testHeaders :: Test+testHeaders = testCase "test/requestBuilder/testHeaders" $ do+ request <- buildRequest $ do+ get "/" Map.empty+ setHeader "foo" "foo"+ addHeader "bar" "bar"+ addHeader "bar" "bar2"+ setContentType "image/gif" -- this should get deleted+ assertEqual "setHeader" (Just "foo") $ getHeader "foo" request+ assertEqual "addHeader" (Just "bar,bar2") $ T.getHeader "bar" request+ assertEqual "contentType" Nothing $ T.getHeader "Content-Type" request+ assertEqual "contentLength" Nothing $ rqContentLength request+ assertEqual "contentLengthHdr" Nothing $ getHeader "Content-Length" request++ request2 <- buildRequest $ put "/" "text/zzz" "zzz"+ assertEqual "contentType2" (Just "text/zzz") $+ T.getHeader "Content-Type" request2+ assertEqual "contentLength" (Just 3) $ rqContentLength request2+ assertEqual "contentLengthHdr" (Just "3") $+ getHeader "Content-Length" request2+++------------------------------------------------------------------------------+testMisc :: Test+testMisc = testCase "test/requestBuilder/testMisc" $ do+ request <- buildRequest $ do+ get "/" Map.empty+ setSecure True+ setRequestPath "/foo/bar"++ assertEqual "secure" True $ rqIsSecure request+ assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request+ assertEqual "rqURI" "/foo/bar" $ rqURI request+ assertEqual "rqContextPath" "/" $ rqContextPath request+ assertEqual "rqVersion" (1,1) $ rqVersion request++ body <- getRqBody request+ assertEqual "body" "" body++ request2 <- buildRequest $ do+ postRaw "/" "text/zzz" "zzz"+ setHttpVersion (1,0)++ body2 <- getRqBody request2+ assertEqual "body2" "zzz" body2++ assertEqual "contentType2" (Just "text/zzz") $+ T.getHeader "Content-Type" request2+ assertEqual "postRaw" POST $ rqMethod request2+ assertEqual "rqVersion2" (1,0) $ rqVersion request2++ request3 <- buildRequest $ do+ delete "/" Map.empty+ setSecure True+ setRequestPath "/foo/bar"++ assertEqual "secure" True $ rqIsSecure request3+ assertEqual "method" DELETE $ rqMethod request3+ assertEqual "rqPathInfo" "foo/bar" $ rqPathInfo request3+ assertEqual "rqURI" "/foo/bar" $ rqURI request3+ assertEqual "rqContextPath" "/" $ rqContextPath request3+ assertEqual "rqVersion" (1,1) $ rqVersion request3+++------------------------------------------------------------------------------+testMultipart :: Test+testMultipart = testCase "test/requestBuilder/testMultipart" $ do+ request0 <- buildRequest rq+ (request,rbody) <- peekRqBody request0+ assertEqual "content-length" (Just (fromIntegral $ S.length rbody)) $+ rqContentLength request++ (_,response) <- runSnap handler (const $ return $! ())+ (const $ return $! ())+ request+ body <- getResponseBody response+ assertEqual "body" "OK" body++ where+ partHandler pinfo stream = do+ let field = partFieldName pinfo+ let fn = partFileName pinfo+ let ct = partContentType pinfo+ body <- liftM S.concat $ Streams.toList stream+ return (field, fn, ct, body)++ expectedParts = [ ("bar", Just "bar1.txt", "text/plain", "bar")+ , ("bar", Just "bar2.txt", "text/zzz", "bar2")+ , ("baz", Just "baz.gif", "text/gif", "baz") ]++ handler = do+ parts <- handleMultipart defaultUploadPolicy partHandler+ fooParam <- getParam "foo"+ liftIO $ assertEqual "param" (Just "oof") fooParam++ quuxParams <- getParam "quux"+ liftIO $ assertEqual "quux" (Just "quux1 quux2") quuxParams+ liftIO $ assertEqual "parts" expectedParts parts+ writeBS "OK"++ rq = postMultipart "/" rt++ rt = [ ("foo", FormData ["oof"])+ , ("bar", Files [fb1, fb2])+ , ("baz", Files [fz])+ , ("zzz", Files [])+ , ("zz0", FormData [])+ , ("quux", FormData ["quux1", "quux2"])+ ]++ fb1 = FileData "bar1.txt" "text/plain" "bar"+ fb2 = FileData "bar2.txt" "text/zzz" "bar2"+ fz = FileData "baz.gif" "text/gif" "baz"+++------------------------------------------------------------------------------+testPost :: Test+testPost = testCase "test/requestBuilder/testPost" $ do+ request <- buildRequest $ do+ postUrlEncoded "/" $ Map.fromList [("foo", ["foo1", "foo2"])]++ body <- getRqBody request+ assertEqual "body" "foo=foo1&foo=foo2" body+ assertEqual "len" (Just (fromIntegral $ S.length body))+ (rqContentLength request)+ assertEqual "contentType" (Just "application/x-www-form-urlencoded") $+ getHeader "Content-Type" request+++------------------------------------------------------------------------------+testToString :: Test+testToString = testCase "test/requestBuilder/testToString" $ do+ rsp <- runHandler rq h+ http <- responseToString rsp+ body <- getResponseBody rsp+ out2 <- evalHandler rq h++ assertSuccess rsp+ assertEqual "Close" (Just "close") $ getHeader "connection" rsp+ assertEqual "HTTP body" "zzz" body+ assertBool "HTTP header" $ http =~ headRE+ assertBool "HTTP date" $ http =~ dateRE+ assertEqual "monadic result" 42 out2+ where+ rq = do postRaw "/" "text/zzz" "zzz"+ setHttpVersion (1,0)+ h = do writeBS "zzz"+ logError "zzz"+ extendTimeout 5+ return (42 :: Int)+ headRE = "HTTP/1.1 200 OK" :: ByteString+ dateRE = S.concat [ "date: [a-zA-Z]+, [0-9]+ [a-zA-Z]+ "+ , "[0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT"+ ]+++------------------------------------------------------------------------------+testRequestToString :: Test+testRequestToString = testCase "test/requestBuilder/reqToString" $ do+ req1 <- buildRequest $ setRequestType GetRequest+ s1 <- requestToString req1+ assertBool "HTTP header" $ s1 =~ headRE++ req2 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"+ setHttpVersion (1,0)+ s2 <- requestToString req2+ assertBool "HTTP header2" $ s2 =~ postHeadRE+ assertBool "HTTP cl" $ s2 =~ ("content-length: 3" :: ByteString)++ req3 <- buildRequest $ do postRaw "/" "text/zzz" "zzz"+ setHeader "transfer-encoding" "chunked"+ s3 <- requestToString req3+ assertBool "HTTP chunked" $ "3\r\nzzz\r\n0\r\n\r\n" `S.isSuffixOf` s3++ where+ headRE = "^GET / HTTP/1.1\r\n" :: ByteString+ postHeadRE = "^POST / HTTP/1.0\r\n" :: ByteString+++------------------------------------------------------------------------------+testAssert404 :: Test+testAssert404 = testCase "test/requestBuilder/testAssert404" $ do+ rsp <- runHandler (get "/" Map.empty) mzero+ assert404 rsp+ expectExceptionH $ assertSuccess rsp+ expectExceptionH $ assertBodyContains "fjlkdja" rsp+ expectExceptionH $ assertRedirectTo "/zzzzz" rsp+ expectExceptionH $ assertRedirect rsp++ rsp2 <- runHandler (get "/" Map.empty) (return ())+ assertSuccess rsp2+ expectExceptionH $ assert404 rsp2++++------------------------------------------------------------------------------+testAssertBodyContains :: Test+testAssertBodyContains =+ testCase "test/requestBuilder/testAssertBodyContains" $ do+ rsp <- runHandler (get "/" Map.empty) $ do+ writeBS "RESPONSE IS OK"+ assertBodyContains "NSE IS" rsp+++------------------------------------------------------------------------------+testAssertRedirect :: Test+testAssertRedirect = testCase "test/requestBuilder/testAssertRedirect" $ do+ rsp <- runHandler (get "/" Map.empty) $ redirect "/bar"+ assertRedirectTo "/bar" rsp+ assertRedirect rsp+ expectExceptionH $ assertRedirectTo "/zzzz" rsp+++------------------------------------------------------------------------------+testCookies :: Test+testCookies = testCase "test/requestBuilder/cookies" $ do+ evalHandler (get "/" Map.empty) (getCookie "foo")+ >>= assertEqual "cookie1" Nothing+ evalHandler (get "/" Map.empty >> addCookies [c1]) (getCookie "foo")+ >>= assertEqual "cookie2" (Just c1)+ evalHandler (get "/" Map.empty >> addCookies [c1]) (readCookie "foo")+ >>= assertEqual "cookie3" ("bar" :: Text)+ expectExceptionH $+ evalHandler (get "/" Map.empty >> addCookies [c2])+ ((readCookie "foo") :: Snap Int)+ expectExceptionH $+ evalHandler (get "/" Map.empty >> addCookies [c2])+ ((readCookie "bar") :: Snap Int)+ rsp <- runHandler (get "/" Map.empty) expire++ let h = Map.lookup "foo" (rspCookies rsp)+ assertBool "isJust" (isJust h)++ now <- getCurrentTime+ let tm = fromJust $ cookieExpires $ fromJust h+ assertBool "time" (tm < now)+ return $! show tm `seq` ()++ -- FIXME(greg): the following test currently fails because we're rendering+ -- the set-cookie headers in the server instead of in fixupResponse where+ -- it should be happening++ -- let h = getHeader "set-cookie" rsp+ -- assertBool "isJust" (isJust h)+ -- let (Just cookie) = h+ -- assertEqual "cookie" "" cookie+ where+ c1 = Cookie "foo" "bar" Nothing Nothing Nothing False False+ c2 = Cookie "foo" "zzzzz" Nothing Nothing Nothing False False++ expire = expireCookie c1+++------------------------------------------------------------------------------+testTerminate :: Test+testTerminate = testCase "test/requestBuilder/terminate" $+ expectExceptionH $+ evalHandler (return ()) (terminateConnection $ ErrorCall "foo")+++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "test/requestBuilder/trivials" $ do+ coverShowInstance (FormData [])+ coverShowInstance (Files [])+ coverShowInstance (FileData "" "" "")+ coverShowInstance GetRequest+ z <- buildRequest $ do+ (() <$ (pure () <* rb *> rb2)) >>= lift . evaluate+ x <- fmap (*4) (return (3 :: Int))+ lift $ assertEqual "fmap" 12 x++ expectExceptionH $ buildRequest $ fail "foo"+ z `seq` return ()++ where+ rb = (return ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()+ rb2 = (pure ()) :: (Functor m, Monad m, Applicative m) => RequestBuilder m ()+++------------------------------------------------------------------------------+testHostName :: Test+testHostName = testCase "test/requestBuilder/hostName" $ do+ request <- buildRequest $ do+ get "/" Map.empty+ setHeader "Host" "just.an.example.com"+ assertEqual "HostName" "just.an.example.com" $ rqHostName request+ assertEqual "Host header" (Just "just.an.example.com") $ getHeader "host" request+++------------------------------------------------------------------------------+getRqBody :: Request -> IO ByteString+getRqBody = liftM S.concat . Streams.toList . rqBody+++peekRqBody :: Request -> IO (Request, ByteString)+peekRqBody rq = do+ l <- Streams.toList $ rqBody rq+ b <- Streams.fromList l++ return (rq { rqBody = b }, S.concat l)
+ test/Snap/Types/Headers/Tests.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++------------------------------------------------------------------------------+module Snap.Types.Headers.Tests (tests) where+------------------------------------------------------------------------------+import Data.CaseInsensitive as CI+import Data.List (sort)+import qualified Data.Set as Set+import Snap.Test.Common (coverShowInstance)+import qualified Snap.Types.Headers as H+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertEqual)+------------------------------------------------------------------------------++tests :: [Test]+tests = [ testTrivials+ , testToFrom+ , testFolds+ ]+++------------------------------------------------------------------------------+testToFrom :: Test+testToFrom = testCase "types/headers/toFrom" $ do+ let h = H.unsafeFromCaseFoldedList [("foo", "bar")]+ assertEqual "toFrom1" [("foo", "bar")] $ H.toList h+ assertEqual "toFrom2" [("foo", "bar")]+ $ H.unsafeToCaseFoldedList $ H.fromList [("Foo", "bar")]+ assertBool "member" $ H.member "Foo" h+ assertBool "not member" $ not $ H.member "Fooooo" h++ let h' = H.set "foo" "zzz" . H.set "zzz" "qqq" $ h+ assertEqual "set/lookup" (Just "zzz") $ H.lookup "Foo" h'+ assertEqual "set/lookupD1" "zzz" $ H.lookupWithDefault "000" "Foo" h'+ assertEqual "set/lookupD2" "000" $ H.lookupWithDefault "000" "Zoo" h'++ assertEqual "toSort" [("a", "b"), ("foo","zzz"), ("zzz","qqq")] $ sort+ $ H.unsafeToCaseFoldedList $ H.unsafeInsert "a" "b" h'+++------------------------------------------------------------------------------+testFolds :: Test+testFolds = testCase "types/headers/folds" $ do+ let h = H.fromList [("foo", "bar"), ("bar", "baz")]+ let r1 = Set.toAscList $ H.foldl' ffl Set.empty h+ let r2 = Set.toAscList $ H.foldr ffr Set.empty h+ let r3 = Set.toAscList $ H.foldedFoldl' fl Set.empty h+ let r4 = Set.toAscList $ H.foldedFoldr fr Set.empty h++ let r = ["bar", "baz", "foo"]+ assertEqual "r1" r r1+ assertEqual "r2" r r2+ assertEqual "r3" r r3+ assertEqual "r4" r r4++ where+ fl !s !k v = Set.insert k $ Set.insert v s+ fr !k v !s = Set.insert k $ Set.insert v s+ ffl !s !k v = Set.insert (CI.foldedCase k) $ Set.insert v s+ ffr !k v !s = Set.insert (CI.foldedCase k) $ Set.insert v s++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "types/headers/show" $ do+ let h = H.empty+ assertBool "null" $ H.null h+ assertEqual "lookupWithDefault" "ok" $ H.lookupWithDefault "ok" "foo" h+ assertEqual "foldr" () $ H.foldr (\_ _ x -> x) () $ H.insert "ok" "ok" h+ assertEqual "foldl'" () $ H.foldl' (\x _ _ -> x) () $ H.insert "ok" "ok" h+ assertEqual "foldedFoldr" () $+ H.foldedFoldr (\_ _ x -> x) () $ H.unsafeInsert "ok" "ok" h+ assertEqual "foldedFoldl'" () $+ H.foldedFoldl' (\x _ _ -> x) () $ H.unsafeInsert "ok" "ok" h+ assertBool "member" $ not $ H.member "foo" h+ coverShowInstance h
+ test/Snap/Util/CORS/Tests.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Util.CORS.Tests (tests) where++------------------------------------------------------------------------------+import Data.ByteString.Char8 (ByteString)+import Data.CaseInsensitive (CI (..))+#if !MIN_VERSION_base(4,8,0)+import Data.Functor ((<$>))+#endif+import qualified Data.HashSet as HashSet+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Snap.Core (Method (..), getHeader, Response(..))+import Snap.Test (RequestBuilder, runHandler, setHeader, setRequestType, RequestType(..), setRequestPath)+import Snap.Util.CORS (applyCORS,CORSOptions(..),defaultOptions,HashableMethod(..))+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertEqual,Assertion)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testCORSSimple+ , testCORSOptions+ ]+++ ---------------+ -- Constants --+ ---------------++------------------------------------------------------------------------------+origin :: ByteString+origin = "http://origin.org"++++ -----------+ -- Tests --+ -----------++------------------------------------------------------------------------------+testCORSSimple :: Test+testCORSSimple = testCase "CORS/simple" $ do+ let testDefault meth = do+ r <- runHandler (mkMethReq meth) $+ applyCORS defaultOptions $ return ()+ checkAllowOrigin (Just origin) r+ checkAllowCredentials (Just "true") r+ checkExposeHeaders Nothing r+ mapM_ testDefault [GET,POST,PUT,DELETE,HEAD]++------------------------------------------------------------------------------+testCORSOptions :: Test+testCORSOptions = testCase "CORS/options" $ do+ let opts = applyCORS defaultOptions { corsAllowedMethods =+ return $ HashSet.singleton $ HashableMethod GET }+ r <- runHandler (mkMethReq OPTIONS+ >> setRequestMethod "GET"+ >> setRequestHeaders "X-STUFF, Content-Type") $+ opts $ return ()+ checkAllowOrigin (Just origin) r+ checkAllowCredentials (Just "true") r+ checkAllowHeaders (Just "Content-Type, X-STUFF") r+ checkAllowMethods (Just "GET") r+ ---------------------------------------------------------+ s <- runHandler (mkMethReq OPTIONS+ >> setRequestMethod "POST"+ >> setRequestHeaders "X-STUFF, Content-Type") $+ opts $ return ()+ checkAllowOrigin Nothing s+ checkAllowCredentials Nothing s+ checkAllowHeaders Nothing s+ checkAllowMethods Nothing s+++ ---------------+ -- Functions --+ ---------------++------------------------------------------------------------------------------+mkMethReq :: Method -> RequestBuilder IO ()+mkMethReq meth = do+ setRequestType $ RequestWithRawBody meth ""+ setRequestPath "/"+ setHeader "Origin" origin++checkHeader :: CI ByteString -> Maybe ByteString -> Response -> Assertion+checkHeader h v r = assertEqual ("Header " ++ show h) v (getHeader h r)++checkAllowOrigin :: Maybe ByteString -> Response -> Assertion+checkAllowOrigin = checkHeader "Access-Control-Allow-Origin"++checkAllowCredentials :: Maybe ByteString -> Response -> Assertion+checkAllowCredentials = checkHeader "Access-Control-Allow-Credentials"++checkExposeHeaders :: Maybe ByteString -> Response -> Assertion+checkExposeHeaders = checkHeader "Access-Control-Expose-Headers"++checkAllowHeaders :: Maybe ByteString -> Response -> Assertion+checkAllowHeaders v r =+ assertEqual "Header Access-Control-Allow-Headers"+ (getSet <$> v)+ (getSet <$> getHeader "Access-Control-Allow-Headers" r)+ where+ getSet = Set.fromList . Text.splitOn ", " . Text.decodeUtf8++checkAllowMethods :: Maybe ByteString -> Response -> Assertion+checkAllowMethods = checkHeader "Access-Control-Allow-Methods"++setRequestMethod :: ByteString -> RequestBuilder IO ()+setRequestMethod = setHeader "Access-Control-Request-Method"++setRequestHeaders :: ByteString -> RequestBuilder IO ()+setRequestHeaders = setHeader "Access-Control-Request-Headers"
+ test/Snap/Util/FileServe/Tests.hs view
@@ -0,0 +1,627 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Util.FileServe.Tests+ ( tests ) where++------------------------------------------------------------------------------+import Control.Applicative ((<|>))+import Control.Monad (forM_, liftM)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S (break, breakEnd, drop, isInfixOf, pack)+import qualified Data.HashMap.Strict as HashMap (empty, fromList, toList)+import qualified Data.Map as Map (empty)+import Data.Maybe (fromJust, isJust)+import qualified Data.Text as T (unpack)+import Snap.Internal.Core (Snap, fixupResponse, pass, runSnap, writeBS)+import Snap.Internal.Http.Types (Request, Response (rspContentLength, rspStatus), getHeader, setHeader)+import Snap.Internal.Util.FileServe (DirectoryConfig (..), decodeFilePath, defaultMimeTypes, fancyDirectoryConfig, serveDirectory, serveDirectoryWith, serveFile, simpleDirectoryConfig)+import qualified Snap.Test as Test (buildRequest, get, getResponseBody, setQueryStringRaw)+import Snap.Test.Common (expectExceptionH)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertEqual)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testFooBin+ , testFooTxt+ , testFooHtml+ , testFooBinBinBin+ , testDirectoryPasses+ , test404s+ , testFsSingle+ , testFsCfgA+ , testFsCfgB+ , testFsCfgC+ , testFsCfgD+ , testFsCfgFancy+ , testRangeOK+ , testRangeBad+ , testMultiRange+ , testIfRange+ , testBadUrl+ , testDecodeFilePath+ ]+++------------------------------------------------------------------------------+expect404 :: IO Response -> IO ()+expect404 m = do+ r <- m+ assertBool "expected 404" (rspStatus r == 404)+++------------------------------------------------------------------------------+expect302 :: ByteString -> IO Response -> IO ()+expect302 p m = do+ r <- m+ assertBool "expected 302" (rspStatus r == 302)+ assertEqual "redir location"+ (Just p)+ (getHeader "location" r)+++------------------------------------------------------------------------------+runIt :: Snap a -> Request -> IO (Request, Response)+runIt m rq = do+ (rq', rsp) <- runSnap m d d rq+ rsp' <- fixupResponse rq rsp+ return (rq', rsp')+ where+ d = const $ return ()+++------------------------------------------------------------------------------+go :: Snap a -> ByteString -> IO Response+go m s = do+ rq <- mkRequest s+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response+goIfModifiedSince m s lm = do+ rq <- mkRequest s+ let r = setHeader "if-modified-since" lm rq+ liftM snd (runIt m r)+++------------------------------------------------------------------------------+goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response+goIfRange m s (start,end) lm = do+ rq <- mkRequest s+ let r = setHeader "if-range" lm $+ setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)+ rq+ liftM snd (runIt m r)+++------------------------------------------------------------------------------+goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response+goRange m s (start,end) = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)+ rq'+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response+goMultiRange m s (start,end) (start2,end2) = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end+ ++ "," ++ show start2 ++ "-" ++ show end2)+ rq'+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+goRangePrefix :: Snap a -> ByteString -> Int -> IO Response+goRangePrefix m s start = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-")+ rq'+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response+goRangeSuffix m s end = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=-" ++ show end)+ rq'+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+mkRequest :: ByteString -> IO Request+mkRequest uri = Test.buildRequest $ do+ Test.get pathPart Map.empty+ Test.setQueryStringRaw queryPart+ where+ (pathPart, queryPart) = breakQuery uri++ breakQuery s = (a, S.drop 1 b)+ where+ (a,b) = S.break (=='?') s+++------------------------------------------------------------------------------+fs :: Snap ()+fs = do+ x <- serveDirectory "test/data/fileServe"+ return $! x `seq` ()+++------------------------------------------------------------------------------+fsSingle :: Snap ()+fsSingle = do+ x <- serveFile "test/data/fileServe/foo.html"+ return $! x `seq` ()+++------------------------------------------------------------------------------+fsCfg :: DirectoryConfig Snap -> Snap ()+fsCfg cfg = do+ x <- serveDirectoryWith cfg "test/data/fileServe"+ return $! x `seq` ()+++------------------------------------------------------------------------------+testFooBin :: Test+testFooBin = testCase "fileServe/foo.bin" $ do+ r1 <- go fs "foo.bin"+ checkProps "fileServe/foo.bin/default" r1+ let !lm = fromJust $ getHeader "last-modified" r1++ go fs "foo.bin?blah=blah" >>= checkProps "fileServe/foo.bin/query-string"++ -- check last modified stuff+ r2 <- goIfModifiedSince fs "foo.bin" lm+ assertEqual "foo.bin 304" 304 $ rspStatus r2++ r3 <- goIfModifiedSince fs "foo.bin" "Wed, 15 Nov 1995 04:58:08 GMT"+ checkProps "fileServe/foo.bin/ifModifiedSince" r3++ where+ checkProps name r = do+ b <- Test.getResponseBody r++ assertEqual (name ++ "/contents") "FOO\n" b+ assertEqual (name ++ "/content-type")+ (Just "application/octet-stream")+ (getHeader "content-type" r)++ assertEqual (name ++ "/size") (Just 4) (rspContentLength r)++ assertBool (name ++ "/last-modified")+ (isJust $ getHeader "last-modified" r)++ assertEqual (name ++ "/accept-ranges")+ (Just "bytes")+ (getHeader "accept-ranges" r)+++------------------------------------------------------------------------------+testFooTxt :: Test+testFooTxt = testCase "fileServe/foo.txt" $ do+ go fs "foo.txt" >>= checkProps "fileServe/foo.txt/default"+ go fs "foo.txt?blah=blah" >>= checkProps "fileServe/foo.txt/query"++ where+ checkProps name r = do+ b <- Test.getResponseBody r++ assertEqual (name ++ "/contents") "FOO\n" b+ assertEqual (name ++ "/content-type")+ (Just "text/plain")+ (getHeader "content-type" r)++ assertEqual (name ++ "/size") (Just 4) (rspContentLength r)++ assertBool (name ++ "/last-modified")+ (isJust $ getHeader "last-modified" r)++ assertEqual (name ++ "/accept-ranges")+ (Just "bytes")+ (getHeader "accept-ranges" r)+++------------------------------------------------------------------------------+testFooHtml :: Test+testFooHtml = testCase "fileServe/foo.html" $ do+ go fs "foo.html" >>= checkProps "fileServe/foo.html/default"+ go fs "foo.html?bar=bar" >>= checkProps "fileServe/foo.html/query"++ where+ checkProps name r = do+ b <- Test.getResponseBody r++ assertEqual (name ++ "/contents") "FOO\n" b+ assertEqual (name ++ "/content-type")+ (Just "text/html")+ (getHeader "content-type" r)++ assertEqual (name ++ "/size") (Just 4) (rspContentLength r)++ assertBool (name ++ "/last-modified")+ (isJust $ getHeader "last-modified" r)++ assertEqual (name ++ "/accept-ranges")+ (Just "bytes")+ (getHeader "accept-ranges" r)+++------------------------------------------------------------------------------+testFooBinBinBin :: Test+testFooBinBinBin = testCase "fileServe/foo.bin.bin.bin" $ do+ go fs "foo.bin.bin.bin" >>= checkProps "fileServe/foo.bin.bin.bin"++ where+ checkProps name r = do+ b <- Test.getResponseBody r++ assertEqual (name ++ "/contents") "FOO\n" b+ assertEqual (name ++ "/content-type")+ (Just "application/octet-stream")+ (getHeader "content-type" r)++ assertEqual (name ++ "/size") (Just 4) (rspContentLength r)++ assertBool (name ++ "/last-modified")+ (isJust $ getHeader "last-modified" r)++ assertEqual (name ++ "/accept-ranges")+ (Just "bytes")+ (getHeader "accept-ranges" r)+++------------------------------------------------------------------------------+test404s :: Test+test404s = testCase "fileServe/404s" $ do+ expect404 $ go fs "jfldksjflksd"+ expect404 $ go fs "dummy/../foo.txt"+ expect404 $ go fs "/etc/password"++ coverMimeMap+++------------------------------------------------------------------------------+printName :: FilePath -> Snap ()+printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c+++------------------------------------------------------------------------------+cfgA, cfgB, cfgC, cfgD :: DirectoryConfig Snap+cfgA = DirectoryConfig {+ indexFiles = []+ , indexGenerator = const pass+ , dynamicHandlers = HashMap.empty+ , mimeTypes = defaultMimeTypes+ , preServeHook = \x -> x `seq` (return $! ())+ }++cfgB = DirectoryConfig {+ indexFiles = ["index.txt", "altindex.html"]+ , indexGenerator = const pass+ , dynamicHandlers = HashMap.empty+ , mimeTypes = defaultMimeTypes+ , preServeHook = \x -> x `seq` (return $! ())+ }++cfgC = DirectoryConfig {+ indexFiles = ["index.txt", "altindex.html"]+ , indexGenerator = printName+ , dynamicHandlers = HashMap.empty+ , mimeTypes = defaultMimeTypes+ , preServeHook = \x -> x `seq` (return $! ())+ }++cfgD = DirectoryConfig {+ indexFiles = []+ , indexGenerator = const pass+ , dynamicHandlers = HashMap.fromList [ (".txt", printName) ]+ , mimeTypes = defaultMimeTypes+ , preServeHook = \x -> x `seq` (return $! ())+ }+++------------------------------------------------------------------------------+testFsCfgA :: Test+testFsCfgA = testCase "fileServe/cfgA" $ do+ let gooo = go (fsCfg cfgA)++ -- Named file in the root directory+ gooo "foo.bin" >>= checkProps "cfgA1/1" "application/octet-stream"+ gooo "foo.bin?blah=blah" >>=+ checkProps "cfgA1/2" "application/octet-stream"++ -- Missing file in the root directory+ expect404 $ gooo "bar.bin"++ -- Named file in a subdirectory+ gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain"+ gooo "mydir2/foo.txt?z=z" >>= checkProps "cfgA1/subdir/2" "text/plain"++ -- Missing file in a subdirectory+ expect404 $ gooo "mydir2/bar.txt"++ -- Request for directory with no trailing slash+ expect302 "/mydir1/" $ gooo "mydir1"++ -- Request for directory with no trailing slash, with query param+ expect302 "/mydir1/?z=z" $ gooo "mydir1?z=z"++ -- Request for directory with trailing slash, no index+ expect404 $ gooo "mydir1/"+ expect404 $ gooo "mydir2/"++ -- Request file with trailing slash+ expect404 $ gooo "foo.html/"+ expect404 $ gooo "mydir2/foo.txt/"++ where+ checkProps name ct r = do+ b <- Test.getResponseBody r++ assertEqual (name ++ "/contents") "FOO\n" b+ assertEqual (name ++ "/content-type")+ (Just ct)+ (getHeader "content-type" r)++ assertEqual (name ++ "/size") (Just 4) (rspContentLength r)++ assertBool (name ++ "/last-modified")+ (isJust $ getHeader "last-modified" r)++ assertEqual (name ++ "/accept-ranges")+ (Just "bytes")+ (getHeader "accept-ranges" r)+++------------------------------------------------------------------------------+testFsCfgB :: Test+testFsCfgB = testCase "fileServe/cfgB" $ do+ let gooo = go (fsCfg cfgB)++ -- Request for root directory with index+ rB1 <- gooo "mydir1/"+ bB1 <- Test.getResponseBody rB1++ assertEqual "B1" "INDEX\n" bB1+ assertEqual "B1 content-type"+ (Just "text/plain")+ (getHeader "content-type" rB1)++ -- Request for root directory with index, query+ rB2 <- gooo "mydir1/?z=z"+ bB2 <- Test.getResponseBody rB2++ assertEqual "B2" "INDEX\n" bB2+ assertEqual "B2 content-type"+ (Just "text/plain")+ (getHeader "content-type" rB2)+++ -- Request for root directory with alternate index+ rB3 <- gooo "mydir3/"+ bB3 <- Test.getResponseBody rB3++ assertEqual "B3" "ALTINDEX\n" bB3+ assertEqual "B3 content-type"+ (Just "text/html")+ (getHeader "content-type" rB3)++ -- Request for root directory with no index+ expect404 $ gooo "mydir2/"+++------------------------------------------------------------------------------+testFsCfgC :: Test+testFsCfgC = testCase "fileServe/cfgC" $ do+ let gooo = go (fsCfg cfgC)++ -- Request for root directory with index+ rC1 <- gooo "mydir1/"+ bC1 <- Test.getResponseBody rC1++ assertEqual "C1" "INDEX\n" bC1+ assertEqual "C1 content-type"+ (Just "text/plain")+ (getHeader "content-type" rC1)++ -- Request for root directory with index, query+ rC2 <- gooo "mydir1/?z=z"+ bC2 <- Test.getResponseBody rC2++ assertEqual "C2" "INDEX\n" bC2+ assertEqual "C2 content-type"+ (Just "text/plain")+ (getHeader "content-type" rC2)++ -- Request for root directory with generated index+ rC3 <- gooo "mydir2/"+ bC3 <- Test.getResponseBody rC3++ assertEqual "C3" "mydir2" bC3+++------------------------------------------------------------------------------+testFsCfgD :: Test+testFsCfgD = testCase "fileServe/cfgD" $ do+ -- Request for file with dynamic handler+ rD1 <- go (fsCfg cfgD) "mydir2/foo.txt"+ bD1 <- Test.getResponseBody rD1++ assertEqual "D1" "foo.txt" bD1+++------------------------------------------------------------------------------+testFsCfgFancy :: Test+testFsCfgFancy = testCase "fileServe/cfgFancy" $ do+ -- Request for directory with autogen index+ rE1 <- go (fsCfg fancyDirectoryConfig) "mydir2/"+ assertEqual "index-type" (Just "text/html; charset=utf-8")+ (getHeader "content-type" rE1)+ bE1 <- Test.getResponseBody rE1++ assertBool "autogen-sub-index" $+ "Directory Listing: /mydir2/" `S.isInfixOf` bE1+ assertBool "autogen-sub-parent" $+ "<a href='../'" `S.isInfixOf` bE1+ assertBool "autogen-sub-dir" $+ "<a href='dir/'" `S.isInfixOf` bE1+ assertBool "autogen-sub-file" $+ "<a href='foo.txt'" `S.isInfixOf` bE1++ -- Request for directory with autogen index+ rE2 <- go (fsCfg fancyDirectoryConfig) "mydir2/?z=z"+ bE2 <- Test.getResponseBody rE2++ assertBool "autogen-sub-index" $+ "Directory Listing: /mydir2/" `S.isInfixOf` bE2+ assertBool "autogen-sub-parent" $+ "<a href='../'" `S.isInfixOf` bE2+ assertBool "autogen-sub-file" $+ "<a href='foo.txt'" `S.isInfixOf` bE2++ rE3 <- go (fsCfg fancyDirectoryConfig) "mydir2/foo.txt"+ assertEqual "c-t" (Just "text/plain") (getHeader "content-type" rE3)+++------------------------------------------------------------------------------+testFsSingle :: Test+testFsSingle = testCase "fileServe/Single" $ do+ r1 <- go fsSingle "foo.html"+ b1 <- Test.getResponseBody r1++ assertEqual "foo.html" "FOO\n" b1+ assertEqual "foo.html content-type"+ (Just "text/html")+ (getHeader "content-type" r1)++ assertEqual "foo.html size" (Just 4) (rspContentLength r1)+++------------------------------------------------------------------------------+testRangeOK :: Test+testRangeOK = testCase "fileServe/range/ok" $ do+ r1 <- goRange fsSingle "foo.html" (1,2)+ assertEqual "foo.html 206" 206 $ rspStatus r1+ b1 <- Test.getResponseBody r1++ assertEqual "foo.html partial" "OO" b1+ assertEqual "foo.html partial size" (Just 2) (rspContentLength r1)+ assertEqual "foo.html content-range"+ (Just "bytes 1-2/4")+ (getHeader "Content-Range" r1)++ r2 <- goRangeSuffix fsSingle "foo.html" 3+ assertEqual "foo.html 206" 206 $ rspStatus r2+ assertEqual "c-l" (Just 3) (rspContentLength r2)+ assertEqual "c-l hdr" (Just "3") (getHeader "content-length" r2)+ b2 <- Test.getResponseBody r2+ assertEqual "foo.html partial suffix" "OO\n" b2++ r3 <- goRangePrefix fsSingle "foo.html" 2+ assertEqual "foo.html 206" 206 $ rspStatus r3+ b3 <- Test.getResponseBody r3+ assertEqual "foo.html partial prefix" "O\n" b3+++------------------------------------------------------------------------------+testMultiRange :: Test+testMultiRange = testCase "fileServe/range/multi" $ do+ r1 <- goMultiRange fsSingle "foo.html" (1,2) (3,3)++ -- we don't support multiple ranges so it's ok for us to return 200 here;+ -- test this behaviour+ assertEqual "foo.html 200" 200 $ rspStatus r1+ b1 <- Test.getResponseBody r1++ assertEqual "foo.html" "FOO\n" b1+++------------------------------------------------------------------------------+testRangeBad :: Test+testRangeBad = testCase "fileServe/range/bad" $ do+ r1 <- goRange fsSingle "foo.html" (1,17)+ assertEqual "bad range" 416 (rspStatus r1)+ assertEqual "bad range content-range"+ (Just "bytes */4")+ (getHeader "Content-Range" r1)+ assertEqual "bad range content-length" (Just 0) (rspContentLength r1)+ b1 <- Test.getResponseBody r1+ assertEqual "bad range empty body" "" b1++ r2 <- goRangeSuffix fsSingle "foo.html" 4893+ assertEqual "bad suffix range" 416 $ rspStatus r2+++------------------------------------------------------------------------------+coverMimeMap :: (Monad m) => m ()+coverMimeMap = Prelude.mapM_ f $ HashMap.toList defaultMimeTypes+ where+ f (!k,!v) = return $ case k `seq` v `seq` () of () -> ()+++------------------------------------------------------------------------------+testIfRange :: Test+testIfRange = testCase "fileServe/range/if-range" $ do+ r <- goIfRange fs "foo.bin" (1,2) "Wed, 15 Nov 1995 04:58:08 GMT"+ assertEqual "foo.bin 200" 200 $ rspStatus r+ b <- Test.getResponseBody r+ assertEqual "foo.bin" "FOO\n" b++ r2 <- goIfRange fs "foo.bin" (1,2) "Tue, 01 Oct 2030 04:58:08 GMT"+ assertEqual "foo.bin 206" 206 $ rspStatus r2+ b2 <- Test.getResponseBody r2+ assertEqual "foo.bin partial" "OO" b2++ r3 <- goIfRange fs "foo.bin" (1,24324) "Tue, 01 Oct 2030 04:58:08 GMT"+ assertEqual "foo.bin 200" 200 $ rspStatus r3+ b3 <- Test.getResponseBody r3+ assertEqual "foo.bin" "FOO\n" b3+++------------------------------------------------------------------------------+testBadUrl :: Test+testBadUrl = testCase "fileServe/badUrl" $ do+ expectExceptionH $ go (fs <|> error "foo") "%$z%%%%%%%%"+ expectExceptionH $ go (fs <|> error "foo") "//etc/passwd"+++------------------------------------------------------------------------------+testDirectoryPasses :: Test+testDirectoryPasses = testCase "fileServe/directory-passes" $ do+ expectExceptionH $ go (fs <|> error "foo") ""+ expectExceptionH $ go (fsCfg simpleDirectoryConfig <|> error "foo") ""+ r <- go (fsCfg simpleDirectoryConfig) "foo.txt"+ assertEqual "c-t" (Just "text/plain") (getHeader "content-type" r)+++------------------------------------------------------------------------------+testDecodeFilePath :: Test+testDecodeFilePath = testCase "fileServe/decodeFilePath" $ do+ forM_ table $ \(nm, inp, expected) -> do+ out <- (map fromEnum . T.unpack) <$> decodeFilePath inp+ assertEqual nm expected out+ where+ table = [ ("bad" , "\x00\xd8\x00\xd8" , [0, 0xd8, 0, 0xd8] )+ , ("bom" , "\xfe\xff" , [0xfe, 0xff] )+ , ("ok" , "ok" , [fromEnum 'o',+ fromEnum 'k'] )+ ]
+ test/Snap/Util/FileUploads/Tests.hs view
@@ -0,0 +1,1199 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Util.FileUploads.Tests+ ( tests ) where++------------------------------------------------------------------------------+import Control.Applicative (Alternative ((<|>)), (<$>))+import Control.DeepSeq (deepseq)+import Control.Exception (ErrorCall (..), evaluate, throwIO)+import Control.Exception.Lifted (Exception (fromException, toException), catch, finally, throw)+import Control.Monad (Monad (return, (>>), (>>=)), liftM, void)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef)+import Data.List (foldl', length)+import qualified Data.Map as Map+import Data.Maybe (Maybe (..), fromJust, maybe)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Prelude (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Show (..), const, either, error, filter, map, seq, snd, ($), ($!), (&&), (++), (.))+import Snap.Internal.Core (EscapeSnap (TerminateConnection), Snap, getParam, getPostParam, getQueryParam, runSnap)+import Snap.Internal.Http.Types (Request (rqBody), Response, setHeader)+import Snap.Internal.Util.FileUploads (BadPartException (..), FileUploadException (..), FormFile (..), PartDisposition (..), PartInfo (..), PolicyViolationException (..), allowWithMaximumSize, defaultFileUploadPolicy, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, foldMultipart, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleFileUploads, handleFormUploads, setMaximumFileSize, setMaximumFormInputSize, setMaximumNumberOfFiles, setMaximumNumberOfFormInputs, setMaximumSkippedFileSize, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setSkipFilesWithoutNames, setUploadTimeout, storeAsLazyByteString, toPartDisposition, withTemporaryStore)+import qualified Snap.Test as Test+import Snap.Test.Common (coverEqInstance, coverShowInstance, coverTypeableInstance, eatException, expectExceptionH, seconds, waitabit)+import qualified Snap.Types.Headers as H+import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeDirectoryRecursive, removeFile)+import System.IO.Streams (RateTooSlowException)+import qualified System.IO.Streams as Streams+import System.Mem (performGC)+import System.Timeout (timeout)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+data TestException = TestException+ deriving (Show, Typeable)++instance Exception TestException++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testFoldMultipart1+ , testFoldMultipart2+ , testFilePolicyViolation1+ , testFilePolicyViolation2+ , testEmptyNamePolicyViolation+ , testEmptyNameStore+ , testEmptyNameSkip+ , testTemporaryStore+ , testTemporaryStoreSafeMove+ , testSuccess1+ , testSuccess2+ , testSuccessUtf8Filename+ , testBadParses+ , testPerPartPolicyViolation1+ , testPerPartPolicyViolation2+ , testFormInputsPolicyViolation+ , testFormSizePolicyViolation+ , testNoFileName+ , testNoFileNameTooBig+ , testTooManyHeaders+ , testNoBoundary+ , testNoMixedBoundary+ , testWrongContentType+ , testSlowEnumerator+ , testSlowEnumerator2+ , testAbortedBody+ , testTrivials+ , testDisconnectionCleanup+ ]++------------------------------------------------------------------------------+testFoldMultipart1 :: Test+testFoldMultipart1 = testCase "fileUploads/fold1" $+ void $ go hndl mixedTestBody++ where+ hndl :: Snap ()+ hndl = do+ (params, files) <- foldMultipart defaultUploadPolicy hndl' []++ let fileMap = foldl' f Map.empty files+ liftIO $ assertEqual "2 params returned" 2 (length params)+ let [p1, p2] = params++ liftIO $ do+ let Just (a1, a2, a3) = Map.lookup "file1.txt" fileMap+ let Just (b1, b2, b3) = Map.lookup "file2.gif" fileMap+ assertEqual "file1 contents"+ ("text/plain", file1Contents)+ (a1, a2)+ assertEqual "file1 header 1"+ (Just "text/plain")+ (H.lookup "content-type" a3)+ assertEqual "file1 header 2"+ (Just "attachment; filename=\"file1.txt\"")+ (H.lookup "content-disposition" a3)++ assertEqual "file2 contents"+ ("image/gif", file2Contents)+ (b1, b2)+ assertEqual "file2 header 1"+ (Just "image/gif")+ (H.lookup "content-type" b3)+ assertEqual "file2 header 2"+ (Just "attachment; filename=\"file2.gif\"")+ (H.lookup "content-disposition" b3)++ assertEqual "field1 contents"+ ("field1", formContents1)+ p1++ assertEqual "field2 contents"+ ("field2", formContents2)+ p2++ f mp (fn, ct, x, hdrs) = Map.insert fn (ct,x,hdrs) mp++ hndl' partInfo istream acc = do+ let+ fn = fromJust $ partFileName partInfo+ ct = partContentType partInfo+ hdrs = partHeaders partInfo+ body <- S.concat <$> Streams.toList istream+ return (acc ++ [(fn, ct, body, hdrs)])++++------------------------------------------------------------------------------+testFoldMultipart2 :: Test+testFoldMultipart2 = testCase "fileUploads/fold2" $+ void $ go hndl mixedTestBody+ where+ policy = setProcessFormInputs False defaultUploadPolicy++ hndl = do+ (fields, fileCount) <- foldMultipart policy hndl' (0::Int)++ liftIO $ do+ assertEqual "num params" 4 fileCount+ assertEqual "num processed" 0 (length fields)++ hndl' !_ !_ !acc = return $ acc + 1++++------------------------------------------------------------------------------+testFilePolicyViolation1 :: Test+testFilePolicyViolation1 = testCase "fileUploads/filePolicyViolation1" $+ assertThrows (go hndl mixedTestBody) h+ where+ h e = assertIsFileSizeException e++ hndl = handleFormUploads defaultUploadPolicy+ (setMaximumFileSize 0 defaultFileUploadPolicy)+ (const storeAsLazyByteString)++++------------------------------------------------------------------------------+testFilePolicyViolation2 :: Test+testFilePolicyViolation2 = testCase "fileUploads/filePolicyViolation2" $+ assertThrows (go hndl mixedTestBody) h+ where+ h (PolicyViolationException r) =+ assertBool "correct exception"+ (T.isInfixOf "number of files exceeded the maximum" r)++ hndl = handleFormUploads defaultUploadPolicy+ (setMaximumNumberOfFiles 0 defaultFileUploadPolicy)+ (const storeAsLazyByteString)+++------------------------------------------------------------------------------+testEmptyNamePolicyViolation :: Test+testEmptyNamePolicyViolation = testCase "fileUploads/emptyNamePolicyViolation" $+ assertThrows (go hndl noFileNameTestBody) h+ where+ h e = assertIsFileSizeException e++ hndl = handleFormUploads defaultUploadPolicy+ (setSkipFilesWithoutNames True defaultFileUploadPolicy)+ (const storeAsLazyByteString)+++------------------------------------------------------------------------------+assertIsFileSizeException :: PolicyViolationException -> Assertion+assertIsFileSizeException (PolicyViolationException r) =+ assertBool "file size exception"+ (T.isInfixOf "File" r &&+ T.isInfixOf "exceeded maximum allowable size" r)+++------------------------------------------------------------------------------+testEmptyNameStore :: Test+testEmptyNameStore = testCase "fileUploads/emptyNameStore" $+ void $ go hndl noFileNameTestBody+ where+ hndl = do+ (inputs, files) <- handleFormUploads defaultUploadPolicy+ (setSkipFilesWithoutNames False defaultFileUploadPolicy)+ (const storeAsLazyByteString)+ liftIO $ do+ assertEqual "got both files" 2 (length files)+ let [f1, f2] = files+ assertEqual "file1 contents"+ (FormFile "files" $ L.fromChunks [file1Contents])+ f1+ assertEqual "file2 contents"+ (FormFile "files" $ L.fromChunks [file2Contents])+ f2+ assertEqual "inputs present" 2 (length inputs)+ return ()+++------------------------------------------------------------------------------+testEmptyNameSkip :: Test+testEmptyNameSkip = testCase "fileUploads/emptyNameSkip" $+ void $ go hndl noFileNameTestBody+ where+ hndl = do+ (inputs, files) <- handleFormUploads defaultUploadPolicy+ ( setMaximumSkippedFileSize 4000+ . setSkipFilesWithoutNames True+ $ defaultFileUploadPolicy )+ (const storeAsLazyByteString)+ liftIO $ do+ assertEqual "files skipped" 0 (length files)+ assertEqual "inputs present" 2 (length inputs)+ return ()+++------------------------------------------------------------------------------+testTemporaryStore :: Test+testTemporaryStore = testCase "fileUploads/temporaryStore" $+ harness "tempdir1" hndl mixedTestBody+ where+ hndl = do+ (fn1, fn2) <- withTemporaryStore "tempdir1" "upload" $ \store -> do+ (inputs, files) <- handleFormUploads defaultUploadPolicy+ defaultFileUploadPolicy+ (const store)+ liftIO $ do+ assertEqual "num files" 2 (length files)+ assertEqual "inputs present" 2 (length inputs)+ let [FormFile name1 fn1, FormFile name2 fn2] = files+ fc1 <- liftIO $ S.readFile fn1+ fc2 <- liftIO $ S.readFile fn2++ assertEqual "file1 content"+ ("files", file1Contents)+ (name1, fc1)++ assertEqual "file2 content"+ ("files", file2Contents)+ (name2, fc2)+ return (fn1, fn2)+ liftIO $ do+ ex1 <- doesFileExist fn1+ ex2 <- doesFileExist fn2+ assertEqual "file1 deleted" False ex1+ assertEqual "file2 deleted" False ex2+++------------------------------------------------------------------------------+testTemporaryStoreSafeMove :: Test+testTemporaryStoreSafeMove = testCase "fileUploads/temporaryStoreSafeMove" $+ harness "tempdir1" hndl mixedTestBody+ where+ hndl = do+ -- should not throw+ withTemporaryStore "tempdir1" "upload" $ \store -> do+ (_, files) <- handleFormUploads defaultUploadPolicy+ defaultFileUploadPolicy+ (const store)+ liftIO $ do+ assertEqual "num files" 2 (length files)+ let [FormFile _ fn1, FormFile _ fn2] = files+ removeFile fn1+ removeFile fn2++++------------------------------------------------------------------------------+testSuccess1 :: Test+testSuccess1 = testCase "fileUploads/success1" $+ harness tmpdir hndl mixedTestBody++ where+ tmpdir = "tempdir1"++ hndl = do+ xs <- handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ let fileMap = foldl' f Map.empty xs+ p1 <- getParam "field1"+ p1P <- getPostParam "field1"+ p1Q <- getQueryParam "field1"+ p2 <- getParam "field2"++ liftIO $ do+ let Just (a1, a2, a3) = Map.lookup "file1.txt" fileMap+ let Just (b1, b2, b3) = Map.lookup "file2.gif" fileMap+ assertEqual "file1 contents"+ ("text/plain", file1Contents)+ (a1, a2)+ assertEqual "file1 header 1"+ (Just "text/plain")+ (H.lookup "content-type" a3)+ assertEqual "file1 header 2"+ (Just "attachment; filename=\"file1.txt\"")+ (H.lookup "content-disposition" a3)++ assertEqual "file2 contents"+ ("image/gif", file2Contents)+ (b1, b2)+ assertEqual "file2 header 1"+ (Just "image/gif")+ (H.lookup "content-type" b3)+ assertEqual "file2 header 2"+ (Just "attachment; filename=\"file2.gif\"")+ (H.lookup "content-disposition" b3)++ assertEqual "field1 contents"+ (Just formContents1)+ p1++ assertEqual "field1 POST contents" (Just formContents1) p1P+ assertEqual "field1 query contents" Nothing p1Q+ assertEqual "field2 contents" (Just formContents2) p2++ f mp (fn, ct, x, hdrs) = Map.insert fn (ct,x,hdrs) mp++ hndl' partInfo =+ either throw+ (\fp -> do+ x <- liftIO $ S.readFile fp+ let fn = fromJust $ partFileName partInfo+ let ct = partContentType partInfo+ let hdrs = partHeaders partInfo+ return (fn, ct, x, hdrs))+++------------------------------------------------------------------------------+testSuccess2 :: Test+testSuccess2 = testCase "fileUploads/success2" $+ harness tmpdir hndl mixedTestBody++ where+ tmpdir = "tempdir2"++ policy = setProcessFormInputs False defaultUploadPolicy++ hndl = do+ ref <- liftIO $ newIORef (0::Int)+ _ <- handleFileUploads tmpdir+ policy+ (const $ allowWithMaximumSize 300000)+ (hndl' ref)++ n <- liftIO $ readIORef ref+ liftIO $ assertEqual "num params" 4 n++ hndl' !ref !_ !_ = atomicModifyIORef ref (\x -> (x+1, ()))++ ------------------------------------------------------------------------------+testSuccessUtf8Filename :: Test+testSuccessUtf8Filename = testCase "fileUploads/utf8-filename" $+ harness tmpdir hndl utf8FilenameBody++ where+ tmpdir = "tempdir3"++ hndl = do+ xs <- handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ liftIO $ assertEqual "filename" [filenameUtf8] xs++ hndl' pinfo _ = return $ fromJust $ partFileName pinfo+++------------------------------------------------------------------------------+testBadParses :: Test+testBadParses = testCase "fileUploads/badParses" $ do+ harness tmpdir hndl mixedTestBodyWithBadTypes+ where+ tmpdir = "tempdir_bad_types"++ hndl = do+ xs <- handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ let fileMap = foldl' f Map.empty xs+ p1 <- getParam "field1"+ p1P <- getPostParam "field1"+ p1Q <- getQueryParam "field1"+ p2 <- getParam "field2"+ pBoo <- getParam "boo"++ liftIO $ do+ assertEqual "file1 contents"+ (Just ("text/plain", file1Contents))+ (Map.lookup "file1.txt" fileMap)++ assertEqual "file2 contents"+ (Just ("text/plain", file2Contents))+ (Map.lookup "file2.gif" fileMap)++ assertEqual "field1 param contents" (Just formContents1) p1+ assertEqual "field1 POST contents" (Just formContents1) p1P+ assertEqual "field1 query contents" Nothing p1Q+ assertEqual "field2 contents" Nothing p2+ assertEqual "boo contents" (Just "boo") pBoo++ f mp (fn, ct, x) = Map.insert fn (ct,x) mp++ hndl' partInfo =+ either throw+ (\fp -> do+ x <- liftIO $ S.readFile fp+ let fn = fromJust $ partFileName partInfo+ let ct = partContentType partInfo+ return (fn, ct, x))++++------------------------------------------------------------------------------+testPerPartPolicyViolation1 :: Test+testPerPartPolicyViolation1 = testCase "fileUploads/perPartPolicyViolation1" $+ harness tmpdir hndl mixedTestBody+ where+ tmpdir = "tempdir_pol1"++ hndl = do+ _ <- handleFileUploads tmpdir defaultUploadPolicy+ (const disallow)+ hndl'++ p1 <- getParam "field1"+ p2 <- getParam "field2"+++ liftIO $ do+ assertEqual "field1 contents"+ (Just formContents1)+ p1++ assertEqual "field2 contents"+ (Just formContents2)+ p2++ hndl' !_ e = either (\i -> show i `deepseq` return $! ())+ (const $ error "expected policy violation")+ e+++------------------------------------------------------------------------------+testPerPartPolicyViolation2 :: Test+testPerPartPolicyViolation2 = testCase "fileUploads/perPartPolicyViolation2" $+ harness tmpdir hndl mixedTestBody+ where+ tmpdir = "tempdir_pol2"++ hndl = handleFileUploads tmpdir defaultUploadPolicy+ (const $ allowWithMaximumSize 4)+ hndl'++ hndl' partInfo e = (if partFileName partInfo == Just "file1.txt"+ then ePass+ else eFail) e++ eFail = either (\i -> show i `deepseq` return ())+ (const $ error "expected policy violation")++ ePass = either (throw)+ (\i -> show i `deepseq` return ())++++------------------------------------------------------------------------------+testNoFileName :: Test+testNoFileName = testCase "fileUploads/noFileName" $+ (harness tmpdir hndl noFileNameTestBody)+ where+ tmpdir = "tempdir_noname"++ hndl = handleFileUploads tmpdir defaultUploadPolicy+ (const $ allowWithMaximumSize 400000)+ hndl'++ hndl' pinfo !_ = do+ assertEqual "filename" Nothing $ partFileName pinfo+ assertEqual "disposition" DispositionFile $ partDisposition pinfo+++------------------------------------------------------------------------------+testNoFileNameTooBig :: Test+testNoFileNameTooBig = testCase "fileUploads/noFileNameTooBig" $+ assertThrows (harness tmpdir hndl noFileNameTestBody) h+ where+ h !(e :: FileUploadException) = do+ let r = fileUploadExceptionReason e+ assertBool "correct exception"+ (T.isInfixOf "File" r &&+ T.isInfixOf "exceeded maximum allowable size" r)++ tmpdir = "tempdir_noname_toobig"++ hndl = handleFileUploads tmpdir defaultUploadPolicy+ (const $ allowWithMaximumSize 1)+ hndl'++ hndl' pinfo !e = do+ let (Left !x) = e+ coverShowInstance x+ assertEqual "filename" Nothing $ partFileName pinfo+ assertEqual "disposition" DispositionFile $ partDisposition pinfo+ throwIO x+++------------------------------------------------------------------------------+testFormSizePolicyViolation :: Test+testFormSizePolicyViolation =+ testCase "fileUploads/formSizePolicy" $+ assertThrows (harness tmpdir hndl mixedTestBody) h+ where+ h !(e :: FileUploadException) = do+ let r = fileUploadExceptionReason e+ assertBool "correct exception"+ (T.isInfixOf "form input" r &&+ T.isInfixOf "exceeded maximum permissible" r)++ tmpdir = "tempdir_formpol"++ policy = setMaximumFormInputSize 2 defaultUploadPolicy++ hndl = handleFileUploads tmpdir policy+ (const $ allowWithMaximumSize 4)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testFormInputsPolicyViolation :: Test+testFormInputsPolicyViolation =+ testCase "fileUploads/formInputsPolicy" $+ assertThrows (harness tmpdir hndl mixedTestBody) h+ where+ h !(e :: FileUploadException) = do+ let r = fileUploadExceptionReason e+ assertBool "correct exception"+ (T.isInfixOf "number of form inputs" r &&+ T.isInfixOf "exceeded maximum" r)++ tmpdir = "tempdir_formpol2"++ policy = setMaximumNumberOfFormInputs 0 defaultUploadPolicy++ hndl = handleFileUploads tmpdir policy+ (\x -> x `seq` allowWithMaximumSize 4000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testNoBoundary :: Test+testNoBoundary = testCase "fileUploads/noBoundary" $+ expectExceptionH $+ harness' goBadContentType tmpdir hndl mixedTestBody+ where+ tmpdir = "tempdir_noboundary"++ hndl = handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testNoMixedBoundary :: Test+testNoMixedBoundary = testCase "fileUploads/noMixedBoundary" $+ expectExceptionH $+ harness' go tmpdir hndl badMixedBody+ where+ tmpdir = "tempdir_mixednoboundary"++ hndl = handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testWrongContentType :: Test+testWrongContentType = testCase "fileUploads/wrongContentType" $+ expectExceptionH $+ harness' goWrongContentType tmpdir hndl mixedTestBody+ where+ tmpdir = "tempdir_noboundary"++ hndl = handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'+ <|> error "expect fail here"++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testTooManyHeaders :: Test+testTooManyHeaders = testCase "fileUploads/tooManyHeaders" $+ assertThrows (harness tmpdir hndl bigHeadersBody) h+ where+ h (e :: BadPartException) = show e `deepseq` return ()++ tmpdir = "tempdir_tooManyHeaders"++ hndl = handleFileUploads tmpdir defaultUploadPolicy+ (const $ allowWithMaximumSize 4)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testAbortedBody :: Test+testAbortedBody = testCase "fileUploads/abortedBody" $+ expectExceptionH $+ harness' goAndAbort tmpdir hndl abortedTestBody+ where+ tmpdir = "tempdir_abort"++ hndl = handleFileUploads tmpdir defaultUploadPolicy+ (const $ allowWithMaximumSize 400000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()++++------------------------------------------------------------------------------+testSlowEnumerator :: Test+testSlowEnumerator =+ testCase "fileUploads/tooSlow" $+ assertThrows (harness' goSlowEnumerator tmpdir hndl mixedTestBody) h0+ where+ h0 (e :: EscapeSnap) = do+ let (TerminateConnection se) = e+ (me :: Maybe RateTooSlowException) = fromException se+ maybe (throw e) h me++ h (e :: RateTooSlowException) = coverShowInstance e++ tmpdir = "tempdir_tooslow"++ policy = setMinimumUploadRate 200000 $+ setMinimumUploadSeconds 2 $+ defaultUploadPolicy++ hndl = handleFileUploads tmpdir policy+ (const $ allowWithMaximumSize 400000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testSlowEnumerator2 :: Test+testSlowEnumerator2 =+ testCase "fileUploads/tooSlow2" $+ assertThrows (harness' goSlowEnumerator tmpdir hndl mixedTestBody) h0+ where+ h0 (e :: EscapeSnap) = do+ let (TerminateConnection se) = e+ (me :: Maybe RateTooSlowException) = fromException se+ maybe (throw e) h me++ h (e :: RateTooSlowException) = e `seq` return ()++ tmpdir = "tempdir_tooslow2"++ policy = setUploadTimeout 2 defaultUploadPolicy++ hndl = handleFileUploads tmpdir policy+ (const $ allowWithMaximumSize 400000)+ hndl'++ hndl' xs _ = show xs `deepseq` return ()+++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "fileUploads/trivials" $ do+ assertEqual "" False $ doProcessFormInputs policy+ assertEqual "" 1000 $ getMinimumUploadRate policy+ assertEqual "" 1000 $ getMinimumUploadRate defaultUploadPolicy+ assertEqual "" 5 $ getMinimumUploadSeconds policy+ assertEqual "" 9 $ getUploadTimeout policy++ let pvi = PolicyViolationException ""+ coverTypeableInstance pvi+ evaluate $ ((fromJust $+ fromException (toException pvi)) :: PolicyViolationException)+ evaluate $ ((fromJust $+ fromException (toException pvi)) :: FileUploadException)+ let !_ = policyViolationExceptionReason pvi++ let bpi = BadPartException ""+ coverTypeableInstance bpi+ let !_ = badPartExceptionReason bpi++ coverShowInstance $ WrappedFileUploadException $ BadPartException ""+ coverShowInstance $ PartInfo "" Nothing "" DispositionFile (H.empty)+ coverShowInstance $ toPartDisposition ""+ coverEqInstance $ DispositionOther ""++ let !gfui = WrappedFileUploadException $ BadPartException ""+ evaluate $ fileUploadExceptionReason gfui++ void $ evaluate+ $ getMaximumNumberOfFormInputs+ $ setMaximumNumberOfFormInputs 2 policy++ where+ policy = setProcessFormInputs False $+ setMinimumUploadRate 1000 $+ setMinimumUploadSeconds 5 $+ setUploadTimeout 9 $+ defaultUploadPolicy+++------------------------------------------------------------------------------+testDisconnectionCleanup :: Test+testDisconnectionCleanup = testCase "fileUploads/disconnectionCleanup" $ do+ runTest `finally` removeDirectoryRecursive tmpdir+ where+ runTest = do+ eatException $ removeDirectoryRecursive tmpdir+ createDirectoryIfMissing True tmpdir+ rq <- mkDamagedRequest mixedTestBody+ eatException $ liftM snd (runIt hndl rq)+ performGC+ dirs <- liftM (filter (\x -> x /= "." && x /= "..")) $+ getDirectoryContents tmpdir+ assertEqual "files should be cleaned up" [] dirs+++ tmpdir = "tempdirC"+ hndl = handleFileUploads tmpdir+ defaultUploadPolicy+ (const $ allowWithMaximumSize 300000)+ hndl'++ hndl' _ _ = return ()+++------------------------------------------------------------------------------+harness :: FilePath -> Snap a -> ByteString -> IO ()+harness = harness' go+++------------------------------------------------------------------------------+harness' :: (Snap a -> ByteString -> IO Response)+ -> FilePath+ -> Snap a+ -> ByteString+ -> IO ()+harness' g tmpdir hndl body = (do+ createDirectoryIfMissing True tmpdir+ !_ <- g hndl body+ return ()) `finally` removeDirectoryRecursive tmpdir+++------------------------------------------------------------------------------+assertThrows :: Exception e => IO a -> (e -> IO ()) -> IO ()+assertThrows act handle = catch action handle+ where+ action = act >> assertFailure "Expected exception to be thrown"+++------------------------------------------------------------------------------+mkRequest :: ByteString -> IO Request+mkRequest body = Test.buildRequest $ Test.postRaw "/" ct body+ where+ ct = S.append "multipart/form-data; boundary=" boundaryValue+++------------------------------------------------------------------------------+mkDamagedRequest :: ByteString -> IO Request+mkDamagedRequest body = do+ req <- Test.buildRequest $ Test.postRaw "/" ct ""++ e <- newIORef False >>= Streams.makeInputStream . enum++ return $! req { rqBody = e }++ where+ ct = S.append "multipart/form-data; boundary=" boundaryValue+ enum ref = do+ x <- readIORef ref+ if x+ then throw TestException+ else do writeIORef ref True+ return $! Just $! S.take (S.length body - 1) body+++------------------------------------------------------------------------------+go :: Snap a -> ByteString -> IO Response+go m s = do+ rq <- mkRequest s+ liftM snd (runIt m rq)+++------------------------------------------------------------------------------+goBadContentType :: Snap a -> ByteString -> IO Response+goBadContentType m s = do+ rq <- mkRequest s+ let rq' = setHeader "Content-Type" "multipart/form-data" rq+ liftM snd (runIt m rq')+++------------------------------------------------------------------------------+goWrongContentType :: Snap a -> ByteString -> IO Response+goWrongContentType m s = do+ rq <- mkRequest s+ let rq' = setHeader "Content-Type" "text/plain" rq+ liftM snd (runIt m rq')+++------------------------------------------------------------------------------+goSlowEnumerator :: Snap a -> ByteString -> IO Response+goSlowEnumerator m s = do+ rq <- mkRequest s+ e <- Streams.fromGenerator slowInput+ let rq' = rq { rqBody = e }+ mx <- timeout (20*seconds) (liftM snd (runIt m rq'))+ maybe (error "timeout") return mx++ where+ body = S.unpack s++ slowInput = f body+ where+ f [] = return ()+ f (x:xs) = do+ liftIO waitabit+ Streams.yield $ S.singleton x+ f xs+++------------------------------------------------------------------------------+goAndAbort :: Snap a -> ByteString -> IO Response+goAndAbort m s = do+ rq <- mkRequest s+ e <- Streams.fromGenerator generator+ let rq' = rq { rqBody = e }+ mx <- timeout (20*seconds) (liftM snd (runIt m rq'))+ maybe (error "timeout") return mx++ where+ generator = do+ Streams.yield s+ liftIO $ throwIO+ $ ErrorCall "For in that sleep of death what dreams may come."+++------------------------------------------------------------------------------+runIt :: Snap a -> Request -> IO (Request, Response)+runIt m rq = runSnap m d bump rq+ where+ bump !f = let !_ = f 1 in return $! ()++ d :: forall a . Show a => a -> IO ()+ d = \x -> show x `deepseq` return ()+++------------------------------------------------------------------------------+-- TEST DATA++formContents1 :: ByteString+formContents1 = "form contents 1"++formContents2 :: ByteString+formContents2 = "form contents 2 zzzzzzzzzzzzzzzzzzzz"++file1Contents :: ByteString+file1Contents = "foo"++file2Contents :: ByteString+file2Contents = "... contents of file2.gif ..."++filenameUtf8 :: ByteString+filenameUtf8 = "\xd1\x82\xd0\xb5\xd1\x81\xd1\x82.png" -- "тест.png" as UTF-8++boundaryValue :: ByteString+boundaryValue = "fkjldsakjfdlsafldksjf"++subBoundaryValue :: ByteString+subBoundaryValue = "zjkzjjfjskzjzjkz"++crlf :: ByteString+crlf = "\r\n"+++------------------------------------------------------------------------------+mixedTestBody :: ByteString+mixedTestBody =+ S.concat+ [ "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field1\"\r\n"+ , crlf+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field2\"\r\n"+ , crlf+ , formContents2+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"files\"\r\n"+ , "Content-type: multipart/mixed; boundary="+ , subBoundaryValue+ , crlf+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file1.txt\"\r\n"+ , "Content-Type: text/plain\r\n"+ , crlf+ , file1Contents+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file2.gif\"\r\n"+ , "Content-type: image/gif\r\n"+ , "Content-Transfer-Encoding: binary\r\n"+ , crlf+ , file2Contents+ , crlf+ , "--"+ , subBoundaryValue+ , "--\r\n"+ , "--"+ , boundaryValue+ , "--\r\n"+ ]++------------------------------------------------------------------------------+mixedTestBodyWithBadTypes :: ByteString+mixedTestBodyWithBadTypes =+ S.concat+ [ "--"+ , boundaryValue+ , crlf+ , "content-type: ;\x01;\x01;\x01;\r\n"+ , "content-disposition: form-data; name=\"field1\"\r\n\r\n"+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data;\x01;;;\x01 name=\"field2\"\r\n"+ , crlf+ , formContents2+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: \x01\x01\x01\x01\r\n"+ , "Content-type: multipart/mixed; boundary="+ , subBoundaryValue+ , crlf+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file1.txt\"\r\n"+ , "Content-Type: ;\x01;\x01;\x01;\r\n"+ , crlf+ , file1Contents+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file2.gif\"\r\n"+ , "Content-type: ;\x01;\x01;\x01\r\n"+ , "Content-Transfer-Encoding: binary\r\n"+ , crlf+ , file2Contents+ , crlf+ , "--"+ , subBoundaryValue+ , "--\r\n"+ , "--"+ , boundaryValue+ , crlf+ , "Content-type: multipart/mixed; \x01\x01;;\x01;\r\n"+ , "Content-disposition: form-data; name=boo\r\n"+ , crlf+ , "boo"+ , crlf+ , "--"+ , boundaryValue+ , "--\r\n"+ ]+++------------------------------------------------------------------------------+badMixedBody :: ByteString+badMixedBody =+ S.concat+ [ crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field1\"\r\n"+ , crlf+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field2\"\r\n"+ , crlf+ , formContents2+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"files\"\r\n"+ , "Content-type: multipart/mixed"+ , crlf+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file1.txt\"\r\n"+ , "Content-Type: text/plain\r\n"+ , crlf+ , file1Contents+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: attachment; filename=\"file2.gif\"\r\n"+ , "Content-type: image/gif\r\n"+ , "Content-Transfer-Encoding: binary\r\n"+ , crlf+ , file2Contents+ , crlf+ , "--"+ , subBoundaryValue+ , "--\r\n"+ , "--"+ , boundaryValue+ , "--\r\n"+ ]+++------------------------------------------------------------------------------+bigHeadersBody :: ByteString+bigHeadersBody =+ S.concat (+ [ "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field1\"\r\n" ]+ +++ map (\i -> S.pack ("field_" ++ show i ++ ": bar\r\n")) [1..40000::Int]+ +++ [ crlf+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , "--\r\n"+ ])+++------------------------------------------------------------------------------+noFileNameTestBody :: ByteString+noFileNameTestBody =+ S.concat+ [ "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field1\"\r\n"+ , crlf+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field2\"\r\n"+ , crlf+ , formContents2+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"files\"\r\n"+ , "Content-type: multipart/mixed; boundary="+ , subBoundaryValue+ , crlf+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: file\r\n"+ , "Content-Type: text/plain\r\n"+ , crlf+ , file1Contents+ , crlf+ , "--"+ , subBoundaryValue+ , crlf+ , "Content-disposition: file\r\n"+ , "Content-type: image/gif\r\n"+ , "Content-Transfer-Encoding: binary\r\n"+ , crlf+ , file2Contents+ , crlf+ , "--"+ , subBoundaryValue+ , "--\r\n"+ , "--"+ , boundaryValue+ , "--\r\n"+ ]+++------------------------------------------------------------------------------+abortedTestBody :: ByteString+abortedTestBody =+ S.concat [ "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field1\"\r\n"+ , crlf+ , formContents1+ , crlf+ , "--"+ , boundaryValue+ , crlf+ , "content-disposition: form-data; name=\"field2\"\r\n"+ , "fdjkljflsdkjfsd"+ ]+++------------------------------------------------------------------------------+utf8FilenameBody :: ByteString+utf8FilenameBody =+ S.concat+ [ "--"+ , boundaryValue+ , crlf+ , "Content-Disposition: form-data; name=\"file\"; filename=\""+ , filenameUtf8+ , "\"\r\n"+ , "Content-Type: image/png\r\n"+ , crlf+ , file2Contents+ , crlf+ , "--"+ , boundaryValue+ , "--\r\n"+ ]
+ test/Snap/Util/GZip/Tests.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Util.GZip.Tests+ ( tests ) where+------------------------------------------------------------------------------+import qualified Codec.Compression.GZip as GZip+import qualified Codec.Compression.Zlib as Zlib+import Control.Monad (replicateM)+import Data.Bits ((.&.))+import qualified Data.ByteString as B+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 Data.Word (Word8)+import Snap.Core (Request, Response, Snap, getHeader, modifyResponse, runSnap, setContentType, setHeader, setResponseBody, writeBS)+import qualified Snap.Test as Test+import Snap.Test.Common (coverTypeableInstance, expectException, expectExceptionH, liftQ)+import Snap.Util.GZip (BadAcceptEncodingException, noCompression, withCompression)+import qualified System.IO.Streams as Streams+import System.Random (randomIO)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (assertEqual)+import qualified Test.HUnit as H+import Test.QuickCheck (Arbitrary (arbitrary))+import Test.QuickCheck.Monadic (PropertyM, assert, forAllM, monadicIO)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+------------------------------------------------------------------------------++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testIdentity1+ , testIdentity1_charset+ , testIdentity2+ , testIdentity3+ , testIdentity4+ , testIdentity5+ , testNoHeaders+ , testNoAcceptEncoding+ , testAcceptEncodingBad+ , testNopWhenContentEncodingSet+ , testCompositionDoesn'tExplode+ , testGzipLotsaChunks+ , testNoCompression+ , testBadHeaders+ , testTrivials+ ]+++------------------------------------------------------------------------------+gzipHdrs, xGzipHdrs, xGzipHdrs2, badHdrs, deflateHdrs, xDeflateHdrs+ :: (CI ByteString, ByteString)++gzipHdrs = ("Accept-Encoding", "deflate,froz,gzip,glorble, x-gzip" )+xGzipHdrs = ("Accept-Encoding", "x-gzip;q=1.0" )+xGzipHdrs2 = ("Accept-Encoding", "x-gzip;q=1" )+badHdrs = ("Accept-Encoding", "*&%^&^$%&%&*^\023" )+deflateHdrs = ("Accept-Encoding", "deflate" )+xDeflateHdrs = ("Accept-Encoding", "x-deflate" )+++------------------------------------------------------------------------------+mkNoHeaders :: IO Request+mkNoHeaders = Test.buildRequest $ return ()+++------------------------------------------------------------------------------+mkGzipRq :: IO Request+mkGzipRq = Test.buildRequest $ uncurry Test.setHeader gzipHdrs+++------------------------------------------------------------------------------+mkXGzipRq :: IO Request+mkXGzipRq = Test.buildRequest $ uncurry Test.setHeader xGzipHdrs+++------------------------------------------------------------------------------+mkXGzip2Rq :: IO Request+mkXGzip2Rq = Test.buildRequest $ uncurry Test.setHeader xGzipHdrs2+++------------------------------------------------------------------------------+mkDeflateRq :: IO Request+mkDeflateRq = Test.buildRequest $ uncurry Test.setHeader deflateHdrs+++------------------------------------------------------------------------------+mkXDeflateRq :: IO Request+mkXDeflateRq = Test.buildRequest $ uncurry Test.setHeader xDeflateHdrs+++------------------------------------------------------------------------------+mkBadRq :: IO Request+mkBadRq = Test.buildRequest $ uncurry Test.setHeader badHdrs+++------------------------------------------------------------------------------+seqSnap :: Snap a -> Snap a+seqSnap m = do+ !x <- m+ return $! x `seq` x+++------------------------------------------------------------------------------+goGeneric :: IO Request -> Snap a -> IO (Request, Response)+goGeneric mkRq m = do+ rq <- mkRq+ runSnap (seqSnap m) d d rq++ where+ d = (const $ return ())+++goGZip, goDeflate, goXGZip, goXGZip2 :: Snap a -> IO (Request,Response)+goNoHeaders, goXDeflate, goBad :: Snap a -> IO (Request,Response)++goGZip = goGeneric mkGzipRq+goDeflate = goGeneric mkDeflateRq+goXGZip = goGeneric mkXGzipRq+goXGZip2 = goGeneric mkXGzip2Rq+goXDeflate = goGeneric mkXDeflateRq+goBad = goGeneric mkBadRq+goNoHeaders = goGeneric mkNoHeaders+++------------------------------------------------------------------------------+noContentType :: L.ByteString -> Snap ()+noContentType body = modifyResponse $ setResponseBody e+ where+ e s = do+ Streams.writeList (map byteString $ L.toChunks body) s+ return s++------------------------------------------------------------------------------+withContentType :: ByteString -> L.ByteString -> Snap ()+withContentType ct body = modifyResponse $+ setResponseBody e . setContentType ct+ where+ e s = do+ Streams.writeList (map byteString $ L.toChunks body) s+ return s+++------------------------------------------------------------------------------+textPlain :: L.ByteString -> Snap ()+textPlain = withContentType "text/plain"+++------------------------------------------------------------------------------+binary :: L.ByteString -> Snap ()+binary = withContentType "application/octet-stream"+++------------------------------------------------------------------------------+testNoHeaders :: Test+testNoHeaders = testProperty "gzip/noheaders" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ -- if there's no content-type, withCompression should be a no-op+ (!_,!rsp) <- goNoHeaders (seqSnap $ withCompression+ $ noContentType s)+ assertEqual "" Nothing $ getHeader "Content-Encoding" rsp+ assertEqual "" Nothing $ getHeader "Vary" rsp+ body <- Test.getResponseBody rsp++ assertEqual "" s $ L.fromChunks [body]+++------------------------------------------------------------------------------+testNoAcceptEncoding :: Test+testNoAcceptEncoding = testProperty "gzip/noAcceptEncoding" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ -- if there's no accept-encoding, withCompression should be a no-op+ (!_,!rsp) <- goNoHeaders (seqSnap $ withCompression+ $ textPlain s)+ assertEqual "" Nothing $ getHeader "Content-Encoding" rsp+ assertEqual "" Nothing $ getHeader "Vary" rsp++ body <- Test.getResponseBody rsp+ assertEqual "" s $ L.fromChunks [body]+++------------------------------------------------------------------------------+testAcceptEncodingBad :: Test+testAcceptEncodingBad = testCase "gzip/acceptEncodingBad" $ do+ expectExceptionH $ Test.runHandler (Test.setHeader "Accept-Encoding" "$")+ snap+ expectExceptionH $ Test.runHandler+ (Test.setHeader "Accept-Encoding" "gzip;q=^") snap+ where+ snap = withCompression $ do+ modifyResponse $ setHeader "Content-Type" "text/plain"+ writeBS "ok"+++------------------------------------------------------------------------------+testIdentity1 :: Test+testIdentity1 = testProperty "gzip/identity1" $ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlain s)+ assertEqual "" (Just "gzip") $ getHeader "Content-Encoding" rsp+ assertEqual "" (Just "Accept-Encoding") $ getHeader "Vary" rsp++ body <- Test.getResponseBody rsp+ let s1 = GZip.decompress $ L.fromChunks [body]+ assertEqual "" s s1+++------------------------------------------------------------------------------+testIdentity1_charset :: Test+testIdentity1_charset = testProperty "gzip/identity1_charset" $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $+ withContentType "text/plain; charset=utf-8" s)+ assertEqual "" (Just "gzip") $ getHeader "Content-Encoding" rsp+ assertEqual "" (Just "Accept-Encoding") $ getHeader "Vary" rsp++ body <- Test.getResponseBody rsp+ let s1 = GZip.decompress $ L.fromChunks [body]+ assertEqual "" s s1+++------------------------------------------------------------------------------+testIdentity2 :: Test+testIdentity2 = testProperty "gzip/identity2" $ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goDeflate (seqSnap $ withCompression $ textPlain s)++ assertEqual "" (Just "deflate") $ getHeader "Content-Encoding" rsp+ assertEqual "" (Just "Accept-Encoding") $ getHeader "Vary" rsp++ body <- Test.getResponseBody rsp+ let s' = Zlib.decompress $ L.fromChunks [body]+ assertEqual "" s s'+++------------------------------------------------------------------------------+testIdentity3 :: Test+testIdentity3 = testProperty "gzip/identity3" $ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ binary s)+ body <- Test.getResponseBody rsp+ assertEqual "identify" s $ L.fromChunks [body]+++------------------------------------------------------------------------------+testIdentity4 :: Test+testIdentity4 = testProperty "gzip/identity4" $ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goXGZip (seqSnap $ withCompression $ textPlain s)+ assertEqual "encoding" (Just "x-gzip") (getHeader "Content-Encoding" rsp)+ body <- Test.getResponseBody rsp+ let s1 = GZip.decompress $ L.fromChunks [body]+ assertEqual "identity" s s1++ (!_,!rsp2) <- goXGZip2 (seqSnap $ withCompression $ textPlain s)+ assertEqual "encoding" (Just "x-gzip") (getHeader "Content-Encoding" rsp2)+ body2 <- Test.getResponseBody rsp2+ let s2 = GZip.decompress $ L.fromChunks [body2]+ assertEqual "identity2" s s2+++------------------------------------------------------------------------------+testIdentity5 :: Test+testIdentity5 = testProperty "gzip/identity5" $ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goXDeflate (seqSnap $ withCompression $ textPlain s)++ assertEqual "" (Just "x-deflate") $ getHeader "Content-Encoding" rsp+ body <- Test.getResponseBody rsp+ let s2 = Zlib.decompress $ L.fromChunks [body]+ assertEqual "gzip" s s2+++------------------------------------------------------------------------------+testBadHeaders :: Test+testBadHeaders = testProperty "gzip/bad headers" $ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = expectException $ do+ (!_,!rsp) <- goBad (seqSnap $ withCompression $ textPlain s)+ Test.getResponseBody rsp+++------------------------------------------------------------------------------+testNopWhenContentEncodingSet :: Test+testNopWhenContentEncodingSet =+ testProperty "gzip/testNopWhenContentEncodingSet" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = do+ (!_,!rsp) <- liftQ $ goGZip $ f s+ assert $ getHeader "Content-Encoding" rsp == Just "identity"++ f !s = seqSnap $ withCompression $ do+ modifyResponse $ setHeader "Content-Encoding" "identity"+ textPlain s+++------------------------------------------------------------------------------+testCompositionDoesn'tExplode :: Test+testCompositionDoesn'tExplode =+ testProperty "gzip/testCompositionDoesn'tExplode" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goGZip (seqSnap $+ withCompression $+ withCompression $+ withCompression $ textPlain s)++ assertEqual "" (Just "gzip") $ getHeader "Content-Encoding" rsp++ c <- Test.getResponseBody rsp+ let s1 = GZip.decompress $ L.fromChunks [c]+ assertEqual "composition" s s1+++------------------------------------------------------------------------------+testGzipLotsaChunks :: Test+testGzipLotsaChunks = testCase "gzip/lotsOfChunks" prop+ where+ prop = do+ a <- genRandom 12000+ let s = L.take 120000 $ L.cycle $ L.fromChunks [a, B.reverse a]+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlain s)++ body <- Test.getResponseBody rsp+ let s1 = GZip.decompress $ L.fromChunks [body]+ H.assertEqual "streams equal" s s1++ genRandom n = B.pack <$> replicateM n randomWord8++ t8 c = toEnum $ c .&. 0xff++ randomWord8 :: IO Word8+ randomWord8 = t8 <$> randomIO+++------------------------------------------------------------------------------+testNoCompression :: Test+testNoCompression = testProperty "gzip/noCompression" $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = liftQ $ do+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $+ (noCompression >> textPlain s))+ assertEqual "" (Just "identity") $ getHeader "Content-Encoding" rsp+ body <- Test.getResponseBody rsp+ assertEqual "body matches" (S.concat $ L.toChunks s) body+++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "gzip/trivials" $ do+ coverTypeableInstance (undefined :: BadAcceptEncodingException)
+ test/Snap/Util/Proxy/Tests.hs view
@@ -0,0 +1,164 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Util.Proxy.Tests (tests) where++------------------------------------------------------------------------------+import Control.Monad.State.Strict (modify)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (CI (..))+import qualified Data.Map as Map+import Snap.Core (Request (rqClientAddr, rqClientPort), Snap, rqRemotePort, withRequest)+import Snap.Test (RequestBuilder, evalHandler, get, setHeader)+import Snap.Test.Common (coverEqInstance, coverOrdInstance, coverReadInstance, coverShowInstance)+import Snap.Util.Proxy (ProxyType (NoProxy, X_Forwarded_For), behindProxy)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertEqual)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testNoProxy+ , testForwardedFor+ , testTrivials+ ]+++ ---------------+ -- Constants --+ ---------------++------------------------------------------------------------------------------+initialPort :: Int+initialPort = 9999++initialAddr :: ByteString+initialAddr = "127.0.0.1"+++ -----------+ -- Tests --+ -----------++------------------------------------------------------------------------------+testNoProxy :: Test+testNoProxy = testCase "proxy/no-proxy" $ do+ a <- evalHandler (mkReq $ forwardedFor ["4.3.2.1"])+ (behindProxy NoProxy reportRemoteAddr)+ p <- evalHandler (mkReq $ forwardedFor ["4.3.2.1"] >> xForwardedPort [10903])+ (behindProxy NoProxy reportRemotePort)+ assertEqual "NoProxy leaves request alone" initialAddr a+ assertEqual "NoProxy leaves request alone" initialPort p++ --------------------------------------------------------------------------+ b <- evalHandler (mkReq $ xForwardedFor ["2fe3::d4"])+ (behindProxy NoProxy reportRemoteAddr)+ assertEqual "NoProxy leaves request alone" initialAddr b++ --------------------------------------------------------------------------+ c <- evalHandler (mkReq $ return ())+ (behindProxy NoProxy reportRemoteAddr)+ assertEqual "NoProxy leaves request alone" initialAddr c+++------------------------------------------------------------------------------+testForwardedFor :: Test+testForwardedFor = testCase "proxy/forwarded-for" $ do+ (a,p) <- evalHandler (mkReq $ return ()) handler+ assertEqual "No Forwarded-For, no change" initialAddr a+ assertEqual "port" initialPort p++ --------------------------------------------------------------------------+ (b,q) <- evalHandler (mkReq $ forwardedFor [ip4]) handler+ assertEqual "Behind 5.6.7.8" ip4 b+ assertEqual "No Forwarded-Port, no port change" initialPort q++ --------------------------------------------------------------------------+ (c,_) <- evalHandler (mkReq $ xForwardedFor [ip4, ip6]) handler+ assertEqual "Behind 23fe::d4" ip6 c++ --------------------------------------------------------------------------+ (d,r) <- evalHandler (mkReq $ xForwardedFor [ip6, ip4] >> xForwardedPort [20202, port]) handler+ assertEqual "Behind 5.6.7.8" ip4 d+ assertEqual "port change" port r++ where+ handler = behindProxy X_Forwarded_For $ do+ !a <- reportRemoteAddr+ !p <- reportRemotePort'+ return $! (a,p)++ ip4 = "5.6.7.8"+ ip6 = "23fe::d4"+ port = 10101+++------------------------------------------------------------------------------+testTrivials :: Test+testTrivials = testCase "proxy/trivials" $ do+ coverShowInstance NoProxy+ coverReadInstance NoProxy+ coverEqInstance NoProxy+ coverOrdInstance NoProxy+++ ---------------+ -- Functions --+ ---------------++------------------------------------------------------------------------------+mkReq :: RequestBuilder IO () -> RequestBuilder IO ()+mkReq m = do+ get "/" Map.empty+ modify $ \req -> req { rqClientAddr = initialAddr+ , rqClientPort = initialPort+ }+ m+++------------------------------------------------------------------------------+reportRemoteAddr :: Snap ByteString+reportRemoteAddr = withRequest $ \req -> return $ rqClientAddr req+++------------------------------------------------------------------------------+reportRemotePort :: Snap Int+reportRemotePort = withRequest $ \req -> return $ rqClientPort req+++------------------------------------------------------------------------------+-- Cover deprecated rqRemotePort+reportRemotePort' :: Snap Int+reportRemotePort' = withRequest $ \req -> return $ rqRemotePort req+++------------------------------------------------------------------------------+forwardedFor' :: CI ByteString -- ^ header name+ -> [ByteString] -- ^ list of "forwarded-for"+ -> RequestBuilder IO ()+forwardedFor' hdr addrs =+ setHeader hdr $ S.intercalate ", " addrs+++------------------------------------------------------------------------------+forwardedFor :: [ByteString]+ -> RequestBuilder IO ()+forwardedFor = forwardedFor' "Forwarded-For"+++------------------------------------------------------------------------------+xForwardedFor :: [ByteString]+ -> RequestBuilder IO ()+xForwardedFor = forwardedFor' "X-Forwarded-For"+++------------------------------------------------------------------------------+xForwardedPort :: [Int] -- ^ list of "forwarded-port"+ -> RequestBuilder IO ()+xForwardedPort ports =+ setHeader "X-Forwarded-Port" $ S.intercalate ", " $ map (S.pack . show) $ ports
+ test/TestSuite.hs view
@@ -0,0 +1,45 @@+module Main where++import Test.Framework (defaultMain, testGroup)++------------------------------------------------------------------------------+import qualified Snap.Core.Tests+import qualified Snap.Internal.Http.Types.Tests+import qualified Snap.Internal.Parsing.Tests+import qualified Snap.Internal.Routing.Tests+import qualified Snap.Test.Tests+import qualified Snap.Types.Headers.Tests+import qualified Snap.Util.FileServe.Tests+import qualified Snap.Util.FileUploads.Tests+import qualified Snap.Util.GZip.Tests+import qualified Snap.Util.Proxy.Tests+import qualified Snap.Util.CORS.Tests+++------------------------------------------------------------------------------+main :: IO ()+main = defaultMain tests+ where+ tests = [ testGroup "Snap.Internal.Http.Types.Tests"+ Snap.Internal.Http.Types.Tests.tests+ , testGroup "Snap.Internal.Routing.Tests"+ Snap.Internal.Routing.Tests.tests+ , testGroup "Snap.Core.Tests"+ Snap.Core.Tests.tests+ , testGroup "Snap.Internal.Parsing.Tests"+ Snap.Internal.Parsing.Tests.tests+ , testGroup "Snap.Types.Headers.Tests"+ Snap.Types.Headers.Tests.tests+ , testGroup "Snap.Util.FileServe.Tests"+ Snap.Util.FileServe.Tests.tests+ , testGroup "Snap.Util.FileUploads.Tests"+ Snap.Util.FileUploads.Tests.tests+ , testGroup "Snap.Util.GZip.Tests"+ Snap.Util.GZip.Tests.tests+ , testGroup "Snap.Util.Proxy.Tests"+ Snap.Util.Proxy.Tests.tests+ , testGroup "Snap.Util.CORS.Tests"+ Snap.Util.CORS.Tests.tests+ , testGroup "Snap.Test.Tests"+ Snap.Test.Tests.tests+ ]
+ test/data/fileServe/mydir2/dir/foo.txt view
@@ -0,0 +1,1 @@+FOO
− test/runTestsAndCoverage.sh
@@ -1,64 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then- export DEBUG="testsuite"-fi--SUITE=./dist/build/testsuite/testsuite--export LC_ALL=C-export LANG=C--rm -f testsuite.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-Snap.Internal.Debug-Snap.Internal.Iteratee.Debug-Snap.Iteratee.Tests-Snap.Internal.Http.Parser.Tests-Snap.Internal.Http.Server.Tests-Snap.Internal.Http.Types.Tests-Snap.Internal.Iteratee.Tests-Snap.Internal.Parsing.Tests-Snap.Internal.Routing.Tests-Snap.Test.Tests-Snap.Types.Tests-Snap.Util.FileServe.Tests-Snap.Util.FileUploads.Tests-Snap.Util.GZip.Tests-Text.Snap.Templates.Tests-Snap.Test.Common'--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-core-testsuite.cabal
@@ -1,82 +0,0 @@-name: snap-core-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--Executable testsuite- hs-source-dirs: ../src suite- main-is: TestSuite.hs-- if flag(portable) || os(windows)- cpp-options: -DPORTABLE- else- c-sources: ../cbits/timefuncs.c- include-dirs: ../cbits- build-depends: bytestring-mmap >= 0.2.2 && <0.3,- unix >= 2.4 && <3.0- cpp-options: -DUSE_UNIX-- build-depends:- QuickCheck >= 2.3.0.2,- attoparsec >= 0.10 && < 0.11,- attoparsec-enumerator >= 0.3,- base >= 4 && < 5,- base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.4,- blaze-builder-enumerator >= 0.2 && <0.3,- bytestring,- bytestring-nums,- case-insensitive >= 0.3 && < 0.5,- cereal == 0.3.*,- containers,- deepseq >= 1.1 && <1.3,- directory,- dlist >= 0.5 && < 0.6,- filepath,- HUnit >= 1.2 && < 2,- enumerator >= 0.4.13.1 && < 0.5,- MonadCatchIO-transformers >= 0.2 && < 0.3,- mtl >= 2 && <3,- mwc-random >= 0.10 && <0.11,- old-locale,- old-time,- parallel >= 3 && <4,- pureMD5 == 2.1.*,- regex-posix >= 0.94.4 && <0.96,- test-framework >= 0.4 && < 0.5,- test-framework-hunit >= 0.2.5 && < 0.3,- test-framework-quickcheck2 >= 0.2.6 && < 0.3,- text >= 0.11 && <0.12,- time,- transformers,- unix-compat >= 0.2 && <0.4,- unordered-containers >= 0.1.4.3 && <0.2,- vector >= 0.6 && <0.10,- zlib,- zlib-enum >= 0.2.1 && <0.3-- extensions:- BangPatterns,- CPP,- PackageImports,- ScopedTypeVariables,- EmptyDataDecls,- ForeignFunctionInterface,- OverloadedStrings,- Rank2Types,- TypeSynonymInstances,- FlexibleInstances,- ExistentialQuantification,- OverloadedStrings,- FlexibleContexts,- GeneralizedNewtypeDeriving,- DeriveDataTypeable,- MultiParamTypeClasses-- ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind
− test/suite/Snap/Core/Tests.hs
@@ -1,602 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Core.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Control.Applicative-import Control.Concurrent.MVar-import Control.DeepSeq-import Control.Exception (ErrorCall(..), SomeException, throwIO)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans (liftIO)-import Control.Parallel.Strategies-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.IntMap as IM-import Data.IORef-import Data.Maybe (isJust)-import Data.Monoid-import Data.Text ()-import Data.Text.Lazy ()-import qualified Data.Map as Map-import Prelude hiding (catch)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, path)- -import Snap.Internal.Http.Types-import Snap.Internal.Parsing-import Snap.Internal.Types-import Snap.Iteratee-import qualified Snap.Iteratee as I-import Snap.Test.Common-import qualified Snap.Types.Headers as H---tests :: [Test]-tests = [ testFail- , testAlternative- , testEarlyTermination- , testEscapeHttp- , testCatchFinishWith- , testRqBody- , testRqBodyTooLong- , testRqBodyException- , testRqBodyTermination- , testTrivials- , testMethod- , testMethods- , testDir- , testCatchIO- , testWrites- , testParam- , testURLEncode1- , testURLEncode2- , testDir2- , testIpHeaderFilter- , testMZero404- , testEvalSnap- , testLocalRequest- , testRedirect- , testBracketSnap ]---expectSpecificException :: Exception e => e -> IO a -> IO ()-expectSpecificException e0 m = do- r <- try m-- let b = either (\se -> isJust $- forceSameType (Just e0) (fromException se))- (const False)- r- assertBool ("expected specific exception: " ++ show e0) b---expect404 :: IO (Request,Response) -> IO ()-expect404 m = do- (_,r) <- m- assertBool "expected 404" (rspStatus r == 404)---expectNo404 :: IO (Request,Response) -> IO ()-expectNo404 m = do- (_,r) <- m- assertBool ("expected 200, got " ++ show (rspStatus r))- (rspStatus r /= 404)---mkRequest :: ByteString -> IO Request-mkRequest uri = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" uri "/"- (S.concat ["/",uri]) "" Map.empty--mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request-mkRequestQuery uri k v = do- enum <- newIORef $ SomeEnumerator returnI-- let mp = Map.fromList [(k,v)]- let q = S.concat [k,"=", S.concat v]-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" uri "/"- (S.concat ["/",uri,"?",q]) q mp---mkZomgRq :: IO Request-mkZomgRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty---mkIpHeaderRq :: IO Request-mkIpHeaderRq = do- rq <- mkZomgRq- return $ setHeader "X-Forwarded-For" "1.2.3.4"- $ deleteHeader "X-Forwarded-For"- $ setHeader "X-Forwarded-For" "1.2.3.4" rq---mkRqWithBody :: IO Request-mkRqWithBody = mkRqWithEnum (enumBS "zazzle" >==> enumEOF)---mkRqWithEnum :: (forall a . Enumerator ByteString IO a) -> IO Request-mkRqWithEnum e = do- enum <- newIORef $ SomeEnumerator e- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" "/" "/" "/" ""- Map.empty--testCatchIO :: Test-testCatchIO = testCase "types/catchIO" $ do- (_,rsp) <- go f- (_,rsp2) <- go g-- assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp- assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2-- where- f :: Snap ()- f = (block $ unblock $ throw $ NoHandlerException "") `catch` h-- g :: Snap ()- g = return () `catch` h-- h :: SomeException -> Snap ()- h e = e `seq` modifyResponse $ addHeader "foo" "bar"--go :: Snap a -> IO (Request,Response)-go m = do- zomgRq <- mkZomgRq- run_ $ runSnap m dummy dummy zomgRq- where- dummy !x = return $! (show x `using` rdeepseq) `seq` ()--goIP :: Snap a -> IO (Request,Response)-goIP m = do- rq <- mkIpHeaderRq- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()--goPath :: ByteString -> Snap a -> IO (Request,Response)-goPath s m = do- rq <- mkRequest s- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goPathQuery :: ByteString- -> ByteString- -> [ByteString]- -> Snap a- -> IO (Request,Response)-goPathQuery s k v m = do- rq <- mkRequestQuery s k v- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goBody :: Snap a -> IO (Request,Response)-goBody m = do- rq <- mkRqWithBody- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---goEnum :: (forall a . Enumerator ByteString IO a)- -> Snap b- -> IO (Request,Response)-goEnum enum m = do- rq <- mkRqWithEnum enum- run_ $ runSnap m dummy dummy rq- where- dummy = const $ return ()---testFail :: Test-testFail = testCase "failure" $ expect404 (go pass)---setFoo :: ByteString -> Snap ()-setFoo s = do- modifyResponse (addHeader "Foo" s)- fmap id $ pure ()- pure id <*> (liftIO $ return ())---testAlternative :: Test-testAlternative = testCase "types/alternative" $ do- (_,resp) <- go (pass <|> setFoo "Bar")- assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp-- (_,resp2) <- go (fail ""- <|> fail2- <|> setFoo "Bar"- <|> setFoo "Baz")- assertEqual "alternative chooses correct branch"- (Just ["Bar"]) $ getHeaders "Foo" resp2-- where- fail2 :: Snap ()- fail2 = pass >>= \_ -> return ()---sampleResponse :: Response-sampleResponse = addHeader "Foo" "Quux" $ emptyResponse---testEarlyTermination :: Test-testEarlyTermination = testCase "types/earlyTermination" $ do- (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar")- assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp---testEscapeHttp :: Test-testEscapeHttp = testCase "types/escapeHttp" $ flip catch catchEscape $ do- (_, _) <- go (escapeHttp escaper)- assertFailure "HTTP escape was ignored"- where- escaper _ _ = liftIO $ assert True- tickle _ = return ()-- catchEscape (EscapeHttpException iter) = run_ $ iter tickle (return ())---isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False--isRight :: Either a b -> Bool-isRight (Right _) = True-isRight _ = False---testBracketSnap :: Test-testBracketSnap = testCase "types/bracketSnap" $ do- rq <- mkZomgRq-- ref <- newIORef 0-- expectSpecificException (NoHandlerException "") $- run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq-- y <- readIORef ref- assertEqual "bracketSnap/after1" (1::Int) y-- expectSpecificException (ErrorCall "no value") $- run_ $ evalSnap (act ref <|> finishWith emptyResponse)- (const $ return ())- (const $ return ())- rq- - y' <- readIORef ref- assertEqual "bracketSnap/after" 2 y'--- expectSpecificException (ErrorCall "foo") $- run_ $ evalSnap (act2 ref)- (const $ return ())- (const $ return ())- rq- - y'' <- readIORef ref- assertEqual "bracketSnap/after" 3 y''-- where- act ref = bracketSnap (liftIO $ readIORef ref)- (\z -> liftIO $ writeIORef ref $! z+1)- (\z -> z `seq` mzero)-- act2 ref = bracketSnap (liftIO $ readIORef ref)- (\z -> liftIO $ writeIORef ref $! z+1)- (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")---testCatchFinishWith :: Test-testCatchFinishWith = testCase "types/catchFinishWith" $ do- rq <- mkZomgRq- x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse)- (const $ return ())- (const $ return ())- rq- assertBool "catchFinishWith" $ isLeft x- y <- run_ $ evalSnap (catchFinishWith $ return ())- (const $ return ())- (const $ return ())- rq- assertBool "catchFinishWith" $ isRight y---testRqBody :: Test-testRqBody = testCase "types/requestBodies" $ do- mvar1 <- newEmptyMVar- mvar2 <- newEmptyMVar-- _ <- goBody $ f mvar1 mvar2-- v1 <- takeMVar mvar1- v2 <- takeMVar mvar2-- assertEqual "rq body" "zazzle" v1- assertEqual "rq body 2" "" v2-- (_,rsp) <- goBody g- bd <- getBody rsp-- assertEqual "detached rq body" "zazzle" bd--- where- f mvar1 mvar2 = do- getRequestBody >>= liftIO . putMVar mvar1- getRequestBody >>= liftIO . putMVar mvar2-- g = transformRequestBody returnI---testRqBodyTooLong :: Test-testRqBodyTooLong = testCase "types/requestBodyTooLong" $ do- expectExceptionH $ goBody $ f 2- (_, rsp) <- goBody $ f 200000- bd <- getBody rsp-- assertEqual "detached rq body" "zazzle" bd--- where- f sz = readRequestBody sz >>= writeLBS---testRqBodyException :: Test-testRqBodyException = testCase "types/requestBodyException" $ do- (req,resp) <- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr- bd <- getBody resp-- (SomeEnumerator e) <- readIORef $ rqBody req- b' <- liftM (S.concat) $ run_ $ e $$ consume- assertEqual "request body was consumed" "" b'- assertEqual "response body was produced" "OK" bd-- where- h0 = runRequestBody $ do- _ <- I.head- throw $ ErrorCall "foo"-- hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"---testRqBodyTermination :: Test-testRqBodyTermination =- testCase "types/requestBodyTermination" $- expectExceptionH $- goEnum (enumList 1 ["the", "quick", "brown", "fox"]) hndlr-- where- h0 = runRequestBody $ do- _ <- I.head- terminateConnection $ ErrorCall "foo"-- hndlr = h0 `catch` \(_::SomeException) -> writeBS "OK"----testTrivials :: Test-testTrivials = testCase "types/trivials" $ do- (rq,rsp) <- go $ do- req <- getRequest- putRequest $ req { rqIsSecure=True }- putResponse $ setResponseStatus 333 "333" sampleResponse- r <- getResponse- liftIO $ assertEqual "rsp status" 333 $ rspStatus r- !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do- q <- getRequest- liftIO $ assertEqual "localrq" False $ rqIsSecure q- return ()-- logError "foo"- writeText "zzz"- writeLazyText "zzz"-- let req' = updateContextPath 0 req- let cp1 = rqContextPath req- let cp2 = rqContextPath req'-- liftIO $ assertEqual "updateContextPath 0" cp1 cp2-- withRequest $ return . (`seq` ())- withResponse $ return . (`seq` ())-- return ()-- b <- getBody rsp- coverShowInstance b- coverShowInstance $ NoHandlerException ""- coverShowInstance GET- coverReadInstance GET- coverEqInstance GET- coverEqInstance $ NoHandlerException ""- coverOrdInstance GET-- Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)- `deepseq` return ()-- let cookie = Cookie "" "" Nothing Nothing Nothing False False- coverEqInstance cookie- coverShowInstance cookie-- assertEqual "rq secure" True $ rqIsSecure rq- assertEqual "rsp status" 333 $ rspStatus rsp---testMethod :: Test-testMethod = testCase "types/method" $ do- expect404 $ go (method POST $ return ())- expectNo404 $ go (method GET $ return ())--testMethods :: Test-testMethods = testCase "types/methods" $ do- expect404 $ go (methods [POST,PUT] $ return ())- expectNo404 $ go (methods [GET] $ return ())- expectNo404 $ go (methods [POST,GET] $ return ())- expectNo404 $ go (methods [PUT,GET] $ return ())- expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())---testDir :: Test-testDir = testCase "types/dir" $ do- expect404 $ goPath "foo/bar" (dir "zzz" $ return ())- expectNo404 $ goPath "foo/bar" (dir "foo" $ return ())- expect404 $ goPath "fooz/bar" (dir "foo" $ return ())- expectNo404 $ goPath "foo/bar" (path "foo/bar" $ return ())- expect404 $ goPath "foo/bar/z" (path "foo/bar" $ return ())- expectNo404 $ goPath "" (ifTop $ return ())- expect404 $ goPath "a" (ifTop $ return ())---testParam :: Test-testParam = testCase "types/getParam" $ do- expect404 $ goPath "/foo" f- expectNo404 $ goPathQuery "/foo" "param" ["foo"] f- where- f = do- mp <- getParam "param"- maybe pass- (\s -> if s == "foo" then return () else pass)- mp---getBody :: Response -> IO L.ByteString-getBody r = do- let benum = rspBodyToEnum $ rspBody r- liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)---testWrites :: Test-testWrites = testCase "types/writes" $ do- (_,r) <- go h- b <- getBody r- assertEqual "output functions" "Foo1Foo2Foo3" b- where- h :: Snap ()- h = do- addToOutput $ enumBuilder $ fromByteString "Foo1"- writeBS "Foo2"- writeLBS "Foo3"---testURLEncode1 :: Test-testURLEncode1 = testCase "types/urlEncoding1" $ do- let b = urlEncode "the quick brown fox~#"- assertEqual "url encoding 1" "the+quick+brown+fox%7e%23" b- assertEqual "fail" Nothing $ urlDecode "%"---testURLEncode2 :: Test-testURLEncode2 = testProperty "types/urlEncoding2" prop- where- prop s = (urlDecode $ urlEncode s) == Just s---testDir2 :: Test-testDir2 = testCase "types/dir2" $ do- (_,resp) <- goPath "foo/bar" f- b <- getBody resp- assertEqual "context path" "/foo/bar/" b-- where- f = dir "foo" $ dir "bar" $ do- p <- liftM rqContextPath getRequest- addToOutput $ enumBuilder $ fromByteString p---testIpHeaderFilter :: Test-testIpHeaderFilter = testCase "types/ipHeaderFilter" $ do- (_,r) <- goIP f- b <- getBody r- assertEqual "ipHeaderFilter" "1.2.3.4" b--- (_,r2) <- go f- b2 <- getBody r2- assertEqual "ipHeaderFilter" "127.0.0.1" b2-- where- f = do- ipHeaderFilter- ip <- liftM rqRemoteAddr getRequest- writeBS ip---testMZero404 :: Test-testMZero404 = testCase "types/mzero404" $ do- (_,r) <- go mzero- let l = rspContentLength r- b <- getBody r- assertEqual "mzero 404" "404" b- assertEqual "mzero 404 length" (Just 3) l---testEvalSnap :: Test-testEvalSnap = testCase "types/evalSnap-exception" $ do- rq <- mkZomgRq- expectExceptionH (run_ $ evalSnap f- (const $ return ())- (const $ return ())- rq >> return ())- where- f = do- logError "zzz"- v <- withResponse (return . rspHttpVersion)- liftIO $ assertEqual "evalSnap rsp version" (1,1) v- finishWith emptyResponse---testLocalRequest :: Test-testLocalRequest = testCase "types/localRequest" $ do- rq1 <- mkZomgRq- rq2 <- mkRequest "zzz/zz/z"-- let h = localRequest (const rq2) mzero-- (rq',_) <- go (h <|> return ())-- let u1 = rqURI rq1- let u2 = rqURI rq'-- assertEqual "localRequest backtrack" u1 u2----testRedirect :: Test-testRedirect = testCase "types/redirect" $ do- (_,rsp) <- go (redirect "/foo/bar")-- b <- getBody rsp- assertEqual "no response body" "" b- assertEqual "response content length" (Just 0) $ rspContentLength rsp- assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp- assertEqual "redirect status" 302 $ rspStatus rsp- assertEqual "status description" "Found" $ rspStatusReason rsp--- (_,rsp2) <- go (redirect' "/bar/foo" 307)-- assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2- assertEqual "redirect status" 307 $ rspStatus rsp2- assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2
− test/suite/Snap/Internal/Http/Types/Tests.hs
@@ -1,166 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-module Snap.Internal.Http.Types.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Control.Monad-import Control.Parallel.Strategies-import Data.ByteString.Char8 (ByteString)-import Data.ByteString.Lazy.Char8 ()-import Data.IORef-import qualified Data.Map as Map-import Data.Monoid-import Data.Time.Calendar-import Data.Time.Clock-import Prelude hiding (take)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)-import Text.Regex.Posix--import Snap.Internal.Http.Types-import Snap.Internal.Parsing-import Snap.Iteratee-import qualified Snap.Types.Headers as H---tests :: [Test]-tests = [ testTypes- , testCookies- , testUrlDecode- , testFormatLogTime- , testAddHeader ]---mkRq :: IO Request-mkRq = do- enum <- newIORef (SomeEnumerator $ enumBS "")- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty---testFormatLogTime :: Test-testFormatLogTime = testCase "formatLogTime" $ do- b <- formatLogTime 3804938-- let re = ("^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}:[0-9]{2} (-|\\+)[0-9]{4}$"- :: ByteString)-- assertBool "formatLogTime" $ b =~ re---testAddHeader :: Test-testAddHeader = testCase "addHeader" $ do- defReq <- mkRq-- let req = addHeader "foo" "bar" $- addHeader "foo" "baz" defReq--- let x = getHeader "foo" req- assertEqual "addHeader x 2" (Just "baz bar") x---testUrlDecode :: Test-testUrlDecode = testCase "urlDecode" $ do- assertEqual "bad hex" Nothing $ urlDecode "%qq"---testTypes :: Test-testTypes = testCase "show" $ do- defReq <- mkRq-- let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $- updateHeaders (H.set "zzz" "bbb") $- rqSetParam "foo" ["bar"] $- defReq-- let req2 = (addHeader "zomg" "1234" req) { rqCookies = [ cook, cook2 ] }-- let !a = show req `using` rdeepseq- let !_ = show req2 `using` rdeepseq-- -- we don't care about the show instance really, we're just trying to shut- -- up hpc- assertBool "show" $ a /= b- assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req)- assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req)- assertEqual "lookup 2" (Just ["bbb"]) (H.lookup "zzz" $ headers req)-- assertEqual "response status" 555 $ rspStatus resp- assertEqual "response status reason" "bogus" $ rspStatusReason resp- assertEqual "content-length" (Just 4) $ rspContentLength resp- -- run response body- let benum = rspBodyToEnum $ rspBody resp- bd <- liftM (toByteString . mconcat) (runIteratee consume >>= run_ . benum)- assertEqual "response body" "PING" $ bd-- let !_ = show GET- let !_ = GET == POST- let !_ = headers $ headers defReq-- let !_ = show resp2 `using` rdeepseq--- return ()-- where- resp = addResponseCookie cook $- setContentLength 4 $- modifyResponseBody id $- setResponseBody (enumBuilder (fromByteString "PING")) $- setContentType "text/plain" $- setResponseStatus 555 "bogus" $- emptyResponse- !b = show resp `using` rdeepseq-- resp2 = addResponseCookie cook2 resp-- utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") False False---testCookies :: Test-testCookies = testCase "cookies" $ do- assertEqual "cookie" (Just cook) rCook- assertEqual "cookie2" (Just cook2) rCook2- assertEqual "cookie3" (Just cook3) rCook3- assertEqual "empty response cookie3" (Just cook3) rCook3e- assertEqual "removed cookie" Nothing nilCook- assertEqual "multiple cookies" [cook, cook2] cks- assertEqual "cookie modification" (Just cook3) rCook3Mod-- return ()-- where- resp = addResponseCookie cook $- setContentType "text/plain" $- emptyResponse-- f _ = cook3-- resp' = deleteResponseCookie "foo" resp- resp'' = modifyResponseCookie "foo" f resp- resp2 = addResponseCookie cook2 resp- resp3 = addResponseCookie cook3 resp2- resp4 = addResponseCookie cook3 emptyResponse-- utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False True- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") True False- cook3 = Cookie "boo" "baz" Nothing Nothing Nothing False False-- rCook = getResponseCookie "foo" resp- nilCook = getResponseCookie "foo" resp'- rCook2 = getResponseCookie "zoo" resp2- rCook3 = getResponseCookie "boo" resp3- rCook3e = getResponseCookie "boo" resp4- rCook3Mod = getResponseCookie "boo" resp''-- cks = getResponseCookies resp2----
− test/suite/Snap/Internal/Parsing/Tests.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-module Snap.Internal.Parsing.Tests- ( tests ) where---import qualified Data.ByteString as S-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import Snap.Internal.Http.Types-import Snap.Internal.Parsing---tests :: [Test]-tests = [ testCookie ]---testCookie :: Test-testCookie =- testCase "parsing/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 ]
− test/suite/Snap/Internal/Routing/Tests.hs
@@ -1,325 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Internal.Routing.Tests- ( tests ) where--import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import Snap.Internal.Http.Types-import Snap.Internal.Routing-import Snap.Internal.Types-import Snap.Iteratee hiding (head)-import qualified Snap.Types.Headers as H--tests :: [Test]-tests = [ testRouting1- , testRouting2- , testRouting3- , testRouting4- , testRouting5- , testRouting6- , testRouting7- , testRouting8- , testRouting9- , testRouting10- , testRouting11- , testRouting12- , testRouting13- , testRouting14- , testRouting15- , testRouting16- , testRouting17- , testRouting18- , testRouting19- , testRouting20- , testRouting21- , testRouting22- , testRouting23- , testRouting24- , testRouting25- , testRouting26- , testRouting27- , testRouting28- , testRouteLocal- , testRouteUrlDecode- , testRouteUrlEncodedPath- ]--expectException :: IO a -> IO ()-expectException m = do- e <- try m- case e of- Left (z::SomeException) -> (show z) `seq` return ()- Right _ -> assertFailure "expected exception, didn't get one"---mkRequest :: ByteString -> IO Request-mkRequest uri = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" uri "/"- (B.concat ["/",uri]) "" Map.empty--go :: Snap a -> ByteString -> IO a-go m s = do- req <- mkRequest s- run_ $ evalSnap m dummy dummy req- where- dummy = const $ return ()--routes :: Snap ByteString-routes = route [ ("foo" , topFoo )- , ("foo/bar" , fooBar )- , ("foo/bar/baz" , getRqPathInfo )- , ("foo/:id" , fooCapture )- , ("bar/:id" , fooCapture )- , ("herp/:derp/" , getRqPathInfo )- , ("nerp/:derp/" , getRqContextPath)- , ("a b c d" , return "OK" )- , ("bar/quux" , barQuux )- , ("bar" , bar )- , ("z/:a/:b/:c/d" , zabc ) ]--routesLocal :: Snap ByteString-routesLocal = routeLocal [ ("foo/bar/baz" , getRqPathInfo )- , ("bar" , pass ) ]--routes2 :: Snap ByteString-routes2 = route [ ("" , topTop )- , ("foo" , topFoo ) ]--routes3 :: Snap ByteString-routes3 = route [ (":foo" , topCapture )- , ("" , topTop ) ]--routes4 :: Snap ByteString-routes4 = route [ (":foo" , pass )- , (":foo" , topCapture )- , (":qqq/:id" , fooCapture )- , (":id2/baz" , fooCapture2 ) ]--routes5 :: Snap ByteString-routes5 = route [ ("" , pass )- , ("" , topTop ) ]--routes6 :: Snap ByteString-routes6 = route [ (":a/:a" , dblA ) ]--routes7 :: Snap ByteString-routes7 = route [ ("foo/:id" , fooCapture )- , ("foo/:id/:id2" , fooCapture2)- , ("fooo/:id/:id2" , fooCapture2)- , ("foooo/bar/baz" , bar )- , ("" , topTop ) ]---topTop, topFoo, fooBar, fooCapture, getRqPathInfo, bar,- getRqContextPath, barQuux, dblA, zabc, topCapture, - fooCapture2 :: Snap ByteString--dblA = do- ma <- getParam "a"-- unless (ma == Just "a a") pass- return "ok"---zabc = do- ma <- getParam "a"- mb <- getParam "b"- mc <- getParam "c"-- unless ( ma == Just "a"- && mb == Just "b"- && mc == Just "c" ) pass-- return "ok"---topCapture = do- mp <- getParam "foo"- maybe pass return mp--topTop = return "topTop"-topFoo = return "topFoo"-fooBar = return "fooBar"-fooCapture = liftM (head . fromJust . rqParam "id") getRequest-fooCapture2 = liftM (head . fromJust . rqParam "id2") getRequest-getRqPathInfo = liftM rqPathInfo getRequest-getRqContextPath = liftM rqContextPath getRequest-barQuux = return "barQuux"-bar = return "bar"---- TODO more useful test names--testRouting1 :: Test-testRouting1 = testCase "route/1" $ do- r1 <- go routes "foo"- assertEqual "/foo" "topFoo" r1--testRouting2 :: Test-testRouting2 = testCase "route/2" $ do- r2 <- go routes "foo/baz"- assertEqual "/foo/baz" "baz" r2--testRouting3 :: Test-testRouting3 = testCase "route/3" $ do- expectException $ go routes "/xsaxsaxsax"--testRouting4 :: Test-testRouting4 = testCase "route/4" $ do- r3 <- go routes "foo/bar"- assertEqual "/foo/bar" "fooBar" r3--testRouting5 :: Test-testRouting5 = testCase "route/5" $ do- r4 <- go routes "foo/bar/baz/quux"- assertEqual "/foo/bar/baz/quux" "quux" r4--testRouting6 :: Test-testRouting6 = testCase "route/6" $ do- r5 <- go routes "foo/bar/sproing"- assertEqual "/foo/bar/sproing" "fooBar" r5--testRouting7 :: Test-testRouting7 = testCase "route/7" $ do- r <- go routes "bar"- assertEqual "/bar" "bar" r--testRouting8 :: Test-testRouting8 = testCase "route/8" $ do- r2 <- go routes "bar/quux"- assertEqual "/bar/quux" "barQuux" r2--testRouting9 :: Test-testRouting9 = testCase "route/9" $ do- r3 <- go routes "bar/whatever"- assertEqual "/bar/whatever" "whatever" r3--testRouting10 :: Test-testRouting10 = testCase "route/10" $ do- r4 <- go routes "bar/quux/whatever"- assertEqual "/bar/quux/whatever" "barQuux" r4--testRouting11 :: Test-testRouting11 = testCase "route/11" $ do- r1 <- go routes2 ""- assertEqual "/" "topTop" r1--testRouting12 :: Test-testRouting12 = testCase "route/12" $ do- r1 <- go routes2 "foo"- assertEqual "/foo" "topFoo" r1--testRouting13 :: Test-testRouting13 = testCase "route/13" $ do- r1 <- go routes3 "zzzz"- assertEqual "/zzzz" "zzzz" r1--testRouting14 :: Test-testRouting14 = testCase "route/14" $ do- r1 <- go routes3 ""- assertEqual "/" "topTop" r1--testRouting15 :: Test-testRouting15 = testCase "route/15" $ do- r1 <- go routes4 "zzzz"- assertEqual "/zzzz" "zzzz" r1--testRouting16 :: Test-testRouting16 = testCase "route/16" $ do- r1 <- go routes5 ""- assertEqual "/" "topTop" r1--testRouting17 :: Test-testRouting17 = testCase "route/17" $ do- r1 <- go routes "z/a/b/c/d"- assertEqual "/z/a/b/c/d" "ok" r1--testRouting18 :: Test-testRouting18 = testCase "route/18" $ do- r1 <- go routes6 "a/a"- assertEqual "/a/a" "ok" r1--testRouting19 :: Test-testRouting19 = testCase "route/19" $ do- r1 <- go routes7 "foo"- assertEqual "/foo" "topTop" r1--testRouting20 :: Test-testRouting20 = testCase "route/20" $ do- r1 <- go routes7 "foo/baz"- assertEqual "/foo/baz" "baz" r1--testRouting21 :: Test-testRouting21 = testCase "route/21" $ do- r1 <- go routes7 "foo/baz/quux"- assertEqual "/foo/baz/quux" "quux" r1--testRouting22 :: Test-testRouting22 = testCase "route/22" $ do- r1 <- go routes7 "fooo/baz"- assertEqual "/fooo/baz" "topTop" r1--testRouting23 :: Test-testRouting23 = testCase "route/23" $ do- r1 <- go routes7 "fooo/baz/quux"- assertEqual "/fooo/baz/quux" "quux" r1--testRouting24 :: Test-testRouting24 = testCase "route/24" $ do- r1 <- go routes7 "foooo/bar/bax"- assertEqual "/foooo/bar/bax" "topTop" r1--testRouting25 :: Test-testRouting25 = testCase "route/25" $ do- r1 <- go routes7 "foooo/bar/baz"- assertEqual "/foooo/bar/baz" "bar" r1--testRouting26 :: Test-testRouting26 = testCase "route/26" $ do- r1 <- go routes4 "foo/bar"- assertEqual "capture union" "bar" r1--testRouting27 :: Test-testRouting27 = testCase "route/27" $ do- r1 <- go routes4 "foo"- assertEqual "capture union" "foo" r1--testRouting28 :: Test-testRouting28 = testCase "route/28" $ do- r1 <- go routes4 "quux/baz"- assertEqual "capture union" "quux" r1--testRouteUrlDecode :: Test-testRouteUrlDecode = testCase "route/urlDecode" $ do- r1 <- go routes "herp/%7Bderp%7D/"- assertEqual "rqPathInfo on urldecode" "" r1- r2 <- go routes "foo/%7Bderp%7D/"- assertEqual "urldecoded capture" "{derp}" r2- r3 <- go routes "nerp/%7Bderp%7D/"- assertEqual "rqContextPath on urldecode" "/nerp/%7Bderp%7D/" r3--testRouteUrlEncodedPath :: Test-testRouteUrlEncodedPath = testCase "route/urlEncodedPath" $ do- -- make sure path search urlDecodes.- r1 <- go routes "a+b+c+d"- assertEqual "urlEncoded search works" "OK" r1--testRouteLocal :: Test-testRouteLocal = testCase "route/routeLocal" $ do- r4 <- go routesLocal "foo/bar/baz/quux"- assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4- expectException $ go routesLocal "bar"
− test/suite/Snap/Iteratee/Tests.hs
@@ -1,536 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Snap.Iteratee.Tests- ( tests ) where--import Control.Concurrent (threadDelay)-import qualified Control.Exception as E-import Control.Exception hiding (try, assert, throw, catch)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Identity-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.Int-import Data.Maybe-import Prelude hiding (catch, head, drop, take)-import System.Timeout-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Test.QuickCheck.Gen-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run)-import Test.Framework.Providers.HUnit-import qualified Test.HUnit as H--import Snap.Iteratee-import Snap.Internal.Iteratee.BoyerMooreHorspool-import Snap.Test.Common--import Snap.Internal.Iteratee.Debug--throwErr :: String -> Iteratee a IO b-throwErr = throwError . AssertionFailed---tests :: [Test]-tests = [ testEnumBS- , testEnumLBS- , testUnsafeBuffer- , testUnsafeBuffer2- , testUnsafeBuffer3- , testUnsafeBuffer4- , testUnsafeBuffer5- , testTakeExactly1- , testTakeExactly2- , testTakeExactly3- , testTakeNoMoreThan1- , testTakeNoMoreThan2- , testTakeNoMoreThan3- , testCountBytes- , testCountBytes2- , testKillIfTooSlow1- , testKillIfTooSlow2- , testBMH- , testBMHTrivials- , testCatchIO- ]--testEnumBS :: Test-testEnumBS = testProperty "iteratee/enumBS" prop- where- prop :: S.ByteString -> Bool- prop s = (S.concat $ runIdentity (run_ iter)) == s- where- iter = runIdentity $ liftM (enumBS s) $ runIteratee consume--testEnumLBS :: Test-testEnumLBS = testProperty "iteratee/enumLBS" prop- where- prop :: L.ByteString -> Bool- prop s = L.fromChunks (runIdentity (run_ iter)) == s- where- iter = runIdentity $ liftM (enumLBS s) $ runIteratee consume---copyingConsume :: Iteratee ByteString IO L.ByteString-copyingConsume = f []- where- f l = do- mbX <- head- maybe (return $ L.fromChunks $ reverse l)- (\x -> let !z = S.copy x- in z `seq` f (z : l))- mbX---bufferAndRun :: Iteratee ByteString IO a -> L.ByteString -> IO a-bufferAndRun ii s = do- i <- unsafeBufferIteratee ii >>= runIteratee- run_ $ enumLBS s i---testUnsafeBuffer :: Test-testUnsafeBuffer = testProperty "iteratee/testUnsafeBuffer" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- pre $ s /= L.empty- x <- liftQ $ bufferAndRun copyingConsume s'- assert $ x == s'-- where- s' = L.take 20000 $ L.cycle s---testUnsafeBuffer2 :: Test-testUnsafeBuffer2 = testCase "iteratee/testUnsafeBuffer2" prop- where- prop = do- i <- unsafeBufferIteratee (drop 4 >> copyingConsume) >>= runIteratee- s <- run_ $ enumLBS "abcdefgh" i- H.assertEqual "s == 'efgh'" "efgh" s---testUnsafeBuffer3 :: Test-testUnsafeBuffer3 = testProperty "iteratee/testUnsafeBuffer3" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- pre $ s /= L.empty-- ss <- liftQ $ runIteratee copyingConsume >>=- return . joinI . take 19999-- x <- liftQ $ bufferAndRun (ss >>= \x -> drop 1 >> return x) s'-- let y = L.take 19999 s'- if x /= y- then liftQ $ do- putStrLn $ "FAILED!!!!!"- putStrLn $ "length x = " ++ show (L.length x)- putStrLn $ "length y = " ++ show (L.length y)- diff x y- putStrLn $ "input was " ++ show s- else return ()-- assert $ x == y- where- s' = L.take 20000 $ L.cycle s--- diff a b = d a b (0::Int)- d a b n = do- case ma of- Nothing -> if mb /= Nothing- then do- let Just (y,_) = mb- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=Nothing, b=" ++ show y- else return ()-- Just (x,rest1) ->- if isNothing mb- then do- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=" ++ show x ++ ", b=Nothing"- else do- let Just (y,rest2) = mb- if x /= y- then do- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=" ++ show x ++ ", b=" ++ show y- let r1 = L.take 6 rest1- let r2 = L.take 6 rest2- putStrLn $ "next few bytes a = " ++ show r1- putStrLn $ "next few bytes b = " ++ show r2- else- d rest1 rest2 (n+1)- where- ma = L.uncons a- mb = L.uncons b----tub3Prop s = do- ss <- runIteratee copyingConsume >>=- return . joinI . take 19999-- let it = (ss >>= \x -> drop 1 >> return x)- x <- bufferAndRun (iterateeDebugWrapper "foo" it) s'-- let a = x- let b = L.take 19999 s'- let boo = (a == b)- putStrLn $ "equal? " ++ show boo- diff a b-- where- diff a b = d a b (0::Int)- d a b n = do- case ma of- Nothing -> if mb /= Nothing- then do- let Just (y,_) = mb- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=Nothing, b=" ++ show y- else return ()-- Just (x,rest1) ->- if isNothing mb- then do- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=" ++ show x ++ ", b=Nothing"- else do- let Just (y,rest2) = mb- if x /= y- then do- putStrLn $ "differ at byte " ++ show n- putStrLn $ "a=" ++ show x ++ ", b=" ++ show y- else- d rest1 rest2 (n+1)- where- ma = L.uncons a- mb = L.uncons b-- s' = L.take 20000 $ L.cycle s-----testUnsafeBuffer4 :: Test-testUnsafeBuffer4 = testProperty "iteratee/testUnsafeBuffer4" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- i <- liftQ (unsafeBufferIteratee (copyingConsume >> throwErr "foo") >>=- runIteratee)- expectException $ run_ $ enumLBS s i-- j <- liftQ $ unsafeBufferIteratee (throwErr "foo" >> copyingConsume)- >>= runIteratee- expectException $ run_ $ enumLBS s j---testUnsafeBuffer5 :: Test-testUnsafeBuffer5 = testProperty "iteratee/testUnsafeBuffer5" $- monadicIO $ forAllM arbitrary prop- where- prop s = do- pre $ s /= L.empty- x <- liftQ $ bufferAndRun copyingConsume s- assert $ x == s---testTakeExactly1 :: Test-testTakeExactly1 = testProperty "iteratee/takeExactly1" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- expectException $ doIter >>= run_-- where- doIter = runIteratee consume >>=- runIteratee . joinI . takeExactly (n+1) >>=- return . enumLBS s-- n = fromIntegral $ L.length s---testTakeExactly2 :: Test-testTakeExactly2 = testProperty "iteratee/takeExactly2" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- e <- liftQ $ doIter >>= run_- assert $ L.fromChunks e == s-- where- doIter = runIteratee consume >>=- runIteratee . joinI . takeExactly n >>=- return . enumLBS s-- n = fromIntegral $ L.length s---testTakeExactly3 :: Test-testTakeExactly3 = testProperty "iteratee/takeExactly3" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- e <- liftQ $ doIter >>= run_- assert $ L.fromChunks e == L.take (fromIntegral n) s-- where- doIter = runIteratee consume >>=- runIteratee . joinI . takeExactly n >>=- return . enumLBS s-- n = fromIntegral $ L.length s---testTakeNoMoreThan1 :: Test-testTakeNoMoreThan1 = testProperty "iteratee/takeNoMoreThan1" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- s' <- liftQ $ doIter >>= run_-- assert $ s == L.fromChunks s'-- where- doIter = do- step <- runIteratee consume >>=- runIteratee . joinI . takeNoMoreThan (n+1)- return $ enumLBS s step-- n = fromIntegral $ L.length s---testTakeNoMoreThan2 :: Test-testTakeNoMoreThan2 = testProperty "iteratee/takeNoMoreThan2" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- e <- liftQ $ doIter >>= run_- assert $ L.fromChunks e == s-- where- doIter = do- step <- runIteratee consume- step' <- runIteratee (joinI (takeNoMoreThan n step))- return $ enumLBS (L.concat ["", s]) step'--- n = fromIntegral $ L.length s---testTakeNoMoreThan3 :: Test-testTakeNoMoreThan3 = testProperty "iteratee/takeNoMoreThan3" $- monadicIO $ forAllM arbitrary prop- where- prop :: (Int64,L.ByteString) -> PropertyM IO ()- prop (m,s) = do- step1 <- liftQ $ runIteratee consume- step2 <- liftQ $ runIteratee $ joinI (takeNoMoreThan 0 step1)- v <- liftQ $ run_ $ enumLBS "" step2- assert $ S.concat v == ""-- if (L.null s || m == 0)- then liftQ $ do- !_ <- doIter >>= run_- return ()- else expectException $ doIter >>= run_ >>= return--- where- doIter = do- step <- runIteratee consume- let i = joinI $ takeNoMoreThan (n-abs m) step- step' <- runIteratee i- return $ enumLBS s step'-- n = L.length s---testCountBytes :: Test-testCountBytes = testProperty "iteratee/countBytes" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,n1) <- liftQ (runIteratee (countBytes (return ())) >>= f)- (!_,n2) <- liftQ (runIteratee (countBytes consume) >>= f)-- assert $ n1 == 0- assert $ n2 == n-- expectException $ (runIteratee erriter >>= f)- expectException $ (runIteratee erriter >>= run_ . enumEOF)--- where- erriter = countBytes $ throwError $ AssertionFailed "foo"- f iter = run_ $ enumLBS s iter- n = L.length s----------------------------------------------------------------------------------testCountBytes2 :: Test-testCountBytes2 = testProperty "iteratee/countBytes2" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- pre $ L.length s > 4-- step <- liftQ $ runIteratee iter- (n1,s') <- f step-- assert $ n1 == 4- assert $ s' == L.drop 4 s-- where- f i = liftQ $ run_ $ enumLBS s i- iter = do- (!_,m) <- countBytes $ drop' 4- x <- liftM L.fromChunks consume- return (m,x)----------------------------------------------------------------------------------testBMHTrivials :: Test-testBMHTrivials = testCase "iteratee/BoyerMooreHorspoolTrivial" prop- where- prop = do- coverShowInstance $ Match ""- coverShowInstance $ NoMatch ""----------------------------------------------------------------------------------testBMH :: Test-testBMH = testProperty "iteratee/BoyerMooreHorspool" $- monadicIO $ forAllM arbitrary prop- where- prop :: (ByteString, [ByteString]) -> PropertyM IO ()- prop (needle', haystack') = do- let needle = B16.encode needle'- let haystack = Prelude.map B16.encode haystack'-- let lneedle = L.fromChunks [needle]- let lhaystack = L.fromChunks haystack-- pre ((not $ S.null needle) &&- (not $ L.null lhaystack) &&- (not $ S.isInfixOf needle (S.concat haystack)))-- -- put the needle at the beginning, at the end, and somewhere in the- -- middle-- lhay <- insertNeedle lneedle lhaystack- let stream = L.concat [lneedle, lhay]-- -- there should be exactly three Matches- let iter = enumLBS stream $$ joinI (bmhEnumeratee needle $$ consume)- outp <- QC.run $ run_ iter-- let nMatches = length $ filter isMatch outp-- when (nMatches /= 3) $ QC.run $ do- putStrLn "got wrong number of matches!!"- putStrLn "needle:\n"- putStrLn $ show lneedle- putStrLn "\nhaystack:\n"- mapM_ (putStrLn . show) (L.toChunks stream)- putStrLn "\noutput stream:"- mapM_ (putStrLn . show) outp- putStrLn ""-- assert $ nMatches == 3--- isMatch (Match _) = True- isMatch _ = False-- insertNeedle lneedle lhaystack = do- idxL <- pick $ choose (0, lenL-1)- idxN <- pick $ choose (0, lenN-1)- idxN2 <- pick $ choose (0, lenN-1)- let (l1, l2) = L.splitAt (toEnum idxL) lhaystack- let (n1, n2) = L.splitAt (toEnum idxN) lneedle- let (n3, n4) = L.splitAt (toEnum idxN2) lneedle-- return $ L.concat [ l1, n1, n2, l2, n3, n4 ]-- where- lenN = fromEnum $ L.length lneedle- lenL = fromEnum $ L.length lhaystack---------------------------------------------------------------------------------testKillIfTooSlow1 :: Test-testKillIfTooSlow1 = testCase "iteratee/killIfTooSlow1" $ do- let iter = killIfTooSlow (return ()) 1000 4 consume- m <- timeout (10*seconds) (expectExceptionH $ run_ $ tooSlowEnum 10 $$ iter)- maybe (fail "timed out without dying")- (const $ return ())- m----------------------------------------------------------------------------------testKillIfTooSlow2 :: Test-testKillIfTooSlow2 = testCase "iteratee/killIfTooSlow2" $ do- -- 10 bytes per second, minimum run 2 seconds- let iter = killIfTooSlow (return ()) 10 2 consume- m <- liftM S.concat $ run_ $ tooSlowEnum 3 $$ iter- H.assertEqual "testKillIfTooSlow2" (S.replicate 300 'f') m-----------------------------------------------------------------------------------testCatchIO :: Test-testCatchIO = testCase "iteratee/monadCatchIO" $ do- e <- run_ $ enumList 1 ["1", "2", "3", "4", "5"] $$ iter 0- H.assertBool "handled exception" $ isJust e-- where- iter !i = (continue $ k (i::Int)) `catch` h-- k _ EOF = return Nothing- k i _ = if i >= 2- then throw $ ErrorCall "should not escape!"- else iter (i+1)-- h :: SomeException -> Iteratee ByteString IO (Maybe String)- h e = return $ Just $ show e---------------------------------------------------------------------------------tooSlowEnum :: Int -> Enumerator ByteString IO a-tooSlowEnum ntimes (Continue k) = do- if ntimes <= 0- then k EOF- else do- step <- lift $ runIteratee $ k $ Chunks [S.replicate 100 'f']- liftIO $ waitabit- tooSlowEnum (ntimes-1) step-tooSlowEnum _ z = returnI z----------------------------------------------------------------------------------waitabit :: IO ()-waitabit = threadDelay $ 2*seconds---------------------------------------------------------------------------------seconds :: Int-seconds = (10::Int) ^ (6::Int)
− test/suite/Snap/Test/Common.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---module Snap.Test.Common- ( coverEqInstance- , coverOrdInstance- , coverReadInstance- , coverShowInstance- , coverTypeableInstance- , forceSameType- , expectException- , expectExceptionH- , liftQ- , eatException- ) where--import Control.DeepSeq-import Control.Exception (SomeException(..), evaluate)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w)-import Data.Typeable-import Prelude hiding (catch)-import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic---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----- | 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] ""---eatException :: (MonadCatchIO m) => m a -> m ()-eatException a = (a >> return ()) `catch` handler- where- handler :: (MonadCatchIO m) => SomeException -> m ()- handler _ = return ()---forceSameType :: a -> a -> a-forceSameType _ a = a---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 ()---expectException :: IO a -> PropertyM IO ()-expectException m = do- e <- liftQ $ try m- case e of- Left (z::SomeException) -> (length $ show z) `seq` return ()- Right _ -> fail "expected exception, didn't get one"---expectExceptionH :: IO a -> IO ()-expectExceptionH act = do- e <- try act- case e of- Left (z::SomeException) -> (length $ show z) `seq` return ()- Right _ -> fail "expected exception, didn't get one"---liftQ :: forall a m . (Monad m) => m a -> PropertyM m a-liftQ = QC.run
− test/suite/Snap/Util/FileServe/Tests.hs
@@ -1,565 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Util.FileServe.Tests- ( tests ) where--import Blaze.ByteString.Builder-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Prelude hiding (take)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import Snap.Internal.Http.Types-import Snap.Internal.Types-import Snap.Util.FileServe-import Snap.Iteratee-import qualified Snap.Types.Headers as H--tests :: [Test]-tests = [ testFooBin- , testFooTxt- , testFooHtml- , testFooBinBinBin- , test404s- , testFsSingle-- , testFsCfgA- , testFsCfgB- , testFsCfgC- , testFsCfgD- , testFsCfgFancy-- , testRangeOK- , testRangeBad- , testMultiRange- , testIfRange ]---expect404 :: IO Response -> IO ()-expect404 m = do- r <- m- assertBool "expected 404" (rspStatus r == 404)---expect302 :: ByteString -> IO Response -> IO ()-expect302 p m = do- r <- m- assertBool "expected 302" (rspStatus r == 302)- assertEqual "redir location"- (Just p)- (getHeader "location" r)---getBody :: Response -> IO L.ByteString-getBody r = do- let benum = rspBodyToEnum $ rspBody r- liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)---runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response)-runIt m rq = runSnap m d d rq- where- d = const $ return ()---go :: Snap a -> ByteString -> IO Response-go m s = do- rq <- mkRequest s- liftM snd (run_ $ runIt m rq)---goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response-goIfModifiedSince m s lm = do- rq <- mkRequest s- let r = setHeader "if-modified-since" lm rq- liftM snd (run_ $ runIt m r)---goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response-goIfRange m s (start,end) lm = do- rq <- mkRequest s- let r = setHeader "if-range" lm $- setHeader "Range"- (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)- rq- liftM snd (run_ $ runIt m r)---goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response-goRange m s (start,end) = do- rq' <- mkRequest s- let rq = setHeader "Range"- (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)- rq'- liftM snd (run_ $ runIt m rq)---goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response-goMultiRange m s (start,end) (start2,end2) = do- rq' <- mkRequest s- let rq = setHeader "Range"- (S.pack $ "bytes=" ++ show start ++ "-" ++ show end- ++ "," ++ show start2 ++ "-" ++ show end2)- rq'- liftM snd (run_ $ runIt m rq)---goRangePrefix :: Snap a -> ByteString -> Int -> IO Response-goRangePrefix m s start = do- rq' <- mkRequest s- let rq = setHeader "Range"- (S.pack $ "bytes=" ++ show start ++ "-")- rq'- liftM snd (run_ $ runIt m rq)---goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response-goRangeSuffix m s end = do- rq' <- mkRequest s- let rq = setHeader "Range"- (S.pack $ "bytes=-" ++ show end)- rq'- liftM snd (run_ $ runIt m rq)---mkRequest :: ByteString -> IO Request-mkRequest uri = do- enum <- newIORef $ SomeEnumerator returnI- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False H.empty- enum Nothing GET (1,1) [] "" pathPart "/"- (S.concat ["/",uri]) queryPart Map.empty-- where- (pathPart, queryPart) = breakQuery uri-- breakQuery s = (a, S.drop 1 b)- where- (a,b) = S.break (=='?') s---fs :: Snap ()-fs = do- x <- serveDirectory "data/fileServe"- return $! x `seq` ()---fsSingle :: Snap ()-fsSingle = do- x <- serveFile "data/fileServe/foo.html"- return $! x `seq` ()---fsCfg :: DirectoryConfig Snap -> Snap ()-fsCfg cfg = do- x <- serveDirectoryWith cfg "data/fileServe"- return $! x `seq` ()-----------------------------------------------------------------------------------testFooBin :: Test-testFooBin = testCase "fileServe/foo.bin" $ do- r1 <- go fs "foo.bin"- checkProps "fileServe/foo.bin/default" r1- let !lm = fromJust $ getHeader "last-modified" r1-- go fs "foo.bin?blah=blah" >>= checkProps "fileServe/foo.bin/query-string"-- -- check last modified stuff- r2 <- goIfModifiedSince fs "foo.bin" lm- assertEqual "foo.bin 304" 304 $ rspStatus r2-- r3 <- goIfModifiedSince fs "foo.bin" "Wed, 15 Nov 1995 04:58:08 GMT"- checkProps "fileServe/foo.bin/ifModifiedSince" r3-- where- checkProps name r = do- b <- getBody r-- assertEqual (name ++ "/contents") "FOO\n" b- assertEqual (name ++ "/content-type")- (Just "application/octet-stream")- (getHeader "content-type" r)-- assertEqual (name ++ "/size") (Just 4) (rspContentLength r)-- assertBool (name ++ "/last-modified")- (isJust $ getHeader "last-modified" r)-- assertEqual (name ++ "/accept-ranges")- (Just "bytes")- (getHeader "accept-ranges" r)----------------------------------------------------------------------------------testFooTxt :: Test-testFooTxt = testCase "fileServe/foo.txt" $ do- go fs "foo.txt" >>= checkProps "fileServe/foo.txt/default"- go fs "foo.txt?blah=blah" >>= checkProps "fileServe/foo.txt/query"-- where- checkProps name r = do- b <- getBody r-- assertEqual (name ++ "/contents") "FOO\n" b- assertEqual (name ++ "/content-type")- (Just "text/plain")- (getHeader "content-type" r)-- assertEqual (name ++ "/size") (Just 4) (rspContentLength r)-- assertBool (name ++ "/last-modified")- (isJust $ getHeader "last-modified" r)-- assertEqual (name ++ "/accept-ranges")- (Just "bytes")- (getHeader "accept-ranges" r)- - ---------------------------------------------------------------------------------testFooHtml :: Test-testFooHtml = testCase "fileServe/foo.html" $ do- go fs "foo.html" >>= checkProps "fileServe/foo.html/default"- go fs "foo.html?bar=bar" >>= checkProps "fileServe/foo.html/query"-- where- checkProps name r = do- b <- getBody r-- assertEqual (name ++ "/contents") "FOO\n" b- assertEqual (name ++ "/content-type")- (Just "text/html")- (getHeader "content-type" r)-- assertEqual (name ++ "/size") (Just 4) (rspContentLength r)-- assertBool (name ++ "/last-modified")- (isJust $ getHeader "last-modified" r)-- assertEqual (name ++ "/accept-ranges")- (Just "bytes")- (getHeader "accept-ranges" r)----------------------------------------------------------------------------------testFooBinBinBin :: Test-testFooBinBinBin = testCase "fileServe/foo.bin.bin.bin" $ do- go fs "foo.bin.bin.bin" >>= checkProps "fileServe/foo.bin.bin.bin"-- where- checkProps name r = do- b <- getBody r-- assertEqual (name ++ "/contents") "FOO\n" b- assertEqual (name ++ "/content-type")- (Just "application/octet-stream")- (getHeader "content-type" r)-- assertEqual (name ++ "/size") (Just 4) (rspContentLength r)-- assertBool (name ++ "/last-modified")- (isJust $ getHeader "last-modified" r)-- assertEqual (name ++ "/accept-ranges")- (Just "bytes")- (getHeader "accept-ranges" r)----------------------------------------------------------------------------------test404s :: Test-test404s = testCase "fileServe/404s" $ do- expect404 $ go fs "jfldksjflksd"- expect404 $ go fs "dummy/../foo.txt"- expect404 $ go fs "/etc/password"-- coverMimeMap----------------------------------------------------------------------------------printName :: FilePath -> Snap ()-printName c = writeBS $ snd $ S.breakEnd (=='/') $ S.pack c---cfgA, cfgB, cfgC, cfgD :: DirectoryConfig Snap-cfgA = DirectoryConfig {- indexFiles = []- , indexGenerator = const pass- , dynamicHandlers = Map.empty- , mimeTypes = defaultMimeTypes- , preServeHook = const $ return ()- }--cfgB = DirectoryConfig {- indexFiles = ["index.txt", "altindex.html"]- , indexGenerator = const pass- , dynamicHandlers = Map.empty- , mimeTypes = defaultMimeTypes- , preServeHook = const $ return ()- }--cfgC = DirectoryConfig {- indexFiles = ["index.txt", "altindex.html"]- , indexGenerator = printName- , dynamicHandlers = Map.empty- , mimeTypes = defaultMimeTypes- , preServeHook = const $ return ()- }--cfgD = DirectoryConfig {- indexFiles = []- , indexGenerator = const pass- , dynamicHandlers = Map.fromList [ (".txt", printName) ]- , mimeTypes = defaultMimeTypes- , preServeHook = const $ return ()- }---testFsCfgA :: Test-testFsCfgA = testCase "fileServe/cfgA" $ do- let gooo = go (fsCfg cfgA)-- -- Named file in the root directory- gooo "foo.bin" >>= checkProps "cfgA1/1" "application/octet-stream"- gooo "foo.bin?blah=blah" >>=- checkProps "cfgA1/2" "application/octet-stream"-- -- Missing file in the root directory- expect404 $ gooo "bar.bin"-- -- Named file in a subdirectory- gooo "mydir2/foo.txt" >>= checkProps "cfgA1/subdir/1" "text/plain" - gooo "mydir2/foo.txt?z=z" >>= checkProps "cfgA1/subdir/2" "text/plain"- - -- Missing file in a subdirectory- expect404 $ gooo "mydir2/bar.txt"-- -- Request for directory with no trailing slash- expect302 "/mydir1/" $ gooo "mydir1"-- -- Request for directory with no trailing slash, with query param- expect302 "/mydir1/?z=z" $ gooo "mydir1?z=z"-- -- Request for directory with trailing slash, no index- expect404 $ gooo "mydir1/"- expect404 $ gooo "mydir2/"-- -- Request file with trailing slash- expect404 $ gooo "foo.html/"- expect404 $ gooo "mydir2/foo.txt/"-- where- checkProps name ct r = do- b <- getBody r-- assertEqual (name ++ "/contents") "FOO\n" b- assertEqual (name ++ "/content-type")- (Just ct)- (getHeader "content-type" r)-- assertEqual (name ++ "/size") (Just 4) (rspContentLength r)-- assertBool (name ++ "/last-modified")- (isJust $ getHeader "last-modified" r)-- assertEqual (name ++ "/accept-ranges")- (Just "bytes")- (getHeader "accept-ranges" r)- -testFsCfgB :: Test-testFsCfgB = testCase "fileServe/cfgB" $ do- let gooo = go (fsCfg cfgB)-- -- Request for root directory with index- rB1 <- gooo "mydir1/"- bB1 <- getBody rB1-- assertEqual "B1" "INDEX\n" bB1- assertEqual "B1 content-type"- (Just "text/plain")- (getHeader "content-type" rB1)-- -- Request for root directory with index, query- rB2 <- gooo "mydir1/?z=z"- bB2 <- getBody rB2-- assertEqual "B2" "INDEX\n" bB2- assertEqual "B2 content-type"- (Just "text/plain")- (getHeader "content-type" rB2)--- -- Request for root directory with alternate index- rB3 <- gooo "mydir3/"- bB3 <- getBody rB3-- assertEqual "B3" "ALTINDEX\n" bB3- assertEqual "B3 content-type"- (Just "text/html")- (getHeader "content-type" rB3)-- -- Request for root directory with no index- expect404 $ gooo "mydir2/"---testFsCfgC :: Test-testFsCfgC = testCase "fileServe/cfgC" $ do- let gooo = go (fsCfg cfgC)-- -- Request for root directory with index- rC1 <- gooo "mydir1/"- bC1 <- getBody rC1-- assertEqual "C1" "INDEX\n" bC1- assertEqual "C1 content-type"- (Just "text/plain")- (getHeader "content-type" rC1)-- -- Request for root directory with index, query- rC2 <- gooo "mydir1/?z=z"- bC2 <- getBody rC2-- assertEqual "C2" "INDEX\n" bC2- assertEqual "C2 content-type"- (Just "text/plain")- (getHeader "content-type" rC2)-- -- Request for root directory with generated index- rC3 <- gooo "mydir2/"- bC3 <- getBody rC3-- assertEqual "C3" "mydir2" bC3---testFsCfgD :: Test-testFsCfgD = testCase "fileServe/cfgD" $ do- -- Request for file with dynamic handler- rD1 <- go (fsCfg cfgD) "mydir2/foo.txt"- bD1 <- getBody rD1-- assertEqual "D1" "foo.txt" bD1---testFsCfgFancy :: Test-testFsCfgFancy = testCase "fileServe/cfgFancy" $ do- -- Request for directory with autogen index- rE1 <- go (fsCfg fancyDirectoryConfig) "mydir2/"- bE1 <- S.concat `fmap` L.toChunks `fmap` getBody rE1-- assertBool "autogen-sub-index" $- "Directory Listing: /mydir2/" `S.isInfixOf` bE1- assertBool "autogen-sub-parent" $- "<a href='../'" `S.isInfixOf` bE1- assertBool "autogen-sub-file" $- "<a href='foo.txt'" `S.isInfixOf` bE1--- -- Request for directory with autogen index- rE2 <- go (fsCfg fancyDirectoryConfig) "mydir2/?z=z"- bE2 <- S.concat `fmap` L.toChunks `fmap` getBody rE2-- assertBool "autogen-sub-index" $- "Directory Listing: /mydir2/" `S.isInfixOf` bE2- assertBool "autogen-sub-parent" $- "<a href='../'" `S.isInfixOf` bE2- assertBool "autogen-sub-file" $- "<a href='foo.txt'" `S.isInfixOf` bE2----testFsSingle :: Test-testFsSingle = testCase "fileServe/Single" $ do- r1 <- go fsSingle "foo.html"- b1 <- getBody r1-- assertEqual "foo.html" "FOO\n" b1- assertEqual "foo.html content-type"- (Just "text/html")- (getHeader "content-type" r1)-- assertEqual "foo.html size" (Just 4) (rspContentLength r1)----testRangeOK :: Test-testRangeOK = testCase "fileServe/range/ok" $ do- r1 <- goRange fsSingle "foo.html" (1,2)- assertEqual "foo.html 206" 206 $ rspStatus r1- b1 <- getBody r1-- assertEqual "foo.html partial" "OO" b1- assertEqual "foo.html partial size" (Just 2) (rspContentLength r1)- assertEqual "foo.html content-range"- (Just "bytes 1-2/4")- (getHeader "Content-Range" r1)-- r2 <- goRangeSuffix fsSingle "foo.html" 3- assertEqual "foo.html 206" 206 $ rspStatus r2- b2 <- getBody r2- assertEqual "foo.html partial suffix" "OO\n" b2-- r3 <- goRangePrefix fsSingle "foo.html" 2- assertEqual "foo.html 206" 206 $ rspStatus r3- b3 <- getBody r3- assertEqual "foo.html partial prefix" "O\n" b3---testMultiRange :: Test-testMultiRange = testCase "fileServe/range/multi" $ do- r1 <- goMultiRange fsSingle "foo.html" (1,2) (3,3)-- -- we don't support multiple ranges so it's ok for us to return 200 here;- -- test this behaviour- assertEqual "foo.html 200" 200 $ rspStatus r1- b1 <- getBody r1-- assertEqual "foo.html" "FOO\n" b1---testRangeBad :: Test-testRangeBad = testCase "fileServe/range/bad" $ do- r1 <- goRange fsSingle "foo.html" (1,17)- assertEqual "bad range" 416 (rspStatus r1)- assertEqual "bad range content-range"- (Just "bytes */4")- (getHeader "Content-Range" r1)- assertEqual "bad range content-length" (Just 0) (rspContentLength r1)- b1 <- getBody r1- assertEqual "bad range empty body" "" b1-- r2 <- goRangeSuffix fsSingle "foo.html" 4893- assertEqual "bad suffix range" 416 $ rspStatus r2---coverMimeMap :: (Monad m) => m ()-coverMimeMap = Prelude.mapM_ f $ Map.toList defaultMimeTypes- where- f (!k,!v) = return $ case k `seq` v `seq` () of () -> ()---testIfRange :: Test-testIfRange = testCase "fileServe/range/if-range" $ do- r <- goIfRange fs "foo.bin" (1,2) "Wed, 15 Nov 1995 04:58:08 GMT"- assertEqual "foo.bin 200" 200 $ rspStatus r- b <- getBody r- assertEqual "foo.bin" "FOO\n" b-- r2 <- goIfRange fs "foo.bin" (1,2) "Tue, 01 Oct 2030 04:58:08 GMT"- assertEqual "foo.bin 206" 206 $ rspStatus r2- b2 <- getBody r2- assertEqual "foo.bin partial" "OO" b2-- r3 <- goIfRange fs "foo.bin" (1,24324) "Tue, 01 Oct 2030 04:58:08 GMT"- assertEqual "foo.bin 200" 200 $ rspStatus r3- b3 <- getBody r3- assertEqual "foo.bin" "FOO\n" b3
− test/suite/Snap/Util/FileUploads/Tests.hs
@@ -1,601 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Util.FileUploads.Tests- ( tests ) where---------------------------------------------------------------------------------import Control.Applicative-import Control.Concurrent (threadDelay)-import Control.DeepSeq-import Control.Exception (Exception(..), SomeException(..))-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe-import qualified Data.Text as T-import Data.Typeable-import Prelude hiding (catch)-import System.Directory-import System.Mem-import System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--------------------------------------------------------------------------------import Snap.Internal.Http.Types-import Snap.Internal.Debug-import Snap.Internal.Iteratee.Debug-import Snap.Internal.Types-import Snap.Iteratee hiding (map)-import qualified Snap.Types.Headers as H-import Snap.Test.Common-import Snap.Util.FileUploads----------------------------------------------------------------------------------data TestException = TestException- deriving (Show, Typeable)--instance Exception TestException---------------------------------------------------------------------------------tests :: [Test]-tests = [ testSuccess1- , testSuccess2- , testPerPartPolicyViolation1- , testPerPartPolicyViolation2- , testFormInputPolicyViolation- , testTooManyHeaders- , testNoBoundary- , testNoMixedBoundary- , testWrongContentType- , testSlowEnumerator- , testTrivials- , testDisconnectionCleanup- ]----------------------------------------------------------------------------------testSuccess1 :: Test-testSuccess1 = testCase "fileUploads/success1" $- harness tmpdir hndl mixedTestBody-- where- tmpdir = "tempdir1"-- hndl = handleFileUploads tmpdir- defaultUploadPolicy- (const $ allowWithMaximumSize 300000)- hndl'-- hndl' xs = do- fileMap <- foldM f Map.empty xs-- p1 <- getParam "field1"- p2 <- getParam "field2"-- liftIO $ do- assertEqual "file1 contents"- (Just ("text/plain", file1Contents))- (Map.lookup "file1.txt" fileMap)-- assertEqual "file2 contents"- (Just ("image/gif", file2Contents))- (Map.lookup "file2.gif" fileMap)-- assertEqual "field1 contents"- (Just formContents1)- p1-- assertEqual "field2 contents"- (Just formContents2)- p2---- f mp (partInfo, e) =- either throw- (\fp -> do- x <- liftIO $ S.readFile fp- let fn = fromJust $ partFileName partInfo- let ct = partContentType partInfo- return $ Map.insert fn (ct,x) mp)- e----------------------------------------------------------------------------------testSuccess2 :: Test-testSuccess2 = testCase "fileUploads/success2" $- harness tmpdir hndl mixedTestBody-- where- tmpdir = "tempdir2"-- policy = setProcessFormInputs False defaultUploadPolicy-- hndl = handleFileUploads tmpdir- policy- (const $ allowWithMaximumSize 300000)- hndl'-- hndl' xs = do- liftIO $ assertEqual "num params" 4 (length xs)- show xs `deepseq` return ()----------------------------------------------------------------------------------testPerPartPolicyViolation1 :: Test-testPerPartPolicyViolation1 = testCase "fileUploads/perPartPolicyViolation1" $- harness tmpdir hndl mixedTestBody- where- tmpdir = "tempdir_pol1"-- hndl = handleFileUploads tmpdir defaultUploadPolicy- (const disallow)- hndl'-- hndl' xs = do- p1 <- getParam "field1"- p2 <- getParam "field2"-- mapM_ f xs-- liftIO $ do- assertEqual "field1 contents"- (Just formContents1)- p1-- assertEqual "field2 contents"- (Just formContents2)- p2-- f (!_, e) = either (\i -> show i `deepseq` return ())- (const $ error "expected policy violation")- e----------------------------------------------------------------------------------testPerPartPolicyViolation2 :: Test-testPerPartPolicyViolation2 = testCase "fileUploads/perPartPolicyViolation2" $- harness tmpdir hndl mixedTestBody- where- tmpdir = "tempdir_pol2"-- hndl = handleFileUploads tmpdir defaultUploadPolicy- (const $ allowWithMaximumSize 4)- hndl'-- hndl' xs = mapM_ f xs-- f (partInfo, e) = (if partFileName partInfo == Just "file1.txt"- then ePass- else eFail) e-- eFail = either (\i -> show i `deepseq` return ())- (const $ error "expected policy violation")-- ePass = either (throw)- (\i -> show i `deepseq` return ())-----------------------------------------------------------------------------------testFormInputPolicyViolation :: Test-testFormInputPolicyViolation = testCase "fileUploads/formInputTooBig" $- (harness tmpdir hndl mixedTestBody `catch` h)- where- h !(e :: FileUploadException) = do- let r = fileUploadExceptionReason e- assertBool "correct exception"- (T.isInfixOf "form input" r &&- T.isInfixOf "exceeded maximum" r)-- tmpdir = "tempdir_formpol"-- policy = setMaximumFormInputSize 2 defaultUploadPolicy-- hndl = handleFileUploads tmpdir policy- (const $ allowWithMaximumSize 4)- hndl'-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testNoBoundary :: Test-testNoBoundary = testCase "fileUploads/noBoundary" $- expectExceptionH $- harness' goBadContentType tmpdir hndl mixedTestBody- where- tmpdir = "tempdir_noboundary"-- hndl = handleFileUploads tmpdir- defaultUploadPolicy- (const $ allowWithMaximumSize 300000)- hndl'-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testNoMixedBoundary :: Test-testNoMixedBoundary = testCase "fileUploads/noMixedBoundary" $- expectExceptionH $- harness' go tmpdir hndl badMixedBody- where- tmpdir = "tempdir_mixednoboundary"-- hndl = handleFileUploads tmpdir- defaultUploadPolicy- (const $ allowWithMaximumSize 300000)- hndl'-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testWrongContentType :: Test-testWrongContentType = testCase "fileUploads/wrongContentType" $- expectExceptionH $- harness' goWrongContentType tmpdir hndl mixedTestBody- where- tmpdir = "tempdir_noboundary"-- hndl = handleFileUploads tmpdir- defaultUploadPolicy- (const $ allowWithMaximumSize 300000)- hndl'- <|> error "expect fail here"-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testTooManyHeaders :: Test-testTooManyHeaders = testCase "fileUploads/tooManyHeaders" $- (harness tmpdir hndl bigHeadersBody `catch` h)- where- h (e :: BadPartException) = show e `deepseq` return ()-- tmpdir = "tempdir_tooManyHeaders"-- hndl = handleFileUploads tmpdir defaultUploadPolicy- (const $ allowWithMaximumSize 4)- hndl'-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testSlowEnumerator :: Test-testSlowEnumerator = testCase "fileUploads/tooSlow" $- (harness' goSlowEnumerator tmpdir hndl mixedTestBody- `catch` h0)- where- h0 (e :: ConnectionTerminatedException) =- let (ConnectionTerminatedException se) = e- (me :: Maybe RateTooSlowException) = fromException se- in maybe (throw e) h me-- h (e :: RateTooSlowException) = e `seq` return ()-- tmpdir = "tempdir_tooslow"-- policy = setMinimumUploadRate 200000 $- setMinimumUploadSeconds 2 $- defaultUploadPolicy-- hndl = handleFileUploads tmpdir policy- (const $ allowWithMaximumSize 400000)- hndl'-- hndl' xs = show xs `deepseq` return ()----------------------------------------------------------------------------------testTrivials :: Test-testTrivials = testCase "fileUploads/trivials" $ do- assertEqual "" False $ doProcessFormInputs policy- assertEqual "" 1000 $ getMinimumUploadRate policy- assertEqual "" 1000 $ getMinimumUploadRate defaultUploadPolicy- assertEqual "" 5 $ getMinimumUploadSeconds policy- assertEqual "" 9 $ getUploadTimeout policy-- where- policy = setProcessFormInputs False $- setMinimumUploadRate 1000 $- setMinimumUploadSeconds 5 $- setUploadTimeout 9 $- defaultUploadPolicy----------------------------------------------------------------------------------testDisconnectionCleanup :: Test-testDisconnectionCleanup = testCase "fileUploads/disconnectionCleanup" $ do- runTest `finally` removeDirectoryRecursive tmpdir- where- runTest = do- eatException $ removeDirectoryRecursive tmpdir- createDirectoryIfMissing True tmpdir- rq <- mkDamagedRequest mixedTestBody- eatException $ liftM snd (run_ $ runIt hndl rq)- performGC- dirs <- liftM (filter (\x -> x /= "." && x /= "..")) $- getDirectoryContents tmpdir- assertEqual "files should be cleaned up" [] dirs- -- tmpdir = "tempdirC"- hndl = handleFileUploads tmpdir- defaultUploadPolicy- (const $ allowWithMaximumSize 300000)- hndl'-- hndl' _ = return ()- ---------------------------------------------------------------------------------harness :: FilePath -> Snap a -> ByteString -> IO ()-harness = harness' go----------------------------------------------------------------------------------harness' :: (Snap a -> ByteString -> IO Response)- -> FilePath- -> Snap a- -> ByteString- -> IO ()-harness' g tmpdir hndl body = (do- createDirectoryIfMissing True tmpdir- g hndl body- return ()) `finally` removeDirectoryRecursive tmpdir----------------------------------------------------------------------------------mkRequest :: ByteString -> IO Request-mkRequest body = do- enum <- newIORef $ SomeEnumerator $ enumBS body-- let hdrs = H.fromList [- ("Content-type", S.append "multipart/form-data; boundary="- boundaryValue)- ]-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs- enum Nothing POST (1,1) [] "" "/" "/"- "/" "" Map.empty----------------------------------------------------------------------------------mkDamagedRequest :: ByteString -> IO Request-mkDamagedRequest body = do- enum <- newIORef $ SomeEnumerator $ enum-- let hdrs = H.fromList [- ("Content-type", S.append "multipart/form-data; boundary="- boundaryValue)- ]-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False hdrs- enum Nothing POST (1,1) [] "" "/" "/"- "/" "" Map.empty- where- enum = enumBS (S.take (S.length body - 1) body) >==> dieNow- dieNow _ = throw TestException----------------------------------------------------------------------------------go :: Snap a -> ByteString -> IO Response-go m s = do- rq <- mkRequest s- liftM snd (run_ $ runIt m rq)----------------------------------------------------------------------------------goBadContentType :: Snap a -> ByteString -> IO Response-goBadContentType m s = do- rq <- mkRequest s- let rq' = setHeader "Content-Type" "multipart/form-data" rq- liftM snd (run_ $ runIt m rq')----------------------------------------------------------------------------------goWrongContentType :: Snap a -> ByteString -> IO Response-goWrongContentType m s = do- rq <- mkRequest s- let rq' = setHeader "Content-Type" "text/plain" rq- liftM snd (run_ $ runIt m rq')---------------------------------------------------------------------------------goSlowEnumerator :: Snap a -> ByteString -> IO Response-goSlowEnumerator m s = do- rq <- mkRequest s- writeIORef (rqBody rq) $ SomeEnumerator slowEnum- mx <- timeout (20*seconds) (liftM snd (run_ $ runIt m rq))- maybe (error "timeout") return mx-- where- body = S.unpack s-- slowEnum x = goo x body-- goo (Continue k) [] = k EOF- goo (Continue k) (x:xs) = do- debug $ "goSlowEnumerator: sending " ++ show x- step <- lift $ runIteratee $ k $ Chunks [ S.pack (x:[]) ]- liftIO waitabit- goo step xs- goo (Error e) _ = throwError e- goo _ _ = error "impossible"----------------------------------------------------------------------------------waitabit :: IO ()-waitabit = threadDelay $ 2*seconds---------------------------------------------------------------------------------seconds :: Int-seconds = (10::Int) ^ (6::Int)----------------------------------------------------------------------------------runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response)-runIt m rq = iterateeDebugWrapper "test" $ runSnap m d d rq- where- d :: forall a . Show a => a -> IO ()- d = \x -> show x `deepseq` return ()------------------------------------------------------------------------------------ TEST DATA--formContents1 :: ByteString-formContents1 = "form contents 1"--formContents2 :: ByteString-formContents2 = "form contents 2 zzzzzzzzzzzzzzzzzzzz"--file1Contents :: ByteString-file1Contents = "foo"--file2Contents :: ByteString-file2Contents = "... contents of file2.gif ..."--boundaryValue :: ByteString-boundaryValue = "fkjldsakjfdlsafldksjf"--subBoundaryValue :: ByteString-subBoundaryValue = "zjkzjjfjskzjzjkz"--crlf :: ByteString-crlf = "\r\n"----------------------------------------------------------------------------------mixedTestBody :: ByteString-mixedTestBody =- S.concat- [ "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"field1\"\r\n"- , crlf- , formContents1- , crlf- , "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"field2\"\r\n"- , crlf- , formContents2- , crlf- , "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"files\"\r\n"- , "Content-type: multipart/mixed; boundary="- , subBoundaryValue- , crlf- , crlf- , "--"- , subBoundaryValue- , crlf- , "Content-disposition: attachment; filename=\"file1.txt\"\r\n"- , "Content-Type: text/plain\r\n"- , crlf- , file1Contents- , crlf- , "--"- , subBoundaryValue- , crlf- , "Content-disposition: attachment; filename=\"file2.gif\"\r\n"- , "Content-type: image/gif\r\n"- , "Content-Transfer-Encoding: binary\r\n"- , crlf- , file2Contents- , crlf- , "--"- , subBoundaryValue- , "--\r\n"- , "--"- , boundaryValue- , "--\r\n"- ]----------------------------------------------------------------------------------badMixedBody :: ByteString-badMixedBody =- S.concat- [ "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"field1\"\r\n"- , crlf- , formContents1- , crlf- , "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"field2\"\r\n"- , crlf- , formContents2- , crlf- , "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"files\"\r\n"- , "Content-type: multipart/mixed"- , crlf- , crlf- , "--"- , subBoundaryValue- , crlf- , "Content-disposition: attachment; filename=\"file1.txt\"\r\n"- , "Content-Type: text/plain\r\n"- , crlf- , file1Contents- , crlf- , "--"- , subBoundaryValue- , crlf- , "Content-disposition: attachment; filename=\"file2.gif\"\r\n"- , "Content-type: image/gif\r\n"- , "Content-Transfer-Encoding: binary\r\n"- , crlf- , file2Contents- , crlf- , "--"- , subBoundaryValue- , "--\r\n"- , "--"- , boundaryValue- , "--\r\n"- ]----------------------------------------------------------------------------------bigHeadersBody :: ByteString-bigHeadersBody =- S.concat (- [ "--"- , boundaryValue- , crlf- , "content-disposition: form-data; name=\"field1\"\r\n" ]- ++- map (\i -> S.pack ("field_" ++ show i ++ ": bar\r\n")) [1..40000::Int]- ++- [ crlf- , formContents1- , crlf- , "--"- , boundaryValue- , "--\r\n"- ])
− test/suite/Snap/Util/GZip/Tests.hs
@@ -1,426 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Util.GZip.Tests- ( tests ) where--import Blaze.ByteString.Builder-import qualified Codec.Compression.GZip as GZip-import qualified Codec.Compression.Zlib as Zlib-import Control.Exception hiding (assert)-import Control.Monad (liftM)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Digest.Pure.MD5-import Data.IORef-import qualified Data.Map as Map-import Data.Monoid-import Data.Serialize (encode)-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Monadic hiding (run)-import Test.Framework.Providers.HUnit-import qualified Test.HUnit as H--import Snap.Core-import Snap.Internal.Http.Types-import Snap.Iteratee-import Snap.Test.Common ()-import Snap.Util.GZip-import qualified Snap.Types.Headers as H---stream2stream- :: Iteratee Builder IO L.ByteString-stream2stream = liftM (toLazyByteString . mconcat) consume---------------------------------------------------------------------------------tests :: [Test]-tests = [ testIdentity1- , testIdentity1_charset- , testIdentity2- , testIdentity3- , testIdentity4- , testIdentity5- , testNoHeaders- , testNoAcceptEncoding- , testNopWhenContentEncodingSet- , testCompositionDoesn'tExplode- , testGzipLotsaChunks- , testNoCompression- , testBadHeaders ]----------------------------------------------------------------------------------expectException :: IO a -> PropertyM IO ()-expectException m = do- e <- liftQ $ try m- case e of- Left (z::SomeException) -> (show z) `seq` return ()- Right _ -> fail "expected exception, didn't get one"----------------------------------------------------------------------------------liftQ :: forall a m . (Monad m) => m a -> PropertyM m a-liftQ = QC.run----------------------------------------------------------------------------------gzipHdrs, xGzipHdrs, badHdrs, compressHdrs, xCompressHdrs, emptyHdrs :: Headers-emptyHdrs = H.empty-gzipHdrs = setHeader "Accept-Encoding" "froz,gzip, x-gzip" emptyHdrs-xGzipHdrs = setHeader "Accept-Encoding" "x-gzip;q=1.0" emptyHdrs-badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs-compressHdrs = setHeader "Accept-Encoding" "compress" emptyHdrs-xCompressHdrs = setHeader "Accept-Encoding" "x-compress" emptyHdrs-----------------------------------------------------------------------------------mkNoHeaders :: IO Request-mkNoHeaders = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False emptyHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty---mkGzipRq :: IO Request-mkGzipRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False gzipHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty--mkXGzipRq :: IO Request-mkXGzipRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xGzipHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty-----------------------------------------------------------------------------------mkCompressRq :: IO Request-mkCompressRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty--mkXCompressRq :: IO Request-mkXCompressRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xCompressHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty-----------------------------------------------------------------------------------mkBadRq :: IO Request-mkBadRq = do- enum <- newIORef $ SomeEnumerator returnI-- return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False badHdrs- enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty---------------------------------------------------------------------------------seqSnap :: Snap a -> Snap a-seqSnap m = do- !x <- m- return $! x `seq` x----------------------------------------------------------------------------------goGeneric :: IO Request -> Snap a -> IO (Request, Response)-goGeneric mkRq m = do- rq <- mkRq- run_ $! runSnap (seqSnap m) d d rq- where- d = (const $ return ())---goGZip, goCompress, goXGZip :: Snap a -> IO (Request,Response)-goNoHeaders, goXCompress, goBad :: Snap a -> IO (Request,Response)--goGZip = goGeneric mkGzipRq-goCompress = goGeneric mkCompressRq-goXGZip = goGeneric mkXGzipRq-goXCompress = goGeneric mkXCompressRq-goBad = goGeneric mkBadRq-goNoHeaders = goGeneric mkNoHeaders---------------------------------------------------------------------------------noContentType :: L.ByteString -> Snap ()-noContentType s = modifyResponse $ setResponseBody $- enumBuilder $ fromLazyByteString s---------------------------------------------------------------------------------withContentType :: ByteString -> L.ByteString -> Snap ()-withContentType ct body =- modifyResponse $- setResponseBody (enumBuilder $ fromLazyByteString body) .- setContentType ct---------------------------------------------------------------------------------textPlain :: L.ByteString -> Snap ()-textPlain = withContentType "text/plain"----------------------------------------------------------------------------------binary :: L.ByteString -> Snap ()-binary = withContentType "application/octet-stream"----------------------------------------------------------------------------------testNoHeaders :: Test-testNoHeaders = testProperty "gzip/noheaders" $- monadicIO $- forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- -- if there's no content-type, withCompression should be a no-op- (!_,!rsp) <- liftQ $ goNoHeaders (seqSnap $ withCompression- $ noContentType s)- assert $ getHeader "Content-Encoding" rsp == Nothing- assert $ getHeader "Vary" rsp == Nothing- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- assert $ s == c----------------------------------------------------------------------------------testNoAcceptEncoding :: Test-testNoAcceptEncoding = testProperty "gzip/noAcceptEncoding" $- monadicIO $- forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- -- if there's no accept-encoding, withCompression should be a no-op- (!_,!rsp) <- liftQ $ goNoHeaders (seqSnap $ withCompression- $ textPlain s)- assert $ getHeader "Content-Encoding" rsp == Nothing- assert $ getHeader "Vary" rsp == Nothing- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- assert $ s == c----------------------------------------------------------------------------------testIdentity1 :: Test-testIdentity1 = testProperty "gzip/identity1" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $ textPlain s)- assert $ getHeader "Content-Encoding" rsp == Just "gzip"- assert $ getHeader "Vary" rsp == Just "Accept-Encoding"- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- let s1 = GZip.decompress c- assert $ s == s1----------------------------------------------------------------------------------testIdentity1_charset :: Test-testIdentity1_charset = testProperty "gzip/identity1_charset" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $- goGZip (seqSnap $ withCompression $- withContentType "text/plain; charset=utf-8" s)- assert $ getHeader "Content-Encoding" rsp == Just "gzip"- assert $ getHeader "Vary" rsp == Just "Accept-Encoding"- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- let s1 = GZip.decompress c- assert $ s == s1----------------------------------------------------------------------------------testIdentity2 :: Test-testIdentity2 = testProperty "gzip/identity2" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goCompress (seqSnap $ withCompression $ textPlain s)-- assert $ getHeader "Content-Encoding" rsp == Just "compress"- assert $ getHeader "Vary" rsp == Just "Accept-Encoding"- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- let s' = Zlib.decompress c- assert $ s == s'----------------------------------------------------------------------------------testIdentity3 :: Test-testIdentity3 = testProperty "gzip/identity3" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp3) <- liftQ $ goGZip (seqSnap $ withCompression $ binary s)- let body3 = rspBodyToEnum $ rspBody rsp3-- s3 <- liftQ $- runIteratee stream2stream >>= run_ . body3-- assert $ s == s3----------------------------------------------------------------------------------testIdentity4 :: Test-testIdentity4 = testProperty "gzip/identity4" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goXGZip (seqSnap $ withCompression $ textPlain s)- assert $ getHeader "Content-Encoding" rsp == Just "x-gzip"- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- let s1 = GZip.decompress c- assert $ s == s1----------------------------------------------------------------------------------testIdentity5 :: Test-testIdentity5 = testProperty "gzip/identity5" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp2) <- liftQ $ goXCompress (seqSnap $ withCompression $ textPlain s)-- assert $ getHeader "Content-Encoding" rsp2 == Just "x-compress"- let body2 = rspBodyToEnum $ rspBody rsp2-- c2 <- liftQ $- runIteratee stream2stream >>= run_ . body2-- let s2 = Zlib.decompress c2- assert $ s == s2----------------------------------------------------------------------------------testBadHeaders :: Test-testBadHeaders = testProperty "gzip/bad headers" $ monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = expectException $ do- (!_,!rsp) <- goBad (seqSnap $ withCompression $ textPlain s)- let body = rspBodyToEnum $ rspBody rsp-- runIteratee stream2stream >>= run_ . body----------------------------------------------------------------------------------testNopWhenContentEncodingSet :: Test-testNopWhenContentEncodingSet =- testProperty "gzip/testNopWhenContentEncodingSet" $- monadicIO $- forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goGZip $ f s- assert $ getHeader "Content-Encoding" rsp == Just "identity"-- f !s = seqSnap $ withCompression $ do- modifyResponse $ setHeader "Content-Encoding" "identity"- textPlain s----------------------------------------------------------------------------------testCompositionDoesn'tExplode :: Test-testCompositionDoesn'tExplode =- testProperty "gzip/testCompositionDoesn'tExplode" $- monadicIO $- forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goGZip (seqSnap $- withCompression $- withCompression $- withCompression $ textPlain s)-- assert $ getHeader "Content-Encoding" rsp == Just "gzip"-- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- runIteratee stream2stream >>= run_ . body-- let s1 = GZip.decompress c- assert $ s == s1----------------------------------------------------------------------------------testGzipLotsaChunks :: Test-testGzipLotsaChunks = testCase "gzip/lotsOfChunks" prop- where- prop = do- let s = L.take 120000 $ L.fromChunks $ frobnicate "dshflkahdflkdhsaflk"- (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlain s)- let body = rspBodyToEnum $ rspBody rsp-- c <- runIteratee stream2stream >>= run_ . body-- let s1 = GZip.decompress c- H.assertBool "streams equal" $ s == s1-- - -- in order to get incompressible text (so that we can test whether the- -- gzip thread is streaming properly!) we'll iteratively md5 the source- -- string- frobnicate s = let s' = encode $ md5 $ L.fromChunks [s]- in (s:frobnicate s')----------------------------------------------------------------------------------testNoCompression :: Test-testNoCompression = testProperty "gzip/noCompression" $- monadicIO $ forAllM arbitrary prop- where- prop :: L.ByteString -> PropertyM IO ()- prop s = do- (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $- (noCompression >> textPlain s))- assert $ getHeader "Content-Encoding" rsp == Just "identity"- let body = rspBodyToEnum $ rspBody rsp-- s1 <- liftQ $- runIteratee stream2stream >>= run_ . body-- assert $ s == s1----
− test/suite/TestSuite.hs
@@ -1,37 +0,0 @@-module Main where--import Test.Framework (defaultMain, testGroup)--import qualified Snap.Core.Tests-import qualified Snap.Internal.Http.Types.Tests-import qualified Snap.Internal.Parsing.Tests-import qualified Snap.Internal.Routing.Tests-import qualified Snap.Iteratee.Tests-import qualified Snap.Util.FileServe.Tests-import qualified Snap.Util.FileUploads.Tests-import qualified Snap.Util.GZip.Tests-import qualified Snap.Test.Tests---main :: IO ()-main = defaultMain tests- where tests = [- testGroup "Snap.Internal.Http.Types.Tests"- Snap.Internal.Http.Types.Tests.tests- , testGroup "Snap.Internal.Routing.Tests"- Snap.Internal.Routing.Tests.tests- , testGroup "Snap.Core.Tests"- Snap.Core.Tests.tests- , testGroup "Snap.Iteratee.Tests"- Snap.Iteratee.Tests.tests- , testGroup "Snap.Internal.Parsing.Tests"- Snap.Internal.Parsing.Tests.tests- , testGroup "Snap.Util.GZip.Tests"- Snap.Util.GZip.Tests.tests- , testGroup "Snap.Util.FileServe.Tests"- Snap.Util.FileServe.Tests.tests- , testGroup "Snap.Util.FileUploads.Tests"- Snap.Util.FileUploads.Tests.tests- , testGroup "Snap.Test.Tests"- Snap.Test.Tests.tests- ]