diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,4 @@ +Doug Beardsley +Gregory Collins +Shu-yu Guo +James Sanders diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) +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. diff --git a/README.SNAP.md b/README.SNAP.md new file mode 100644 --- /dev/null +++ b/README.SNAP.md @@ -0,0 +1,55 @@ +Snap Framework 0.1.1 +-------------------- + +This is the first developer prerelease of the Snap 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 +------------------------ + +This developer prerelease contains only the Snap core system, namely: + + * a high-speed HTTP server, with an optional high-concurrency backend using + the [libev](http://software.schmorp.de/pkg/libev.html) library + + * a sensible and clean monad for web programming + + * an xml-based templating system for generating HTML based on + [expat](http://expat.sourceforge.net/) (via + [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to + bind Haskell functionality to XML tags without getting PHP-style tag soup + all over your pants + +Snap currently only runs on Unix platforms; it has been tested on Linux and Mac +OSX Snow Leopard. + + +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 Roadmap +------------ + +Where are we going? + +1. First prerelease: HTTP server, monad, template system + +2. Second prerelease: component system with a collection of useful stock +modules (called "Snaplets") for things like user and session management, +caching, an administrative interface, etc. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,74 @@ +Snap Framework Core 0.1.1 +========================== + +This is the first developer prerelease of the Snap Framework Core library. For +more information about Snap, read the `README.SNAP.md` or visit the Snap +project website at http://www.snapframework.com/. + +Snap is a nascent web framework for Haskell, based on iteratee I/O (as +[popularized by Oleg +Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). + + +## Library contents + +This is the `snap-core` library, which contains: + + * primitive types and functions for HTTP (requests, responses, cookies, + post/query parameters, etc). + + * type aliases and helper functions for Iteratee I/O. + + * a "Snap" monad interface, inspired by + [happstack's](http://happstack.com/index.html), for programming web + handlers, which allows: + + * 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. + + * Some useful utilities for web handlers, including 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 is still in its very early stages, so most of the "action" (and a big +chunk of the code) right now is centred on the test suite. Snap aims for 100% +test coverage, and we're trying hard to stick to that. + +To build the test suite, `cd` into the `test/` directory and run + + $ cabal configure + $ cabal build + +From here you can invoke the testsuite by running: + + $ ./runTestsAndCoverage.sh + + +The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cbits/timefuncs.c b/cbits/timefuncs.c new file mode 100644 --- /dev/null +++ b/cbits/timefuncs.c @@ -0,0 +1,21 @@ +#define _XOPEN_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 mktime(&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); +} diff --git a/extra/fonts/DroidSerif-Bold.eot b/extra/fonts/DroidSerif-Bold.eot new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Bold.eot differ diff --git a/extra/fonts/DroidSerif-Bold.svg b/extra/fonts/DroidSerif-Bold.svg new file mode 100644 --- /dev/null +++ b/extra/fonts/DroidSerif-Bold.svg @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/extra/fonts/DroidSerif-Bold.ttf b/extra/fonts/DroidSerif-Bold.ttf new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Bold.ttf differ diff --git a/extra/fonts/DroidSerif-Bold.woff b/extra/fonts/DroidSerif-Bold.woff new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Bold.woff differ diff --git a/extra/fonts/DroidSerif-BoldItalic.eot b/extra/fonts/DroidSerif-BoldItalic.eot new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-BoldItalic.eot differ diff --git a/extra/fonts/DroidSerif-BoldItalic.svg b/extra/fonts/DroidSerif-BoldItalic.svg new file mode 100644 --- /dev/null +++ b/extra/fonts/DroidSerif-BoldItalic.svg @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/extra/fonts/DroidSerif-BoldItalic.ttf b/extra/fonts/DroidSerif-BoldItalic.ttf new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-BoldItalic.ttf differ diff --git a/extra/fonts/DroidSerif-BoldItalic.woff b/extra/fonts/DroidSerif-BoldItalic.woff new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-BoldItalic.woff differ diff --git a/extra/fonts/DroidSerif-Italic.eot b/extra/fonts/DroidSerif-Italic.eot new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Italic.eot differ diff --git a/extra/fonts/DroidSerif-Italic.svg b/extra/fonts/DroidSerif-Italic.svg new file mode 100644 --- /dev/null +++ b/extra/fonts/DroidSerif-Italic.svg @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/extra/fonts/DroidSerif-Italic.ttf b/extra/fonts/DroidSerif-Italic.ttf new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Italic.ttf differ diff --git a/extra/fonts/DroidSerif-Italic.woff b/extra/fonts/DroidSerif-Italic.woff new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Italic.woff differ diff --git a/extra/fonts/DroidSerif-Regular.eot b/extra/fonts/DroidSerif-Regular.eot new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Regular.eot differ diff --git a/extra/fonts/DroidSerif-Regular.svg b/extra/fonts/DroidSerif-Regular.svg new file mode 100644 --- /dev/null +++ b/extra/fonts/DroidSerif-Regular.svg @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/extra/fonts/DroidSerif-Regular.ttf b/extra/fonts/DroidSerif-Regular.ttf new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Regular.ttf differ diff --git a/extra/fonts/DroidSerif-Regular.woff b/extra/fonts/DroidSerif-Regular.woff new file mode 100644 Binary files /dev/null and b/extra/fonts/DroidSerif-Regular.woff differ diff --git a/extra/haddock.css b/extra/haddock.css new file mode 100644 --- /dev/null +++ b/extra/haddock.css @@ -0,0 +1,478 @@ +/* -------- Global things --------- */ + +@font-face { + font-family: 'DroidSerif'; + src: url('fonts/DroidSerif-Regular.eot'); + src: local('Droid Serif'), + url('fonts/DroidSerif-Regular.woff') format('woff'), + url('fonts/DroidSerif-Regular.ttf') format('truetype'), + url('fonts/DroidSerif-Regular.svg#DroidSerif') format('svg'); +} + +@font-face { + font-family: 'DroidSerif'; + font-style: italic; + src: url('fonts/DroidSerif-Italic.eot'); + src: local('Droid Serif'), + url('fonts/DroidSerif-Italic.woff') format('woff'), + url('fonts/DroidSerif-Italic.ttf') format('truetype'), + url('fonts/DroidSerif-Italic.svg#DroidSerif-Italic') format('svg'); +} + +@font-face { + font-family: 'DroidSerif'; + font-weight: bold; + src: url('fonts/DroidSerif-Bold.eot'); + src: local('Droid Serif'), + url('fonts/DroidSerif-Bold.woff') format('woff'), + url('fonts/DroidSerif-Bold.ttf') format('truetype'), + url('fonts/DroidSerif-Bold.svg#DroidSerif-Bold') format('svg'); +} + +@font-face { + font-family: 'DroidSerif'; + src: url('fonts/DroidSerif-BoldItalic.eot'); + font-weight: bold; + font-style: italic; + src: local('Droid Serif'), + url('fonts/DroidSerif-BoldItalic.woff') format('woff'), + url('fonts/DroidSerif-BoldItalic.ttf') format('truetype'), + url('fonts/DroidSerif-BoldItalic.svg#DroidSerif-BoldItalic') format('svg'); +} + + + +HTML { + background-color: #f0f3ff; + width: 100%; +} + +BODY { + -moz-border-radius:5px; + -webkit-border-radius:5px; + width: 90ex; + margin: 2em auto; + padding: 0; + background-color: #ffffff; + color: #000000; + font-size: 110%; + font-family: DroidSerif, 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; +} + + diff --git a/extra/hscolour.css b/extra/hscolour.css new file mode 100644 --- /dev/null +++ b/extra/hscolour.css @@ -0,0 +1,15 @@ +body { font-size: 90%; } + +pre, code, body { + font-family: Monaco, + "DejaVu Sans Mono", + "Bitstream Vera Sans Mono", + "Lucida Console", + monospace; +} + +.hs-keyglyph, .hs-layout {color: #5200A3;} +.hs-keyword {color: #3465a4; font-weight: bold;} +.hs-comment, .hs-comment a {color: #579; } +.hs-str, .hs-chr {color: #141B24;} +.hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} diff --git a/extra/logo.gif b/extra/logo.gif new file mode 100644 Binary files /dev/null and b/extra/logo.gif differ diff --git a/haddock.sh b/haddock.sh new file mode 100644 --- /dev/null +++ b/haddock.sh @@ -0,0 +1,13 @@ +#!/bin/sh + +set -x + +rm -Rf dist/doc + +HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css' + +cabal haddock $HADDOCK_OPTS --hyperlink-source $@ + +cp -r extra/fonts dist/doc/html/snap-core/ +cp extra/logo.gif dist/doc/html/snap-core/haskell_icon.gif +cp extra/hscolour.css dist/doc/html/snap-core/src/ diff --git a/snap-core.cabal b/snap-core.cabal new file mode 100644 --- /dev/null +++ b/snap-core.cabal @@ -0,0 +1,194 @@ +name: snap-core +version: 0.1.1 +synopsis: Snap: A Haskell Web Framework (Core) + +description: + This is the first developer prerelease of the Snap 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 . + . + 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. Type aliases and helper functions for Iteratee I/O + . + 3. A monad for programming web handlers called \"Snap\", inspired by + happstack's (), 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.Types", + some iteratee utilities are in "Snap.Iteratee". + . + Higher-level facilities for building web applications (like user/session + management, component interfaces, data modeling, etc.) are planned but not + yet implemented, so this release will mostly be of interest for those who: + . + * need a fast and minimal HTTP API at roughly the same level of abstraction + as Java servlets, or + . + * are interested in contributing to the Snap Framework project. + +license: BSD3 +license-file: LICENSE +author: James Sanders, Gregory Collins, Doug Beardsley +maintainer: snap@snapframework.com +build-type: Simple +cabal-version: >= 1.6 +homepage: http://snapframework.com/ +category: Web + +extra-source-files: + test/suite/TestSuite.hs, + cbits/timefuncs.c, + CONTRIBUTORS, + extra/fonts/DroidSerif-Bold.eot, + extra/fonts/DroidSerif-Bold.svg, + extra/fonts/DroidSerif-Bold.ttf, + extra/fonts/DroidSerif-Bold.woff, + extra/fonts/DroidSerif-BoldItalic.eot, + extra/fonts/DroidSerif-BoldItalic.svg, + extra/fonts/DroidSerif-BoldItalic.ttf, + extra/fonts/DroidSerif-BoldItalic.woff, + extra/fonts/DroidSerif-Italic.eot, + extra/fonts/DroidSerif-Italic.svg, + extra/fonts/DroidSerif-Italic.ttf, + extra/fonts/DroidSerif-Italic.woff, + extra/fonts/DroidSerif-Regular.eot, + extra/fonts/DroidSerif-Regular.svg, + extra/fonts/DroidSerif-Regular.ttf, + extra/fonts/DroidSerif-Regular.woff, + extra/haddock.css, + extra/hscolour.css, + extra/logo.gif, + haddock.sh, + LICENSE, + README.md, + README.SNAP.md, + Setup.hs, + test/data/fileServe/foo.bin, + test/data/fileServe/foo.bin.bin.bin, + test/data/fileServe/foo.html, + test/data/fileServe/foo.txt, + test/runTestsAndCoverage.sh, + test/snap-core-testsuite.cabal, + test/suite/Snap/Internal/Http/Types/Tests.hs, + test/suite/Snap/Internal/Routing/Tests.hs, + test/suite/Snap/Iteratee/Tests.hs, + test/suite/Snap/Test/Common.hs, + test/suite/Snap/Types/Tests.hs, + test/suite/Snap/Util/FileServe/Tests.hs, + test/suite/Snap/Util/GZip/Tests.hs + + +Flag debug + Description: Enable debug logging to stderr + Default: False + +Flag testsuite + Description: Are we running the testsuite? Causes arguments to \"debug\" to + be evaluated but not printed. + Default: False + +Library + hs-source-dirs: src + + if flag(debug) + cpp-options: -DDEBUG + + if flag(testsuite) + cpp-options: -DDEBUG_TEST + + c-sources: cbits/timefuncs.c + include-dirs: cbits + + exposed-modules: + Data.CIByteString, + Snap.Types, + Snap.Iteratee, + Snap.Internal.Debug, + Snap.Internal.Http.Types, + Snap.Internal.Iteratee.Debug, + Snap.Util.FileServe, + Snap.Util.GZip + + other-modules: + Snap.Internal.Routing, + Snap.Internal.Types + + build-depends: + attoparsec >= 0.8.0.2 && < 0.9, + base >= 4 && < 5, + bytestring, + bytestring-mmap >= 0.2.1 && <0.3, + bytestring-nums, + cereal >= 0.2 && < 0.3, + containers, + directory, + dlist >= 0.5 && < 0.6, + filepath, + iteratee >= 0.3.1 && <0.4, + MonadCatchIO-transformers >= 0.2.1 && < 0.3, + monads-fd, + old-locale, + old-time, + text >= 0.7.1 && <0.8, + time, + transformers, + unix, + zlib + + ghc-prof-options: -prof -auto-all + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + +Executable snap + hs-source-dirs: src + main-is: Snap/Starter.hs + + build-depends: + attoparsec >= 0.8.0.2 && < 0.9, + base >= 4 && < 5, + bytestring, + bytestring-nums, + cereal >= 0.2 && < 0.3, + containers, + directory, + dlist >= 0.5 && < 0.6, + filepath, + haskell98, + iteratee >= 0.3.1 && <0.4, + monads-fd, + old-locale, + old-time, + text >= 0.7.1 && <0.8, + time, + transformers, + unix, + zlib + + ghc-prof-options: -prof -auto-all + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + +source-repository head + type: git + location: http://git.snapframework.com/snap-core diff --git a/src/Data/CIByteString.hs b/src/Data/CIByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/CIByteString.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | "Data.CIByteString" is a module containing 'CIByteString', a wrapper for +-- 'ByteString' which provides case-insensitive (ASCII-wise) 'Ord' and 'Eq' +-- instances. +-- +-- 'CIByteString' also has an 'IsString' instance, so if you use the +-- \"OverloadedStrings\" LANGUAGE pragma you can write case-insensitive string +-- literals, e.g.: +-- +-- @ +-- \> let a = \"Foo\" in +-- putStrLn $ (show $ unCI a) ++ \"==\\\"FoO\\\" is \" ++ show (a == \"FoO\") +-- \"Foo\"==\"FoO\" is True +-- @ + +module Data.CIByteString + ( CIByteString + , toCI + , unCI + ) where + +-- for IsString instance +import Data.ByteString.Char8 () +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString as S +import Data.Char +import Data.String + + +-- | A case-insensitive newtype wrapper for 'ByteString' +data CIByteString = CIByteString { unCI :: !ByteString + , _lowercased :: !ByteString } + +toCI :: ByteString -> CIByteString +toCI s = CIByteString s t + where + t = lowercase s + +instance Show CIByteString where + show (CIByteString s _) = show s + +lowercase :: ByteString -> ByteString +lowercase = S.map (c2w . toLower . w2c) + +instance Eq CIByteString where + (CIByteString _ a) == (CIByteString _ b) = a == b + (CIByteString _ a) /= (CIByteString _ b) = a /= b + +instance Ord CIByteString where + (CIByteString _ a) <= (CIByteString _ b) = a <= b + +instance IsString CIByteString where + fromString = toCI . fromString diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Debug.hs @@ -0,0 +1,76 @@ +-- | An internal Snap module for (optionally) printing debugging +-- messages. Normally 'debug' does nothing, but you can pass \"-fdebug\" to +-- @cabal install@ to build a @snap-core@ which debugs to stderr. +-- +-- /N.B./ this is an internal interface, please don't write external code that +-- depends on it. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Snap.Internal.Debug where + +import Control.Monad.Trans + +#ifdef DEBUG_TEST + +debug :: (MonadIO m) => String -> m () +debug !s = return $ s `seq` () +{-# INLINE debug #-} + +debugErrno :: (MonadIO m) => String -> m () +debugErrno !s = return $ s `seq` () + +#elif defined(DEBUG) + +------------------------------------------------------------------------------ +import Control.Concurrent +import Data.List +import Data.Maybe +import Foreign.C.Error +import System.IO +import System.IO.Unsafe +import Text.Printf +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +_debugMVar :: MVar () +_debugMVar = unsafePerformIO $ newMVar () + + +------------------------------------------------------------------------------ +debug :: (MonadIO m) => String -> m () +debug 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 + +{-# INLINE debug #-} + + +------------------------------------------------------------------------------ +debugErrno :: (MonadIO m) => String -> m () +debugErrno loc = liftIO $ do + err <- getErrno + let ex = errnoToIOError loc err Nothing Nothing + debug $ show ex +------------------------------------------------------------------------------ + +#else + +------------------------------------------------------------------------------ +debug :: (MonadIO m) => String -> m () +debug _ = return () +{-# INLINE debug #-} + +debugErrno :: (MonadIO m) => String -> m () +debugErrno _ = return () +------------------------------------------------------------------------------ + +#endif diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Types.hs @@ -0,0 +1,638 @@ +-- | 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.Types". + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Snap.Internal.Http.Types where + + +------------------------------------------------------------------------------ +import Control.Applicative hiding (empty) +import Control.Monad (liftM, when) +import qualified Data.Attoparsec as Atto +import Data.Attoparsec hiding (many, Result(..)) +import Data.Bits +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w,w2c) +import qualified Data.ByteString.Nums.Careless.Hex as Cvt +import qualified Data.ByteString as S +import Data.Char +import Data.DList (DList) +import qualified Data.DList as DL +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid +import Data.Serialize.Builder +import Data.Time.Clock +import Data.Time.Format +import Data.Word +import Foreign hiding (new) +import Foreign.C.String +import Foreign.C.Types +import Prelude hiding (take) +import System.Locale (defaultTimeLocale) + +------------------------------------------------------------------------------ +import Data.CIByteString +import qualified Snap.Iteratee as I + + +------------------------------------------------------------------------------ +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 () + +------------------------------------------------------------------------------ +type Enumerator a = I.Enumerator IO a + +------------------------------------------------------------------------------ +-- | A type alias for a case-insensitive key-value mapping. +type Headers = Map CIByteString [ByteString] + + +------------------------------------------------------------------------------ +-- | A typeclass for datatypes which contain HTTP headers. +class HasHeaders a where + + -- | Modify the datatype's headers. + updateHeaders :: (Headers -> Headers) -> a -> a + + -- | Retrieve the headers from a datatype that has headers. + headers :: a -> Headers + + +------------------------------------------------------------------------------ +-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header with +-- the same name already exists, the new value is appended to the headers list. +addHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a +addHeader k v = updateHeaders $ Map.insertWith' (++) k [v] + + +------------------------------------------------------------------------------ +-- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with +-- the same name already exists, it is overwritten with the new value. +setHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a +setHeader k v = updateHeaders $ Map.insert k [v] + + +------------------------------------------------------------------------------ +-- | Gets all of the values for a given header. +getHeaders :: (HasHeaders a) => CIByteString -> a -> Maybe [ByteString] +getHeaders k a = Map.lookup k $ headers a + + +------------------------------------------------------------------------------ +-- | Gets a header value out of a 'HasHeaders' datatype. If many headers came +-- in with the same name, they will be catenated together. +getHeader :: (HasHeaders a) => CIByteString -> a -> Maybe ByteString +getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a) + + +------------------------------------------------------------------------------ +-- | Enumerates the HTTP method values (see +-- ). +data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT + deriving(Show,Read,Ord,Eq) + + +------------------------------------------------------------------------------ +type HttpVersion = (Int,Int) + + +------------------------------------------------------------------------------ +-- | A datatype representing an HTTP cookie. +data Cookie = Cookie { + -- | The name of the cookie. + cookieName :: !ByteString + + -- | The cookie's string value. + , cookieValue :: !ByteString + + -- | The cookie's expiration value, if it has one. + , cookieExpires :: !(Maybe UTCTime) + + -- | The cookie's \"domain\" value, if it has one. + , cookieDomain :: !(Maybe ByteString) + + -- | The cookie path. + , cookiePath :: !(Maybe ByteString) +} 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 +------------------------------------------------------------------------------ + +data SomeEnumerator = SomeEnumerator (forall a . Enumerator a) + + +------------------------------------------------------------------------------ +-- | Contains all of the information about an incoming HTTP request. +data Request = Request + { -- | The server name of the request, as it came in from the request's + -- @Host:@ header. + rqServerName :: !ByteString + + -- | Returns the port number the HTTP server is listening on. + , rqServerPort :: !Int + + -- | The remote IP address. + , rqRemoteAddr :: !ByteString + + -- | The remote TCP port number. + , rqRemotePort :: !Int + + -- | The local IP address for this request. + , rqLocalAddr :: !ByteString + + -- | Returns the port number the HTTP server is listening on. + , rqLocalPort :: !Int + + -- | Returns the HTTP server's idea of its local hostname. + , rqLocalHostname :: !ByteString + + -- | Returns @True@ if this is an @HTTPS@ session (currently always + -- @False@). + , rqIsSecure :: !Bool + , rqHeaders :: Headers + , rqBody :: IORef SomeEnumerator + + -- | Returns the @Content-Length@ of the HTTP request body. + , rqContentLength :: !(Maybe Int) + + -- | Returns the HTTP request method. + , rqMethod :: !Method + + -- | Returns the HTTP version used by the client. + , rqVersion :: !HttpVersion + + -- | Returns a list of the cookies that came in from the HTTP request + -- headers. + , rqCookies :: [Cookie] + + + -- | We'll be doing web components (or \"snaplets\") for version 0.2. The + -- \"snaplet path\" refers to the place on the URL where your containing + -- snaplet is hung. The value of 'rqSnapletPath' is either @\"\"@ (at the + -- top-level context) or is a path beginning with a slash, but not ending + -- with one. + -- + -- An identity is that: + -- + -- > rqURI r == 'S.concat' [ rqSnapletPath r + -- > , rqContextPath r + -- > , rqPathInfo r ] + -- + -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will be + -- \"\" + , rqSnapletPath :: !ByteString + + -- | Handlers can (/will be; --ed/) be hung on a @URI@ \"entry point\"; + -- this is called the \"context path\". If a handler is hung on the + -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value + -- of 'rqPathInfo' will be @\"bar\"@. + , rqPathInfo :: !ByteString + + -- | The \"context path\" of the request; catenating 'rqContextPath', and + -- 'rqPathInfo' should get you back to the original 'rqURI'. The + -- 'rqContextPath' always begins and ends with a slash (@\"\/\"@) + -- character, and represents the path (relative to your + -- component\/snaplet) you took to get to your handler. + , rqContextPath :: !ByteString + + -- | Returns the @URI@ requested by the client. + , rqURI :: !ByteString + + -- | Returns the HTTP query string for this 'Request'. + , rqQueryString :: !ByteString + + -- | Returns the 'Params' mapping for this 'Request'. \"Parameters\" are + -- automatically decoded from the query string and @POST@ body and + -- entered into this mapping. + , rqParams :: Params + } + + +------------------------------------------------------------------------------ +instance Show Request where + show r = concat [ "Request <\n" + , body + , ">" ] + where + body = concat $ map ((" "++) . (++ "\n")) [ + sname + , remote + , local + , beginheaders + , hdrs + , endheaders + , contentlength + , method + , version + , cookies + , pathinfo + , contextpath + , snapletpath + , uri + , params + ] + + sname = concat [ "server-name: ", toStr $ rqServerName r ] + remote = concat [ "remote: " + , toStr $ rqRemoteAddr r + , ":" + , show (rqRemotePort r) + ] + local = concat [ "local: " + , toStr $ rqLocalAddr r + , ":" + , show $ rqServerPort r + ] + beginheaders = "Headers:\n ========================================" + endheaders = " ========================================" + hdrs = " " ++ show (rqHeaders r) + contentlength = concat [ "content-length: " + , show $ rqContentLength r + ] + method = concat [ "method: " + , show $ rqMethod r + ] + version = concat [ "version: " + , show $ rqVersion r + ] + cookies = concat [ "cookies:\n" + , " ========================================\n" + , " " ++ (show $ rqCookies r) + , "\n ========================================" + ] + pathinfo = concat [ "pathinfo: ", toStr $ rqPathInfo r ] + contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ] + snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ] + uri = concat [ "URI: ", toStr $ rqURI r ] + params = concat [ "params:\n" + , " ========================================\n" + , " " ++ (show $ rqParams r) + , "\n ========================================" + ] + + +------------------------------------------------------------------------------ +instance HasHeaders Request where + headers = rqHeaders + updateHeaders f r = r { rqHeaders = f (rqHeaders r) } + + +------------------------------------------------------------------------------ +instance HasHeaders Headers where + headers = id + updateHeaders = id + +------------------------------------------------------------------------------ +-- response type +------------------------------------------------------------------------------ + +data ResponseBody = Enum (forall a . Enumerator a) -- ^ output body is enumerator + | SendFile FilePath -- ^ output body is sendfile() + + +------------------------------------------------------------------------------ +rspBodyMap :: (forall a . Enumerator a -> Enumerator a) + -> ResponseBody + -> ResponseBody +rspBodyMap f b = Enum $ f $ rspBodyToEnum b + + +------------------------------------------------------------------------------ +rspBodyToEnum :: ResponseBody -> Enumerator a +rspBodyToEnum (Enum e) = e +rspBodyToEnum (SendFile fp) = I.enumFile fp + + +------------------------------------------------------------------------------ +-- | Represents an HTTP response. +data Response = Response + { rspHeaders :: Headers + , rspHttpVersion :: !HttpVersion + + -- | We will need to inspect the content length no matter what, and + -- looking up \"content-length\" in the headers and parsing the number + -- out of the text will be too expensive. + , rspContentLength :: !(Maybe Int) + , rspBody :: ResponseBody + + -- | Returns the HTTP status code. + , rspStatus :: !Int + + -- | Returns the HTTP status explanation string. + , rspStatusReason :: !ByteString + } + + +------------------------------------------------------------------------------ +instance Show Response where + show r = concat [ "Response <\n" + , body + , ">" ] + where + body = concat $ map ((" "++) . (++ "\n")) [ + hdrs + , version + , status + , reason + ] + + hdrs = concat [ "headers:\n" + , " ==============================\n " + , show $ rspHeaders r + , "\n ==============================" ] + + version = concat [ "version: ", show $ rspHttpVersion r ] + status = concat [ "status: ", show $ rspStatus r ] + reason = concat [ "reason: ", toStr $ rspStatusReason r ] + + +------------------------------------------------------------------------------ +instance HasHeaders Response where + headers = rspHeaders + updateHeaders f r = r { rspHeaders = f (rspHeaders r) } + + +------------------------------------------------------------------------------ +-- | Looks up the value(s) for the given named parameter. Parameters initially +-- come from the request's query string and any decoded POST body (if the +-- request's @Content-Type@ is @application\/x-www-form-urlencoded@). Parameter +-- values can be modified within handlers using "rqModifyParams". +rqParam :: ByteString -- ^ parameter name to look up + -> Request -- ^ HTTP request + -> Maybe [ByteString] +rqParam k rq = Map.lookup k $ rqParams rq +{-# INLINE rqParam #-} + + +------------------------------------------------------------------------------ +-- | Modifies the parameters mapping (which is a @Map ByteString ByteString@) in +-- a 'Request' using the given function. +rqModifyParams :: (Params -> Params) -> Request -> Request +rqModifyParams f r = r { rqParams = p } + where + p = f $ rqParams r +{-# INLINE rqModifyParams #-} + + +------------------------------------------------------------------------------ +-- | Writes a key-value pair to the parameters mapping within the given request. +rqSetParam :: ByteString -- ^ parameter name + -> [ByteString] -- ^ parameter values + -> Request -- ^ request + -> Request +rqSetParam k v = rqModifyParams $ Map.insert k v +{-# INLINE rqSetParam #-} + +------------------------------------------------------------------------------ +-- responses +------------------------------------------------------------------------------ + +-- | An empty 'Response'. +emptyResponse :: Response +emptyResponse = Response Map.empty (1,1) Nothing (Enum return) 200 "OK" + + +------------------------------------------------------------------------------ +-- | Sets an HTTP response body to the given 'Enumerator' value. +setResponseBody :: (forall a . Enumerator a) -- ^ new response body + -- enumerator + -> Response -- ^ response to modify + -> Response +setResponseBody e r = r { rspBody = Enum e } +{-# INLINE setResponseBody #-} + + +------------------------------------------------------------------------------ +-- | Sets the HTTP response status. +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 #-} + + +------------------------------------------------------------------------------ +-- | Modifies a response body. +modifyResponseBody :: (forall a . Enumerator a -> Enumerator a) + -> Response + -> Response +modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) } +{-# INLINE modifyResponseBody #-} + + +------------------------------------------------------------------------------ +-- | Sets the @Content-Type@ in the 'Response' headers. +setContentType :: ByteString -> Response -> Response +setContentType = setHeader "Content-Type" +{-# INLINE setContentType #-} + + +------------------------------------------------------------------------------ +-- | Adds an HTTP 'Cookie' to the 'Response' headers. +addCookie :: Cookie -- ^ cookie value + -> Response -- ^ response to modify + -> Response +addCookie (Cookie k v mbExpTime mbDomain mbPath) = updateHeaders f + where + f = Map.insertWith' (++) "Set-Cookie" [cookie] + cookie = S.concat [k, "=", v, path, exptime, domain] + path = maybe "" (S.append "; path=") mbPath + domain = maybe "" (S.append "; domain=") mbDomain + exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime + fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" + + +------------------------------------------------------------------------------ +-- | A note here: if you want to set the @Content-Length@ for the response, +-- Snap forces you to do it with this function rather than by setting it in the +-- headers; the @Content-Length@ in the headers will be ignored. +-- +-- The reason for this is that Snap needs to look up the value of +-- @Content-Length@ for each request, and looking the string value up in the +-- headers and parsing the number out of the text will be too expensive. +-- +-- If you don't set a content length in your response, HTTP keep-alive will be +-- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For HTTP\/1.1 +-- clients, Snap will switch to the chunked transfer encoding if +-- @Content-Length@ is not specified. +setContentLength :: Int -> Response -> Response +setContentLength l r = r { rspContentLength = Just l } +{-# INLINE setContentLength #-} + + +------------------------------------------------------------------------------ +-- | Removes any @Content-Length@ set in the 'Response'. +clearContentLength :: Response -> Response +clearContentLength r = r { rspContentLength = Nothing } +{-# INLINE clearContentLength #-} + + +------------------------------------------------------------------------------ +-- HTTP dates + +{- +-- | Converts a 'ClockTime' into an HTTP timestamp. +formatHttpTime :: UTCTime -> ByteString +formatHttpTime = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" + +-- | Converts an HTTP timestamp into a 'UTCTime'. +parseHttpTime :: ByteString -> Maybe UTCTime +parseHttpTime s' = + parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" s + where + s = toStr s' +-} + +-- | Converts a 'CTime' into an HTTP timestamp. +formatHttpTime :: CTime -> IO ByteString +formatHttpTime t = allocaBytes 40 $ \ptr -> do + c_format_http_time t ptr + S.packCString ptr + + +------------------------------------------------------------------------------ +-- | Converts an HTTP timestamp into a 'CTime'. +parseHttpTime :: ByteString -> IO CTime +parseHttpTime s = S.useAsCString s $ \ptr -> + c_parse_http_time ptr + + +------------------------------------------------------------------------------ +-- URL ENCODING +------------------------------------------------------------------------------ + +parseToCompletion :: Parser a -> ByteString -> Maybe a +parseToCompletion p s = toResult $ finish r + where + r = parse p s + + toResult (Atto.Done _ c) = Just c + toResult _ = Nothing + + +------------------------------------------------------------------------------ +pUrlEscaped :: Parser ByteString +pUrlEscaped = do + sq <- nextChunk DL.empty + return $ S.concat $ DL.toList sq + + where + nextChunk :: DList ByteString -> Parser (DList ByteString) + nextChunk s = (endOfInput *> pure s) <|> do + c <- anyWord8 + case w2c 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 . w2c) hx)) $ + fail "bad hex in url" + + let code = (Cvt.hex hx) :: Word8 + nextChunk $ DL.snoc l (S.singleton code) + + unEncoded :: Word8 -> DList ByteString -> Parser (DList ByteString) + unEncoded c l' = do + let l = DL.snoc l' (S.singleton c) + bs <- takeTill (flip elem (map c2w "%+")) + if S.null bs + then nextChunk l + else nextChunk $ DL.snoc l bs + + plusSpace :: DList ByteString -> Parser (DList ByteString) + plusSpace l = nextChunk (DL.snoc l (S.singleton $ c2w ' ')) + + +------------------------------------------------------------------------------ +-- | Decodes an URL-escaped string (see +-- ) +urlDecode :: ByteString -> Maybe ByteString +urlDecode = parseToCompletion pUrlEscaped + + +------------------------------------------------------------------------------ +-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'()," +-- [not including the quotes - ed], and reserved characters used for their +-- reserved purposes may be used unencoded within a URL." + +-- | URL-escapes a string (see +-- ) +urlEncode :: ByteString -> ByteString +urlEncode = toByteString . S.foldl' f empty + where + f b c = + if c == c2w ' ' + then b `mappend` singleton (c2w '+') + else if isKosher c + then b `mappend` singleton c + else b `mappend` hexd c + + isKosher w = any ($ c) [ isAlphaNum + , flip elem ['$', '-', '.', '!', '*' + , '\'', '(', ')', ',' ]] + where + c = w2c w + + +------------------------------------------------------------------------------ +hexd :: Word8 -> Builder +hexd c = singleton (c2w '%') `mappend` singleton hi `mappend` singleton low + where + d = c2w . intToDigit + low = d $ fromEnum $ c .&. 0xf + hi = d $ fromEnum $ (c .&. 0xf0) `shift` (-4) + + +------------------------------------------------------------------------------ +finish :: Atto.Result a -> Atto.Result a +finish (Atto.Partial f) = flip feed "" $ f "" +finish x = x + + +------------------------------------------------------------------------------ +-- local definitions +fromStr :: String -> ByteString +fromStr = S.pack . map c2w +{-# INLINE fromStr #-} + +------------------------------------------------------------------------------ +-- private helper functions +toStr :: ByteString -> String +toStr = map w2c . S.unpack + diff --git a/src/Snap/Internal/Iteratee/Debug.hs b/src/Snap/Internal/Iteratee/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Iteratee/Debug.hs @@ -0,0 +1,37 @@ +-- | An internal Snap module for debugging iteratees. +-- +-- /N.B./ this is an internal interface, please don't write user code that +-- depends on it. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + +module Snap.Internal.Iteratee.Debug ( debugIteratee ) where + +------------------------------------------------------------------------------ +import Data.Iteratee.WrappedByteString +import Data.Word (Word8) +import System.IO +------------------------------------------------------------------------------ +import Snap.Iteratee +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +instance Show (WrappedByteString Word8) where + show (WrapBS s) = show s + + +------------------------------------------------------------------------------ +debugIteratee :: Iteratee IO () +debugIteratee = IterateeG f + where + f c@(EOF _) = do + putStrLn $ "got chunk: " ++ show c + hFlush stdout + return (Done () c) + + f c@(Chunk _) = do + putStrLn $ "got chunk: " ++ show c + hFlush stdout + return $ Cont debugIteratee Nothing diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Routing.hs @@ -0,0 +1,185 @@ +module Snap.Internal.Routing where + + +------------------------------------------------------------------------------ +import Control.Applicative ((<|>)) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString as B +import Data.Monoid +import qualified Data.Map as Map + +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types +import Snap.Internal.Types + + +------------------------------------------------------------------------------ +{-| + +The internal data type you use to build a routing tree. Matching is +done unambiguously. + +'Capture' and 'Dir' routes can have a "fallback" route: + + - For 'Capture', the fallback is routed when there is nothing to capture + - For 'Dir', the fallback is routed when we can't find a route in its map + +Fallback routes are stacked: i.e. for a route like: + +> Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz + +visiting the URI foo/ will result in the "bar" capture being empty and +triggering its fallback. It's NoRoute, so we go to the nearest parent +fallback and try that, which is the baz action. + +-} +data Route a = Action (Snap a) -- wraps a 'Snap' action + | Capture ByteString (Route a) (Route a) -- captures the dir in a param + | Dir (Map.Map ByteString (Route a)) (Route a) -- match on a dir + | NoRoute + + +------------------------------------------------------------------------------ +instance Monoid (Route a) where + mempty = NoRoute + + -- Unions two routes, favoring the right-hand side + mappend NoRoute r = r + + mappend l@(Action _) r = case r of + (Action _) -> r + (Capture p r' fb) -> Capture p r' (mappend fb l) + (Dir _ _) -> mappend (Dir Map.empty l) r + NoRoute -> l + + 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') + | otherwise -> r + (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 (Map.unionWith mappend rm rm') (mappend fb fb') + NoRoute -> l + + +------------------------------------------------------------------------------ +-- | A web handler which, given a mapping from URL entry points to web +-- handlers, efficiently routes requests to the correct handler. +-- +-- The URL entry points are given as relative paths, for example: +-- +-- > route [ ("foo/bar/quux", fooBarQuux) ] +-- +-- If the URI of the incoming request is +-- +-- > /foo/bar/quux +-- +-- 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...@\". +-- +-- @FIXME@\/@TODO@: we need a version with and without the context path setting +-- behaviour; if the route is \"@article\/:id\/print@\", we probably want the +-- contextPath to be \"@\/article@\" instead of \"@\/article\/whatever\/print@\". +-- +-- 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", method POST doLogin) ] +-- +route :: [(ByteString, Snap a)] -> Snap a +route rts = route' (return ()) rts' [] + where + rts' = mconcat (map pRoute rts) + + +------------------------------------------------------------------------------ +-- | 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. +routeLocal :: [(ByteString, Snap a)] -> Snap 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 rts [] <|> (md >> pass) + + where + rts = mconcat (map pRoute rts') + + +------------------------------------------------------------------------------ +pRoute :: (ByteString, Snap a) -> Route a +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 (Map.fromList [(s, rt)]) NoRoute + + +------------------------------------------------------------------------------ +route' :: Snap () -- ^ an action to be run before any user + -- handler + -> Route a -- ^ currently active routing table + -> [Route a] -- ^ list of fallback routing tables in case + -- the current table fails + -> Snap a +route' pre (Action action) _ = pre >> action + +route' pre (Capture param rt fb) fbs = do + cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo + if B.null cwd + then route' pre fb fbs + else do localRequest (updateContextPath (B.length cwd) . (f cwd)) $ + route' pre rt (fb:fbs) + where + f v req = req { rqParams = Map.insertWith (++) param [v] (rqParams req) } + +route' pre (Dir rtm fb) fbs = do + cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo + case Map.lookup cwd rtm of + Just rt -> do + localRequest (updateContextPath (B.length cwd)) $ + route' pre rt (fb:fbs) + Nothing -> route' pre fb fbs + +route' _ NoRoute [] = pass +route' pre NoRoute (fb:fbs) = route' pre fb fbs diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Types.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Snap.Internal.Types where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Exception (throwIO, ErrorCall(..)) +import Control.Monad.CatchIO +import Control.Monad.State.Strict +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.IORef +import qualified Data.Iteratee as Iter +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +import Data.Typeable + +------------------------------------------------------------------------------ +import Snap.Iteratee hiding (Enumerator) +import Snap.Internal.Http.Types + + +------------------------------------------------------------------------------ +-- The Snap Monad +------------------------------------------------------------------------------ + +{-| + +'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you: + +1. stateful access to fetch or modify an HTTP 'Request' + +2. stateful access to fetch or modify an HTTP 'Response' + +3. failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can + choose not to handle a given request, using 'empty' or its synonym 'pass', + and you can try alternative handlers with the '<|>' operator: + + > a :: Snap String + > a = pass + > + > b :: Snap String + > b = return "foo" + > + > c :: Snap String + > c = a <|> b -- try running a, if it fails then try b + +4. convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText', + 'addToOutput') for writing output to the 'Response': + + > a :: (forall a . Enumerator a) -> Snap () + > a someEnumerator = do + > writeBS "I'm a strict bytestring" + > writeLBS "I'm a lazy bytestring" + > addToOutput someEnumerator + +5. early termination: if you call 'finishWith': + + > a :: Snap () + > a = do + > modifyResponse $ setResponseStatus 500 "Internal Server Error" + > writeBS "500 error" + > r <- getResponse + > finishWith r + + then any subsequent processing will be skipped and supplied 'Response' value + will be returned from 'runSnap' as-is. + +6. access to the 'IO' monad through a 'MonadIO' instance: + + > a :: Snap () + > a = liftIO fireTheMissiles +-} + + +------------------------------------------------------------------------------ +newtype Snap a = Snap { + unSnap :: StateT SnapState (Iteratee IO) (Maybe (Either Response a)) +} + + +------------------------------------------------------------------------------ +data SnapState = SnapState + { _snapRequest :: Request + , _snapResponse :: Response } + + +------------------------------------------------------------------------------ +instance Monad Snap where + (Snap m) >>= f = + Snap $ do + eth <- m + maybe (return Nothing) + (either (return . Just . Left) + (unSnap . f)) + eth + + return = Snap . return . Just . Right + fail = const $ Snap $ return Nothing + + +------------------------------------------------------------------------------ +instance MonadIO Snap where + liftIO m = Snap $ liftM (Just . Right) $ liftIO m + + +------------------------------------------------------------------------------ +instance MonadCatchIO Snap where + catch (Snap m) handler = Snap $ do + x <- try m + case x of + (Left e) -> let (Snap z) = handler e in z + (Right y) -> return y + + block (Snap m) = Snap $ block m + unblock (Snap m) = Snap $ unblock m + + +------------------------------------------------------------------------------ +instance MonadPlus Snap where + mzero = Snap $ return Nothing + + a `mplus` b = + Snap $ do + mb <- unSnap a + if isJust mb then return mb else unSnap b + + +------------------------------------------------------------------------------ +instance Functor Snap where + fmap = liftM + + +------------------------------------------------------------------------------ +instance Applicative Snap where + pure = return + (<*>) = ap + + +------------------------------------------------------------------------------ +instance Alternative Snap where + empty = mzero + (<|>) = mplus + + +------------------------------------------------------------------------------ +liftIter :: Iteratee IO a -> Snap a +liftIter i = Snap (lift i >>= return . Just . Right) + + +------------------------------------------------------------------------------ +-- | Sends the request body through an iteratee (data consumer) and +-- returns the result. +runRequestBody :: Iteratee IO a -> Snap a +runRequestBody iter = do + req <- getRequest + senum <- liftIO $ readIORef $ rqBody req + let (SomeEnumerator enum) = senum + + -- make sure the iteratee consumes all of the output + let iter' = iter >>= (\a -> Iter.skipToEof >> return a) + + -- run the iteratee + result <- liftIter $ Iter.joinIM $ enum iter' + + -- stuff a new dummy enumerator into the request, so you can only try to + -- read the request body from the socket once + liftIO $ writeIORef (rqBody req) + (SomeEnumerator $ return . Iter.joinI . Iter.take 0 ) + + return result + + +------------------------------------------------------------------------------ +-- | Returns the request body as a bytestring. +getRequestBody :: Snap L.ByteString +getRequestBody = liftM fromWrap $ runRequestBody stream2stream +{-# INLINE getRequestBody #-} + + +------------------------------------------------------------------------------ +-- | Detaches the request body's 'Enumerator' from the 'Request' and +-- returns it. You would want to use this if you needed to send the +-- HTTP request body (transformed or otherwise) through to the output +-- in O(1) space. (Examples: transcoding, \"echo\", etc) +-- +-- Normally Snap is careful to ensure that the request body is fully +-- consumed after your web handler runs; this function is marked +-- \"unsafe\" because it breaks this guarantee and leaves the +-- responsibility up to you. If you don't fully consume the +-- 'Enumerator' you get here, the next HTTP request in the pipeline +-- (if any) will misparse. Be careful with exception handlers. +unsafeDetachRequestBody :: Snap (Enumerator a) +unsafeDetachRequestBody = do + req <- getRequest + let ioref = rqBody req + senum <- liftIO $ readIORef ioref + let (SomeEnumerator enum) = senum + liftIO $ writeIORef ioref + (SomeEnumerator $ return . Iter.joinI . Iter.take 0) + return enum + + +------------------------------------------------------------------------------ +-- | Short-circuits a 'Snap' monad action early, storing the given +-- 'Response' value in its state. +finishWith :: Response -> Snap () +finishWith = Snap . return . Just . Left +{-# INLINE finishWith #-} + + +------------------------------------------------------------------------------ +-- | Fails out of a 'Snap' monad action. This is used to indicate +-- that you choose not to handle the given request within the given +-- handler. +pass :: Snap a +pass = empty + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' monad action only if the request's HTTP method matches +-- the given method. +method :: Method -> Snap a -> Snap a +method m action = do + req <- getRequest + unless (rqMethod req == m) pass + action +{-# INLINE method #-} + + +------------------------------------------------------------------------------ +-- 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 :: (ByteString -> ByteString -> Bool) + -> ByteString + -> Snap a + -> Snap a +pathWith c p action = do + req <- getRequest + unless (c p (rqPathInfo req)) pass + localRequest (updateContextPath $ S.length p) action + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request +-- starts with the given path. For example, +-- +-- > dir "foo" handler +-- +-- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will +-- add @\"foo\/\"@ to the handler's local 'rqContextPath'. +dir :: ByteString -- ^ path component to match + -> Snap a -- ^ handler to run + -> Snap a +dir = pathWith f + where + f dr pinfo = dr == x + where + (x,_) = S.break (=='/') pinfo +{-# INLINE dir #-} + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is exactly +-- equal to the given string. If the path matches, locally sets 'rqContextPath' +-- to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\", and runs the given +-- handler. +path :: ByteString -- ^ path to match against + -> Snap a -- ^ handler to run + -> Snap a +path = pathWith (==) +{-# INLINE path #-} + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. +ifTop :: Snap a -> Snap a +ifTop = path "" +{-# INLINE ifTop #-} + + +------------------------------------------------------------------------------ +-- | Local Snap version of 'get'. +sget :: Snap SnapState +sget = Snap $ liftM (Just . Right) get +{-# INLINE sget #-} + + +------------------------------------------------------------------------------ +-- | Local Snap monad version of 'modify'. +smodify :: (SnapState -> SnapState) -> Snap () +smodify f = Snap $ modify f >> return (Just $ Right ()) +{-# INLINE smodify #-} + + +------------------------------------------------------------------------------ +-- | Grabs the 'Request' object out of the 'Snap' monad. +getRequest :: Snap Request +getRequest = liftM _snapRequest sget +{-# INLINE getRequest #-} + + +------------------------------------------------------------------------------ +-- | Grabs the 'Response' object out of the 'Snap' monad. +getResponse :: Snap Response +getResponse = liftM _snapResponse sget +{-# INLINE getResponse #-} + + +------------------------------------------------------------------------------ +-- | Puts a new 'Response' object into the 'Snap' monad. +putResponse :: Response -> Snap () +putResponse r = smodify $ \ss -> ss { _snapResponse = r } +{-# INLINE putResponse #-} + + +------------------------------------------------------------------------------ +-- | Puts a new 'Request' object into the 'Snap' monad. +putRequest :: Request -> Snap () +putRequest r = smodify $ \ss -> ss { _snapRequest = r } +{-# INLINE putRequest #-} + + +------------------------------------------------------------------------------ +-- | Modifies the 'Request' object stored in a 'Snap' monad. +modifyRequest :: (Request -> Request) -> Snap () +modifyRequest f = smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss } +{-# INLINE modifyRequest #-} + + +------------------------------------------------------------------------------ +-- | Modifes the 'Response' object stored in a 'Snap' monad. +modifyResponse :: (Response -> Response) -> Snap () +modifyResponse f = smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss } +{-# INLINE modifyResponse #-} + + +------------------------------------------------------------------------------ +-- | Adds the output from the given enumerator to the 'Response' +-- stored in the 'Snap' monad state. +addToOutput :: (forall a . Enumerator a) -- ^ output to add + -> Snap () +addToOutput enum = modifyResponse $ modifyResponseBody (>. enum) + + +------------------------------------------------------------------------------ +-- | Adds the given strict 'ByteString' to the body of the 'Response' stored in +-- the 'Snap' monad state. +writeBS :: ByteString -> Snap () +writeBS s = addToOutput $ enumBS s + + +------------------------------------------------------------------------------ +-- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored in +-- the 'Snap' monad state. +writeLBS :: L.ByteString -> Snap () +writeLBS s = addToOutput $ enumLBS s + + +------------------------------------------------------------------------------ +-- | Adds the given strict 'T.Text' to the body of the 'Response' stored in the +-- 'Snap' monad state. +writeText :: T.Text -> Snap () +writeText s = writeBS $ T.encodeUtf8 s + + +------------------------------------------------------------------------------ +-- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the +-- 'Snap' monad state. +writeLazyText :: LT.Text -> Snap () +writeLazyText s = writeLBS $ LT.encodeUtf8 s + + +------------------------------------------------------------------------------ +-- | Sets the output to be the contents of the specified file. +-- +-- Calling 'sendFile' will overwrite any output queued to be sent in the +-- 'Response'. If the response body is not modified after the call to +-- 'sendFile', Snap will use the efficient @sendfile()@ system call on +-- platforms that support it. +-- +-- If the response body is modified (using 'modifyResponseBody'), the file will +-- be read using @mmap()@. +sendFile :: FilePath -> Snap () +sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f } + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' action with a locally-modified 'Request' state +-- object. The 'Request' object in the Snap monad state after the call +-- to localRequest will be unchanged. +localRequest :: (Request -> Request) -> Snap a -> Snap a +localRequest f m = do + req <- getRequest + + runAct req <|> (putRequest req >> pass) + + where + runAct req = do + modifyRequest f + result <- m + putRequest req + return result +{-# INLINE localRequest #-} + + +------------------------------------------------------------------------------ +-- | Fetches the 'Request' from state and hands it to the given action. +withRequest :: (Request -> Snap a) -> Snap a +withRequest = (getRequest >>=) +{-# INLINE withRequest #-} + + +------------------------------------------------------------------------------ +-- | Fetches the 'Response' from state and hands it to the given action. +withResponse :: (Response -> Snap a) -> Snap a +withResponse = (getResponse >>=) +{-# INLINE withResponse #-} + + +------------------------------------------------------------------------------ +-- | This exception is thrown if the handler you supply to 'runSnap' fails. +data NoHandlerException = NoHandlerException + deriving (Eq, Typeable) + + +------------------------------------------------------------------------------ +instance Show NoHandlerException where + show NoHandlerException = "No handler for request" + + +------------------------------------------------------------------------------ +instance Exception NoHandlerException + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' monad action in the 'Iteratee IO' monad. +runSnap :: Snap a -> Request -> Iteratee IO (Request,Response) +runSnap (Snap m) req = do + (r, ss') <- runStateT m ss + + e <- maybe (return $ Left fourohfour) + return + r + + -- is this a case of early termination? + let resp = case e of + Left x -> x + Right _ -> _snapResponse ss' + + return (_snapRequest ss', resp) + + where + fourohfour = setContentLength 3 $ + setResponseStatus 404 "Not Found" $ + modifyResponseBody (>. enumBS "404") $ + emptyResponse + + dresp = emptyResponse { rspHttpVersion = rqVersion req } + + ss = SnapState req dresp +{-# INLINE runSnap #-} + + +------------------------------------------------------------------------------ +evalSnap :: Snap a -> Request -> Iteratee IO a +evalSnap (Snap m) req = do + (r, _) <- runStateT m ss + + e <- maybe (liftIO $ throwIO NoHandlerException) + return + r + + -- is this a case of early termination? + case e of + Left _ -> liftIO $ throwIO $ ErrorCall "no value" + Right x -> return x + where + dresp = emptyResponse { rspHttpVersion = rqVersion req } + ss = SnapState req dresp +{-# INLINE evalSnap #-} + + + +------------------------------------------------------------------------------ +-- | See 'rqParam'. Looks up a value for the given named parameter in the +-- 'Request'. If more than one value was entered for the given parameter name, +-- 'getParam' gloms the values together with: +-- +-- @ 'S.intercalate' \" \"@ +-- +getParam :: ByteString -- ^ parameter name to look up + -> Snap (Maybe ByteString) +getParam k = do + rq <- getRequest + return $ liftM (S.intercalate " ") $ rqParam k rq + + diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Iteratee.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Snap Framework type aliases and utilities for iteratees. Note that as a +-- convenience, this module also exports everything from @Data.Iteratee@ in the +-- @iteratee@ library. +-- +-- /WARNING/: Note that all of these types are scheduled to change in the +-- @darcs@ head version of the @iteratee@ library; John Lato et al. are working +-- on a much improved iteratee formulation. + +module Snap.Iteratee + ( -- * Convenience aliases around types from @Data.Iteratee@ + Stream + , IterV + , Iteratee + , Enumerator + + -- * Re-export types and functions from @Data.Iteratee@ + , module Data.Iteratee + + -- * Helper functions + + -- ** Enumerators + , enumBS + , enumLBS + , enumFile + + -- ** Conversion to/from 'WrappedByteString' + , fromWrap + , toWrap + + -- ** Iteratee utilities + , takeExactly + , takeNoMoreThan + , countBytes + , bufferIteratee + ) where + +------------------------------------------------------------------------------ +import Control.Exception (SomeException) +import Control.Monad +import Control.Monad.CatchIO +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Iteratee +import qualified Data.Iteratee.Base.StreamChunk as SC +import Data.Iteratee.WrappedByteString +import Data.Monoid (mappend) +import Data.Word (Word8) +import Prelude hiding (catch,drop) +import System.IO.Posix.MMap +import qualified Data.DList as D +------------------------------------------------------------------------------ + +type Stream = StreamG WrappedByteString Word8 +type IterV m = IterGV WrappedByteString Word8 m +type Iteratee m = IterateeG WrappedByteString Word8 m +type Enumerator m a = Iteratee m a -> m (Iteratee m a) + + +------------------------------------------------------------------------------ +instance (Functor m, MonadCatchIO m) => + MonadCatchIO (IterateeG s el m) where + --catch :: Exception e => m a -> (e -> m a) -> m a + catch m handler = IterateeG $ \str -> do + ee <- try $ runIter m str + case ee of + (Left e) -> runIter (handler e) str + (Right v) -> return v + + --block :: m a -> m a + block m = IterateeG $ \str -> block $ runIter m str + unblock m = IterateeG $ \str -> unblock $ runIter m str + + +------------------------------------------------------------------------------ +-- | Wraps an 'Iteratee', counting the number of bytes consumed by it. +countBytes :: (Monad m) => Iteratee m a -> Iteratee m (a, Int) +countBytes = go 0 + where + go !n iter = IterateeG $ f n iter + + f !n !iter ch@(Chunk ws) = do + iterv <- runIter iter ch + case iterv of + Done x rest -> let !n' = n + m - len rest + in return $! Done (x, n') rest + Cont i err -> return $ Cont ((go $! n + m) i) err + where + m = S.length $ unWrap ws + + len (EOF _) = 0 + len (Chunk s) = S.length $ unWrap s + + f !n !iter stream = do + iterv <- runIter iter stream + case iterv of + Done x rest -> return $ Done (x, n) rest + Cont i err -> return $ Cont (go n i) err + + +------------------------------------------------------------------------------ +-- | Buffers an iteratee. +-- +-- Our enumerators produce a lot of little strings; rather than spending all +-- our time doing kernel context switches for 4-byte write() calls, we buffer +-- the iteratee to send 2KB at a time. +bufferIteratee :: (Monad m) => Enumerator m a +bufferIteratee = return . go (D.empty,0) + where + blocksize = 2048 + + --go :: (DList ByteString, Int) -> Iteratee m a -> Iteratee m a + go (!dl,!n) iter = IterateeG $! f (dl,n) iter + + --f :: (DList ByteString, Int) -> Iteratee m a -> Stream -> m (IterV m a) + f _ !iter ch@(EOF (Just _)) = runIter iter ch + f (!dl,_) !iter ch@(EOF Nothing) = do + iterv <- runIter iter $ Chunk big + case iterv of + Done x rest -> return $ Done x rest + Cont i (Just e) -> return $ Cont i (Just e) + Cont i Nothing -> runIter i ch + where + big = toWrap $ L.fromChunks [S.concat $ D.toList dl] + + f (!dl,!n) iter (Chunk ws) = + if n' > blocksize + then do + iterv <- runIter iter (Chunk big) + case iterv of + Done x rest -> return $ Done x rest + Cont i (Just e) -> return $ Cont i (Just e) + Cont i Nothing -> return $ Cont (go (D.empty,0) i) Nothing + else return $ Cont (go (dl',n') iter) Nothing + where + s = S.concat $ L.toChunks $ fromWrap ws + m = S.length s + n' = n+m + dl' = D.snoc dl s + big = toWrap $ L.fromChunks [S.concat $ D.toList dl'] + + +------------------------------------------------------------------------------ +-- | Enumerates a strict bytestring. +enumBS :: (Monad m) => ByteString -> Enumerator m a +enumBS bs = enumPure1Chunk $ WrapBS bs +{-# INLINE enumBS #-} + + +------------------------------------------------------------------------------ +-- | Enumerates a lazy bytestring. +enumLBS :: (Monad m) => L.ByteString -> Enumerator m a +enumLBS lbs iter = foldM k iter enums + where + enums = map (enumPure1Chunk . WrapBS) $ L.toChunks lbs + k i e = e i + + +------------------------------------------------------------------------------ +-- | Converts a lazy bytestring to a wrapped bytestring. +toWrap :: L.ByteString -> WrappedByteString Word8 +toWrap = WrapBS . S.concat . L.toChunks +{-# INLINE toWrap #-} + + +------------------------------------------------------------------------------ +-- | Converts a wrapped bytestring to a lazy bytestring. +fromWrap :: WrappedByteString Word8 -> L.ByteString +fromWrap = L.fromChunks . (:[]) . unWrap +{-# INLINE fromWrap #-} + + +------------------------------------------------------------------------------ +-- | Reads n elements from a stream and applies the given iteratee to +-- the stream of the read elements. Reads exactly n elements, and if +-- the stream is short propagates an error. +takeExactly :: (SC.StreamChunk s el, Monad m) => + Int -> + EnumeratorN s el s el m a +takeExactly 0 iter = return iter +takeExactly n' iter = + if n' < 0 + then takeExactly 0 iter + else IterateeG (step n') + where + step n chk@(Chunk str) + | SC.null str = return $ Cont (takeExactly n iter) Nothing + | SC.length str < n = liftM (flip Cont Nothing) inner + where inner = liftM (check (n - SC.length str)) (runIter iter chk) + step n (Chunk str) = done (Chunk s1) (Chunk s2) + where (s1, s2) = SC.splitAt n str + step _n (EOF (Just e)) = return $ Cont undefined (Just e) + step _n (EOF Nothing) = return $ Cont undefined (Just (Err "short write")) + check n (Done x _) = drop n >> return (return x) + check n (Cont x Nothing) = takeExactly n x + check n (Cont _ (Just e)) = drop n >> throwErr e + done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return) + + +------------------------------------------------------------------------------ +-- | Reads up to n elements from a stream and applies the given iteratee to the +-- stream of the read elements. If more than n elements are read, propagates an +-- error. +takeNoMoreThan :: (SC.StreamChunk s el, Monad m) => + Int -> + EnumeratorN s el s el m a +takeNoMoreThan n' iter = + if n' < 0 + then takeNoMoreThan 0 iter + else IterateeG (step n') + where + step n chk@(Chunk str) + | SC.null str = return $ Cont (takeNoMoreThan n iter) Nothing + | SC.length str < n = liftM (flip Cont Nothing) inner + | otherwise = done (Chunk s1) (Chunk s2) + where inner = liftM (check (n - SC.length str)) (runIter iter chk) + (s1, s2) = SC.splitAt n str + + step _n (EOF (Just e)) = return $ Cont undefined (Just e) + step _n chk@(EOF Nothing) = do + v <- runIter iter chk + + case v of + (Done x s) -> return $ Done (return x) s + (Cont _ (Just e)) -> return $ Cont undefined (Just e) + (Cont _ Nothing) -> return $ Cont (throwErr $ Err "premature EOF") Nothing + + check _ v@(Done _ _) = return $ liftI v + check n (Cont x Nothing) = takeNoMoreThan n x + check _ (Cont _ (Just e)) = throwErr e + + done _ (EOF _) = error "impossible" + done s1 s2@(Chunk s2') = do + v <- runIter iter s1 + case v of + (Done x s') -> return $ Done (return x) (s' `mappend` s2) + (Cont _ (Just e)) -> return $ Cont undefined (Just e) + (Cont i Nothing) -> + if SC.null s2' + then return $ Cont (takeNoMoreThan 0 i) Nothing + else return $ Cont undefined (Just $ Err "too many bytes") + + +------------------------------------------------------------------------------ +enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a) +enumFile fp iter = do + es <- (try $ + liftM WrapBS $ + unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8)) + + case es of + (Left e) -> return $ throwErr $ Err $ "IO error" ++ show e + (Right s) -> liftM liftI $ runIter iter $ Chunk s diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Starter.hs @@ -0,0 +1,107 @@ +module Main where + +------------------------------------------------------------------------------ +import System +import System.Directory +import System.FilePath.Posix +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +usage :: String +usage = unlines + ["Usage:" + ,"" + ," snap " + ,"" + ," can be one of:" + ," init - create a new project directory structure in the current directory" + ] + + +------------------------------------------------------------------------------ +initProject :: IO () +initProject = do + cur <- getCurrentDirectory + let dirs = splitDirectories cur + projName = last dirs + writeFile (projName++".cabal") (cabalFile projName) + createDirectory "src" + writeFile "src/Main.hs" mainFile + + +------------------------------------------------------------------------------ +main :: IO () +main = do + args <- getArgs + case args of + ["init"] -> initProject + _ -> do putStrLn usage + exitFailure + + +------------------------------------------------------------------------------ +cabalFile :: String -> String +cabalFile projName = unlines + ["Name: "++projName + ,"Version: 0.1" + ,"Synopsis: Project Synopsis Here" + ,"Description: Project Description Here" + ,"License: AllRightsReserved" + ,"Author: Author" + ,"Maintainer: maintainer@example.com" + ,"Stability: Experimental" + ,"Category: Web" + ,"Build-type: Simple" + ,"Cabal-version: >=1.2" + ,"" + ,"Executable "++projName + ," hs-source-dirs: src" + ," main-is: Main.hs" + ,"" + ," Build-depends:" + ," base >= 4," + ," haskell98," + ," monads-fd >= 0.1 && <0.2," + ," bytestring >= 0.9.1 && <0.10," + ," snap-core >= 0.1 && <0.2," + ," snap-server >= 0.1 && <0.2," + ," heist >= 0.1 && <0.2," + ," filepath >= 1.1 && <1.2" + ,"" + ," ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-imports" + ,"" + ," Extensions: OverloadedStrings" + ] + + +------------------------------------------------------------------------------ +mainFile :: String +mainFile = unlines + ["module Main where" + ,"" + ,"import System" + ,"import Control.Applicative" + ,"import Control.Monad.Trans" + ,"import Snap.Http.Server" + ,"import Snap.Types" + ,"import Snap.Util.FileServe" + ,"import Text.Templating.Heist" + ,"" + ,"site :: Snap ()" + ,"site =" + ," ifTop (writeBS \"hello world\") <|>" + ," fileServe \".\"" + ,"" + ,"main :: IO ()" + ,"main = do" + ," args <- getArgs" + ," let port = case args of" + ," [] -> 8000" + ," p:_ -> read p" + ," httpServe \"*\" port \"myserver\"" + ," (Just \"access.log\")" + ," (Just \"error.log\")" + ," site" + ] + diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Types.hs @@ -0,0 +1,117 @@ +{-| + +This module contains the core type definitions, class instances, and functions +for HTTP as well as the 'Snap' monad, which is used for web handlers. + +-} +module Snap.Types + ( + -- * The Snap Monad + Snap + , runSnap + , NoHandlerException(..) + + -- ** Functions for control flow and early termination + , finishWith + , pass + + -- ** Routing + , method + , path + , dir + , ifTop + , route + , routeLocal + + -- ** Access to state + , getRequest + , getResponse + , putRequest + , putResponse + , modifyRequest + , modifyResponse + , localRequest + , withRequest + , withResponse + + -- ** Grabbing request bodies + , runRequestBody + , getRequestBody + , unsafeDetachRequestBody + -- * HTTP Datatypes and Functions + -- $httpDoc + -- + , Request + , Response + , Headers + , HasHeaders(..) + , Params + , Method(..) + , Cookie(..) + , HttpVersion + + -- ** Headers + , addHeader + , setHeader + , getHeader + + -- ** Requests + , rqServerName + , rqServerPort + , rqRemoteAddr + , rqRemotePort + , rqLocalAddr + , rqLocalHostname + , rqIsSecure + , rqContentLength + , rqMethod + , rqVersion + , rqCookies + , rqPathInfo + , rqContextPath + , rqURI + , rqQueryString + , rqParams + , rqParam + , getParam + , rqModifyParams + , rqSetParam + + -- ** Responses + , emptyResponse + , setResponseStatus + , rspStatus + , rspStatusReason + , setContentType + , addCookie + , setContentLength + , clearContentLength + + -- *** Response I/O + , setResponseBody + , modifyResponseBody + , addToOutput + , writeBS + , writeLazyText + , writeText + , writeLBS + , sendFile + + -- * Iteratee + , Enumerator + + -- * HTTP utilities + , formatHttpTime + , parseHttpTime + , urlEncode + , urlDecode + ) where + +------------------------------------------------------------------------------ +import Snap.Internal.Http.Types +import Snap.Internal.Routing +import Snap.Internal.Types +------------------------------------------------------------------------------ + +-- $httpDoc +-- HTTP-related datatypes: 'Request', 'Response', 'Cookie', etc. diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Util/FileServe.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Contains web handlers to serve files from a directory. +module Snap.Util.FileServe +( + getSafePath +, fileServe +, fileServe' +, fileServeSingle +, fileServeSingle' +, defaultMimeTypes +, MimeMap +) where + +------------------------------------------------------------------------------ +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Char8 (ByteString) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import System.Directory +import System.FilePath +import System.Posix.Files + +------------------------------------------------------------------------------ +import Snap.Types + + +------------------------------------------------------------------------------ +-- | A type alias for MIME type +type MimeMap = Map FilePath ByteString + + +------------------------------------------------------------------------------ +-- | The default set of mime type mappings we use when serving files. Its +-- value: +-- +-- > Map.fromList [ +-- > ( ".asc" , "text/plain" ), +-- > ( ".asf" , "video/x-ms-asf" ), +-- > ( ".asx" , "video/x-ms-asf" ), +-- > ( ".avi" , "video/x-msvideo" ), +-- > ( ".bz2" , "application/x-bzip" ), +-- > ( ".c" , "text/plain" ), +-- > ( ".class" , "application/octet-stream" ), +-- > ( ".conf" , "text/plain" ), +-- > ( ".cpp" , "text/plain" ), +-- > ( ".css" , "text/css" ), +-- > ( ".cxx" , "text/plain" ), +-- > ( ".dtd" , "text/xml" ), +-- > ( ".dvi" , "application/x-dvi" ), +-- > ( ".gif" , "image/gif" ), +-- > ( ".gz" , "application/x-gzip" ), +-- > ( ".hs" , "text/plain" ), +-- > ( ".htm" , "text/html" ), +-- > ( ".html" , "text/html" ), +-- > ( ".jar" , "application/x-java-archive" ), +-- > ( ".jpeg" , "image/jpeg" ), +-- > ( ".jpg" , "image/jpeg" ), +-- > ( ".js" , "text/javascript" ), +-- > ( ".log" , "text/plain" ), +-- > ( ".m3u" , "audio/x-mpegurl" ), +-- > ( ".mov" , "video/quicktime" ), +-- > ( ".mp3" , "audio/mpeg" ), +-- > ( ".mpeg" , "video/mpeg" ), +-- > ( ".mpg" , "video/mpeg" ), +-- > ( ".ogg" , "application/ogg" ), +-- > ( ".pac" , "application/x-ns-proxy-autoconfig" ), +-- > ( ".pdf" , "application/pdf" ), +-- > ( ".png" , "image/png" ), +-- > ( ".ps" , "application/postscript" ), +-- > ( ".qt" , "video/quicktime" ), +-- > ( ".sig" , "application/pgp-signature" ), +-- > ( ".spl" , "application/futuresplash" ), +-- > ( ".swf" , "application/x-shockwave-flash" ), +-- > ( ".tar" , "application/x-tar" ), +-- > ( ".tar.bz2" , "application/x-bzip-compressed-tar" ), +-- > ( ".tar.gz" , "application/x-tgz" ), +-- > ( ".tbz" , "application/x-bzip-compressed-tar" ), +-- > ( ".text" , "text/plain" ), +-- > ( ".tgz" , "application/x-tgz" ), +-- > ( ".torrent" , "application/x-bittorrent" ), +-- > ( ".txt" , "text/plain" ), +-- > ( ".wav" , "audio/x-wav" ), +-- > ( ".wax" , "audio/x-ms-wax" ), +-- > ( ".wma" , "audio/x-ms-wma" ), +-- > ( ".wmv" , "video/x-ms-wmv" ), +-- > ( ".xbm" , "image/x-xbitmap" ), +-- > ( ".xml" , "text/xml" ), +-- > ( ".xpm" , "image/x-xpixmap" ), +-- > ( ".xwd" , "image/x-xwindowdump" ), +-- > ( ".zip" , "application/zip" ) ] +-- +defaultMimeTypes :: MimeMap +defaultMimeTypes = Map.fromList [ + ( ".asc" , "text/plain" ), + ( ".asf" , "video/x-ms-asf" ), + ( ".asx" , "video/x-ms-asf" ), + ( ".avi" , "video/x-msvideo" ), + ( ".bz2" , "application/x-bzip" ), + ( ".c" , "text/plain" ), + ( ".class" , "application/octet-stream" ), + ( ".conf" , "text/plain" ), + ( ".cpp" , "text/plain" ), + ( ".css" , "text/css" ), + ( ".cxx" , "text/plain" ), + ( ".dtd" , "text/xml" ), + ( ".dvi" , "application/x-dvi" ), + ( ".gif" , "image/gif" ), + ( ".gz" , "application/x-gzip" ), + ( ".hs" , "text/plain" ), + ( ".htm" , "text/html" ), + ( ".html" , "text/html" ), + ( ".jar" , "application/x-java-archive" ), + ( ".jpeg" , "image/jpeg" ), + ( ".jpg" , "image/jpeg" ), + ( ".js" , "text/javascript" ), + ( ".log" , "text/plain" ), + ( ".m3u" , "audio/x-mpegurl" ), + ( ".mov" , "video/quicktime" ), + ( ".mp3" , "audio/mpeg" ), + ( ".mpeg" , "video/mpeg" ), + ( ".mpg" , "video/mpeg" ), + ( ".ogg" , "application/ogg" ), + ( ".pac" , "application/x-ns-proxy-autoconfig" ), + ( ".pdf" , "application/pdf" ), + ( ".png" , "image/png" ), + ( ".ps" , "application/postscript" ), + ( ".qt" , "video/quicktime" ), + ( ".sig" , "application/pgp-signature" ), + ( ".spl" , "application/futuresplash" ), + ( ".swf" , "application/x-shockwave-flash" ), + ( ".tar" , "application/x-tar" ), + ( ".tar.bz2" , "application/x-bzip-compressed-tar" ), + ( ".tar.gz" , "application/x-tgz" ), + ( ".tbz" , "application/x-bzip-compressed-tar" ), + ( ".text" , "text/plain" ), + ( ".tgz" , "application/x-tgz" ), + ( ".torrent" , "application/x-bittorrent" ), + ( ".ttf" , "application/x-font-truetype" ), + ( ".txt" , "text/plain" ), + ( ".wav" , "audio/x-wav" ), + ( ".wax" , "audio/x-ms-wax" ), + ( ".wma" , "audio/x-ms-wma" ), + ( ".wmv" , "video/x-ms-wmv" ), + ( ".xbm" , "image/x-xbitmap" ), + ( ".xml" , "text/xml" ), + ( ".xpm" , "image/x-xpixmap" ), + ( ".xwd" , "image/x-xwindowdump" ), + ( ".zip" , "application/zip" ) ] + +------------------------------------------------------------------------------ +-- | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is +-- safe to use for opening files. A path is safe if it is a relative path +-- and has no ".." elements to escape the intended directory structure. +getSafePath :: Snap FilePath +getSafePath = do + req <- getRequest + let p = S.unpack $ rqPathInfo req + + -- check that we don't have any sneaky .. paths + let dirs = splitDirectories p + when (elem ".." dirs) pass + return p + + +------------------------------------------------------------------------------ +-- | Serves files out of the given directory. The relative path given in +-- 'rqPathInfo' is searched for the given 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. +-- +-- Uses 'defaultMimeTypes' to determine the @Content-Type@ based on the file's +-- extension. +fileServe :: FilePath -- ^ root directory + -> Snap () +fileServe = fileServe' defaultMimeTypes +{-# INLINE fileServe #-} + + +------------------------------------------------------------------------------ +-- | Same as 'fileServe', with control over the MIME mapping used. +fileServe' :: MimeMap -- ^ MIME type mapping + -> FilePath -- ^ root directory + -> Snap () +fileServe' mm root = do + sp <- getSafePath + let fp = root sp + + -- check that the file exists + liftIO (doesFileExist fp) >>= flip unless pass + + let fn = takeFileName fp + let mime = fileType mm fn + fileServeSingle' mime fp +{-# INLINE fileServe' #-} + + +------------------------------------------------------------------------------ +-- | Serves a single file specified by a full or relative path. The +-- path restrictions on fileServe don't apply to this function since +-- the path is not being supplied by the user. +fileServeSingle :: FilePath -- ^ path to file + -> Snap () +fileServeSingle fp = + fileServeSingle' (fileType defaultMimeTypes (takeFileName fp)) fp +{-# INLINE fileServeSingle #-} + + +------------------------------------------------------------------------------ +-- | Same as 'fileServeSingle', with control over the MIME mapping used. +fileServeSingle' :: ByteString -- ^ MIME type mapping + -> FilePath -- ^ path to file + -> Snap () +fileServeSingle' mime fp = do + req <- getRequest + + let mbH = getHeader "if-modified-since" req + mbIfModified <- liftIO $ case mbH of + Nothing -> return Nothing + (Just s) -> liftM Just $ parseHttpTime s + + -- check modification time and bug out early if the file is not modified. + filestat <- liftIO $ getFileStatus fp + let mt = modificationTime filestat + maybe (return ()) (chkModificationTime mt) mbIfModified + + let sz = fromEnum $ fileSize filestat + lm <- liftIO $ formatHttpTime mt + + modifyResponse $ setHeader "Last-Modified" lm + . setContentType mime + . setContentLength sz + sendFile fp + + where + -------------------------------------------------------------------------- + chkModificationTime mt lt = when (mt <= lt) notModified + + -------------------------------------------------------------------------- + notModified = finishWith $ + setResponseStatus 304 "Not Modified" emptyResponse + + +------------------------------------------------------------------------------ +fileType :: MimeMap -> FilePath -> ByteString +fileType mm f = + if null ext + then defaultMimeType + else fromMaybe (fileType mm (drop 1 ext)) + mbe + + where + ext = takeExtensions f + mbe = Map.lookup ext mm + + +------------------------------------------------------------------------------ +defaultMimeType :: ByteString +defaultMimeType = "application/octet-stream" diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Util/GZip.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Util.GZip +( withCompression +, withCompression' ) where + +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Zlib as Zlib +import Control.Concurrent +import Control.Applicative hiding (many) +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Data.Attoparsec.Char8 hiding (Done) +import qualified Data.Attoparsec.Char8 as Atto +import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Char8 (ByteString) +import Data.Iteratee.WrappedByteString +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Typeable +import Prelude hiding (catch, takeWhile) + +------------------------------------------------------------------------------ +import Snap.Internal.Debug +import Snap.Iteratee hiding (Enumerator) +import Snap.Types + + +------------------------------------------------------------------------------ +-- | Runs a 'Snap' web handler with compression if available. +-- +-- If the client has indicated support for @gzip@ or @compress@ in its +-- @Accept-Encoding@ header, and the @Content-Type@ in the response is one of +-- the following types: +-- +-- * @application/x-javascript@ +-- +-- * @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. +-- +withCompression :: Snap a -- ^ the web handler to run + -> Snap () +withCompression = withCompression' compressibleMimeTypes + + +------------------------------------------------------------------------------ +-- | The same as 'withCompression', with control over which MIME types to +-- compress. +withCompression' :: Set ByteString + -- ^ set of compressible MIME types + -> Snap a + -- ^ the web handler to run + -> Snap () +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. + if isJust $ getHeader "Content-Encoding" resp + then return () + else do + let mbCt = getHeader "Content-Type" resp + + debug $ "withCompression', content-type is " ++ show mbCt + + case mbCt of + (Just ct) -> if Set.member ct mimeTable + then chkAcceptEncoding + else return () + _ -> return () + + + getResponse >>= finishWith + + where + chkAcceptEncoding :: Snap () + 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 types + + + chooseType [] = return () + chooseType ("gzip":_) = gzipCompression + chooseType ("compress":_) = compressCompression + chooseType ("x-gzip":_) = gzipCompression + chooseType ("x-compress":_) = compressCompression + chooseType (_:xs) = chooseType xs + + +------------------------------------------------------------------------------ +-- private following +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +compressibleMimeTypes :: Set ByteString +compressibleMimeTypes = Set.fromList [ "application/x-font-truetype" + , "application/x-javascript" + , "text/css" + , "text/html" + , "text/javascript" + , "text/plain" + , "text/xml" ] + + + + +------------------------------------------------------------------------------ +gzipCompression :: Snap () +gzipCompression = modifyResponse f + where + f = setHeader "Content-Encoding" "gzip" . + clearContentLength . + modifyResponseBody gcompress + + +------------------------------------------------------------------------------ +compressCompression :: Snap () +compressCompression = modifyResponse f + where + f = setHeader "Content-Encoding" "compress" . + clearContentLength . + modifyResponseBody ccompress + + +------------------------------------------------------------------------------ +gcompress :: forall a . Enumerator a -> Enumerator a +gcompress = compressEnumerator GZip.compress + + +------------------------------------------------------------------------------ +ccompress :: forall a . Enumerator a -> Enumerator a +ccompress = compressEnumerator Zlib.compress + + +------------------------------------------------------------------------------ +compressEnumerator :: forall a . + (L.ByteString -> L.ByteString) + -> Enumerator a + -> Enumerator a +compressEnumerator compFunc enum iteratee = do + writeEnd <- newChan + readEnd <- newChan + tid <- forkIO $ threadProc readEnd writeEnd + + enum (IterateeG $ f readEnd writeEnd tid iteratee) + + where + -------------------------------------------------------------------------- + streamFinished :: Stream -> Bool + streamFinished (EOF _) = True + streamFinished (Chunk _) = False + + + -------------------------------------------------------------------------- + consumeSomeOutput :: Chan Stream + -> Iteratee IO a + -> IO (Iteratee IO a) + consumeSomeOutput writeEnd iter = do + e <- isEmptyChan writeEnd + if e + then return iter + else do + ch <- readChan writeEnd + + iter' <- liftM liftI $ runIter iter ch + if (streamFinished ch) + then return iter' + else consumeSomeOutput writeEnd iter' + + + -------------------------------------------------------------------------- + consumeRest :: Chan Stream + -> Iteratee IO a + -> IO (IterV IO a) + consumeRest writeEnd iter = do + ch <- readChan writeEnd + + iv <- runIter iter ch + if (streamFinished ch) + then return iv + else consumeRest writeEnd $ liftI iv + + + -------------------------------------------------------------------------- + f readEnd writeEnd tid i (EOF Nothing) = do + writeChan readEnd Nothing + x <- consumeRest writeEnd i + killThread tid + return x + + f _ _ tid i ch@(EOF (Just _)) = do + x <- runIter i ch + killThread tid + return x + + f readEnd writeEnd tid i (Chunk s') = do + let s = unWrap s' + writeChan readEnd $ Just s + i' <- consumeSomeOutput writeEnd i + return $ Cont (IterateeG $ f readEnd writeEnd tid i') Nothing + + + -------------------------------------------------------------------------- + threadProc :: Chan (Maybe ByteString) + -> Chan Stream + -> IO () + threadProc readEnd writeEnd = do + stream <- getChanContents readEnd + let bs = L.fromChunks $ streamToChunks stream + + let output = L.toChunks $ compFunc bs + let runIt = do + mapM_ (writeChan writeEnd . toChunk) output + writeChan writeEnd $ EOF Nothing + + runIt `catch` \(e::SomeException) -> + writeChan writeEnd $ EOF (Just $ Err $ show e) + + + -------------------------------------------------------------------------- + streamToChunks [] = [] + streamToChunks (Nothing:_) = [] + streamToChunks ((Just x):xs) = x:(streamToChunks xs) + + + -------------------------------------------------------------------------- + toChunk = Chunk . WrapBS + + +------------------------------------------------------------------------------ +fullyParse :: ByteString -> Parser a -> Either String a +fullyParse s p = + case r' of + (Fail _ _ e) -> Left e + (Partial _) -> Left "parse failed" + (Atto.Done _ x) -> Right x + where + r = parse p s + r' = feed r "" + + +------------------------------------------------------------------------------ +-- We're not gonna bother with quality values; we'll do gzip or compress in +-- that order. +acceptParser :: Parser [ByteString] +acceptParser = do + xs <- option [] $ (:[]) <$> encoding + ys <- many (char ',' *> encoding) + endOfInput + return $ xs ++ ys + where + encoding = skipSpace *> c <* skipSpace + + c = do + x <- coding + option () qvalue + return x + + qvalue = do + skipSpace + char ';' + skipSpace + char 'q' + skipSpace + char '=' + float + return () + + coding = string "*" <|> takeWhile isAlpha_ascii + + float = takeWhile isDigit >> + option () (char '.' >> takeWhile isDigit >> pure ()) + + +------------------------------------------------------------------------------ +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 + diff --git a/test/data/fileServe/foo.bin b/test/data/fileServe/foo.bin new file mode 100644 --- /dev/null +++ b/test/data/fileServe/foo.bin @@ -0,0 +1,1 @@ +FOO diff --git a/test/data/fileServe/foo.bin.bin.bin b/test/data/fileServe/foo.bin.bin.bin new file mode 100644 --- /dev/null +++ b/test/data/fileServe/foo.bin.bin.bin @@ -0,0 +1,1 @@ +FOO diff --git a/test/data/fileServe/foo.html b/test/data/fileServe/foo.html new file mode 100644 --- /dev/null +++ b/test/data/fileServe/foo.html @@ -0,0 +1,1 @@ +FOO diff --git a/test/data/fileServe/foo.txt b/test/data/fileServe/foo.txt new file mode 100644 --- /dev/null +++ b/test/data/fileServe/foo.txt @@ -0,0 +1,1 @@ +FOO diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh new file mode 100644 --- /dev/null +++ b/test/runTestsAndCoverage.sh @@ -0,0 +1,54 @@ +#!/bin/sh + +set -e + +SUITE=./dist/build/testsuite/testsuite + +rm -f testsuite.tix + +if [ ! -f $SUITE ]; then + cat </dev/null 2>&1 + +rm -f testsuite.tix + +cat <= 1.6 + +Flag debug + Description: Enable debug logging to stderr + Default: False + +Flag testsuite + Description: Are we running the testsuite? Causes arguments to \"debug\" to + be evaluated but not printed. + Default: False + +Executable testsuite + c-sources: ../cbits/timefuncs.c + include-dirs: ../cbits + hs-source-dirs: ../src suite + main-is: TestSuite.hs + + if flag(debug) + cpp-options: -DDEBUG + + if flag(testsuite) + cpp-options: -DDEBUG_TEST + + build-depends: + QuickCheck >= 2, + attoparsec >= 0.8.0.2 && < 0.9, + base >= 4 && < 5, + bytestring, + bytestring-mmap >= 0.2.1 && <0.3, + bytestring-nums, + cereal >= 0.2 && < 0.3, + containers, + directory, + dlist >= 0.5 && < 0.6, + filepath, + HUnit >= 1.2 && < 2, + iteratee >= 0.3.1 && < 0.4, + MonadCatchIO-transformers >= 0.2 && < 0.3, + monads-fd, + old-locale, + old-time, + parallel >= 2.2 && <2.3, + test-framework >= 0.3.1 && <0.4, + test-framework-hunit >= 0.2.5 && < 0.3, + test-framework-quickcheck2 >= 0.2.6 && < 0.3, + text >= 0.7.1 && <0.8, + time, + transformers, + unix, + zlib + + ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs b/test/suite/Snap/Internal/Http/Types/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Internal/Http/Types/Tests.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Snap.Internal.Http.Types.Tests + ( tests ) where + +import Control.Monad +import Control.Parallel.Strategies +import Data.ByteString.Lazy.Char8 () +import Data.IORef +import Data.Iteratee (stream2stream, run) +import qualified Data.Map as Map +import Data.Time.Calendar +import Data.Time.Clock +import Prelude hiding (take) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + + +import Snap.Internal.Http.Types +import Snap.Iteratee (enumBS, fromWrap) + +tests :: [Test] +tests = [ testTypes ] + + +mkRq :: IO Request +mkRq = do + enum <- newIORef (SomeEnumerator return) + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + + +testTypes :: Test +testTypes = testCase "show" $ do + defReq <- mkRq + + let req = rqModifyParams (Map.insert "zzz" ["bbb"]) $ + updateHeaders (Map.insert "zzz" ["bbb"]) $ + rqSetParam "foo" ["bar"] $ + defReq + + let !a = show req `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"]) (Map.lookup "zzz" $ headers req) + assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) cook' + + assertEqual "response status" 555 $ rspStatus resp + assertEqual "response status reason" "bogus" $ rspStatusReason resp + assertEqual "content-length" (Just 4) $ rspContentLength resp + -- run response body + bd <- (rspBodyToEnum $ rspBody resp) stream2stream >>= run + assertEqual "response body" "PING" (fromWrap bd) + + let !_ = show GET + let !_ = GET == POST + let !_ = headers $ headers defReq + + + return () + + where + resp = addCookie cook $ + setContentLength 4 $ + modifyResponseBody id $ + setResponseBody (enumBS "PING") $ + setContentType "text/plain" $ + setResponseStatus 555 "bogus" $ + emptyResponse + !b = show resp `using` rdeepseq + + utc = UTCTime (ModifiedJulianDay 55226) 0 + cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") + cook' = Map.lookup "Set-Cookie" $ headers resp + diff --git a/test/suite/Snap/Internal/Routing/Tests.hs b/test/suite/Snap/Internal/Routing/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Internal/Routing/Tests.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Internal.Routing.Tests + ( tests ) where + +import Control.Exception +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + + +import Snap.Internal.Http.Types +import Snap.Internal.Routing +import Snap.Internal.Types +import Snap.Iteratee hiding (head) + +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 + , testRouteLocal ] + +expectException :: IO a -> IO () +expectException m = do + e <- try m + case e of + Left (z::SomeException) -> (show z) `seq` return () + Right _ -> assertFailure "expected exception, didn't get one" + + +mkRequest :: ByteString -> IO Request +mkRequest uri = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" uri "/" + (B.concat ["/",uri]) "" Map.empty + +go :: Snap a -> ByteString -> IO a +go m s = do + req <- mkRequest s + run $ evalSnap m $ req + + +routes :: Snap ByteString +routes = route [ ("foo" , topFoo ) + , ("foo/bar" , fooBar ) + , ("foo/bar/baz" , fooBarBaz ) + , ("foo/:id" , fooCapture) + , ("bar/:id" , fooCapture) + , ("bar/quux" , barQuux ) + , ("bar" , bar ) + , ("z/:a/:b/:c/d" , zabc ) ] + +routesLocal :: Snap ByteString +routesLocal = routeLocal [ ("foo/bar/baz" , fooBarBaz ) + , ("bar" , pass ) ] + +routes2 :: Snap ByteString +routes2 = route [ ("" , topTop ) + , ("foo" , topFoo ) ] + +routes3 :: Snap ByteString +routes3 = route [ (":foo" , topCapture ) + , ("" , topTop ) ] + +routes4 :: Snap ByteString +routes4 = route [ (":foo" , pass ) + , (":foo" , topCapture ) ] + +routes5 :: Snap ByteString +routes5 = route [ ("" , pass ) + , ("" , topTop ) ] + +routes6 :: Snap ByteString +routes6 = route [ (":a/:a" , dblA ) ] + +routes7 :: Snap ByteString +routes7 = route [ ("foo/:id" , fooCapture ) + , ("foo/:id/:id2" , fooCapture2) + , ("fooo/:id/:id2" , fooCapture2) + , ("foooo/bar/baz" , bar ) + , ("" , topTop ) ] + + +topTop, topFoo, fooBar, fooCapture, fooBarBaz, bar, barQuux :: Snap ByteString +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 +fooBarBaz = liftM rqPathInfo getRequest +barQuux = return "barQuux" +bar = return "bar" + +testRouting1 :: Test +testRouting1 = testCase "routing1" $ do + r1 <- go routes "foo" + assertEqual "/foo" "topFoo" r1 + + +testRouting2 :: Test +testRouting2 = testCase "routing2" $ do + r2 <- go routes "foo/baz" + assertEqual "/foo/baz" "baz" r2 + +testRouting3 :: Test +testRouting3 = testCase "routing3" $ do + expectException $ go routes "/xsaxsaxsax" + +testRouting4 :: Test +testRouting4 = testCase "routing4" $ do + r3 <- go routes "foo/bar" + assertEqual "/foo/bar" "fooBar" r3 + +testRouting5 :: Test +testRouting5 = testCase "routing5" $ do + r4 <- go routes "foo/bar/baz/quux" + assertEqual "/foo/bar/baz/quux" "quux" r4 + +testRouting6 :: Test +testRouting6 = testCase "routing6" $ do + r5 <- go routes "foo/bar/sproing" + assertEqual "/foo/bar/sproing" "fooBar" r5 + +testRouting7 :: Test +testRouting7 = testCase "routing7" $ do + r <- go routes "bar" + assertEqual "/bar" "bar" r + +testRouting8 :: Test +testRouting8 = testCase "routing8" $ do + r2 <- go routes "bar/quux" + assertEqual "/bar/quux" "barQuux" r2 + +testRouting9 :: Test +testRouting9 = testCase "routing9" $ do + r3 <- go routes "bar/whatever" + assertEqual "/bar/whatever" "whatever" r3 + +testRouting10 :: Test +testRouting10 = testCase "routing10" $ do + r4 <- go routes "bar/quux/whatever" + assertEqual "/bar/quux/whatever" "barQuux" r4 + +testRouting11 :: Test +testRouting11 = testCase "routing11" $ do + r1 <- go routes2 "" + assertEqual "/" "topTop" r1 + +testRouting12 :: Test +testRouting12 = testCase "routing12" $ do + r1 <- go routes2 "foo" + assertEqual "/foo" "topFoo" r1 + +testRouting13 :: Test +testRouting13 = testCase "routing13" $ do + r1 <- go routes3 "zzzz" + assertEqual "/zzzz" "zzzz" r1 + +testRouting14 :: Test +testRouting14 = testCase "routing14" $ do + r1 <- go routes3 "" + assertEqual "/" "topTop" r1 + +testRouting15 :: Test +testRouting15 = testCase "routing15" $ do + r1 <- go routes4 "zzzz" + assertEqual "/zzzz" "zzzz" r1 + +testRouting16 :: Test +testRouting16 = testCase "routing16" $ do + r1 <- go routes5 "" + assertEqual "/" "topTop" r1 + +testRouting17 :: Test +testRouting17 = testCase "routing17" $ do + r1 <- go routes "z/a/b/c/d" + assertEqual "/z/a/b/c/d" "ok" r1 + +testRouting18 :: Test +testRouting18 = testCase "routing18" $ do + r1 <- go routes6 "a/a" + assertEqual "/a/a" "ok" r1 + +testRouting19 :: Test +testRouting19 = testCase "routing19" $ do + r1 <- go routes7 "foo" + assertEqual "/foo" "topTop" r1 + +testRouting20 :: Test +testRouting20 = testCase "routing20" $ do + r1 <- go routes7 "foo/baz" + assertEqual "/foo/baz" "baz" r1 + +testRouting21 :: Test +testRouting21 = testCase "routing21" $ do + r1 <- go routes7 "foo/baz/quux" + assertEqual "/foo/baz/quux" "quux" r1 + +testRouting22 :: Test +testRouting22 = testCase "routing22" $ do + r1 <- go routes7 "fooo/baz" + assertEqual "/fooo/baz" "topTop" r1 + +testRouting23 :: Test +testRouting23 = testCase "routing23" $ do + r1 <- go routes7 "fooo/baz/quux" + assertEqual "/fooo/baz/quux" "quux" r1 + +testRouting24 :: Test +testRouting24 = testCase "routing24" $ do + r1 <- go routes7 "foooo/bar/bax" + assertEqual "/foooo/bar/bax" "topTop" r1 + +testRouting25 :: Test +testRouting25 = testCase "routing25" $ do + r1 <- go routes7 "foooo/bar/baz" + assertEqual "/foooo/bar/baz" "bar" r1 + +testRouteLocal :: Test +testRouteLocal = testCase "routeLocal" $ do + r4 <- go routesLocal "foo/bar/baz/quux" + assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4 + expectException $ go routesLocal "bar" diff --git a/test/suite/Snap/Iteratee/Tests.hs b/test/suite/Snap/Iteratee/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Iteratee/Tests.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Iteratee.Tests + ( tests ) where + +import qualified Control.Exception as E +import Control.Exception hiding (try, assert) +import Control.Monad +import Control.Monad.Identity +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy.Char8 as L +import Prelude hiding (drop, take) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic hiding (run) +import Test.Framework.Providers.HUnit +import qualified Test.HUnit as H + +import Snap.Iteratee +import Snap.Test.Common () + +liftQ :: forall a m . (Monad m) => m a -> PropertyM m a +liftQ = QC.run + +expectException :: IO a -> PropertyM IO () +expectException m = do + e <- liftQ $ E.try m + case e of + Left (z::SomeException) -> (show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +tests :: [Test] +tests = [ testEnumBS + , testEnumLBS + , testBuffer + , testBuffer2 + , testBuffer3 + , testBuffer4 + , testTakeExactly1 + , testTakeExactly2 + , testTakeExactly3 + , testTakeNoMoreThan1 + , testTakeNoMoreThan2 + , testTakeNoMoreThan3 + , testCountBytes + , testCountBytes2 + ] + +testEnumBS :: Test +testEnumBS = testProperty "enumBS" prop + where + prop :: S.ByteString -> Bool + prop s = (S.concat $ L.toChunks $ fromWrap $ runIdentity (run iter)) == s + where + iter = runIdentity $ enumBS s stream2stream + +testEnumLBS :: Test +testEnumLBS = testProperty "enumLBS" prop + where + prop :: L.ByteString -> Bool + prop s = fromWrap (runIdentity (run iter)) == s + where + iter = runIdentity $ enumLBS s stream2stream + + +testBuffer :: Test +testBuffer = testProperty "testBuffer" prop + where + prop s = s /= L.empty ==> fromWrap (runIdentity (run iter)) == s' + where + s' = L.take 20000 $ L.cycle s + i = runIdentity $ bufferIteratee stream2stream + iter = runIdentity $ enumLBS s' i + + +testBuffer2 :: Test +testBuffer2 = testCase "testBuffer2" prop + where + prop = do + i <- bufferIteratee $ drop 4 >> stream2stream + + s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap + H.assertEqual "s == 'efgh'" "efgh" s + + +testBuffer3 :: Test +testBuffer3 = testProperty "testBuffer3" prop + where + prop s = s /= L.empty ==> fromWrap (runIdentity (run iter)) == (L.take 19999 s') + where + s' = L.take 20000 $ L.cycle s + ss = joinI $ take 19999 stream2stream + i = runIdentity $ bufferIteratee (ss >>= \x -> drop 1 >> return x) + iter = runIdentity $ enumLBS s' i + +testBuffer4 :: Test +testBuffer4 = testProperty "testBuffer4" $ + monadicIO $ forAllM arbitrary prop + where + prop s = do + i <- liftQ $ bufferIteratee (stream2stream >> throwErr (Err "foo")) + i' <- liftQ $ enumLBS s i + expectException $ run i' + + j <- liftQ $ bufferIteratee (throwErr (Err "foo") >> stream2stream) + j' <- liftQ $ enumLBS s j + expectException $ run j' + + k <- liftQ $ enumErr "foo" j + expectException $ run k + + +testTakeExactly1 :: Test +testTakeExactly1 = testProperty "short stream" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + expectException $ doIter >>= run >>= return . fromWrap + + where + doIter = enumLBS s (joinI (takeExactly (n+1) stream2stream)) + + n = fromIntegral $ L.length s + + +testTakeExactly2 :: Test +testTakeExactly2 = testProperty "exact stream" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + e <- liftQ $ doIter >>= run >>= return . fromWrap + assert $ e == s + + where + doIter = enumLBS s (joinI (takeExactly n stream2stream)) + + n = fromIntegral $ L.length s + + +testTakeExactly3 :: Test +testTakeExactly3 = testProperty "long stream" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + e <- liftQ $ doIter >>= run >>= return . fromWrap + assert $ e == L.take (fromIntegral n) s + + where + doIter = enumLBS s (joinI (takeExactly n stream2stream)) + + n = fromIntegral $ L.length s + + +testTakeNoMoreThan1 :: Test +testTakeNoMoreThan1 = testProperty "takeNoMore: short stream" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + s' <- liftQ $ doIter >>= run >>= return . fromWrap + + assert $ s == s' + + where + doIter = enumLBS s (joinI (takeNoMoreThan (n+1) stream2stream)) + + n = fromIntegral $ L.length s + + +testTakeNoMoreThan2 :: Test +testTakeNoMoreThan2 = testProperty "takeNoMore: exact stream" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + e <- liftQ $ doIter >>= run >>= return . fromWrap + assert $ e == s + + where + doIter = enumLBS s (joinI (takeNoMoreThan n stream2stream)) + + n = fromIntegral $ L.length s + + +testTakeNoMoreThan3 :: Test +testTakeNoMoreThan3 = testProperty "takeNoMoreLong" $ + monadicIO $ forAllM arbitrary prop + where + prop :: (Int,L.ByteString) -> PropertyM IO () + prop (m,s) = do + v <- liftQ $ enumLBS "" (joinI (takeNoMoreThan 0 stream2stream)) >>= run + assert $ fromWrap v == "" + + if (L.null s || m == 0) + then liftQ $ do + !v <- doIter >>= run + return () + else expectException $ doIter >>= run >>= return . fromWrap + + + where + doIter = enumLBS s (joinI (takeNoMoreThan (n-abs m) stream2stream)) + n = fromIntegral $ L.length s + + +testCountBytes :: Test +testCountBytes = testProperty "count bytes" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (!_,n1) <- f (countBytes (return ())) + (!_,n2) <- f (countBytes stream2stream) + + assert $ n1 == 0 + assert $ n2 == n + + expectException $ g erriter + expectException $ enumEof erriter >>= run + + + where + erriter = countBytes $ throwErr $ Err "foo" + g iter = enumLBS s iter >>= run + f = liftQ . g + n = fromEnum $ L.length s + + +testCountBytes2 :: Test +testCountBytes2 = testProperty "count bytes" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + pre $ L.length s > 4 + n1 <- f iter + + assert $ n1 == 4 + + where + f i = liftQ $ enumLBS s i >>= run + iter = do + (!_,m) <- countBytes $ drop 4 + stream2stream + return m diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Test/Common.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + + +module Snap.Test.Common where + +import Control.Monad +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal (c2w) +import Data.Iteratee.WrappedByteString +import Data.Word +import Test.QuickCheck + + +instance Show (WrappedByteString Word8) where + show (WrapBS s) = show s + +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 + diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Types/Tests.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Types.Tests + ( tests ) where + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans (liftIO) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.IORef +import Data.Iteratee +import qualified Data.Map as Map +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test, path) + +import Snap.Internal.Types +import Snap.Internal.Http.Types +import Snap.Iteratee +import Snap.Test.Common () + + +tests :: [Test] +tests = [ testFail + , testAlternative + , testEarlyTermination + , testRqBody + , testTrivials + , testMethod + , testDir + , testWrites + , testParam + , testURLEncode1 + , testURLEncode2 ] + + +expect404 :: IO (Request,Response) -> IO () +expect404 m = do + (_,r) <- m + assertBool "expected 404" (rspStatus r == 404) + +expectNo404 :: IO (Request,Response) -> IO () +expectNo404 m = do + (_,r) <- m + assertBool ("expected 200, got " ++ show (rspStatus r)) + (rspStatus r /= 404) + + +mkRequest :: ByteString -> IO Request +mkRequest uri = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" uri "/" + (S.concat ["/",uri]) "" Map.empty + +mkRequestQuery :: ByteString -> ByteString -> [ByteString] -> IO Request +mkRequestQuery uri k v = do + enum <- newIORef $ SomeEnumerator return + + let mp = Map.fromList [(k,v)] + let q = S.concat [k,"=", S.concat v] + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" uri "/" + (S.concat ["/",uri,"?",q]) q mp + + +mkZomgRq :: IO Request +mkZomgRq = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + + +mkRqWithBody :: IO Request +mkRqWithBody = do + enum <- newIORef $ SomeEnumerator (enumBS "zazzle") + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" "/" "/" "/" "" + Map.empty + + +go :: Snap a -> IO (Request,Response) +go m = do + zomgRq <- mkZomgRq + run $ runSnap m zomgRq + + +goPath :: ByteString -> Snap a -> IO (Request,Response) +goPath s m = do + rq <- mkRequest s + run $ runSnap m $ rq + + +goPathQuery :: ByteString + -> ByteString + -> [ByteString] + -> Snap a + -> IO (Request,Response) +goPathQuery s k v m = do + rq <- mkRequestQuery s k v + run $ runSnap m $ rq + + +goBody :: Snap a -> IO (Request,Response) +goBody m = do + rq <- mkRqWithBody + run $ runSnap m 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 ()) + + +testAlternative :: Test +testAlternative = testCase "alternative" $ do + (_,resp) <- go (pass <|> setFoo "Bar") + assertEqual "foo present" (Just "Bar") $ getHeader "Foo" resp + + (_,resp2) <- go (fail "" + <|> fail2 + <|> setFoo "Bar" + <|> setFoo "Baz") + assertEqual "alternative chooses correct branch" + (Just ["Bar"]) $ getHeaders "Foo" resp2 + + where + fail2 :: Snap () + fail2 = pass >>= \_ -> return () + + +sampleResponse :: Response +sampleResponse = addHeader "Foo" "Quux" $ emptyResponse + + +testEarlyTermination :: Test +testEarlyTermination = testCase "early termination" $ do + (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar") + assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp + + +testRqBody :: Test +testRqBody = testCase "request bodies" $ 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 + + _ <- goBody $ g mvar1 mvar2 + w1 <- takeMVar mvar1 + w2 <- takeMVar mvar2 + + assertEqual "rq body" "zazzle" w1 + assertEqual "rq body 2" "" w2 + + + + where + f mvar1 mvar2 = do + getRequestBody >>= liftIO . putMVar mvar1 + getRequestBody >>= liftIO . putMVar mvar2 + + g mvar1 mvar2 = do + enum <- unsafeDetachRequestBody + bs <- liftM fromWrap (liftIO $ enum stream2stream >>= run) + liftIO $ putMVar mvar1 bs + getRequestBody >>= liftIO . putMVar mvar2 + + +testTrivials :: Test +testTrivials = testCase "trivial functions" $ do + (rq,rsp) <- go $ do + req <- getRequest + putRequest $ req { rqIsSecure=True } + putResponse $ setResponseStatus 333 "333" sampleResponse + r <- getResponse + liftIO $ assertEqual "rsp status" 333 $ rspStatus r + !_ <- localRequest (\x -> x {rqIsSecure=False}) $ do + q <- getRequest + liftIO $ assertEqual "localrq" False $ rqIsSecure q + return () + return () + + let !_ = show NoHandlerException `seq` () + + assertEqual "rq secure" True $ rqIsSecure rq + assertEqual "rsp status" 333 $ rspStatus rsp + + +testMethod :: Test +testMethod = testCase "method" $ do + expect404 $ go (method POST $ return ()) + expectNo404 $ go (method GET $ return ()) + + +testDir :: Test +testDir = testCase "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 "getParam" $ do + expect404 $ goPath "/foo" f + expectNo404 $ goPathQuery "/foo" "param" ["foo"] f + where + f = do + mp <- getParam "param" + maybe pass + (\s -> if s == "foo" then return () else pass) + mp + + +getBody :: Response -> IO L.ByteString +getBody r = liftM fromWrap ((rspBodyToEnum $ rspBody r) stream2stream >>= run) + + +testWrites :: Test +testWrites = testCase "writes" $ do + (_,r) <- go h + b <- getBody r + assertEqual "output functions" "Foo1Foo2Foo3" b + where + h :: Snap () + h = do + addToOutput $ enumBS "Foo1" + writeBS "Foo2" + writeLBS "Foo3" + + +testURLEncode1 :: Test +testURLEncode1 = testCase "url encoding 1" $ 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 "url encoding 2" prop + where + prop s = (urlDecode $ urlEncode s) == Just s diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Util.FileServe.Tests + ( tests ) where + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe +import Prelude hiding (take) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + +import Snap.Internal.Http.Types +import Snap.Internal.Types +import Snap.Util.FileServe +import Snap.Iteratee + +tests :: [Test] +tests = [ testFs ] + + +expect404 :: IO Response -> IO () +expect404 m = do + r <- m + assertBool "expected 404" (rspStatus r == 404) + + +getBody :: Response -> IO L.ByteString +getBody r = liftM fromWrap ((rspBodyToEnum $ rspBody r) stream2stream >>= run) + + +go :: Snap a -> ByteString -> IO Response +go m s = do + rq <- mkRequest s + liftM snd (run $ runSnap m rq) + +goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response +goIfModifiedSince m s lm = do + rq <- mkRequest s + let r = setHeader "if-modified-since" lm rq + liftM snd (run $ runSnap m r) + + +mkRequest :: ByteString -> IO Request +mkRequest uri = do + enum <- newIORef $ SomeEnumerator return + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty + enum Nothing GET (1,1) [] "" uri "/" + (B.concat ["/",uri]) "" Map.empty + +fs :: Snap () +fs = fileServe "data/fileServe" + +testFs :: Test +testFs = testCase "fileServe" $ do + r1 <- go fs "foo.bin" + b1 <- getBody r1 + + assertEqual "foo.bin" "FOO\n" b1 + assertEqual "foo.bin content-type" + (Just "application/octet-stream") + (getHeader "content-type" r1) + + assertEqual "foo.bin size" (Just 4) (rspContentLength r1) + + assertBool "last-modified header" (isJust $ getHeader "last-modified" r1) + let !lm = fromJust $ getHeader "last-modified" r1 + + -- 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" + assertEqual "foo.bin 200" 200 $ rspStatus r3 + b3 <- getBody r3 + assertEqual "foo.bin 2" "FOO\n" b3 + + r4 <- go fs "foo.txt" + b4 <- getBody r4 + + assertEqual "foo.txt" "FOO\n" b4 + assertEqual "foo.txt content-type" + (Just "text/plain") + (getHeader "content-type" r4) + + r5 <- go fs "foo.html" + b5 <- getBody r5 + + assertEqual "foo.html" "FOO\n" b5 + assertEqual "foo.html content-type" + (Just "text/html") + (getHeader "content-type" r5) + + r6 <- go fs "foo.bin.bin.bin" + b6 <- getBody r6 + + assertEqual "foo.bin.bin.bin" "FOO\n" b6 + assertEqual "foo.bin.bin.bin content-type" + (Just "application/octet-stream") + (getHeader "content-type" r6) + + expect404 $ go fs "jfldksjflksd" + expect404 $ go fs "dummy/../foo.txt" + expect404 $ go fs "/etc/password" + + coverMimeMap + + +coverMimeMap :: (Monad m) => m () +coverMimeMap = mapM_ f $ Map.toList defaultMimeTypes + where + f (!k,!v) = return $ case k `seq` v `seq` () of () -> () diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# 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.Exception hiding (assert) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.IORef +import Data.Iteratee +import qualified Data.Map as Map +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic hiding (run) + +import Snap.Types +import Snap.Internal.Http.Types +import Snap.Iteratee +import Snap.Test.Common () +import Snap.Util.GZip + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = [ testIdentity1 + , testIdentity2 + , testIdentity3 + , testCompositionDoesn'tExplode + , testBadHeaders ] + + +------------------------------------------------------------------------------ +expectException :: IO a -> PropertyM IO () +expectException m = do + e <- liftQ $ try m + case e of + Left (z::SomeException) -> (show z) `seq` return () + Right _ -> fail "expected exception, didn't get one" + + +------------------------------------------------------------------------------ +liftQ :: forall a m . (Monad m) => m a -> PropertyM m a +liftQ = QC.run + + +------------------------------------------------------------------------------ +gzipHdrs, badHdrs, compressHdrs, emptyHdrs :: Headers +emptyHdrs = Map.empty +gzipHdrs = setHeader "Accept-Encoding" "froz,gzip" emptyHdrs +badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs +compressHdrs = setHeader "Accept-Encoding" "compress" emptyHdrs + + +------------------------------------------------------------------------------ +mkGzipRq :: IO Request +mkGzipRq = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False gzipHdrs + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + + +------------------------------------------------------------------------------ +mkCompressRq :: IO Request +mkCompressRq = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + + +------------------------------------------------------------------------------ +mkBadRq :: IO Request +mkBadRq = do + enum <- newIORef $ SomeEnumerator return + + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False badHdrs + enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty + +------------------------------------------------------------------------------ +goGZip, goCompress, goBad :: Snap a -> IO (Request,Response) +goGZip m = do + gzipRq <- mkGzipRq + run $ runSnap m gzipRq + +goCompress m = do + compressRq <- mkCompressRq + run $ runSnap m compressRq + +goBad m = do + badRq <- mkBadRq + run $ runSnap m badRq + +------------------------------------------------------------------------------ +textPlain :: L.ByteString -> Snap () +textPlain s = modifyResponse $ + setResponseBody (enumLBS s) . + setContentType "text/plain" + + +------------------------------------------------------------------------------ +binary :: L.ByteString -> Snap () +binary s = modifyResponse $ + setResponseBody (enumLBS s) . + setContentType "application/octet-stream" + + +------------------------------------------------------------------------------ +testIdentity1 :: Test +testIdentity1 = testProperty "identity1" $ monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (_,rsp) <- liftQ $ goGZip (withCompression $ textPlain s) + let body = rspBodyToEnum $ rspBody rsp + + c <- liftQ $ + body stream2stream >>= run >>= return . fromWrap + + let s1 = GZip.decompress c + assert $ s == s1 + +testCompositionDoesn'tExplode :: Test +testCompositionDoesn'tExplode = + testProperty "testCompositionDoesn'tExplode" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (_,rsp) <- liftQ $ goGZip (withCompression $ withCompression $ textPlain s) + let body = rspBodyToEnum $ rspBody rsp + + c <- liftQ $ + body stream2stream >>= run >>= return . fromWrap + + let s1 = GZip.decompress c + assert $ s == s1 + + + +testIdentity2 :: Test +testIdentity2 = testProperty "identity2" $ monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (_,rsp2) <- liftQ $ goCompress (withCompression $ textPlain s) + let body2 = rspBodyToEnum $ rspBody rsp2 + + c2 <- liftQ $ + body2 stream2stream >>= run >>= return . fromWrap + + let s2 = Zlib.decompress c2 + assert $ s == s2 + + +testIdentity3 :: Test +testIdentity3 = testProperty "identity3" $ monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (_,rsp3) <- liftQ $ goGZip (withCompression $ binary s) + let body3 = rspBodyToEnum $ rspBody rsp3 + + s3 <- liftQ $ + body3 stream2stream >>= run >>= return . fromWrap + + assert $ s == s3 + + + +------------------------------------------------------------------------------ +testBadHeaders :: Test +testBadHeaders = testProperty "bad headers" $ monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = expectException $ do + (_,rsp) <- goBad (withCompression $ textPlain s) + let body = rspBodyToEnum $ rspBody rsp + + body stream2stream >>= run >>= return . fromWrap diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/suite/TestSuite.hs @@ -0,0 +1,28 @@ +module Main where + +import Test.Framework (defaultMain, testGroup) + +import qualified Snap.Types.Tests +import qualified Snap.Internal.Http.Types.Tests +import qualified Snap.Internal.Routing.Tests +import qualified Snap.Iteratee.Tests +import qualified Snap.Util.FileServe.Tests +import qualified Snap.Util.GZip.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.Types.Tests" + Snap.Types.Tests.tests + , testGroup "Snap.Iteratee.Tests" + Snap.Iteratee.Tests.tests + , testGroup "Snap.Util.GZip.Tests" + Snap.Util.GZip.Tests.tests + , testGroup "Snap.Util.FileServe.Tests" + Snap.Util.FileServe.Tests.tests + ]