snap-core-1.0.0.0/0000755000000000000000000000000012751762146011736 5ustar0000000000000000snap-core-1.0.0.0/CONTRIBUTORS0000644000000000000000000000062712751762146013623 0ustar0000000000000000Doug Beardsley Gregory Collins Shu-yu Guo Carl Howells Shane O'Brien James Sanders Jacob Stanley Jonas Kramer Jurriën Stutterheim Jasper Van der Jeugt Bryan O'Sullivan snap-core-1.0.0.0/haddock.sh0000755000000000000000000000044612751762146013676 0ustar0000000000000000#!/bin/sh set -x rm -Rf dist/doc HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' cabal haddock $HADDOCK_OPTS --hyperlink-source $@ cp extra/logo.gif dist/doc/html/snap-core/haskell_icon.gif cp extra/hscolour.css dist/doc/html/snap-core/src/ snap-core-1.0.0.0/LICENSE0000644000000000000000000000300612751762146012742 0ustar0000000000000000Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) Copyright (c) 2010, Google, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the Snap Framework authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. snap-core-1.0.0.0/README.md0000644000000000000000000000343712751762146013224 0ustar0000000000000000Snap Framework Core =================== [![Build Status](https://travis-ci.org/snapframework/snap-core.svg?branch=master)](https://travis-ci.org/snapframework/snap-core) 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: * primitive types and functions for HTTP (requests, responses, cookies, post/query parameters, etc). * a "Snap" monad interface for programming web handlers, which allows: * stateful access to the HTTP request and response objects. * monadic failure (i.e. MonadPlus/Alternative instances) for declining to handle requests and chaining handlers together. * early termination of the computation if you know early what you want to return and want to prevent further monadic processing. * useful utilities for web handlers, like file serving and gzip/zlib compression. Building snap-core =================== The snap-core library is built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run cabal install from the `snap-core` toplevel directory. ## Building the Haddock Documentation The haddock documentation can be built using the supplied `haddock.sh` shell script: ./haddock.sh The docs get put in `dist/doc/html/`. ## Building the testsuite Snap aims for 100% test coverage, and we're trying hard to stick to that. To build the test suite, configure with --enable-tests: $ cabal configure --enable-tests $ cabal build From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh The testsuite generates an `hpc` test coverage report in `dist/hpc`. snap-core-1.0.0.0/README.SNAP.md0000644000000000000000000000213612751762146013757 0ustar0000000000000000Snap Framework -------------- Snap is a simple and fast web development framework and server written in Haskell. For more information or to download the latest version, you can visit the Snap project website at http://snapframework.com/. Snap Status and Features ------------------------ The Snap core system consists of: * a sensible and clean monad for web programming * a high-speed HTTP server called "snap-server" * an xml-based templating system called "heist" for generating HTML that allows you to bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX, and is reported to work on Windows. Snap Philosophy --------------- Snap aims to be the *de facto* web toolkit for Haskell, on the basis of: * High performance * High design standards * Simplicity and ease of use, even for Haskell beginners * Excellent documentation * Robustness and high test coverage snap-core-1.0.0.0/runTestsAndCoverage.sh0000755000000000000000000000233312751762146016224 0ustar0000000000000000#!/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 <. . This library contains the core definitions and types for the Snap framework, including: . 1. Primitive types and functions for HTTP (requests, responses, cookies, post/query parameters, etc) . 2. A monad for programming web handlers called \"Snap\", which allows: . * Stateful access to the HTTP request and response objects . * Monadic failure (i.e. MonadPlus/Alternative instances) for declining to handle requests and chaining handlers together . * 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". license: BSD3 license-file: LICENSE author: Snap Framework Authors (see CONTRIBUTORS) maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.10 homepage: http://snapframework.com/ bug-reports: https://github.com/snapframework/snap-core/issues category: Web, Snap, IO-Streams Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 extra-source-files: test/TestSuite.hs, cbits/timefuncs.c, CONTRIBUTORS, extra/haddock.css, extra/hscolour.css, extra/logo.gif, haddock.sh, LICENSE, 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/foo.txt, test/data/fileServe/mydir3/altindex.html, 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 optimizations such as C routines will be used. Default: False Flag debug Description: Enable debug logging code. With this flag, Snap will test the DEBUG environment variable to decide whether to do logging, and this introduces a tiny amount of overhead (a call into a function pointer) because the calls to 'debug' cannot be inlined. Default: False Library Default-language: Haskell2010 hs-source-dirs: src if !flag(debug) cpp-options: -DNODEBUG 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 exposed-modules: Snap.Core, Snap.Internal.Core, Snap.Internal.Debug, Snap.Internal.Http.Types, Snap.Internal.Parsing, Snap.Test, Snap.Types.Headers, Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip, Snap.Util.Proxy other-modules: Snap.Internal.Instances, Snap.Internal.Routing, Snap.Internal.Test.RequestBuilder, Snap.Internal.Test.Assertions, Snap.Internal.Util.FileServe, Snap.Internal.Util.FileUploads build-depends: HUnit >= 1.2 && < 2, attoparsec >= 0.12 && < 0.14, base >= 4 && < 5, bytestring >= 0.9 && < 0.11, 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.4, monad-control >= 1.0 && < 1.1, mtl >= 2.0 && < 2.3, random >= 1 && < 2, readable >= 0.1 && < 0.4, regex-posix >= 0.95 && < 1, text >= 0.11 && < 1.3, time >= 1.0 && < 1.7, transformers >= 0.3 && < 0.6, transformers-base >= 0.4 && < 0.5, unix-compat >= 0.3 && < 0.5, unordered-containers >= 0.1.4.3 && < 0.3, vector >= 0.6 && < 0.12 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 Test-suite testsuite hs-source-dirs: src test Type: exitcode-stdio-1.0 Main-is: TestSuite.hs Default-language: Haskell2010 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.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.FileServe.Tests, Snap.Util.FileUploads.Tests, Snap.Util.GZip.Tests, Snap.Util.Proxy.Tests build-depends: HUnit, attoparsec, base, bytestring, bytestring-builder, case-insensitive, containers, directory, filepath, 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 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind other-extensions: BangPatterns, CPP, DeriveDataTypeable, EmptyDataDecls, ExistentialQuantification, FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, GeneralizedNewtypeDeriving, MagicHash, MultiParamTypeClasses, OverloadedStrings, Rank2Types, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeSynonymInstances source-repository head type: git location: git://github.com/snapframework/snap-core.git snap-core-1.0.0.0/cbits/0000755000000000000000000000000012751762146013042 5ustar0000000000000000snap-core-1.0.0.0/cbits/timefuncs.c0000644000000000000000000000112512751762146015202 0ustar0000000000000000#define _DEFAULT_SOURCE #define _XOPEN_SOURCE #define _BSD_SOURCE #include #include void set_c_locale() { setlocale(LC_TIME, "C"); } time_t c_parse_http_time(char* s) { struct tm dest; strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest); return timegm(&dest); } void c_format_http_time(time_t src, char* dest) { struct tm t; gmtime_r(&src, &t); strftime(dest, 40, "%a, %d %b %Y %H:%M:%S GMT", &t); } void c_format_log_time(time_t src, char* dest) { struct tm t; localtime_r(&src, &t); strftime(dest, 40, "%d/%b/%Y:%H:%M:%S %z", &t); } snap-core-1.0.0.0/extra/0000755000000000000000000000000012751762146013061 5ustar0000000000000000snap-core-1.0.0.0/extra/haddock.css0000644000000000000000000002016112751762146015170 0ustar0000000000000000HTML { background-color: #f0f3ff; width: 100%; } BODY { -moz-border-radius:5px; -webkit-border-radius:5px; width: 50em; margin: 2em auto; padding: 0; background-color: #ffffff; color: #000000; font-size: 110%; font-family: Georgia, serif; } A:link { color: #5200A3; text-decoration: none } A:visited { color: #5200A3; text-decoration: none } A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; } TABLE.vanilla { width: 100%; border-width: 0px; /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ } DL { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; letter-spacing: -0.01em; margin: 0; } .vanilla .vanilla dl { font-size: 80%; } .vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; } TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL { padding: 0 30px 0 34px; } TABLE.vanilla2 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; border-width: 0px; } /* font is a little too small in MSIE */ TT, PRE, CODE { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; font-size: 90%; } LI P { margin: 0pt } P { margin-top: 0; margin-bottom: 0.75em; } TD { border-width: 0px; } TABLE.narrow { border-width: 0px; } TD.s8 { height: 0; margin:0; padding: 0 } TD.s15 { height: 20px; } SPAN.keyword { text-decoration: underline; } /* Resize the buttom image to match the text size */ IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } /* --------- Contents page ---------- */ DIV.node { padding-left: 3em; } DIV.cnode { padding-left: 1.75em; } SPAN.pkg { position: absolute; left: 50em; } /* --------- Documentation elements ---------- */ TD FONT { font-weight: bold; letter-spacing: -0.02em; } TD.children { padding-left: 25px; } TD.synopsis { padding: 2px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } TD.decl { padding: 4px 8px; background-color: #FAFAFA; border-bottom: #F2F2F2 solid 1px; border-top: #FCFCFC solid 1px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; } TD.decl TD.decl { font-size: 100%; padding: 4px 0; border: 0; } TD.topdecl { padding: 20px 30px 0.5ex 30px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; ; vertical-align: top; } .vanilla .vanilla .vanilla .topdecl { padding-left: 0; padding-right: 0; } .vanilla .vanilla .vanilla { padding-left: 30px; } .decl .vanilla { padding-left: 0px !important; } .body .vanilla .body { padding-left: 0; padding-right: 0; } .body .vanilla .body .decl { padding-left: 12px; } .body .vanilla .body div .vanilla .decl { padding-left: 12px; } TABLE.declbar { background-color: #f0f0f0; border-spacing: 0px; border-bottom:1px solid #d7d7df; border-right:1px solid #d7d7df; border-top:1px solid #f4f4f9; border-left:1px solid #f4f4f9; padding: 4px; } TD.declname { width: 100%; padding-right: 4px; } TD.declbut { padding-left: 8px; padding-right: 5px; border-left-width: 1px; border-left-color: #000099; border-left-style: solid; white-space: nowrap; font-size: x-small; } /* arg is just like decl, except that wrapping is not allowed. It is used for function and constructor arguments which have a text box to the right, where if wrapping is allowed the text box squashes up the declaration by wrapping it. */ TD.arg { padding: 2px 12px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; white-space: nowrap; } TD.recfield { padding-left: 20px } TD.doc { padding-left: 38px; font-size: 95%; line-height: 1.66; } TD.ndoc { font-size: 95%; line-height: 1.66; padding: 2px 4px 2px 8px; } TD.rdoc { padding: 2px; padding-left: 30px; width: 100%; font-size: 80%; font-style: italic; font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.body { padding: 0 30px; } TD.pkg { width: 100%; padding-left: 30px } TABLE.indexsearch TR.indexrow { display: none; } TABLE.indexsearch TR.indexshow { display: table-row; } TD.indexentry { vertical-align: top; padding: 0 30px } TD.indexannot { vertical-align: top; padding-left: 20px; white-space: nowrap } TD.indexlinks { width: 100% } /* ------- Section Headings ------- */ TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.section1 { padding-top: 14px; font-weight: bold; letter-spacing: -0.02em; font-size: 140% } TD.section2 { padding-top: 4px; font-weight: bold; letter-spacing: -0.02em; font-size: 120% } TD.section3 { padding-top: 5px; font-weight: bold; letter-spacing: -0.02em; font-size: 105% } TD.section4 { font-weight: bold; padding-top: 12px; padding-bottom: 4px; letter-spacing: -0.02em; font-size: 90% } /* -------------- The title bar at the top of the page */ TD.infohead { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; font-weight: bold; padding: 0 30px; text-align: left; } TD.infoval { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding: 0 30px; text-align: left; } TD.topbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; background-color: #3465a4; padding: 5px; -moz-border-radius-topleft:5px; -moz-border-radius-topright:5px; -webkit-border-radius-topleft:5px; -webkit-border-radius-topright:5px; } TD.title { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding-left: 30px; letter-spacing: -0.02em; font-weight: bold; width: 100% } TD.topbut { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; padding-left: 5px; padding-right: 5px; border-left-width: 1px; border-left-color: #ffffff; border-left-style: solid; letter-spacing: -0.02em; font-weight: bold; white-space: nowrap; } TD.topbut A:link { color: #ffffff } TD.topbut A:visited { color: #ffff00 } TD.topbut A:hover { background-color: #C9D3DE; } TD.topbut:hover { background-color: #C9D3DE; } TD.modulebar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #141B24; background-color: #C9D3DE; padding: 5px; border-top-width: 1px; border-top-color: #ffffff; border-top-style: solid; -moz-border-radius-bottomleft:5px; -moz-border-radius-bottomright:5px; -webkit-border-radius-bottomleft:5px; -webkit-border-radius-bottomright:5px; } /* --------- The page footer --------- */ TD.botbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; -moz-border-radius:5px; -webkit-border-radius:5px; background-color: #3465a4; color: #ffffff; padding: 5px } TD.botbar A:link { color: #ffffff; text-decoration: underline } TD.botbar A:visited { color: #ffff00 } TD.botbar A:hover { background-color: #6060ff } /* --------- Mini Synopsis for Frame View --------- */ .outer { margin: 0 0; padding: 0 0; } .mini-synopsis { padding: 0.25em 0.25em; } .mini-synopsis H1 { font-size: 120%; } .mini-synopsis H2 { font-size: 107%; } .mini-synopsis H3 { font-size: 100%; } .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; margin-top: 0.5em; margin-bottom: 0.25em; padding: 0 0; font-weight: bold; letter-spacing: -0.02em; } .mini-synopsis H1 { border-bottom: 1px solid #ccc; } .mini-topbar { font-size: 120%; background: #0077dd; padding: 0.25em; } snap-core-1.0.0.0/extra/hscolour.css0000644000000000000000000000073712751762146015440 0ustar0000000000000000body { font-size: 90%; } pre, code, body { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } .hs-keyglyph, .hs-layout {color: #5200A3;} .hs-keyword {color: #3465a4; font-weight: bold;} .hs-comment, .hs-comment a {color: #579; } .hs-str, .hs-chr {color: #141B24;} .hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} snap-core-1.0.0.0/extra/logo.gif0000644000000000000000000000113712751762146014512 0ustar0000000000000000GIF89a` J"K#M%N(P1W1X3Z6\?d4e=i9i:j= 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 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) = "" show (EscapeHttp _) = "" ------------------------------------------------------------------------------ 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 : @ 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 return = snapReturn 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 #-} snapReturn :: a -> Snap a snapReturn = pure {-# INLINE snapReturn #-} 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 -- -- \ -- \ -- \ -- \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\n" , "\n" , "\n" , "No handler accepted \"" , rqURI req , "\"\n" ] -------------------------------------------------------------------------- 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 ------------------------------------------------------------------------------ evalSnap :: Snap a -> (ByteString -> IO ()) -> ((Int -> Int) -> IO ()) -> 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 snap-core-1.0.0.0/src/Snap/Internal/Debug.hs0000644000000000000000000001200312751762146016560 0ustar0000000000000000-- | 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 FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-cse #-} module Snap.Internal.Debug (debug, debugErrno) where ------------------------------------------------------------------------------ import Control.Monad.IO.Class (MonadIO (..)) #ifndef NODEBUG 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 ------------------------------------------------------------------------------ -- | 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" !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) (\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 = length s `seq` return $! () {-# NOINLINE debugSeq #-} ------------------------------------------------------------------------------ _debugMVar :: MVar () _debugMVar = unsafePerformIO $ newMVar () {-# NOINLINE _debugMVar #-} ------------------------------------------------------------------------------ debugOn :: (MonadIO m) => String -> m () debugOn s = liftIO $ withMVar _debugMVar $ \_ -> do tid <- myThreadId hPutStrLn stderr $ s' tid hFlush stderr where chop x = let y = fromMaybe x $ stripPrefix "ThreadId " x in printf "%8s" y s' t = "[" ++ chop (show t) ++ "] " ++ s {-# NOINLINE debugOn #-} ------------------------------------------------------------------------------ debugErrnoOn :: (MonadIO m) => String -> m () debugErrnoOn loc = liftIO $ do err <- getErrno let ex = errnoToIOError loc err Nothing Nothing debug $ show ex ------------------------------------------------------------------------------ #else debug = debugIgnore {-# INLINE debug #-} debugErrno = debugErrnoIgnore {-# INLINE debugErrno #-} #endif ------------------------------------------------------------------------------ debugIgnore :: (MonadIO m) => String -> m () debugIgnore _ = return () {-# INLINE debugIgnore #-} debugErrnoIgnore :: (MonadIO m) => String -> m () debugErrnoIgnore _ = return () {-# INLINE debugErrnoIgnore #-} ------------------------------------------------------------------------------ snap-core-1.0.0.0/src/Snap/Internal/Instances.hs0000644000000000000000000000617212751762146017473 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -- 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 Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Error (Error, ErrorT) #if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except (ExceptT) #endif import Control.Monad.Trans.List (ListT) 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 (MonadSnap m, Error e) => MonadSnap (ErrorT e m) where liftSnap = lift . liftSnap #if MIN_VERSION_transformers(0,4,0) instance (MonadSnap m, Monoid e) => MonadSnap (ExceptT e m) where liftSnap = lift . liftSnap #endif ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (ListT m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance (MonadSnap m, Monoid w) => MonadSnap (RWST r w s m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance (MonadSnap m, Monoid w) => MonadSnap (LRWS.RWST r w s m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (ReaderT r m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (StateT s m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (LState.StateT s m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance (MonadSnap m, Monoid w) => MonadSnap (WriterT w m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ instance (MonadSnap m, Monoid w) => MonadSnap (LWriter.WriterT w m) where liftSnap = lift . liftSnap snap-core-1.0.0.0/src/Snap/Internal/Parsing.hs0000644000000000000000000005060212751762146017144 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ module Snap.Internal.Parsing where ------------------------------------------------------------------------------ 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) 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#), uncheckedShiftRL#, word2Int#) 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)) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ {-# INLINE fullyParse #-} fullyParse :: ByteString -> Parser a -> Either String a 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 _ context e) -> Left $ concat [ "Parsing " , intercalate "/" context , ": " , e , "." ] (Partial _) -> Left "parse failed" -- expected to be impossible (Done _ x) -> Right x where r = parseFunc p s r' = feedFunc r "" ------------------------------------------------------------------------------ -- Parsers for different tokens in an HTTP request. ------------------------------------------------------------------------------ parseNum :: Parser Int64 parseNum = decimal ------------------------------------------------------------------------------ untilEOL :: Parser ByteString untilEOL = takeWhile notend "untilEOL" where notend c = not $ c == '\r' || c == '\n' ------------------------------------------------------------------------------ crlf :: Parser ByteString crlf = string "\r\n" "crlf" ------------------------------------------------------------------------------ toTable :: (Char -> Bool) -> (Char -> Bool) toTable f = inClass $ filter f $ map w2c [0..255] {-# INLINE toTable #-} ------------------------------------------------------------------------------ skipFieldChars :: Parser () skipFieldChars = skipWhile isFieldChar ------------------------------------------------------------------------------ isFieldChar :: Char -> Bool isFieldChar = toTable f where f c = (isDigit c) || (isAlpha c) || c == '-' || c == '_' ------------------------------------------------------------------------------ -- | Parser for request headers. pHeaders :: Parser [(ByteString, ByteString)] pHeaders = many' header "headers" where -------------------------------------------------------------------------- slurp p = fst <$> match p -------------------------------------------------------------------------- header = {-# SCC "pHeaders/header" #-} liftA2 (,) fieldName (char ':' *> skipSpace *> contents) -------------------------------------------------------------------------- fieldName = {-# SCC "pHeaders/fieldName" #-} slurp (letter_ascii *> skipFieldChars) -------------------------------------------------------------------------- contents = {-# SCC "pHeaders/contents" #-} liftA2 S.append (untilEOL <* crlf) (continuation <|> pure S.empty) -------------------------------------------------------------------------- isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-} w == ' ' || w == '\t' -------------------------------------------------------------------------- leadingWhiteSpace = {-# SCC "pHeaders/leadingWhiteSpace" #-} skipWhile1 isLeadingWS -------------------------------------------------------------------------- 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 (/= ';')) ------------------------------------------------------------------------------ pQuotedString :: Parser ByteString pQuotedString = q *> quotedText <* q where quotedText = (S.concat . L.toChunks . toLazyByteString) <$> f mempty f soFar = do t <- takeWhile qdtext let soFar' = soFar <> byteString t -- RFC says that backslash only escapes for <"> choice [ string "\\\"" *> f (soFar' <> char8 '"') , pure soFar' ] q = char '"' qdtext = matchAll [ isRFCText, (/= '"'), (/= '\\') ] ------------------------------------------------------------------------------ {-# INLINE isRFCText #-} isRFCText :: Char -> Bool isRFCText = not . isControl ------------------------------------------------------------------------------ {-# INLINE matchAll #-} matchAll :: [ Char -> Bool ] -> Char -> Bool matchAll x c = and $ map ($ c) x ------------------------------------------------------------------------------ pAvPairs :: Parser [(ByteString, ByteString)] pAvPairs = do a <- pAvPair b <- many' (skipSpace *> char ';' *> skipSpace *> pAvPair) return $! a:b ------------------------------------------------------------------------------ {-# INLINE pAvPair #-} pAvPair :: Parser (ByteString, ByteString) pAvPair = do key <- pToken <* skipSpace val <- liftM trim (option "" $ char '=' *> skipSpace *> pWord) return $! (key, val) ------------------------------------------------------------------------------ pParameter :: Parser (ByteString, ByteString) pParameter = parser "pParameter" where parser = do key <- pToken <* skipSpace val <- liftM trim (char '=' *> skipSpace *> pWord) 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 = parser "pValueWithParameters" where parser = do value <- liftM trim (skipSpace *> takeWhile (/= ';')) params <- many' pParam endOfInput return (value, map (first CI.mk) params) pParam = skipSpace *> char ';' *> skipSpace *> pParameter ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ {-# INLINE isToken #-} isToken :: Char -> Bool isToken = toTable f where f = matchAll [ isAscii , not . isControl , not . isSpace , not . flip elem [ '(', ')', '<', '>', '@', ',', ';' , ':', '\\', '\"', '/', '[', ']' , '?', '=', '{', '}' ] ] ------------------ -- Url encoding -- ------------------ ------------------------------------------------------------------------------ {-# INLINE parseToCompletion #-} parseToCompletion :: Parser a -> ByteString -> Maybe a parseToCompletion p s = toResult $ finish r where r = parse p s toResult (Done _ c) = Just c toResult _ = Nothing ------------------------------------------------------------------------------ type DList a = [a] -> [a] pUrlEscaped :: Parser ByteString pUrlEscaped = do sq <- nextChunk id return $! S.concat $ sq [] where -------------------------------------------------------------------------- nextChunk :: DList ByteString -> Parser (DList ByteString) 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 hx <- take 2 when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $ mzero let code = w2c ((unsafeFromHex hx) :: Word8) nextChunk $ l . ((S.singleton code) :) -------------------------------------------------------------------------- unEncoded :: Char -> DList ByteString -> Parser (DList ByteString) unEncoded !c !l' = do let l = l' . ((S.singleton c) :) bs <- takeTill (flip elem ['%', '+']) if S.null bs then nextChunk l else nextChunk $ l . (bs :) -------------------------------------------------------------------------- plusSpace :: DList ByteString -> Parser (DList ByteString) plusSpace l = nextChunk (l . ((S.singleton ' ') :)) ------------------------------------------------------------------------------ -- "...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 -- ) -- -- 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 #-} ------------------------------------------------------------------------------ -- | URL-escape a string (see -- ) -- -- Example: -- -- @ -- ghci> 'urlEncode' "1 attoparsec ~= 3 * 10^-2 meters" -- "1+attoparsec+%7e%3d+3+*+10%5e-2+meters" -- @ urlEncode :: ByteString -> ByteString urlEncode = S.concat . L.toChunks . toLazyByteString . urlEncodeBuilder {-# INLINE urlEncode #-} ------------------------------------------------------------------------------ -- | URL-escape a string (see -- ) 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 = go mempty where 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 ------------------------------------------------------------------------------ urlEncodeClean :: Char -> Bool urlEncodeClean = toTable f where f c = any ($ c) [\c' -> isAscii c' && isAlphaNum c' , flip elem [ '$', '_', '-', '.', '!' , '*' , '\'', '(', ')', ',' ]] ------------------------------------------------------------------------------ hexd :: Char -> Builder hexd c0 = char8 '%' <> word8 hi <> word8 low where !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#)) ------------------------------------------------------------------------------ finish :: Result a -> Result a finish (Partial f) = flip feed "" $ f "" finish x = x --------------------------------------- -- application/x-www-form-urlencoded -- --------------------------------------- ------------------------------------------------------------------------------ -- | 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 ins Map.empty decoded where -------------------------------------------------------------------------- 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') -------------------------------------------------------------------------- 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 (char8 '&') $ concatMap encodeVS $ Map.toList m encodeVS (k,vs) = map (encodeOne k) vs 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 = S.concat . L.toChunks . toLazyByteString . buildUrlEncoded -------------------- -- Cookie parsing -- -------------------- ------------------------------------------------------------------------------ -- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109 -- (cookie spec): please point out any errors! ------------------------------------------------------------------------------ pCookies :: Parser [Cookie] pCookies = do -- grab kvps and turn to strict bytestrings kvps <- pAvPairs return $! map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps where toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False ------------------------------------------------------------------------------ parseCookie :: ByteString -> Maybe [Cookie] parseCookie = parseToCompletion pCookies ----------------------- -- 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 #-} ------------------------------------------------------------------------------ -- 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 #-} snap-core-1.0.0.0/src/Snap/Internal/Routing.hs0000644000000000000000000002734712751762146017202 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} module Snap.Internal.Routing ( Route(..) , pRoute , route , routeEarliestNC , routeHeight , routeLocal , splitPath ) where ------------------------------------------------------------------------------ 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 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 ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 (HashMap ByteString (Route a m)) (Route a m) | NoRoute ------------------------------------------------------------------------------ instance Monoid (Route a m) where mempty = NoRoute mappend NoRoute r = r mappend 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 H.empty l) r NoRoute -> l -- Whenever we're unioning two Captures and their capture variables -- differ, we have an ambiguity. We resolve this in the following order: -- 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) (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) where rh' = routeHeight r' rh'' = routeHeight r'' en' = routeEarliestNC r' 1 en'' = routeEarliestNC r'' 1 (Dir rm fb') -> Dir rm (mappend 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 (H.unionWith mappend rm rm') (mappend fb fb') NoRoute -> l ------------------------------------------------------------------------------ routeHeight :: Route a m -> Int routeHeight r = case r of NoRoute -> 1 (Action _) -> 1 (Capture _ r' _) -> 1 + routeHeight r' (Dir rm _) -> 1 + foldl max 1 (map routeHeight $ H.elems rm) {-# INLINE routeHeight #-} ------------------------------------------------------------------------------ routeEarliestNC :: Route a m -> Int -> Int routeEarliestNC r n = case r of NoRoute -> n (Action _) -> n (Capture _ r' _) -> routeEarliestNC r' n+1 (Dir _ _) -> n {-# INLINE routeEarliestNC #-} ------------------------------------------------------------------------------ -- | A web handler which, given a mapping from URL entry points to web -- handlers, efficiently routes requests to the correct handler. -- -- -- __Usage__ -- -- 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@ 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 (@\":\"@) -- 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. -- -- 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. -- -- @ -- 'route' [ (\"article\", renderIndex) -- , (\"article\/:id\", renderArticle) -- , (\"login\", 'Snap.Core.method' POST doLogin) ] -- @ -- -- __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 -- contain the original encoded URL, i.e. what the user entered. For example, -- in the following scenario: -- -- > 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/\"@. -- -- 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' where rts' = mconcat (map pRoute rts) {-# INLINE route #-} ------------------------------------------------------------------------------ -- | 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 let ctx = rqContextPath req let p = rqPathInfo req let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p} (route' md [] (splitPath p) Map.empty rts') <|> (md >> pass) where rts' = mconcat (map pRoute rts) {-# INLINE routeLocal #-} ------------------------------------------------------------------------------ splitPath :: ByteString -> [ByteString] splitPath = B.splitWith (== (c2w '/')) {-# INLINE splitPath #-} ------------------------------------------------------------------------------ pRoute :: MonadSnap m => (ByteString, m a) -> Route a m pRoute (r, a) = foldr f (Action a) hier where 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 (H.fromList [(s, rt)]) NoRoute {-# INLINE pRoute #-} ------------------------------------------------------------------------------ route' :: MonadSnap m => m () -- ^ action to run before we call the user handler -> [ByteString] -- ^ the \"context\"; the list of path segments we've -- already successfully matched, in reverse order -> [ByteString] -- ^ the list of path segments we haven't yet matched -> Params -> Route a m -> m a route' pre !ctx _ !params (Action action) = localRequest (updateContextPath (B.length ctx') . updateParams) (pre >> action) where ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx) updateParams req = req { rqParams = Map.unionWith (flip (++)) params (rqParams req) } route' pre !ctx [] !params (Capture _ _ fb) = route' pre ctx [] params fb route' pre !ctx paths@(cwd:rest) !params (Capture p rt fb) | B.null cwd = fallback | otherwise = m <|> fallback where 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 paths@(cwd:rest) !params (Dir rtm fb) = do cwd' <- maybe pass return $ urlDecode cwd case H.lookup cwd' rtm of Just rt -> (route' pre (cwd:ctx) rest params rt) <|> (route' pre ctx paths params fb) Nothing -> route' pre ctx paths params fb route' _ _ _ _ NoRoute = pass snap-core-1.0.0.0/src/Snap/Internal/Http/0000755000000000000000000000000012751762146016121 5ustar0000000000000000snap-core-1.0.0.0/src/Snap/Internal/Http/Types.hs0000644000000000000000000013342112751762146017565 0ustar0000000000000000{-# 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 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 -- ). 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'. -- -- 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 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 ------------------------------------------------------------------------------ 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") ] ------------------------------------------------------------------------------ -- 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.*" #-} snap-core-1.0.0.0/src/Snap/Internal/Test/0000755000000000000000000000000012751762146016121 5ustar0000000000000000snap-core-1.0.0.0/src/Snap/Internal/Test/Assertions.hs0000644000000000000000000001401012751762146020603 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings #-} module Snap.Internal.Test.Assertions where ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Given a 'Response', return its body as a 'ByteString'. -- -- Example: -- -- @ -- ghci> 'getResponseBody' 'emptyResponse' -- \"\" -- @ -- getResponseBody :: Response -> IO ByteString getResponseBody rsp = do (os, grab) <- Streams.listOutputStream enum os liftM toBS grab where enum os = do os' <- rspBodyToEnum (rspBody rsp) os Streams.write Nothing os' toBS = S.concat . L.toChunks . toLazyByteString . mconcat ------------------------------------------------------------------------------ -- | 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', 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 message = "Expected Not Found (404) but got (" ++ (show status) ++ ")" status = rspStatus rsp ------------------------------------------------------------------------------ -- | 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 -> Assertion assertRedirectTo uri rsp = do assertRedirect rsp assertEqual message uri rspUri where rspUri = fromJust $ getHeader "Location" rsp message = "Expected redirect to " ++ show uri ++ " but got redirected to " ++ show rspUri ++ " instead" ------------------------------------------------------------------------------ -- | 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 message = "Expected redirect but got status code (" ++ show status ++ ")" status = rspStatus rsp ------------------------------------------------------------------------------ -- | 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 assertBodyContains match rsp = do body <- getResponseBody rsp assertBool message (body =~ match) where message = "Expected body to match regexp \"" ++ show match ++ "\", but didn't" snap-core-1.0.0.0/src/Snap/Internal/Test/RequestBuilder.hs0000644000000000000000000010654512751762146021427 0ustar0000000000000000{- 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 , MultipartParams , MultipartParam(..) , FileData (..) , RequestType (..) , addHeader , buildRequest , delete , evalHandler , evalHandlerM , get , postMultipart , postRaw , postUrlEncoded , put , requestToString , responseToString , runHandler , runHandlerM , setContentType , setHeader , addCookies , setHttpVersion , setQueryString , setQueryStringRaw , setRequestPath , setRequestType , setSecure ) where ------------------------------------------------------------------------------ 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 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 (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 ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 ( Applicative , Functor , Monad , MonadIO , MonadState Request , MonadTrans ) ------------------------------------------------------------------------------ mkDefaultRequest :: IO Request mkDefaultRequest = do b <- Streams.fromList $! [] return $ Request "localhost" "127.0.0.1" 60000 "127.0.0.1" 8080 "localhost" False H.empty 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) rq0 <- liftIO mkDefaultRequest execStateT m rq0 where fixup = do fixupURI 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 { rqBody = b } rPut $ rq' { rqContentLength = Nothing } else return $! () fixupCL = do rq <- rGet maybe (rPut $ deleteHeader "Content-Length" rq) (\cl -> rPut $ H.setHeader "Content-Length" (S.pack (show cl)) rq) (rqContentLength rq) fixupParams = do rq <- rGet 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 (!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 = 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 -- values or a set of file uploads. type MultipartParams = [(ByteString, MultipartParam)] ------------------------------------------------------------------------------ -- | 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. | Files [FileData] -- ^ a file upload consisting of the given 'FileData' values. deriving (Show) ------------------------------------------------------------------------------ -- | Represents a single file upload for the 'MultipartParam'. data FileData = FileData { fdFileName :: ByteString -- ^ the file's name , fdContentType :: ByteString -- ^ the file's content-type , fdContents :: ByteString -- ^ the file contents } deriving (Show) ------------------------------------------------------------------------------ -- | The 'RequestType' datatype enumerates the different kinds of HTTP -- requests you can generate using the testing interface. Most users will -- prefer to use the 'get', 'postUrlEncoded', 'postMultipart', 'put', and -- 'delete' convenience functions. data RequestType = GetRequest | RequestWithRawBody Method ByteString | MultipartPostRequest MultipartParams | UrlEncodedPostRequest Params | DeleteRequest deriving (Show) ------------------------------------------------------------------------------ -- | 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 body <- liftIO $ Streams.fromList $! [] rPut $ rq { rqMethod = GET , rqContentLength = Nothing , rqBody = body } setRequestType DeleteRequest = do rq <- rGet body <- liftIO $ Streams.fromList $! [] rPut $ rq { rqMethod = DELETE , rqContentLength = Nothing , rqBody = body } setRequestType (RequestWithRawBody m b) = do rq <- rGet body <- liftIO $ Streams.fromList $! [ b ] rPut $ rq { rqMethod = m , 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 let b = printUrlEncoded fp body <- liftIO $ Streams.fromList $! [b] rPut $ rq { rqMethod = POST , rqContentLength = Just $! fromIntegral $ S.length b , rqBody = body } ------------------------------------------------------------------------------ makeBoundary :: MonadIO m => m ByteString makeBoundary = do xs <- liftIO $ replicateM 16 randomWord8 let x = S.pack $ map (toEnum . fromEnum) xs 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 [ byteString boundary , byteString "\r\ncontent-disposition: form-data" , byteString "; name=\"" , byteString name , byteString "\"\r\n" ] ------------------------------------------------------------------------------ -- Assume initial or preceding "--" just before this encodeFormData :: ByteString -> ByteString -> [ByteString] -> IO Builder encodeFormData boundary name vals = case vals of [] -> return mempty [v] -> return $ mconcat [ hdr , cr , byteString v , byteString "\r\n--" ] _ -> multi where hdr = multipartHeader boundary name cr = byteString "\r\n" oneVal b v = mconcat [ byteString b , cr , cr , byteString v , byteString "\r\n--" ] multi = do b <- makeBoundary return $ mconcat [ hdr , multipartMixed b , cr , byteString "--" , mconcat (map (oneVal b) vals) , byteString b , byteString "--\r\n--" ] ------------------------------------------------------------------------------ multipartMixed :: ByteString -> Builder 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 = case files of [] -> return mempty _ -> do b <- makeBoundary return $ mconcat [ hdr , multipartMixed b , cr , byteString "--" , mconcat (map (oneVal b) files) , byteString b , byteString "--\r\n--" ] where -------------------------------------------------------------------------- contentDisposition fn = mconcat [ byteString "Content-Disposition: attachment" , byteString "; filename=\"" , byteString fn , byteString "\"\r\n" ] -------------------------------------------------------------------------- contentType ct = mconcat [ byteString "Content-Type: " , byteString ct , cr ] -------------------------------------------------------------------------- oneVal b fd = mconcat [ byteString b , cr , contentType ct , contentDisposition fileName , byteString "Content-Transfer-Encoding: binary\r\n" , cr , byteString contents , byteString "\r\n--" ] where fileName = fdFileName fd ct = fdContentType fd contents = fdContents fd -------------------------------------------------------------------------- hdr = multipartHeader boundary name cr = byteString "\r\n" ------------------------------------------------------------------------------ encodeMultipart :: MonadIO m => MultipartParams -> RequestBuilder m () encodeMultipart kvps = do boundary <- liftIO $ makeBoundary builders <- liftIO $ mapM (handleOne boundary) kvps let b = toByteString $ mconcat (byteString "--" : builders) `mappend` finalBoundary boundary rq0 <- rGet 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 $ fromIntegral $ S.length b , rqBody = body } where finalBoundary b = mconcat [byteString b, byteString "--\r\n"] handleOne boundary (name, mp) = case mp of (FormData vals) -> encodeFormData boundary name vals (Files fs) -> encodeFiles boundary name fs ------------------------------------------------------------------------------ fixupURI :: Monad m => RequestBuilder m () fixupURI = do rq <- rGet 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 rPut $ rq { rqQueryString = r } fixupURI ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | 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) ------------------------------------------------------------------------------ -- | 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 } ------------------------------------------------------------------------------ -- | Sets the request's path. The path provided must begin with a \"@/@\" and -- 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 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 -> RequestBuilder m () get uri params = do setRequestType GetRequest 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 -> RequestBuilder m () delete uri params = do setRequestType DeleteRequest setQueryString params setRequestPath uri ------------------------------------------------------------------------------ -- | 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 -> RequestBuilder m () postUrlEncoded uri params = do setRequestType $ UrlEncodedPostRequest params setRequestPath uri ------------------------------------------------------------------------------ -- | 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 -> RequestBuilder m () postMultipart uri params = do setRequestType $ MultipartPostRequest params setRequestPath uri ------------------------------------------------------------------------------ -- | 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 -> ByteString -- ^ request body contents -> RequestBuilder m () put uri contentType putData = do setRequestType $ RequestWithRawBody PUT putData setHeader "Content-Type" contentType setRequestPath uri ------------------------------------------------------------------------------ -- | 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 -> ByteString -- ^ request body contents -> RequestBuilder m () postRaw uri contentType postData = do setRequestType $ RequestWithRawBody POST postData setContentType contentType setRequestPath uri ------------------------------------------------------------------------------ -- | 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 () -- ^ a request builder -> n b -- ^ a web handler -> m Response runHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rsp <- rSnap rq snap -- simulate server logic t1 <- liftIO (epochTime >>= formatHttpTime) 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 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 = liftIO $ evalSnap s (const $ return $! ()) (const $ return $! ()) rq ------------------------------------------------------------------------------ -- | 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. -- -- 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 let act = rspBodyToEnum $ rspBody resp (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 rPut :: Monad m => Request -> RequestBuilder m () rPut s = RequestBuilder $ State.put s 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 snap-core-1.0.0.0/src/Snap/Internal/Util/0000755000000000000000000000000012751762146016117 5ustar0000000000000000snap-core-1.0.0.0/src/Snap/Internal/Util/FileServe.hs0000644000000000000000000024010412751762146020340 0ustar0000000000000000{-# 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 ) 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" ), -- > ( ".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" ), -- > ( ".tif" , "image/tiff" ), -- > ( ".tiff" , "image/tiff" ), -- > ( ".tgz" , "application/x-tgz" ), -- > ( ".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" ), ( ".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" ), ( ".tif" , "image/tiff" ), ( ".tiff" , "image/tiff" ), ( ".tgz" , "application/x-tgz" ), ( ".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" ) ] ------------------------------------------------------------------------------ -- | 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 "\n\n" writeBS "Directory Listing: " writeBS uri writeBS "" writeBS "" writeBS "
Directory Listing: " writeBS uri writeBS "
" writeBS "" when (pInfo /= "") $ writeBS "" 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 "" forM_ (sort files) $ \f0 -> do f <- liftIO $ liftM T.encodeUtf8 $ decodeFilePath f0 stat <- liftIO $ getFileStatus (d f0) tm <- liftIO $ formatHttpTime (modificationTime stat) writeBS "" writeBS "
File NameTypeLast Modified" writeBS "
..DIR
" writeBS f writeBS "DIR
" writeBS f writeBS "" writeBS (fileType mm f0) writeBS "" writeBS tm writeBS "
Powered by " writeBS "Snap
" writeBS "" ------------------------------------------------------------------------------ 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: -- -- <> 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 snap-core-1.0.0.0/src/Snap/Internal/Util/FileUploads.hs0000644000000000000000000007643512751762146020701 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Util.FileUploads ( -- * Functions 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 -- *** 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, fromException, mask, throwIO, toException) import qualified Control.Exception.Lifted as E (try) import Control.Monad (Functor (fmap), Monad ((>>=), return), MonadPlus (mzero), guard, liftM, sequence, void, when, (>=>)) 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.CaseInsensitive as CI (mk) import Data.Int (Int, Int64) import Data.List (concat, find, map, (++)) import qualified Data.Map as Map (insertWith', size) 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, flip, fst, id, max, not, otherwise, snd, ($), ($!), (.), (^), (||)) 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) 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) = do 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 , "\"" ] ) ------------------------------------------------------------------------------ -- | A type alias for a function that will process one of the parts of a -- @multipart/form-data@ HTTP request body. type PartProcessor a = PartInfo -> InputStream ByteString -> IO a ------------------------------------------------------------------------------ -- | Given an upload policy and a function to consume uploaded \"parts\", -- consume a request body uploaded with @Content-type: multipart/form-data@. -- -- 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 -- 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 -> PartProcessor a -- ^ part processor -> m [a] handleMultipart uploadPolicy origPartHandler = 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 -> liftM File $ origPartHandler x y -- 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 captures <- runRequestBody (proc bumpTimeout boundary partHandler) procCaptures captures id where -------------------------------------------------------------------------- uploadRate = minimumUploadRate uploadPolicy uploadSecs = minimumUploadSeconds uploadPolicy maxFormVars = maximumNumberOfFormInputs uploadPolicy -------------------------------------------------------------------------- proc bumpTimeout boundary partHandler = Streams.throwIfTooSlow bumpTimeout uploadRate uploadSecs >=> internalHandleMultipart boundary partHandler -------------------------------------------------------------------------- procCaptures [] dl = return $! dl [] procCaptures ((File x):xs) dl = procCaptures xs (dl . (x:)) procCaptures ((Capture k v):xs) dl = do rq <- getRequest when (Map.size (rqPostParams rq) >= maxFormVars) $ throwIO . PolicyViolationException $ T.concat [ "number of form inputs exceeded maximum of " , T.pack $ show maxFormVars ] putRequest $ modifyParams (ins k v) rq procCaptures xs dl -------------------------------------------------------------------------- ins k v = Map.insertWith' (flip (++)) k [v] -------------------------------------------------------------------------- modifyParams f r = r { rqPostParams = f $ rqPostParams r , rqParams = f $ rqParams r } ------------------------------------------------------------------------------ -- | Represents the disposition type specified via the @Content-Disposition@ -- header field. See . 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 -- @\ 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 } ------------------------------------------------------------------------------ -- | 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/. allowWithMaximumSize :: Int64 -> PartUploadPolicy allowWithMaximumSize = PartUploadPolicy . Just ------------------------------------------------------------------------------ -- private exports follow. FIXME: organize ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ captureVariableOrReadFile :: Int64 -- ^ maximum size of form input -> PartProcessor a -- ^ file reading code -> PartProcessor (Capture a) captureVariableOrReadFile maxSize fileHandler partInfo stream = if isFile then liftM File $ fileHandler partInfo stream 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 ------------------------------------------------------------------------------ internalHandleMultipart :: ByteString -- ^ boundary value -> (PartInfo -> InputStream ByteString -> IO a) -- ^ part processor -> InputStream ByteString -> IO [a] internalHandleMultipart !boundary clientHandler !stream = go where -------------------------------------------------------------------------- go = do -- swallow the first boundary _ <- parseFromStream (parseFirstBoundary boundary) stream bmstream <- search (fullBoundary boundary) stream liftM concat $ processParts goPart bmstream -------------------------------------------------------------------------- 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 = 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) mboundary else do let info = PartInfo fieldName fileName contentType disposition hdrs liftM (:[]) $ clientHandler info str -------------------------------------------------------------------------- processMixed !fieldName !str !mixedBoundary = do -- swallow the first boundary _ <- parseFromStream (parseFirstBoundary mixedBoundary) str bm <- search (fullBoundary mixedBoundary) str processParts (mixedStream fieldName) bm -------------------------------------------------------------------------- mixedStream !fieldName !str = do hdrs <- takeHeaders str let (contentType, _) = getContentType hdrs let (_, fileName, disposition) = getFieldHeaderInfo hdrs let info = PartInfo fieldName fileName contentType disposition hdrs clientHandler info str ------------------------------------------------------------------------------ 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 (!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 processParts :: (InputStream ByteString -> IO a) -> InputStream MatchInfo -> IO [a] processParts partFunc stream = go id where part pStream = do isLast <- parseFromStream pBoundaryEnd pStream if isLast then return Nothing else do !x <- partFunc pStream Streams.skipToEof pStream return $! Just x go !soFar = partStream stream >>= part >>= maybe (return $ soFar []) (\x -> go (soFar . (x:))) 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 snap-core-1.0.0.0/src/Snap/Types/0000755000000000000000000000000012751762146014532 5ustar0000000000000000snap-core-1.0.0.0/src/Snap/Types/Headers.hs0000644000000000000000000002431212751762146016443 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | An opaque data type for HTTP headers. Intended to be imported qualified, -- i.e: -- -- > import Snap.Types.Headers (Headers) -- > import qualified Snap.Types.Headers as H -- > -- > foo :: Headers -- > foo = H.empty module Snap.Types.Headers ( -- * Headers type Headers -- * Headers creation , empty -- * Predicates , null , member -- * Lookup , lookup , lookupWithDefault -- * Adding/setting headers , insert , unsafeInsert , set -- * Deleting , delete -- * Traversal , foldl' , foldr , foldedFoldl' , foldedFoldr -- * Lists , toList , fromList , unsafeFromCaseFoldedList , unsafeToCaseFoldedList ) where ------------------------------------------------------------------------------ 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, ($), ($!), (.)) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 [] ------------------------------------------------------------------------------ -- | 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 = 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 k0 = f . unH where k = CI.foldedCase k0 f m = List.any ((k ==) . fst) m {-# INLINE member #-} ------------------------------------------------------------------------------ -- | 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 #-} ------------------------------------------------------------------------------ -- | 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 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 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 $ List.filter ((k' /=) . fst) m where k' = CI.foldedCase k ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | 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' v (x,y) = f v x y ------------------------------------------------------------------------------ -- | 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' (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 snap-core-1.0.0.0/src/Snap/Util/0000755000000000000000000000000012751762146014343 5ustar0000000000000000snap-core-1.0.0.0/src/Snap/Util/FileServe.hs0000644000000000000000000000311112751762146016557 0ustar0000000000000000-- | Contains web handlers to serve files from a directory. -- -- Example usage: -- -- @ -- {-# LANGUAGE OverloadedStrings #-} -- -- module Main where -- -- import "Snap.Core" (Snap, route) -- import "Snap.Http.Server" (quickHttpServe) -- import "Snap.Util.FileServe" -- -- 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 import Snap.Internal.Util.FileServe (DirectoryConfig (..), HandlerMap, MimeMap, defaultDirectoryConfig, defaultIndexGenerator, defaultMimeTypes, fancyDirectoryConfig, fileType, getSafePath, serveDirectory, serveDirectoryWith, serveFile, serveFileAs, simpleDirectoryConfig) snap-core-1.0.0.0/src/Snap/Util/FileUploads.hs0000644000000000000000000001026712751762146017114 0ustar0000000000000000------------------------------------------------------------------------------ -- | This module contains primitives and helper functions for handling -- requests with @Content-type: multipart/form-data@, i.e. HTML forms and file -- uploads. -- -- Typically most users will want to use 'handleFileUploads', which writes -- uploaded files to a temporary directory before sending them on to a handler -- specified by the user. -- -- Users who wish to handle their file uploads differently can use the -- 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 -- allowed to upload?\" and \"should we read form inputs into the parameters -- mapping?\". Policy is specified on a \"global\" basis (using -- '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>\" -- -- 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 , handleMultipart , PartProcessor -- * Uploaded parts , PartInfo , PartDisposition(..) , partFieldName , partFileName , partContentType , partHeaders , partDisposition -- ** Policy -- *** General upload policy , UploadPolicy , defaultUploadPolicy , doProcessFormInputs , setProcessFormInputs , getMaximumFormInputSize , setMaximumFormInputSize , getMaximumNumberOfFormInputs , setMaximumNumberOfFormInputs , getMinimumUploadRate , setMinimumUploadRate , getMinimumUploadSeconds , setMinimumUploadSeconds , getUploadTimeout , setUploadTimeout -- *** Per-file upload policy , PartUploadPolicy , disallow , allowWithMaximumSize -- * Exceptions , FileUploadException , fileUploadExceptionReason , BadPartException , badPartExceptionReason , PolicyViolationException , policyViolationExceptionReason ) where import Snap.Internal.Util.FileUploads (BadPartException (badPartExceptionReason), FileUploadException, PartDisposition (..), PartInfo (..), PartProcessor, PartUploadPolicy, PolicyViolationException (policyViolationExceptionReason), UploadPolicy, allowWithMaximumSize, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, getMaximumFormInputSize, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleMultipart, setMaximumFormInputSize, setMaximumNumberOfFormInputs, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setUploadTimeout) snap-core-1.0.0.0/src/Snap/Util/GZip.hs0000644000000000000000000002352512751762146015557 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | Helpers for running a 'Snap' web handler with compression. module Snap.Util.GZip ( withCompression , withCompression' , noCompression , BadAcceptEncodingException ) 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 @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@ -- -- * @text/javascript@ -- -- * @text/plain@ -- -- * @text/xml@ -- -- * @application/x-font-truetype@ -- -- Then the given handler's output stream will be compressed, -- @Content-Encoding@ will be set in the output headers, and the -- @Content-Length@ will be cleared if it was set. (We can't process the -- stream in O(1) space if the length is known beforehand.) -- -- The wrapped handler will be run to completion, and then the 'Response' -- 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 () withCompression = withCompression' compressibleMimeTypes ------------------------------------------------------------------------------ -- | The same as 'withCompression', with control over which MIME types to -- compress. withCompression' :: MonadSnap m => Set ByteString -- ^ set of compressible MIME types -> m a -- ^ the web handler to run -> m () withCompression' mimeTable action = do _ <- action resp <- getResponse -- If a content-encoding is already set, do nothing. This prevents -- "withCompression $ withCompression m" from ruining your day. when (not $ isJust $ getHeader "Content-Encoding" resp) $ do let mbCt = fmap chop $ getHeader "Content-Type" resp debug $ "withCompression', content-type is " ++ show mbCt case mbCt of (Just ct) -> when (Set.member ct mimeTable) chkAcceptEncoding _ -> return $! () getResponse >>= finishWith where chop = S.takeWhile (\c -> c /= ';' && not (Char.isSpace c)) chkAcceptEncoding = do req <- getRequest debug $ "checking accept-encoding" let mbAcc = getHeader "Accept-Encoding" req debug $ "accept-encoding is " ++ show mbAcc let s = fromMaybe "" mbAcc types <- liftIO $ parseAcceptEncoding s 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 !_ ("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. 'withCompression' is a no-op when a content-encoding is -- already set. noCompression :: MonadSnap m => m () noCompression = modifyResponse $ setHeader "Content-Encoding" "identity" ------------------------------------------------------------------------------ -- private following ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ compressibleMimeTypes :: Set ByteString compressibleMimeTypes = Set.fromList [ "application/x-font-truetype" , "application/x-javascript" , "application/json" , "text/css" , "text/html" , "text/javascript" , "text/plain" , "text/xml" ] ------------------------------------------------------------------------------ gzipCompression :: MonadSnap m => ByteString -> m () gzipCompression ce = modifyResponse f where 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 r = setHeader "Content-Encoding" ce $ setHeader "Vary" "Accept-Encoding" $ clearContentLength $ modifyResponseBody ccompress r ------------------------------------------------------------------------------ gcompress :: (OutputStream Builder -> IO (OutputStream Builder)) -> OutputStream Builder -> IO (OutputStream Builder) gcompress body stream = Streams.gzipBuilder 5 stream >>= body ------------------------------------------------------------------------------ ccompress :: (OutputStream Builder -> IO (OutputStream Builder)) -> OutputStream Builder -> IO (OutputStream Builder) ccompress body stream = Streams.compressBuilder 5 stream >>= body ------------------------------------------------------------------------------ -- We're not gonna bother with quality values; we'll do gzip or compress in -- that order. acceptParser :: Parser [ByteString] acceptParser = do xs <- ((:[]) <$> encoding) <|> (return $! []) ys <- many (char ',' *> encoding) endOfInput return $! xs ++ ys where encoding = skipSpace *> c <* skipSpace c = do x <- coding qvalue <|> (return $! ()) return x qvalue = do skipSpace void $! char ';' skipSpace void $! char 'q' skipSpace void $! char '=' float return $! () coding = string "*" <|> takeWhile1 isCodingChar isCodingChar ch = isDigit ch || isAlpha_ascii ch || ch == '-' || ch == '_' float = takeWhile isDigit >> (char '.' >> takeWhile isDigit >> (pure $! ())) <|> (pure $! ()) ------------------------------------------------------------------------------ -- | Thrown when the 'Accept-Encoding' request header has invalid format. data BadAcceptEncodingException = BadAcceptEncodingException deriving (Typeable) ------------------------------------------------------------------------------ instance Show BadAcceptEncodingException where show BadAcceptEncodingException = "bad 'accept-encoding' header" ------------------------------------------------------------------------------ instance Exception BadAcceptEncodingException ------------------------------------------------------------------------------ parseAcceptEncoding :: ByteString -> IO [ByteString] parseAcceptEncoding s = case r of Left _ -> throwIO BadAcceptEncodingException Right x -> return x where r = fullyParse s acceptParser snap-core-1.0.0.0/src/Snap/Util/Proxy.hs0000644000000000000000000000637612751762146016034 0ustar0000000000000000{-# 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.Arrow (second) import qualified Data.ByteString.Char8 as S (break, breakEnd, drop, dropWhile, readInt, spanEnd) import Data.Char (isSpace) import Data.Maybe (fromJust) import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), getHeader, modifyRequest) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 proxyString = getHeader "Forwarded-For" req <|> getHeader "X-Forwarded-For" req <|> Just (rqClientAddr req) proxyAddr = trim . snd . S.breakEnd (== ',') . fromJust $ proxyString trim = fst . S.spanEnd isSpace . S.dropWhile isSpace (ip,portStr) = second (S.drop 1) . S.break (== ':') $ proxyAddr port = fromJust (fst <$> S.readInt portStr <|> Just (rqClientPort req)) {-# INLINE xForwardedFor #-} snap-core-1.0.0.0/test/0000755000000000000000000000000012751762146012715 5ustar0000000000000000snap-core-1.0.0.0/test/TestSuite.hs0000644000000000000000000000334712751762146015211 0ustar0000000000000000module 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 ------------------------------------------------------------------------------ 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.Test.Tests" Snap.Test.Tests.tests ] snap-core-1.0.0.0/test/data/0000755000000000000000000000000012751762146013626 5ustar0000000000000000snap-core-1.0.0.0/test/data/fileServe/0000755000000000000000000000000012751762146015552 5ustar0000000000000000snap-core-1.0.0.0/test/data/fileServe/foo.bin0000644000000000000000000000000412751762146017021 0ustar0000000000000000FOO snap-core-1.0.0.0/test/data/fileServe/foo.bin.bin.bin0000644000000000000000000000000412751762146020337 0ustar0000000000000000FOO snap-core-1.0.0.0/test/data/fileServe/foo.html0000644000000000000000000000000412751762146017215 0ustar0000000000000000FOO snap-core-1.0.0.0/test/data/fileServe/foo.txt0000644000000000000000000000000412751762146017070 0ustar0000000000000000FOO snap-core-1.0.0.0/test/data/fileServe/mydir1/0000755000000000000000000000000012751762146016757 5ustar0000000000000000snap-core-1.0.0.0/test/data/fileServe/mydir1/index.txt0000644000000000000000000000000612751762146020623 0ustar0000000000000000INDEX snap-core-1.0.0.0/test/data/fileServe/mydir2/0000755000000000000000000000000012751762146016760 5ustar0000000000000000snap-core-1.0.0.0/test/data/fileServe/mydir2/foo.txt0000644000000000000000000000000412751762146020276 0ustar0000000000000000FOO snap-core-1.0.0.0/test/data/fileServe/mydir3/0000755000000000000000000000000012751762146016761 5ustar0000000000000000snap-core-1.0.0.0/test/data/fileServe/mydir3/altindex.html0000644000000000000000000000001112751762146021447 0ustar0000000000000000ALTINDEX snap-core-1.0.0.0/test/Snap/0000755000000000000000000000000012751762145013615 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Core/0000755000000000000000000000000012751762146014506 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Core/Tests.hs0000644000000000000000000010154512751762146016152 0ustar0000000000000000{-# 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 ((>>), (>>=), fail, return), MonadPlus (mplus, mzero), forM_, liftM, void) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Error (ErrorT (runErrorT)) import Data.ByteString.Builder (byteString) #if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except (runExceptT) #endif import Control.Monad.Trans.List (ListT (runListT)) 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, 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 "" <|> 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" ("> 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 coverErrorT #if MIN_VERSION_transformers(0,4,0) coverExceptT #endif coverListT 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 coverErrorT = cover (\m -> do (_ :: Either String ()) <- runErrorT m return ()) #if MIN_VERSION_transformers(0,4,0) coverExceptT = cover (\m -> do (_ :: Either String ()) <- runExceptT m return ()) #endif coverListT = cover (void . runListT) 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" snap-core-1.0.0.0/test/Snap/Internal/0000755000000000000000000000000012751762145015371 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Internal/Http/0000755000000000000000000000000012751762145016310 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Internal/Http/Types/0000755000000000000000000000000012751762146017415 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Internal/Http/Types/Tests.hs0000644000000000000000000002036012751762146021054 0ustar0000000000000000{-# 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 snap-core-1.0.0.0/test/Snap/Internal/Parsing/0000755000000000000000000000000012751762146016775 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Internal/Parsing/Tests.hs0000644000000000000000000001374212751762146020442 0ustar0000000000000000{-# 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, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat) 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 , testUnsafeFromHex , testUnsafeFromInt , testUrlEncoded , testFailParse ] ------------------------------------------------------------------------------ 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\"" ------------------------------------------------------------------------------ -- 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` () snap-core-1.0.0.0/test/Snap/Internal/Routing/0000755000000000000000000000000012751762146017021 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Internal/Routing/Tests.hs0000644000000000000000000004067112751762146020467 0ustar0000000000000000{-# 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) snap-core-1.0.0.0/test/Snap/Test/0000755000000000000000000000000012751762146014535 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Test/Common.hs0000644000000000000000000001144012751762146016321 0ustar0000000000000000{-# 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 ((>>), fail, 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 (..), 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) snap-core-1.0.0.0/test/Snap/Test/Tests.hs0000644000000000000000000004446712751762146016212 0ustar0000000000000000{-# 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, 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) 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) snap-core-1.0.0.0/test/Snap/Types/0000755000000000000000000000000012751762145014721 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Types/Headers/0000755000000000000000000000000012751762146016275 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Types/Headers/Tests.hs0000644000000000000000000000642412751762146017741 0ustar0000000000000000{-# 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 snap-core-1.0.0.0/test/Snap/Util/0000755000000000000000000000000012751762145014532 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Util/FileServe/0000755000000000000000000000000012751762146016417 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Util/FileServe/Tests.hs0000644000000000000000000005251112751762146020061 0ustar0000000000000000{-# 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" $ " 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'] ) ] snap-core-1.0.0.0/test/Snap/Util/FileUploads/0000755000000000000000000000000012751762146016742 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Util/FileUploads/Tests.hs0000644000000000000000000007462212751762146020413 0ustar0000000000000000{-# 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), Handler (Handler), catch, catches, 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 Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef) import Data.List (foldl') 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 (..), PartDisposition (..), PartInfo (..), PolicyViolationException (..), allowWithMaximumSize, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, setMaximumFormInputSize, setMaximumNumberOfFormInputs, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setUploadTimeout, toPartDisposition) 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, getDirectoryContents, removeDirectoryRecursive) 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 (assertBool, assertEqual) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ data TestException = TestException deriving (Show, Typeable) instance Exception TestException ------------------------------------------------------------------------------ tests :: [Test] tests = [ testSuccess1 , testSuccess2 , testBadParses , testPerPartPolicyViolation1 , testPerPartPolicyViolation2 , testFormInputsPolicyViolation , testFormSizePolicyViolation , testNoFileName , testNoFileNameTooBig , testTooManyHeaders , testNoBoundary , testNoMixedBoundary , testWrongContentType , testSlowEnumerator , testSlowEnumerator2 , testAbortedBody , testTrivials , testDisconnectionCleanup ] ------------------------------------------------------------------------------ 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, ())) ------------------------------------------------------------------------------ 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" $ (harness tmpdir hndl noFileNameTestBody `catch` 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_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 ------------------------------------------------------------------------------ testFormSizePolicyViolation :: Test testFormSizePolicyViolation = testCase "fileUploads/formSizePolicy" $ (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 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" $ (harness tmpdir hndl mixedTestBody `catch` 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" $ (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 () ------------------------------------------------------------------------------ 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" $ ((harness' goSlowEnumerator tmpdir hndl mixedTestBody >> error "shouldn't get here") `catches` [Handler 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" $ (harness' goSlowEnumerator tmpdir hndl mixedTestBody `catches` [Handler 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 ------------------------------------------------------------------------------ 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 ..." 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" ] snap-core-1.0.0.0/test/Snap/Util/GZip/0000755000000000000000000000000012751762146015404 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Util/GZip/Tests.hs0000644000000000000000000003546712751762146017061 0ustar0000000000000000{-# 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 (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) snap-core-1.0.0.0/test/Snap/Util/Proxy/0000755000000000000000000000000012751762146015654 5ustar0000000000000000snap-core-1.0.0.0/test/Snap/Util/Proxy/Tests.hs0000644000000000000000000001371512751762146017321 0ustar0000000000000000{-# 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", Nothing)]) (behindProxy NoProxy reportRemoteAddr) p <- evalHandler (mkReq $ forwardedFor [("4.3.2.1", Nothing)]) (behindProxy NoProxy reportRemotePort) assertEqual "NoProxy leaves request alone" initialAddr a assertEqual "NoProxy leaves request alone" initialPort p -------------------------------------------------------------------------- b <- evalHandler (mkReq $ xForwardedFor [("4.3.2.1", Nothing)]) (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,_) <- evalHandler (mkReq $ forwardedFor addr) handler assertEqual "Behind 5.6.7.8" ip b -------------------------------------------------------------------------- (c,q) <- evalHandler (mkReq $ xForwardedFor addrs2) handler assertEqual "Behind 5.6.7.8" ip c assertEqual "port change" port q where handler = behindProxy X_Forwarded_For $ do !a <- reportRemoteAddr !p <- reportRemotePort' return $! (a,p) ip = "5.6.7.8" port = 10101 addr = [ (ip, Nothing) ] addr2 = [ (ip, Just port) ] addrs2 = [("4.3.2.1", Just 20202)] ++ addr2 ------------------------------------------------------------------------------ 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, Maybe Int)] -- ^ list of "forwarded-for" -> RequestBuilder IO () forwardedFor' hdr addrs = do setHeader hdr out where toStr (a, Nothing) = a toStr (a, Just p ) = S.concat [ a, ":", S.pack $ show p ] out = S.intercalate ", " $ map toStr addrs ------------------------------------------------------------------------------ forwardedFor :: [(ByteString, Maybe Int)] -> RequestBuilder IO () forwardedFor = forwardedFor' "Forwarded-For" ------------------------------------------------------------------------------ xForwardedFor :: [(ByteString, Maybe Int)] -> RequestBuilder IO () xForwardedFor = forwardedFor' "X-Forwarded-For"